diff --git a/Microsoft COBOL v45/BINB/ADISCF.EXE b/Microsoft COBOL v45/BINB/ADISCF.EXE new file mode 100644 index 0000000..a2f2b65 Binary files /dev/null and b/Microsoft COBOL v45/BINB/ADISCF.EXE differ diff --git a/Microsoft COBOL v45/BINB/ADISCF.LBR b/Microsoft COBOL v45/BINB/ADISCF.LBR new file mode 100644 index 0000000..f01e4e5 Binary files /dev/null and b/Microsoft COBOL v45/BINB/ADISCF.LBR differ diff --git a/Microsoft COBOL v45/BINB/ADISCTRL b/Microsoft COBOL v45/BINB/ADISCTRL new file mode 100644 index 0000000..21bf45b Binary files /dev/null and b/Microsoft COBOL v45/BINB/ADISCTRL differ diff --git a/Microsoft COBOL v45/BINB/ANIMATE.EXE b/Microsoft COBOL v45/BINB/ANIMATE.EXE new file mode 100644 index 0000000..d8f4431 Binary files /dev/null and b/Microsoft COBOL v45/BINB/ANIMATE.EXE differ diff --git a/Microsoft COBOL v45/BINB/ANIMATE.PIF b/Microsoft COBOL v45/BINB/ANIMATE.PIF new file mode 100644 index 0000000..9093080 Binary files /dev/null and b/Microsoft COBOL v45/BINB/ANIMATE.PIF differ diff --git a/Microsoft COBOL v45/BINB/ANIMATOR.LBR b/Microsoft COBOL v45/BINB/ANIMATOR.LBR new file mode 100644 index 0000000..76bab50 Binary files /dev/null and b/Microsoft COBOL v45/BINB/ANIMATOR.LBR differ diff --git a/Microsoft COBOL v45/BINB/ANIMRTNS.EXE b/Microsoft COBOL v45/BINB/ANIMRTNS.EXE new file mode 100644 index 0000000..11db6c9 Binary files /dev/null and b/Microsoft COBOL v45/BINB/ANIMRTNS.EXE differ diff --git a/Microsoft COBOL v45/BINB/ANIMUSER.EXE b/Microsoft COBOL v45/BINB/ANIMUSER.EXE new file mode 100644 index 0000000..5f7aead Binary files /dev/null and b/Microsoft COBOL v45/BINB/ANIMUSER.EXE differ diff --git a/Microsoft COBOL v45/BINB/BIND.EXE b/Microsoft COBOL v45/BINB/BIND.EXE new file mode 100644 index 0000000..edced18 Binary files /dev/null and b/Microsoft COBOL v45/BINB/BIND.EXE differ diff --git a/Microsoft COBOL v45/BINB/CHECK.LBR b/Microsoft COBOL v45/BINB/CHECK.LBR new file mode 100644 index 0000000..67c9f62 Binary files /dev/null and b/Microsoft COBOL v45/BINB/CHECK.LBR differ diff --git a/Microsoft COBOL v45/BINB/COBCLI.LBR b/Microsoft COBOL v45/BINB/COBCLI.LBR new file mode 100644 index 0000000..9ac57d0 Binary files /dev/null and b/Microsoft COBOL v45/BINB/COBCLI.LBR differ diff --git a/Microsoft COBOL v45/BINB/COBOL.EXE b/Microsoft COBOL v45/BINB/COBOL.EXE new file mode 100644 index 0000000..a846d28 Binary files /dev/null and b/Microsoft COBOL v45/BINB/COBOL.EXE differ diff --git a/Microsoft COBOL v45/BINB/COBOL.PIF b/Microsoft COBOL v45/BINB/COBOL.PIF new file mode 100644 index 0000000..477a290 Binary files /dev/null and b/Microsoft COBOL v45/BINB/COBOL.PIF differ diff --git a/Microsoft COBOL v45/BINB/E.CBL b/Microsoft COBOL v45/BINB/E.CBL new file mode 100644 index 0000000..7a98f05 --- /dev/null +++ b/Microsoft COBOL v45/BINB/E.CBL @@ -0,0 +1,58 @@ + IDENTIFICATION DIVISION. + PROGRAM-ID. E. + * REMARKS. generate digits of e + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 ARRAYS. + 02 A PIC 9(04) COMP OCCURS 200 TIMES. + 01 X PIC 9(04) COMP VALUE 0. + 01 TMOD PIC 9(04) COMP VALUE 0. + 01 TM PIC 9(04) COMP VALUE 0. + 01 TD PIC 9(04) COMP VALUE 0. + 01 N PIC 9(04) COMP VALUE 0. + 01 HV PIC 9(04) COMP VALUE 0. + 01 NUM-DISP PIC 9999. + + PROCEDURE DIVISION. + MAIN. + DISPLAY 'computing e'. + PERFORM INITA-ROUTINE. + PERFORM INITA-ROUTINE-B. + PERFORM INITA-ROUTINE-C. + PERFORM OUTER-LOOP. + STOP RUN. + + INITA-ROUTINE. + MOVE 200 TO HV. + MOVE 0 TO X. + MOVE 199 TO N. + + INITA-ROUTINE-B. + MOVE 1 TO A( N + 1 ). + SUBTRACT 1 FROM N. + IF N > 0 GO TO INITA-ROUTINE-B. + + INITA-ROUTINE-C. + MOVE 2 TO A( 2 ). + MOVE 0 TO A( 1 ). + + OUTER-LOOP. + SUBTRACT 1 FROM HV. + MOVE HV TO N. + PERFORM INNER-LOOP. + IF HV > 9 GO TO OUTER-LOOP. + + INNER-LOOP. + DIVIDE X BY N GIVING TD. + COMPUTE TMOD = ( X - ( TD * N ) ) + IF 0 = X MOVE 0 TO TMOD. + MOVE TMOD TO A( N + 1 ). + MULTIPLY 10 BY A( N ) GIVING TM. + COMPUTE X = TM + TD. + SUBTRACT 1 FROM N. + IF N > 0 GO TO INNER-LOOP. + MOVE X TO NUM-DISP. + DISPLAY NUM-DISP. + diff --git a/Microsoft COBOL v45/BINB/EXEHDR.EXE b/Microsoft COBOL v45/BINB/EXEHDR.EXE new file mode 100644 index 0000000..7efe234 Binary files /dev/null and b/Microsoft COBOL v45/BINB/EXEHDR.EXE differ diff --git a/Microsoft COBOL v45/BINB/EXP.EXE b/Microsoft COBOL v45/BINB/EXP.EXE new file mode 100644 index 0000000..a3434af Binary files /dev/null and b/Microsoft COBOL v45/BINB/EXP.EXE differ diff --git a/Microsoft COBOL v45/BINB/GENERATE.LBR b/Microsoft COBOL v45/BINB/GENERATE.LBR new file mode 100644 index 0000000..050cc9e Binary files /dev/null and b/Microsoft COBOL v45/BINB/GENERATE.LBR differ diff --git a/Microsoft COBOL v45/BINB/H2CPY.EXE b/Microsoft COBOL v45/BINB/H2CPY.EXE new file mode 100644 index 0000000..86d5d39 Binary files /dev/null and b/Microsoft COBOL v45/BINB/H2CPY.EXE differ diff --git a/Microsoft COBOL v45/BINB/HELP.LBR b/Microsoft COBOL v45/BINB/HELP.LBR new file mode 100644 index 0000000..3d04a28 Binary files /dev/null and b/Microsoft COBOL v45/BINB/HELP.LBR differ diff --git a/Microsoft COBOL v45/BINB/HELPADCF.LBR b/Microsoft COBOL v45/BINB/HELPADCF.LBR new file mode 100644 index 0000000..6bf9539 Binary files /dev/null and b/Microsoft COBOL v45/BINB/HELPADCF.LBR differ diff --git a/Microsoft COBOL v45/BINB/HELPMAKE.EXE b/Microsoft COBOL v45/BINB/HELPMAKE.EXE new file mode 100644 index 0000000..6edffb3 Binary files /dev/null and b/Microsoft COBOL v45/BINB/HELPMAKE.EXE differ diff --git a/Microsoft COBOL v45/BINB/HELPNAME.LBR b/Microsoft COBOL v45/BINB/HELPNAME.LBR new file mode 100644 index 0000000..ab37d17 Binary files /dev/null and b/Microsoft COBOL v45/BINB/HELPNAME.LBR differ diff --git a/Microsoft COBOL v45/BINB/HNFDC.EXE b/Microsoft COBOL v45/BINB/HNFDC.EXE new file mode 100644 index 0000000..6921bee Binary files /dev/null and b/Microsoft COBOL v45/BINB/HNFDC.EXE differ diff --git a/Microsoft COBOL v45/BINB/HYHELP.EXE b/Microsoft COBOL v45/BINB/HYHELP.EXE new file mode 100644 index 0000000..a2fde27 Binary files /dev/null and b/Microsoft COBOL v45/BINB/HYHELP.EXE differ diff --git a/Microsoft COBOL v45/BINB/HYHELP.LBR b/Microsoft COBOL v45/BINB/HYHELP.LBR new file mode 100644 index 0000000..d0d1ff4 Binary files /dev/null and b/Microsoft COBOL v45/BINB/HYHELP.LBR differ diff --git a/Microsoft COBOL v45/BINB/HYHELP.PIF b/Microsoft COBOL v45/BINB/HYHELP.PIF new file mode 100644 index 0000000..f8058ce Binary files /dev/null and b/Microsoft COBOL v45/BINB/HYHELP.PIF differ diff --git a/Microsoft COBOL v45/BINB/ILINK.EXE b/Microsoft COBOL v45/BINB/ILINK.EXE new file mode 100644 index 0000000..d2916cc Binary files /dev/null and b/Microsoft COBOL v45/BINB/ILINK.EXE differ diff --git a/Microsoft COBOL v45/BINB/ILINKSTB.OVL b/Microsoft COBOL v45/BINB/ILINKSTB.OVL new file mode 100644 index 0000000..758cce1 Binary files /dev/null and b/Microsoft COBOL v45/BINB/ILINKSTB.OVL differ diff --git a/Microsoft COBOL v45/BINB/IMPLIB.EXE b/Microsoft COBOL v45/BINB/IMPLIB.EXE new file mode 100644 index 0000000..7109305 Binary files /dev/null and b/Microsoft COBOL v45/BINB/IMPLIB.EXE differ diff --git a/Microsoft COBOL v45/BINB/KEYBCF.EXE b/Microsoft COBOL v45/BINB/KEYBCF.EXE new file mode 100644 index 0000000..16a4ad2 Binary files /dev/null and b/Microsoft COBOL v45/BINB/KEYBCF.EXE differ diff --git a/Microsoft COBOL v45/BINB/LIB.EXE b/Microsoft COBOL v45/BINB/LIB.EXE new file mode 100644 index 0000000..5624050 Binary files /dev/null and b/Microsoft COBOL v45/BINB/LIB.EXE differ diff --git a/Microsoft COBOL v45/BINB/LINK.EXE b/Microsoft COBOL v45/BINB/LINK.EXE new file mode 100644 index 0000000..ddbce0c Binary files /dev/null and b/Microsoft COBOL v45/BINB/LINK.EXE differ diff --git a/Microsoft COBOL v45/BINB/LRFMERGE.EXE b/Microsoft COBOL v45/BINB/LRFMERGE.EXE new file mode 100644 index 0000000..abeac5b Binary files /dev/null and b/Microsoft COBOL v45/BINB/LRFMERGE.EXE differ diff --git a/Microsoft COBOL v45/BINB/MSHIF.EXE b/Microsoft COBOL v45/BINB/MSHIF.EXE new file mode 100644 index 0000000..df649ee Binary files /dev/null and b/Microsoft COBOL v45/BINB/MSHIF.EXE differ diff --git a/Microsoft COBOL v45/BINB/NAME.LBR b/Microsoft COBOL v45/BINB/NAME.LBR new file mode 100644 index 0000000..f0bb564 Binary files /dev/null and b/Microsoft COBOL v45/BINB/NAME.LBR differ diff --git a/Microsoft COBOL v45/BINB/PKUNZIP.EXE b/Microsoft COBOL v45/BINB/PKUNZIP.EXE new file mode 100644 index 0000000..f817c08 Binary files /dev/null and b/Microsoft COBOL v45/BINB/PKUNZIP.EXE differ diff --git a/Microsoft COBOL v45/BINB/PWBRMAKE.EXE b/Microsoft COBOL v45/BINB/PWBRMAKE.EXE new file mode 100644 index 0000000..17119d5 Binary files /dev/null and b/Microsoft COBOL v45/BINB/PWBRMAKE.EXE differ diff --git a/Microsoft COBOL v45/BINB/REBUILD.EXE b/Microsoft COBOL v45/BINB/REBUILD.EXE new file mode 100644 index 0000000..22dea5b Binary files /dev/null and b/Microsoft COBOL v45/BINB/REBUILD.EXE differ diff --git a/Microsoft COBOL v45/BINB/RM.EXE b/Microsoft COBOL v45/BINB/RM.EXE new file mode 100644 index 0000000..e55df93 Binary files /dev/null and b/Microsoft COBOL v45/BINB/RM.EXE differ diff --git a/Microsoft COBOL v45/BINB/SBR-LOAD.GNT b/Microsoft COBOL v45/BINB/SBR-LOAD.GNT new file mode 100644 index 0000000..f0836d7 Binary files /dev/null and b/Microsoft COBOL v45/BINB/SBR-LOAD.GNT differ diff --git a/Microsoft COBOL v45/BINB/SCREENS.EXE b/Microsoft COBOL v45/BINB/SCREENS.EXE new file mode 100644 index 0000000..a8267c1 Binary files /dev/null and b/Microsoft COBOL v45/BINB/SCREENS.EXE differ diff --git a/Microsoft COBOL v45/BINB/SCREENS.LBR b/Microsoft COBOL v45/BINB/SCREENS.LBR new file mode 100644 index 0000000..e7f09c6 Binary files /dev/null and b/Microsoft COBOL v45/BINB/SCREENS.LBR differ diff --git a/Microsoft COBOL v45/BINB/SCREENS.PIF b/Microsoft COBOL v45/BINB/SCREENS.PIF new file mode 100644 index 0000000..0238726 Binary files /dev/null and b/Microsoft COBOL v45/BINB/SCREENS.PIF differ diff --git a/Microsoft COBOL v45/BINB/SIEVE.CBL b/Microsoft COBOL v45/BINB/SIEVE.CBL new file mode 100644 index 0000000..e9b9e21 --- /dev/null +++ b/Microsoft COBOL v45/BINB/SIEVE.CBL @@ -0,0 +1,51 @@ + IDENTIFICATION DIVISION. + PROGRAM-ID. SIEVE. + * REMARKS. BYTE magazine benchmark. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 MISC. + 03 I PIC 9(4) COMP. + 03 PRIME PIC 9(5) COMP. + 03 K PIC 9(4) COMP. + 03 TOTAL-PRIME-COUNT PIC 9(4) COMP. + 02 SIEVETABLE. + 04 FLAGS PIC 9 COMP OCCURS 8191 TIMES. + 01 NUM-DISP PIC 9999. + + PROCEDURE DIVISION. + MAIN. + PERFORM ITER-ROUTINE 10 TIMES. + MOVE TOTAL-PRIME-COUNT TO NUM-DISP. + DISPLAY NUM-DISP ' primes'. + STOP RUN. + + ITER-ROUTINE. + MOVE ZEROES TO TOTAL-PRIME-COUNT. + PERFORM TFR VARYING I FROM 1 BY 1 UNTIL I = 8191. + PERFORM DCP THRU DCE VARYING I FROM 0 BY 1 UNTIL I = 8190. + + TFR. + MOVE 1 TO FLAGS(I). + + DCP. + IF FLAGS( I + 1 ) = 0 + GO TO DCE. + COMPUTE PRIME = I + I + 3. + COMPUTE K = I + PRIME. + + FIRST1. + IF K > 8190 GO TO NEXT1. + MOVE 0 TO FLAGS( K + 1 ). + COMPUTE K = PRIME + K. + GO TO FIRST1. + + NEXT1. + ADD 1 TO TOTAL-PRIME-COUNT. + * MOVE PRIME TO NUM-DISP. + * DISPLAY 'FOUND PRIME = ' NUM-DISP. + + DCE. + EXIT. + diff --git a/Microsoft COBOL v45/BINB/SPLIT78.EXE b/Microsoft COBOL v45/BINB/SPLIT78.EXE new file mode 100644 index 0000000..8bb4829 Binary files /dev/null and b/Microsoft COBOL v45/BINB/SPLIT78.EXE differ diff --git a/Microsoft COBOL v45/BINB/TTT.CBL b/Microsoft COBOL v45/BINB/TTT.CBL new file mode 100644 index 0000000..dfbf6f2 --- /dev/null +++ b/Microsoft COBOL v45/BINB/TTT.CBL @@ -0,0 +1,168 @@ + IDENTIFICATION DIVISION. + PROGRAM-ID. TTT. + * REMARKS. prove tic-tac-toe is not winnable against a good foe. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 BOARD. + 05 B PIC 9(04) COMP OCCURS 9 TIMES. + 05 VALST PIC 9(04) COMP OCCURS 10 TIMES. + 05 ALPHAST PIC 9(04) COMP OCCURS 10 TIMES. + 05 BETAST PIC 9(04) COMP OCCURS 10 TIMES. + 05 XST PIC 9(04) COMP OCCURS 10 TIMES. + 05 PMST PIC 9(04) COMP OCCURS 10 TIMES. + 01 MOVECOUNT PIC 9(04) COMP VALUE 0. + 01 DEPTH PIC 9(04) COMP VALUE 0. + 01 NUM-DISP PIC 9999. + 01 ITER PIC 9(04) COMP VALUE 0. + 01 WI PIC 9(04) COMP VALUE 0. + 01 VAL PIC 9(04) COMP VALUE 0. + 01 T PIC 9(04) COMP VALUE 0. + 01 D PIC 9(04) COMP VALUE 0. + 01 M PIC 9(04) COMP VALUE 0. + 01 X PIC 9(04) COMP VALUE 0. + 01 PM PIC 9(04) COMP VALUE 0. + 01 SC PIC 9(04) COMP VALUE 0. + 01 Z PIC 9(04) COMP VALUE 0. + 01 ALPHA PIC 9(04) COMP VALUE 0. + 01 BETA PIC 9(04) COMP VALUE 0. + 01 FIRSTMOVE PIC 9(04) COMP VALUE 0. + + PROCEDURE DIVISION. + MAIN. + DISPLAY 'hello from cobol'. + MOVE 1 TO ITER. + INITBOARD. + MOVE 0 TO B( ITER ). + ADD 1 TO ITER. + IF ITER < 10 GO TO INITBOARD. + + MOVE 0 TO ITER. + NEXTITER. + MOVE 0 TO MOVECOUNT. + MOVE 1 TO FIRSTMOVE. + PERFORM RUNMM. + MOVE 2 TO FIRSTMOVE. + PERFORM RUNMM. + MOVE 5 TO FIRSTMOVE. + PERFORM RUNMM. + ADD 1 TO ITER. + IF ITER < 10 GO TO NEXTITER. + + DISPLAY 'final move count and winner: '. + MOVE MOVECOUNT TO NUM-DISP. + DISPLAY NUM-DISP. + MOVE SC TO NUM-DISP. + DISPLAY NUM-DISP. + + STOP RUN. + + RUNMM. + MOVE 1 TO B( FIRSTMOVE ). + MOVE FIRSTMOVE TO X + MOVE 2 TO ALPHA + MOVE 9 TO BETA + PERFORM MINMAX. + MOVE 0 TO B( FIRSTMOVE ). + + WINNER. + MOVE 0 TO WI. + MOVE B( 1 ) TO T. + IF 0 NOT = T AND T=B(2) AND T=B(3) MOVE T TO WI + ELSE IF 0 NOT= T AND T=B(4) AND T=B(7) MOVE T TO WI. + + IF 0 = WI + MOVE B(2) TO T + IF 0 NOT= T AND T=B(5) AND T=B(8) MOVE T TO WI + ELSE + MOVE B(3) TO T + IF 0 NOT= T AND T=B(6) AND T=B(9) MOVE T TO WI + ELSE + MOVE B(4) TO T + IF 0 NOT= T AND T=B(5) AND T=B(6) MOVE T TO WI + ELSE + MOVE B(7) TO T + IF 0 NOT= T AND T=B(8) AND T=B(9) MOVE T TO WI + ELSE + MOVE B(5) TO T + IF 0 NOT= T AND T=B(1) AND T=B(9) MOVE T TO WI + ELSE + IF 0 NOT= T AND T=B(3) AND T=B(7) MOVE T TO WI. + + SHOWPOS. + MOVE B(Z) TO NUM-DISP. + DISPLAY NUM-DISP. + + SHOWBOARD. + DISPLAY 'board: '. + PERFORM SHOWPOS VARYING Z FROM 1 BY 1 UNTIL Z>9. + + INITVALPM. + DIVIDE DEPTH BY 2 GIVING D. + MULTIPLY D BY 2 GIVING M. + + IF DEPTH NOT = M + MOVE 2 TO VAL + MOVE 1 TO PM + ELSE + MOVE 9 TO VAL + MOVE 2 TO PM. + + MINMAX. + ADD 1 TO MOVECOUNT. + MOVE 0 TO VAL. + + IF DEPTH > 3 + PERFORM WINNER + IF WI NOT = 0 + IF WI = 1 MOVE 6 TO VAL ELSE MOVE 4 TO VAL + ELSE IF DEPTH = 8 MOVE 5 TO VAL. + + IF 0 = VAL + PERFORM INITVALPM + + ADD 1 TO DEPTH + PERFORM MAKEMOVE VARYING X FROM 1 BY 1 UNTIL (X>9) + SUBTRACT 1 FROM DEPTH. + + MOVE VAL TO SC. + + UPDATEODD. + IF SC = 6 MOVE 10 TO X. + IF SC > VAL MOVE SC TO VAL. + IF VAL NOT < BETA MOVE 10 TO X. + IF VAL > ALPHA MOVE VAL TO ALPHA. + + UPDATEEVEN. + IF SC = 4 MOVE 10 TO X. + IF SC < VAL MOVE SC TO VAL. + IF VAL NOT > ALPHA MOVE 10 TO X. + IF VAL < BETA MOVE VAL TO BETA. + + UPDATESTATE. + IF PM = 1 PERFORM UPDATEODD + ELSE PERFORM UPDATEEVEN. + + MAKEMOVE. + IF B( X ) = 0 + MOVE PM TO B( X ) + + MOVE VAL TO VALST( DEPTH ) + MOVE X TO XST( DEPTH ) + MOVE PM TO PMST( DEPTH ) + MOVE ALPHA TO ALPHAST( DEPTH ) + MOVE BETA TO BETAST( DEPTH ) + + PERFORM MINMAX + + MOVE BETAST( DEPTH ) TO BETA + MOVE ALPHAST( DEPTH ) TO ALPHA + MOVE PMST( DEPTH ) TO PM + MOVE XST( DEPTH ) TO X + MOVE VALST( DEPTH ) TO VAL + + MOVE 0 TO B( X ) + + PERFORM UPDATESTATE. + diff --git a/Microsoft COBOL v45/BINB/UNDEL.EXE b/Microsoft COBOL v45/BINB/UNDEL.EXE new file mode 100644 index 0000000..e906377 Binary files /dev/null and b/Microsoft COBOL v45/BINB/UNDEL.EXE differ diff --git a/Microsoft COBOL v45/BINB/UTILS.LBR b/Microsoft COBOL v45/BINB/UTILS.LBR new file mode 100644 index 0000000..b2809b4 Binary files /dev/null and b/Microsoft COBOL v45/BINB/UTILS.LBR differ diff --git a/Microsoft COBOL v45/BINB/m.bat b/Microsoft COBOL v45/BINB/m.bat new file mode 100644 index 0000000..88bb00c --- /dev/null +++ b/Microsoft COBOL v45/BINB/m.bat @@ -0,0 +1,9 @@ +del %1.obj +del %1.exe + +ntvdm -r:.. -m -c -d -e:path=c:\binb;c:\binr cobol %1,%1,%1,%1 + +ntvdm -h -c -r:.. -e:lib=c:\lib link %1,,%1,,nul.def + +ntvdm -c -m -r:.. -e:path=c:\binb;c:\binr %1 + diff --git a/Microsoft COBOL v45/BINR/CCIIPX.EXE b/Microsoft COBOL v45/BINR/CCIIPX.EXE new file mode 100644 index 0000000..1c1ab5c Binary files /dev/null and b/Microsoft COBOL v45/BINR/CCIIPX.EXE differ diff --git a/Microsoft COBOL v45/BINR/CCINETB.EXE b/Microsoft COBOL v45/BINR/CCINETB.EXE new file mode 100644 index 0000000..075f67d Binary files /dev/null and b/Microsoft COBOL v45/BINR/CCINETB.EXE differ diff --git a/Microsoft COBOL v45/BINR/COBFP87.DLE b/Microsoft COBOL v45/BINR/COBFP87.DLE new file mode 100644 index 0000000..ebcee58 Binary files /dev/null and b/Microsoft COBOL v45/BINR/COBFP87.DLE differ diff --git a/Microsoft COBOL v45/BINR/COBLIB.DLE b/Microsoft COBOL v45/BINR/COBLIB.DLE new file mode 100644 index 0000000..4332322 Binary files /dev/null and b/Microsoft COBOL v45/BINR/COBLIB.DLE differ diff --git a/Microsoft COBOL v45/BINR/FIXSHIFT.COM b/Microsoft COBOL v45/BINR/FIXSHIFT.COM new file mode 100644 index 0000000..ef521a1 Binary files /dev/null and b/Microsoft COBOL v45/BINR/FIXSHIFT.COM differ diff --git a/Microsoft COBOL v45/BINR/HIMEM.SYS b/Microsoft COBOL v45/BINR/HIMEM.SYS new file mode 100644 index 0000000..212c9d8 Binary files /dev/null and b/Microsoft COBOL v45/BINR/HIMEM.SYS differ diff --git a/Microsoft COBOL v45/BINR/NEW-VARS.BAT b/Microsoft COBOL v45/BINR/NEW-VARS.BAT new file mode 100644 index 0000000..ae39edf --- /dev/null +++ b/Microsoft COBOL v45/BINR/NEW-VARS.BAT @@ -0,0 +1,12 @@ +REM The following lines should be placed in a DOS CONFIG.SYS +REM FILES=100 +REM BUFFERS=10 +REM +REM The following lines should be placed in AUTOEXEC.BAT +PATH=C:\COBOL\BINB;C:\COBOL\BINR;%PATH% +SET COBDIR=C:\COBOL\BINB;C:\COBOL\BINR +SET LIB=C:\COBOL\LIB;%LIB% +SET COBHNF=C:\COBOL\HELP +SET INCLUDE=C:\COBOL\SOURCE;%INCLUDE% +SET HELPFILES=C:\COBOL\HELP;%HELPFILES% +SET INIT=C:\COBOL\INIT;%INIT% diff --git a/Microsoft COBOL v45/BINR/NMAKE.EXE b/Microsoft COBOL v45/BINR/NMAKE.EXE new file mode 100644 index 0000000..40d9db6 Binary files /dev/null and b/Microsoft COBOL v45/BINR/NMAKE.EXE differ diff --git a/Microsoft COBOL v45/BINR/NMK.COM b/Microsoft COBOL v45/BINR/NMK.COM new file mode 100644 index 0000000..69923a8 Binary files /dev/null and b/Microsoft COBOL v45/BINR/NMK.COM differ diff --git a/Microsoft COBOL v45/BINR/PWB.COM b/Microsoft COBOL v45/BINR/PWB.COM new file mode 100644 index 0000000..4f45044 Binary files /dev/null and b/Microsoft COBOL v45/BINR/PWB.COM differ diff --git a/Microsoft COBOL v45/BINR/PWBCOBOL.MXT b/Microsoft COBOL v45/BINR/PWBCOBOL.MXT new file mode 100644 index 0000000..7b9cd74 Binary files /dev/null and b/Microsoft COBOL v45/BINR/PWBCOBOL.MXT differ diff --git a/Microsoft COBOL v45/BINR/PWBED.EXE b/Microsoft COBOL v45/BINR/PWBED.EXE new file mode 100644 index 0000000..4a5bbdb Binary files /dev/null and b/Microsoft COBOL v45/BINR/PWBED.EXE differ diff --git a/Microsoft COBOL v45/BINR/PWBHELP.MXT b/Microsoft COBOL v45/BINR/PWBHELP.MXT new file mode 100644 index 0000000..f0e3714 Binary files /dev/null and b/Microsoft COBOL v45/BINR/PWBHELP.MXT differ diff --git a/Microsoft COBOL v45/BINR/PWBROWSE.MXT b/Microsoft COBOL v45/BINR/PWBROWSE.MXT new file mode 100644 index 0000000..336c925 Binary files /dev/null and b/Microsoft COBOL v45/BINR/PWBROWSE.MXT differ diff --git a/Microsoft COBOL v45/BINR/PWBUTILS.MXT b/Microsoft COBOL v45/BINR/PWBUTILS.MXT new file mode 100644 index 0000000..717f22f Binary files /dev/null and b/Microsoft COBOL v45/BINR/PWBUTILS.MXT differ diff --git a/Microsoft COBOL v45/BINR/QH.EXE b/Microsoft COBOL v45/BINR/QH.EXE new file mode 100644 index 0000000..57a4b37 Binary files /dev/null and b/Microsoft COBOL v45/BINR/QH.EXE differ diff --git a/Microsoft COBOL v45/BINR/RAMDRIVE.SYS b/Microsoft COBOL v45/BINR/RAMDRIVE.SYS new file mode 100644 index 0000000..4741ec6 Binary files /dev/null and b/Microsoft COBOL v45/BINR/RAMDRIVE.SYS differ diff --git a/Microsoft COBOL v45/BINR/SMARTDRV.SYS b/Microsoft COBOL v45/BINR/SMARTDRV.SYS new file mode 100644 index 0000000..dab279c Binary files /dev/null and b/Microsoft COBOL v45/BINR/SMARTDRV.SYS differ diff --git a/Microsoft COBOL v45/DEMO/ADMOUSE.CBL b/Microsoft COBOL v45/DEMO/ADMOUSE.CBL new file mode 100644 index 0000000..beee31d --- /dev/null +++ b/Microsoft COBOL v45/DEMO/ADMOUSE.CBL @@ -0,0 +1,73 @@ + $set noosvs mf ans85 + ************************************************************ + * * + * (C) Micro Focus Ltd. 1990 * + * * + * ADMOUSE.CBL * + * * + * This program demonstrates the use of a mouse in * + * ADIS ACCEPT statements. * + * * + ************************************************************ + identification division. + data division. + + working-storage section. + 01 filler. + 04 occurs 6. + 05 occurs 10. + 06 ws-item pic 999 value zero. + 01 mouse-param pic 99 comp-x. + 01 use-mouse pic 99 comp-x value 64. + 01 use-panels pic 99 comp-x value 49. + + screen section. + 01 g-admouse. + 02 background-color 7 foreground-color 1. + 03 blank screen. + 03 line 2 col 15 value "USING THE MOUSE POINTER TO MOVE AROUND + - " FIELDS" background-color 3 underline. + 03 line 4 col 8 value "Move the mouse to the field in which y + - "ou wish to enter data, then". + 03 line 5 col 8 value "press the left hand button on the mo + - "use to move the text cursor". + 03 line 6 col 8 value "to the selected field.". + 03 line 8 col 4 value "SALES FIGURES" foreground-color 4 + underline. + 02 background-color 7 foreground-color 6. + 03 line 10 col 13 value " JAN FEB MAR APR MAY JUN + -" JUL AUG SEP OCT". + 03 line 11 col 13 value "ÚÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄ + -"ÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄ¿". + 03 occurs 6. + 05 line + 1 col 13 value "³ ³ ³ ³ ³ ³ + -" ³ ³ ³ ³ ³". + 05 line + 1 col 13 value "ÃÄÄÄÄÄÅÄÄÄÄÄÅÄÄÄÄÄÅÄÄÄÄÄÅÄÄÄÄÄÅÄÄÄ + -"ÄÄÅÄÄÄÄÄÅÄÄÄÄÄÅÄÄÄÄÄÅÄÄÄÄÄ´". + 03 line 23 col 13 value "ÀÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÁ + -"ÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÙ". + 03 line 12 col 4 value "Jam". + 03 line + 2 col 4 value "Honey". + 03 line + 2 col 4 value "Sugar". + 03 line + 2 col 4 value "Bread". + 03 line + 2 col 4 value "Flour". + 03 line + 2 col 4 value "Butter". + 03 line 12 col 15. + 02 background-color 7 foreground-color 0. + 04 occurs 6. + 05 occurs 10. + 06 pic 999 using ws-item. + 06 col + 4. + 05 line + 2 col - 60. + + procedure division. + call x"af" using use-mouse mouse-param + * activate the mouse + move 1 to mouse-param + call x"af" using use-mouse mouse-param. + display g-admouse. + accept g-admouse. + * terminate the mouse + move 0 to mouse-param + call x"af" using use-mouse mouse-param. + stop run. diff --git a/Microsoft COBOL v45/DEMO/APPCDEMO/ACSSVC.CPY b/Microsoft COBOL v45/DEMO/APPCDEMO/ACSSVC.CPY new file mode 100644 index 0000000..c78769f --- /dev/null +++ b/Microsoft COBOL v45/DEMO/APPCDEMO/ACSSVC.CPY @@ -0,0 +1,164 @@ + ******************************************************************* + * * + * (C) Micro Focus Ltd. 1990 * + * * + * ACSSVC copy file * + * * + ******************************************************************* + + *================================================================= + * verb parameter constants + *================================================================= + + 78 sv-add value 0. + 78 sv-change value 1. + 78 sv-ignore value 0. + 78 sv-no-add value 1. + 78 sv-no-send value 1. + 78 sv-send value 0. + + 78 sv-no value h"00". + 78 sv-yes value h"01". + 78 sv-a value h"01". + 78 sv-ae value h"00". + 78 sv-alert-subvectors value h"02". + 78 sv-ascii-to-ebcdic value h"00". + 78 sv-ebcdic-to-ascii value h"01". + 78 sv-g value h"02". + 78 sv-intrv value h"00". + 78 sv-nmvt value h"01". + 78 sv-no-intrv value h"01". + 78 sv-off value h"00". + 78 sv-on value h"01". + 78 sv-pdstats-subvectors value h"03". + 78 sv-substitute value h"00". + 78 sv-round-trip value h"01". + 78 sv-user-defined value h"00". + + *================================================================= + * return codes + *================================================================= + + 78 sv-invalid-verb-segment value h"f008". + 78 sv-invalid-verb value h"ffff". + 78 sv-keylock-secured value h"f013". + 78 sv-ok value h"0000". + 78 sv-parameter-check value h"0001". + 78 sv-comm-subsystem-not-loaded value h"f012". + 78 sv-state-check value h"0002". + 78 sv-unexpected-dos-error value h"f011". + + 78 sv-conversion-error value h"00000406". + 78 sv-data-exceeds-ru-size value h"00000302". + 78 sv-invalid-character-set value h"00000402". + 78 sv-invalid-data-segment value h"00000006". + 78 sv-invalid-data-type value h"00000303". + 78 sv-invalid-direction value h"00000401". + 78 sv-invalid-first-character value h"00000404". + 78 sv-invalid-message-action value h"00000621". + 78 sv-invalid-set value h"00000624". + 78 sv-invalid-storage-size value h"00000627". + 78 sv-sscp-pu-session-not-active value h"00000301". + 78 sv-table-error value h"00000405". + 78 sv-invalid-nmvt-header value h"00000304". + 78 sv-invalid-char-not-found value h"00000630". + 78 sv-invalid-source-code-page value h"00000631". + 78 sv-invalid-target-code-page value h"00000632". + + *================================================================= + * operation codes + *================================================================= + + 78 sv-convert value h"1a00". + 78 sv-define-trace value h"1d00". + 78 sv-get-cp-convert-table value h"1900". + 78 sv-log-message value h"1f00". + 78 sv-transfer-ms-data value h"1c00". + + + *================================================================= + * verb structures + *================================================================= + *----------------------------------------------------------------- + * convert service verb record definitions + *----------------------------------------------------------------- + + *--------------- convert verb ------------------------------------ + 01 convert-verb redefines vcb. + 03 opcode-cvt pic 9(4) comp-x. + 03 filler pic x(2). + 03 primary-rc-cvt pic 9(4) comp-x. + 03 secondary-rc-cvt pic 9(8) comp-x. + 03 direction-cvt pic 9(2) comp-x. + 03 char-set-cvt pic 9(2) comp-x. + 03 len-cvt pic 9(4) comp-5. + 03 src-ptr-cvt usage pointer. + 03 targ-ptr-cvt usage pointer. + *----------------------------------------------------------------- + + *--------------- define-trace verb ------------------------------- + 01 define-trace-verb redefines vcb. + 03 opcode-dft pic 9(4) comp-x. + 03 filler pic x(2). + 03 primary-rc-dft pic 9(4) comp-x. + 03 secondary-rc-dft pic 9(8) comp-x. + 03 filler pic x(8). + 03 dt-set-dft pic 9(2) comp-x. + 03 appc-dft pic 9(2) comp-x. + 03 filler pic x. + 03 srpi-dft pic 9(2) comp-x. + 03 sdlc-dft pic 9(2) comp-x. + 03 tkn-rng-dlc-dft pic 9(2) comp-x. + 03 pcnet-dlc-dft pic 9(2) comp-x. + 03 dft-data pic 9(2) comp-x. + 03 acdi-data pic 9(2) comp-x. + 03 filler pic x. + 03 comm-serv-dft pic 9(2) comp-x. + 03 filler pic x(16). + 03 reset-trc-dft pic 9(2) comp-x. + 03 trunc-dft pic 9(4) comp-5. + 03 strg-size-dft pic 9(4) comp-5. + 03 filler pic x(65). + *----------------------------------------------------------------- + + *--------------- get-cp-convert-table verb ----------------------- + 01 get-cp-convert-table-verb redefines vcb. + 03 opcode-gcp pic 9(4) comp-x. + 03 filler pic x(2). + 03 primary-rc-gcp pic 9(4) comp-x. + 03 secondary-rc-gcp pic 9(8) comp-x. + 03 source-cp-gcp pic 9(4) comp-x. + 03 target-cp-gcp pic 9(4) comp-x. + 03 conv-tbl-addr-gcp usage pointer. + 03 char-not-fnd-gcp pic 9(2) comp-x. + 03 sub-char-gcp pic 9(2) comp-x. + *----------------------------------------------------------------- + + *--------------- log-message verb -------------------------------- + 01 log-message-verb redefines vcb. + 03 opcode-lmg pic 9(4) comp-x. + 03 filler pic x(2). + 03 primary-rc-lmg pic 9(4) comp-x. + 03 secondary-rc-lmg pic 9(8) comp-x. + 03 msg-num-lmg pic 9(4) comp-5. + 03 origntr-id-lmg pic x(8). + 03 msg-file-name-lmg pic x(3). + 03 msg-action-lmg pic 9(2) comp-x. + 03 msg-ins-len-lmg pic 9(4) comp-x. + 03 msg-ins-addr-lmg usage pointer. + *----------------------------------------------------------------- + + *--------------- transfer-ms-data verb---------------------------- + 01 transfer-ms-data-verb redefines vcb. + 03 opcode-tmd pic 9(4) comp-x. + 03 type-tmd pic 9(2) comp-x. + 03 filler pic x. + 03 primary-rc-tmd pic 9(4) comp-x. + 03 secondary-rc-tmd pic 9(8) comp-x. + 03 options-tmd pic 9(2) comp-x. + 03 filler pic x. + 03 origntr-id-tmd pic x(8). + 03 dlen-tmd pic 9(4) comp-5. + 03 data-ptr-tmd usage pointer. + *----------------------------------------------------------------- + diff --git a/Microsoft COBOL v45/DEMO/APPCDEMO/ADAPTER.EXE b/Microsoft COBOL v45/DEMO/APPCDEMO/ADAPTER.EXE new file mode 100644 index 0000000..823018c Binary files /dev/null and b/Microsoft COBOL v45/DEMO/APPCDEMO/ADAPTER.EXE differ diff --git a/Microsoft COBOL v45/DEMO/APPCDEMO/APPC.CPY b/Microsoft COBOL v45/DEMO/APPCDEMO/APPC.CPY new file mode 100644 index 0000000..af0b834 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/APPCDEMO/APPC.CPY @@ -0,0 +1,712 @@ + ******************************************************************* + * * + * (C) Micro Focus Ltd. 1990 * + * * + * APPC copy file * + * * + ******************************************************************* + + *================================================================= + * verb parameter constants + *================================================================= + + 78 ap-no value h"00". + 78 ap-yes value h"01". + + 78 ap-abend value h"05". + 78 ap-abend-prog value h"02". + 78 ap-abend-svc value h"03". + 78 ap-abend-timer value h"04". + 78 ap-basic-conversation value h"00". + 78 ap-buffer value h"00". + 78 ap-confirm-sync-level value h"01". + 78 ap-flush value h"01". + 78 ap-hard value h"01". + 78 ap-immediate value h"01". + 78 ap-ll value h"01". + 78 ap-long value h"01". + 78 ap-mapped-conversation value h"01". + 78 ap-none value h"00". + 78 ap-pgm value h"02". + 78 ap-prog value h"00". + 78 ap-same value h"01". + 78 ap-short value h"00". + 78 ap-soft value h"00". + 78 ap-svc value h"01". + 78 ap-sync-level value h"00". + 78 ap-when-session-allocated value h"00". + 78 ap-when-session-free value h"02". + + 78 ap-confirm-what-received value h"0200". + 78 ap-confirm-deallocate value h"0400". + 78 ap-confirm-send value h"0300". + 78 ap-data value h"0001". + 78 ap-data-complete value h"0002". + 78 ap-data-incomplete value h"0004". + 78 ap-send value h"0100". + + *================================================================= + * return codes + *================================================================= + 78 ap-allocation-error value h"0003". + 78 ap-cancelled value h"0021". + 78 ap-comm-subsystem-abended value h"f003". + 78 ap-comm-subsystem-not-loaded value h"f004". + 78 ap-conv-failure-retry value h"000f". + 78 ap-conv-failure-no-retry value h"0010". + 78 ap-conversation-type-mixed value h"0019". + 78 ap-dealloc-abend value h"0005". + 78 ap-dealloc-abend-prog value h"0006". + 78 ap-dealloc-abend-svc value h"0007". + 78 ap-dealloc-abend-timer value h"0008". + 78 ap-dealloc-normal value h"0009". + 78 ap-invalid-verb-segment value h"f008". + 78 ap-ok value h"0000". + 78 ap-parameter-check value h"0001". + 78 ap-prog-error-no-trunc value h"000c". + 78 ap-prog-error-purging value h"000e". + 78 ap-prog-error-trunc value h"000d". + 78 ap-state-check value h"0002". + 78 ap-svc-error-no-trunc value h"0011". + 78 ap-svc-error-purging value h"0013". + 78 ap-svc-error-trunc value h"0012". + 78 ap-tp-busy value h"f002". + 78 ap-unexpected-dos-error value h"f011". + 78 ap-unsuccessful value h"0014". + 78 ap-stack-too-small value h"f015". + + 78 ap-allocate-not-pending value h"00000509". + 78 ap-alloc-failure-no-retry value h"00000004". + 78 ap-alloc-failure-retry value h"00000005". + 78 ap-attach-mgr-inactive value h"00000508". + 78 ap-bad-conv-id value h"00000002". + 78 ap-bad-conv-type value h"00000011". + 78 ap-bad-ll value h"000000f1". + 78 ap-bad-lu-name value h"00000003". + 78 ap-bad-return-control value h"00000014". + 78 ap-bad-security value h"00000013". + 78 ap-bad-sync-level value h"00000012". + 78 ap-bad-tp-id value h"00000001". + 78 ap-confirm-bad-state value h"00000032". + 78 ap-confirm-not-ll-bdy value h"00000033". + 78 ap-confirm-on-sync-lvl-none value h"00000031". + 78 ap-confirmed-bad-state value h"00000041". + 78 ap-conv-type-mismatch value h"10086034". + 78 ap-dealloc-bad-type value h"00000051". + 78 ap-dealloc-conf-bad-state value h"00000053". + 78 ap-dealloc-flush-bad-state value h"00000052". + 78 ap-dealloc-log-ll-wrong value h"00000057". + 78 ap-dealloc-not-ll-bdy value h"00000055". + 78 ap-flush-not-send-state value h"00000061". + 78 ap-invalid-data-segment value h"00000006". + 78 ap-invalid-process value h"00000525". + 78 ap-invalid-semaphore-handle value h"000000d6". + 78 ap-no-use-of-snasvcmg value h"00000017". + 78 ap-p-to-r-invalid-type value h"000000a1". + 78 ap-p-to-r-not-ll-bdy value h"000000a2". + 78 ap-p-to-r-not-send-state value h"000000a3". + 78 ap-pip-len-incorrect value h"00000016". + 78 ap-pip-not-allowed value h"10086031". + 78 ap-pip-not-spec-correct value h"10086032". + 78 ap-rcv-and-post-not-ll-bdy value h"000000d2". + 78 ap-r-t-s-bad-state value h"000000e1". + 78 ap-rcv-and-post-bad-fill value h"000000d5". + 78 ap-rcv-and-post-bad-state value h"000000d1". + 78 ap-rcv-and-wait-bad-fill value h"000000b5". + 78 ap-rcv-and-wait-bad-state value h"000000b1". + 78 ap-rcv-and-wait-not-ll-bdy value h"000000b2". + 78 ap-rcv-immd-bad-fill value h"000000c4". + 78 ap-rcv-immd-bad-state value h"000000c1". + 78 ap-security-not-valid value h"080f6051". + 78 ap-send-data-bad-map-name value h"000000f3". + 78 ap-send-data-not-send-state value h"000000f2". + 78 ap-send-error-bad-type value h"00000103". + 78 ap-sync-level-not-supported value h"10086041". + 78 ap-send-error-log-ll-wrong value h"00000102". + 78 ap-too-many-tps value h"00000243". + 78 ap-tp-name-not-recognized value h"10086021". + 78 ap-t-pgm-not-avail-no-retry value h"084c0000". + 78 ap--pgm-not-avail-retry value h"084b6031". + 78 ap-undefined-tp-name value h"00000506". + 78 ap-unknown-partner-mode value h"00000018". + + *================================================================= + * operation codes + *================================================================= + 78 ap-b-allocate value h"0100". + 78 ap-b-confirm value h"0300". + 78 ap-b-confirmed value h"0400". + 78 ap-b-deallocate value h"0500". + 78 ap-b-flush value h"0600". + 78 ap-b-get-attributes value h"0700". + 78 ap-b-prepare-to-receive value h"0a00". + 78 ap-b-receive-and-post value h"0d00". + 78 ap-b-receive-and-wait value h"0b00". + 78 ap-b-receive-immediate value h"0c00". + 78 ap-b-request-to-send value h"0e00". + 78 ap-b-send-data value h"0f00". + 78 ap-b-send-error value h"1000". + 78 ap-b-test-rts value h"1200". + + 78 ap-m-allocate value h"0100". + 78 ap-m-confirm value h"0300". + 78 ap-m-confirmed value h"0400". + 78 ap-m-deallocate value h"0500". + 78 ap-m-flush value h"0600". + 78 ap-m-get-attributes value h"0700". + 78 ap-m-prepare-to-receive value h"0a00". + 78 ap-m-receive-and-post value h"0d00". + 78 ap-m-receive-and-wait value h"0b00". + 78 ap-m-receive-immediate value h"0c00". + 78 ap-m-request-to-send value h"0e00". + 78 ap-m-send-data value h"0f00". + 78 ap-m-send-error value h"1000". + 78 ap-m-test-rts value h"1200". + + 78 ap-get-type value h"0800". + 78 ap-receive-allocate value h"1600". + 78 ap-tp-ended value h"1300". + 78 ap-tp-started value h"1400". + + + *================================================================= + * verb structures + *================================================================= + + *----------------------------------------------------------------- + * verb control block + * + * this is a buffer which is passed to all of the APPC verbs. + * the contents of the VCB are different for each verb called + * Not all the fields of the VCB are used in every verb call, + * those that are not should be zeroed. + * + * The VCB is defined below - and the redefinitions that follow + * specify the structure of each verb. + * + *----------------------------------------------------------------- + 01 vcb. + 03 opcode-vcb pic 9(4) comp-x. + 03 opext-vcb pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-vcb pic 9(4) comp-x. + 03 sec-rc-vcb pic 9(8) comp-x. + 03 filler pic x(290). + + *----------------------------------------------------------------- + * transaction program control interface + *----------------------------------------------------------------- + + *--------------- receive-allocate verb --------------------------- + 01 rcv-alloc-verb redefines vcb. + 03 opcode-ral pic 9(4) comp-x. + 03 filler pic x(2). + 03 prim-rc-ral pic 9(4) comp-x. + 03 sec-rc-ral pic 9(8) comp-x. + 03 tp-name-ral pic x(64). + 03 tp-id-ral pic x(8). + 03 conv-id-ral pic x(4). + 03 sync-lvl-ral pic 9(2) comp-x. + 03 conv-type-ral pic 9(2) comp-x. + 03 user-id-ral pic x(10). + 03 lu-alias-ral pic x(8). + 03 plu-alias-ral pic x(8). + 03 mode-name-ral pic x(8). + 03 filler pic x(28). + *----------------------------------------------------------------- + + *--------------- tp-ended ---------------------------------------- + 01 tp-ended-verb redefines vcb. + 03 opcode-tpe pic 9(4) comp-x. + 03 filler pic x(2). + 03 prim-rc-tpe pic 9(4) comp-x. + 03 sec-rc-tpe pic 9(8) comp-x. + 03 tp-id-tpe pic x(8). + 03 filler pic x(28). + *----------------------------------------------------------------- + + *--------------- tp-started -------------------------------------- + 01 tp-started-verb redefines vcb. + 03 opcode-tps pic 9(4) comp-x. + 03 filler pic x(2). + 03 prim-rc-tps pic 9(4) comp-x. + 03 sec-rc-tps pic 9(8) comp-x. + 03 lu-alias-tps pic x(8). + 03 tp-id-tps pic x(8). + 03 tp-name-tps pic x(64). + *----------------------------------------------------------------- + + *----------------------------------------------------------------- + * Transaction programming interface - basic conversation + *----------------------------------------------------------------- + + *--------------- allocate ---------------------------------------- + 01 alloc-verb redefines vcb. + 03 opcode-alc pic 9(4) comp-x. + 03 opext-alc pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-alc pic 9(4) comp-x. + 03 sec-rc-alc pic 9(8) comp-x. + 03 tp-id-alc pic x(8). + 03 conv-id-alc pic x(4). + 03 conv-type-alc pic 9(2) comp-x. + 03 sync-lvl-alc pic 9(2) comp-x. + 03 filler pic x(2). + 03 rtn-ctl-alc pic 9(2) comp-x. + 03 filler pic x(9). + 03 plu-alias-alc pic x(8). + 03 mode-name-alc pic x(8). + 03 tp-name-alc pic x(64). + 03 security-alc pic 9(2) comp-x. + 03 filler pic x(11). + 03 pwd-alc pic x(10). + 03 user-id-alc pic x(10). + 03 pip-dlen-alc pic 9(4) comp-5. + 03 pip-dptr-alc usage pointer. + 03 filler pic x(26). + *----------------------------------------------------------------- + + *--------------- confirm ----------------------------------------- + 01 cnfrm-verb redefines vcb. + 03 opcode-cfm pic 9(4) comp-x. + 03 opext-cfm pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-cfm pic 9(4) comp-x. + 03 sec-rc-cfm pic 9(8) comp-x. + 03 tp-id-cfm pic x(8). + 03 conv-id-cfm pic x(4). + 03 rts-rcvd-cfm pic 9(2) comp-x. + *----------------------------------------------------------------- + + *--------------- confirmed --------------------------------------- + 01 cnfrmd-verb redefines vcb. + 03 opcode-cfd pic 9(4) comp-x. + 03 opext-cfd pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-cfd pic 9(4) comp-x. + 03 sec-rc-cfd pic 9(8) comp-x. + 03 tp-id-cfd pic x(8). + 03 conv-id-cfd pic x(4). + *----------------------------------------------------------------- + + *--------------- deallocate -------------------------------------- + 01 dealloc-verb redefines vcb. + 03 opcode-dal pic 9(4) comp-x. + 03 opext-dal pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-dal pic 9(4) comp-x. + 03 sec-rc-dal pic 9(8) comp-x. + 03 tp-id-dal pic x(8). + 03 conv-id-dal pic x(4). + 03 filler pic x. + 03 dealloc-type-dal pic 9(2) comp-x. + 03 log-dlen-dal pic 9(4) comp-5. + 03 log-dptr-dal usage pointer. + *----------------------------------------------------------------- + + *--------------- flush ------------------------------------------- + 01 flush-verb redefines vcb. + 03 opcode-fls pic 9(4) comp-x. + 03 opext-fls pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-fls pic 9(4) comp-x. + 03 sec-rc-fls pic 9(8) comp-x. + 03 tp-id-fls pic x(8). + 03 conv-id-fls pic x(4). + *----------------------------------------------------------------- + + *--------------- get-attributes ---------------------------------- + 01 get-atts-verb redefines vcb. + 03 opcode-gat pic 9(4) comp-x. + 03 opext-gat pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-gat pic 9(4) comp-x. + 03 sec-rc-gat pic 9(8) comp-x. + 03 tp-id-gat pic x(8). + 03 conv-id-gat pic x(4). + 03 filler pic x. + 03 sync-lvl-gat pic 9(2) comp-x. + 03 mode-name-gat pic x(8). + 03 net-name-gat pic x(8). + 03 lu-name-gat pic x(8). + 03 lu-alias-gat pic x(8). + 03 plu-alias-gat pic x(8). + 03 plu-un-name-gat pic x(8). + 03 filler pic x(2). + 03 fqplun-gat pic x(17). + 03 filler pic x. + 03 user-id-gat pic x(10). + 03 filler pic x(26). + *----------------------------------------------------------------- + + *--------------- prepare-to-receive ------------------------------ + 01 prp-to-rcv-verb redefines vcb. + 03 opcode-ptr pic 9(4) comp-x. + 03 opext-ptr pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-ptr pic 9(4) comp-x. + 03 sec-rc-ptr pic 9(8) comp-x. + 03 tp-id-ptr pic x(8). + 03 conv-id-ptr pic x(4). + 03 ptr-type-ptr pic 9(2) comp-x. + 03 locks-ptr pic 9(2) comp-x. + *----------------------------------------------------------------- + + *--------------- receive-and-post -------------------------------- + 01 rcv-and-post-verb redefines vcb. + 03 opcode-rap pic 9(4) comp-x. + 03 opext-rap pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-rap pic 9(4) comp-x. + 03 sec-rc-rap pic 9(8) comp-x. + 03 tp-id-rap pic x(8). + 03 conv-id-rap pic x(4). + 03 what-rcvd-rap pic 9(4) comp-x. + 03 filler pic x. + 03 fill-rap pic 9(2) comp-x. + 03 rts-rcvd-rap pic 9(2) comp-x. + 03 filler pic x. + 03 max-len-rap pic 9(4) comp-5. + 03 dlen-rap pic 9(4) comp-5. + 03 dptr-rap usage pointer. + 03 sema-rap pic 9(8) comp-5. + 03 filler pic x. + *----------------------------------------------------------------- + + *--------------- receive-and-wait -------------------------------- + 01 rcv-and-wait-verb redefines vcb. + 03 opcode-raw pic 9(4) comp-x. + 03 opext-raw pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-raw pic 9(4) comp-x. + 03 sec-rc-raw pic 9(8) comp-x. + 03 tp-id-raw pic x(8). + 03 conv-id-raw pic x(4). + 03 what-rcvd-raw pic 9(4) comp-x. + 03 filler pic x. + 03 fill-raw pic 9(2) comp-x. + 03 rts-rcvd-raw pic 9(2) comp-x. + 03 filler pic x. + 03 max-len-raw pic 9(4) comp-5. + 03 dlen-raw pic 9(4) comp-5. + 03 dptr-raw usage pointer. + 03 filler pic x(5). + *----------------------------------------------------------------- + + *--------------- receive-immediate ------------------------------- + 01 rcv-imm-verb redefines vcb. + 03 opcode-rim pic 9(4) comp-x. + 03 opext-rim pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-rim pic 9(4) comp-x. + 03 sec-rc-rim pic 9(8) comp-x. + 03 tp-id-rim pic x(8). + 03 conv-id-rim pic x(4). + 03 what-rcvd-rim pic 9(4) comp-x. + 03 filler pic x. + 03 fill-rim pic 9(2) comp-x. + 03 rts-rcvd-rim pic 9(2) comp-x. + 03 filler pic x. + 03 max-len-rim pic 9(4) comp-5. + 03 dlen-rim pic 9(4) comp-5. + 03 dptr-rim usage pointer. + 03 filler pic x(5). + *----------------------------------------------------------------- + + *--------------- request-to-send --------------------------------- + 01 rq-to-snd-verb redefines vcb. + 03 opcode-rts pic 9(4) comp-x. + 03 opext-rts pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-rts pic 9(4) comp-x. + 03 sec-rc-rts pic 9(8) comp-x. + 03 tp-id-rts pic x(8). + 03 conv-id-rts pic x(4). + *----------------------------------------------------------------- + + *--------------- send-data --------------------------------------- + 01 snd-data-verb redefines vcb. + 03 opcode-sdt pic 9(4) comp-x. + 03 opext-sdt pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-sdt pic 9(4) comp-x. + 03 sec-rc-sdt pic 9(8) comp-x. + 03 tp-id-sdt pic x(8). + 03 conv-id-sdt pic x(4). + 03 rts-rcvd-sdt pic 9(2) comp-x. + 03 filler pic x. + 03 dlen-sdt pic 9(4) comp-5. + 03 dptr-sdt usage pointer. + 03 filler pic x(2). + *----------------------------------------------------------------- + + *--------------- send-error -------------------------------------- + 01 snd-err-verb redefines vcb. + 03 opcode-ser pic 9(4) comp-x. + 03 opext-ser pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-ser pic 9(4) comp-x. + 03 sec-rc-ser pic 9(8) comp-x. + 03 tp-id-ser pic x(8). + 03 conv-id-ser pic x(4). + 03 rts-rcvd-ser pic 9(2) comp-x. + 03 err-type-ser pic 9(2) comp-x. + 03 filler pic x(2). + 03 log-dlen-ser pic 9(4) comp-5. + 03 l-dptr-ser usage pointer. + *----------------------------------------------------------------- + + *--------------- test-rts ---------------------------------------- + 01 test-rts-verb redefines vcb. + 03 opcode-tst pic 9(4) comp-x. + 03 opext-tst pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-tst pic 9(4) comp-x. + 03 sec-rc-tst pic 9(8) comp-x. + 03 tp-id-tst pic x(8). + 03 conv-id-tst pic x(4). + 03 filler pic x. + *----------------------------------------------------------------- + + *----------------------------------------------------------------- + * Transaction programming interface - mapped conversation + *----------------------------------------------------------------- + + *--------------- mc-allocate ------------------------------------- + 01 mc-alloc-verb redefines vcb. + 03 opcode-mal pic 9(4) comp-x. + 03 opext-mal pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-mal pic 9(4) comp-x. + 03 sec-rc-mal pic 9(8) comp-x. + 03 tp-id-mal pic x(8). + 03 conv-id-mal pic x(4). + 03 conv-type-mal pic 9(2) comp-x. + 03 sync-lvl-mal pic 9(2) comp-x. + 03 filler pic x(2). + 03 rtn-ctl-mal pic 9(2) comp-x. + 03 filler pic x(9). + 03 plu-alias-mal pic x(8). + 03 mode-name-mal pic x(8). + 03 tp-name-mal pic x(64). + 03 security-mal pic 9(2) comp-x. + 03 filler pic x(11). + 03 pwd-mal pic x(10). + 03 user-id-mal pic x(10). + 03 pip-dlen-mal pic 9(4) comp-5. + 03 pip-dptr-mal usage pointer. + 03 filler pic x(26). + *----------------------------------------------------------------- + + *--------------- mc-confirm -------------------------------------- + 01 mc-cnfrm-verb redefines vcb. + 03 opcode-mcm pic 9(4) comp-x. + 03 opext-mcm pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-mcm pic 9(4) comp-x. + 03 sec-rc-mcm pic 9(8) comp-x. + 03 tp-id-mcm pic x(8). + 03 conv-id-mcm pic x(4). + 03 rts-rcvd-mcm pic 9(2) comp-x. + *----------------------------------------------------------------- + + *--------------- mc-confirmed ------------------------------------ + 01 mc-cnfrmd-verb redefines vcb. + 03 opcode-mcd pic 9(4) comp-x. + 03 opext-mcd pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-mcd pic 9(4) comp-x. + 03 sec-rc-mcd pic 9(8) comp-x. + 03 tp-id-mcd pic x(8). + 03 conv-id-mcd pic x(4). + *----------------------------------------------------------------- + + *--------------- mc-deallocate ----------------------------------- + 01 mc-dealloc-verb redefines vcb. + 03 opcode-mda pic 9(4) comp-x. + 03 opext-mda pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-mda pic 9(4) comp-x. + 03 sec-rc-mda pic 9(8) comp-x. + 03 tp-id-mda pic x(8). + 03 conv-id-mda pic x(4). + 03 filler pic x. + 03 dealloc-type-mda pic 9(2) comp-x. + 03 filler pic x(6). + *----------------------------------------------------------------- + + *--------------- mc-flush ---------------------------------------- + 01 mc-flush-verb redefines vcb. + 03 opcode-mfl pic 9(4) comp-x. + 03 opext-mfl pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-mfl pic 9(4) comp-x. + 03 sec-rc-mfl pic 9(8) comp-x. + 03 tp-id-mfl pic x(8). + 03 conv-id-mfl pic x(4). + *----------------------------------------------------------------- + + *--------------- mc-get-attributes ------------------------------- + 01 mc-get-atts-verb redefines vcb. + 03 opcode-mga pic 9(4) comp-x. + 03 opext-mga pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-mga pic 9(4) comp-x. + 03 sec-rc-mga pic 9(8) comp-x. + 03 tp-id-mga pic x(8). + 03 conv-id-mga pic x(4). + 03 filler pic x. + 03 sync-lvl-mga pic 9(2) comp-x. + 03 mode-name-mga pic x(8). + 03 net-name-mga pic x(8). + 03 lu-name-mga pic x(8). + 03 lu-alias-mga pic x(8). + 03 plu-alias-mga pic x(8). + 03 plu-un-name-mga pic x(8). + 03 filler pic x(2). + 03 fqplun-mga pic x(17). + 03 filler pic x. + 03 user-id-mga pic x(10). + 03 filler pic x(26). + *----------------------------------------------------------------- + + *--------------- mc-prepare-to-receive --------------------------- + 01 mc-prp-to-rcv-verb redefines vcb. + 03 opcode-mpr pic 9(4) comp-x. + 03 opext-mpr pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-mpr pic 9(4) comp-x. + 03 sec-rc-mpr pic 9(8) comp-x. + 03 tp-id-mpr pic x(8). + 03 conv-id-mpr pic x(4). + 03 ptr-type-mpr pic 9(2) comp-x. + 03 locks-mpr pic 9(2) comp-x. + *----------------------------------------------------------------- + + *--------------- mc-receive-and-post ----------------------------- + 01 mc-rcv-and-post-verb redefines vcb. + 03 opcode-mrp pic 9(4) comp-x. + 03 opext-mrp pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-mrp pic 9(4) comp-x. + 03 sec-rc-mrp pic 9(8) comp-x. + 03 tp-id-mrp pic x(8). + 03 conv-id-mrp pic x(4). + 03 what-rcvd-mrp pic 9(4) comp-x. + 03 filler pic x(2). + 03 rts-rcvd-mrp pic 9(2) comp-x. + 03 filler pic x. + 03 max-len-mrp pic 9(4) comp-5. + 03 dlen-mrp pic 9(4) comp-5. + 03 dptr-mrp usage pointer. + 03 sema-mrp pic 9(8) comp-5. + 03 filler pic x. + *----------------------------------------------------------------- + + *--------------- mc-receive-and-wait ----------------------------- + 01 mc-rcv-and-wait-verb redefines vcb. + 03 opcode-mrw pic 9(4) comp-x. + 03 opext-mrw pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-mrw pic 9(4) comp-x. + 03 sec-rc-mrw pic 9(8) comp-x. + 03 tp-id-mrw pic x(8). + 03 conv-id-mrw pic x(4). + 03 what-rcvd-mrw pic 9(4) comp-x. + 03 filler pic x(2). + 03 rts-rcvd-mrw pic 9(2) comp-x. + 03 filler pic x. + 03 max-len-mrw pic 9(4) comp-5. + 03 dlen-mrw pic 9(4) comp-5. + 03 dptr-mrw usage pointer. + 03 filler pic x(5). + *----------------------------------------------------------------- + + *--------------- mc-receive-immediate ---------------------------- + 01 mc-rcv-imm-verb redefines vcb. + 03 opcode-mri pic 9(4) comp-x. + 03 opext-mri pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-mri pic 9(4) comp-x. + 03 sec-rc-mri pic 9(8) comp-x. + 03 tp-id-mri pic x(8). + 03 conv-id-mri pic x(4). + 03 what-rcvd-mri pic 9(4) comp-x. + 03 filler pic x(2). + 03 rts-rcvd-mri pic 9(2) comp-x. + 03 filler pic x. + 03 max-len-mri pic 9(4) comp-5. + 03 dlen-mri pic 9(4) comp-5. + 03 dptr-mri usage pointer. + 03 filler pic x(5). + *----------------------------------------------------------------- + + *--------------- mc-request-to-send ------------------------------ + 01 mc-rq-to-snd-verb redefines vcb. + 03 opcode-mrs pic 9(4) comp-x. + 03 opext-mrs pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-mrs pic 9(4) comp-x. + 03 sec-rc-mrs pic 9(8) comp-x. + 03 tp-id-mrs pic x(8). + 03 conv-id-mrs pic x(4). + *----------------------------------------------------------------- + + *--------------- mc-send-data ------------------------------------ + 01 mc-snd-data-verb redefines vcb. + 03 opcode-msd pic 9(4) comp-x. + 03 opext-msd pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-msd pic 9(4) comp-x. + 03 sec-rc-msd pic 9(8) comp-x. + 03 tp-id-msd pic x(8). + 03 conv-id-msd pic x(4). + 03 rts-rcvd-msd pic 9(2) comp-x. + 03 filler pic x. + 03 dlen-msd pic 9(4) comp-5. + 03 dptr-msd usage pointer. + 03 filler pic x(2). + *----------------------------------------------------------------- + + *--------------- mc-send-error ----------------------------------- + 01 mc-snd-err-verb redefines vcb. + 03 opcode-mse pic 9(4) comp-x. + 03 opext-mse pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-mse pic 9(4) comp-x. + 03 sec-rc-mse pic 9(8) comp-x. + 03 tp-id-mse pic x(8). + 03 conv-id-mse pic x(4). + 03 rts-rcvd-mse pic 9(2) comp-x. + 03 err-type-mse pic 9(2) comp-x. + 03 filler pic x(8). + *----------------------------------------------------------------- + + *--------------- mc-test-rts ------------------------------------- + 01 mc-test-rts-verb redefines vcb. + 03 opcode-mtr pic 9(4) comp-x. + 03 opext-mtr pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-mtr pic 9(4) comp-x. + 03 sec-rc-mtr pic 9(8) comp-x. + 03 tp-id-mtr pic x(8). + 03 conv-id-mtr pic x(4). + 03 filler pic x. + *----------------------------------------------------------------- + + *----------------------------------------------------------------- + * type independent conversation interface + *----------------------------------------------------------------- + + *--------------- get-type ---------------------------------------- + 01 get-type-verb redefines vcb. + 03 opcode-gtt pic 9(4) comp-x. + 03 opext-gtt pic 9(2) comp-x. + 03 filler pic x. + 03 prim-rc-gtt pic 9(4) comp-x. + 03 sec-rc-gtt pic 9(8) comp-x. + 03 tp-id-gtt pic x(8). + 03 conv-id-gtt pic x(4). + 03 conv-type-gtt pic 9(2) comp-x. + *----------------------------------------------------------------- + diff --git a/Microsoft COBOL v45/DEMO/APPCDEMO/APPCBATL.CFG b/Microsoft COBOL v45/DEMO/APPCDEMO/APPCBATL.CFG new file mode 100644 index 0000000..b14fafa Binary files /dev/null and b/Microsoft COBOL v45/DEMO/APPCDEMO/APPCBATL.CFG differ diff --git a/Microsoft COBOL v45/DEMO/APPCDEMO/APPCBATR.CFG b/Microsoft COBOL v45/DEMO/APPCDEMO/APPCBATR.CFG new file mode 100644 index 0000000..953afca Binary files /dev/null and b/Microsoft COBOL v45/DEMO/APPCDEMO/APPCBATR.CFG differ diff --git a/Microsoft COBOL v45/DEMO/APPCDEMO/APPCDEMO.DOC b/Microsoft COBOL v45/DEMO/APPCDEMO/APPCDEMO.DOC new file mode 100644 index 0000000..de2d123 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/APPCDEMO/APPCDEMO.DOC @@ -0,0 +1,254 @@ + + + COBOL Advanced Program to Program (APPC) Demonstration + ====================================================== + + + Contents + -------- + + Introduction + Hardware/software requirements + Amending the configuration profiles + Changing CONFIG.SYS + Compiling and running the demonstration + User instructions + + + Introduction + ------------ + + This document describes how to run a demonstration which uses + Advanced Program to Program Communication to communicate between two + programs on a network. + + The demonstration is the game Battleships. Each program controls + the two player's views of the battle scene, showing positions of his + own ships and coordinates where previous attacks have been made. + The game involves a simple two way communication of sending + coordinates, receiving opponent's damage reports, receiving + opponent's attack coordinates and sending own damage reports. + Instructions for playing the game are provided later. + + If you have no previous knowledge of APPC, we recommend that you read + the IBM OS/2 Extended Edition Version 1.1 APPC Programming Reference + manual to gain a basic understanding of the concepts and terminology. + For detailed information about configuring Communications Manager, + refer to the IBM Operating System/2 Extended Edition Version 1.1 + System Administrator's Guide for Communications. Also read the + section on using APPC in the document INTERFAC.DOC. + + + Hardware/Software requirements + ------------------------------ + + Hardware: + + o Two IBM PS/2s or machines capable of running IBM OS/2 1.1 Extended + Edition + + o Memory enough to run IBM OS/2 1.1 EE with Communications Manager, + this will be around 6 megabytes. + + o Both machines to be connected to an IBM Token Ring Network or PC LAN + Network + + System Software: + + o IBM OS/2 1.1 Extended Edition + + o Communications Manager (CM) + + o CM configuration profile to run APPC + + o Network Driver software relevent to type of network being used + + Application Software: + + o The following programs/configurations have been provided: + + BATTLEL.CBL - main program for local machine + BATTRER.CBL - main program for remote machine + BATTLE.WKS - working storage copy file + BATTLE.SS - screen section copy file + BATTLE.CBL - procedure copy file + BATTLE.CMD - batch file to create run files + BATTAPPC.CBL - communications interface + APPCBATL.CFG - CM configuration profile for local machine + APPCBATR.CFG - CM configuration profile for remote machine + ADAPTER.EXE - Utility program to get adapter address + APPC.CPY - APPC COBOL definitions (appc basic/mapped verbs) + ACSSVC.CPY - ACSSVC COBOL definitions (common service verbs) + + o APPC.CPY and ACSSVC.CPY are general purpose copy files, and can be + used by any COBOL APPC application. The files contain definitions + for each verb's control block, operation codes, error codes and + constants. + + + Amending the configuration profiles + ----------------------------------- + + Before you can start running the demonstration programs you must amend + one and possibly both the configuration files. The configurations + provided assume that you will be using an IBM Token Ring Network running + on a PS/2 machine. If you have a different type of machine or you are + using a different DLC type (eg. IBM PC Network ) it is likely that you + will have to amend the configurations. + + The other change, which you should make to APPCBATL.CFG, is to fill in + the adapter number field in the Partner Logical Unit Profiles of the SNA + Feature Profiles menu. This tells Communications Manager which machine + on the network to talk converse with. + + The profile which you should change is called DEMOPLU. To change this + field: + + o start Communications Manager with the configuration file as a + parameter: 'CM APPCBATL' + o press F10 and select 'A' to get to the advanced pull down menu + o select 'C' for configuration + o enter configuration name APPCBATL (if not already shown) and press + enter key + o select the SNA Feature Profiles menu + o select the PLU profile menu + o enter 'H' to change profile + o enter profile name 'DEMOPLU1' and press enter key + o press enter key to accept first screen + o move cursor to adapter number field and enter the adapter address of + the network adapter card in the machine that will use the other + configuration ie. APPCBATR.CFG. + o keep pressing the enter key until you reach the SNA Feature + Configuration menu, then press the escape key to get back to + Communication Configuration menu + o press F10 and then 'V' and the enter key to verify the changes you + have made + o the verification should complete successfully + o exit Communications Manager + + The adapter number is the hard coded address of the network adapter card + (each card is given a unique address by the manufacturer). You can find out + this address by running ADAPTER.EXE (OS/2 1.1), or by looking in ACSLAN.LOG + in the CMLIB directory (OS/2 1.2) on the machine which will use the + configuration file 'APPCBATR.CFG'. + + + Changing CONFIG.SYS + ------------------- + + The device drivers which control the network hardware require the CM + configuration profiles to be specified as parameters. + + If you are using a IBM Token Ring Network amend the following lines in + CONFIG.SYS. + o on the local machine: + + DEVICE=C:\CMLIB\TRNETDD.SYS CFG=C:\CMLIB\APPCBATL.CFG + DEVICE=C:\CMLIB\NETBDD.SYS CFG=C:\CMLIB\APPCBATL.CFG + + o on the remote machine: + + DEVICE=C:\CMLIB\TRNETDD.SYS CFG=C:\CMLIB\APPCBATR.CFG + DEVICE=C:\CMLIB\NETBDD.SYS CFG=C:\CMLIB\APPCBATR.CFG + + If you are using a IBM PC LAN Network amend the following lines in + CONFIG.SYS. + o on the local machine: + + DEVICE=C:\CMLIB\PCNETDD.SYS CFG=C:\CMLIB\APPCBATL.CFG + DEVICE=C:\CMLIB\NETBDD.SYS CFG=C:\CMLIB\APPCBATL.CFG + + o on the remote machine: + + DEVICE=C:\CMLIB\PCNETDD.SYS CFG=C:\CMLIB\APPCBATR.CFG + DEVICE=C:\CMLIB\NETBDD.SYS CFG=C:\CMLIB\APPCBATR.CFG + + After changing CONFIG.SYS reboot both machines so that the device + drivers are reactivated with the correct configurations. + + + Starting Communications Manager + ------------------------------- + + Before you start running the demo program you must make sure that you + have started Communications Manager (CM) on each machine with the + respective configuration file active. To make the configuration + active supply its name as a parameter when you start CM. + + eg. STARTCM APPCBATL + + If you receive any error messages when you start CM you should fix + these problems before attempting to run the programs. If you do have + problems record the error message number and refer to the IBM OS/2 EE + Manual on Programming Services and Problem Determination for + Communications for help. + + + Compiling and running the demonstration + --------------------------------------- + + The demonstration programs can be compiled for use with Animator or as + object files which can then be linked to produce standalone executable + programs. + + A batch file has been provided : BATTLE.CMD which will create the + files to run the demonstration. The batch file will produce files for + animation or for direct execution. + + To run the demonstration, start BATTLEL on the machine that has + configuration profile APPCBATL.CFG active. + + If there are no problems with the connection, a message on the remote + machine should appear instructing the operator to begin a transaction + program called BATTLE. + + This message is your prompt to start BATTLER on the remote machine. + + If a conversation is established, the two programs should start to + communicate with each other and the BATTLESHIPS game should start. + + If any errors occur, the program will stop and the error codes, together + with the verb operation code will be displayed. Refer to the APPC + Reference Manual for information on error codes. Additional information + is provided by the error log, which can be accessed from the Problem + Determination menu of the Advanced features pull down menu. This provides + information in the form of error codes which reference cause/diagnosis + text in the Problem Determination for Communications manual - it will + also report what area of communications the problem occured in. + + Unless you change the programs, the most likely cause of any problems + that may occur will be due to problems in the configuration file. The + configurations provided are model profiles. This means that you may have + to amend some fields in the profile which suit the particular setup you + have. For example the LAN Adapter Type profile has been configured as an + IBM Token-Ring Network Adapter /A card which is generally used by IBM + PS/2 machines. If you are using a different machine you will likely have + to change the profile to configure a different type of card. Also it is + possible to have two adapter cards installed in a machine. The primary + adapter card is known as Adapter 0 and the secondary as Adapter 1. The + configurations assume only one card is installed which define Adapter 0. + If you have two cards, you may have to alter the profile to reflect this. + + + User Instructions + ----------------- + + Before the game starts, both players should agree on how many ships that + are going to take part and how many of each type of ship. There are four + types of ships: Aircraft Carrier, Battleship, Frigate and Gun-Boat, + denoted by the letters: A,B,F and G respectively. There is no limit to + the numbers of ships, nor of each type. The only requirement is that + different ships of the same type are not placed in adjacent locations to + one another. + + The game starts for player 1. Player 1 selects a grid coordinate where he + thinks an opponent ship is located. Coordinates are specified in column + row order (eg. F2). After a while, player 1 will receive a damage report + of the earlier attempt this will be either a hit, a miss or a sinking. + If a part of an opponent's ship has been hit, the grid location is + colored red, a miss it is colored cyan and a sink, the whole ship is + marked in black. After this player 2 has his turn. The player who sinks + all of his opponent's ships first wins the game. + + The game can be stopped by entering a grid location of Q. This will + send a message to the opponent to quit. diff --git a/Microsoft COBOL v45/DEMO/APPCDEMO/BATTAPPC.CBL b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTAPPC.CBL new file mode 100644 index 0000000..f17c09e --- /dev/null +++ b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTAPPC.CBL @@ -0,0 +1,646 @@ + $set mf ans85 noosvs + ******************************************************************* + * * + * * + * (C) Micro Focus Ltd. 1990 * + * * + * BATTAPPC.CBL * + * * + * COBOL Advanced Program to Program (APPC) Demonstration * + * * + * Battleships * + * communications module * + * * + ******************************************************************* + + ******************************************************************* + * BATTAPPC - links two battleships games using APPC * + * * + * This program is called by BATTLEL & BATTLER to communicate * + * between one another. * + * * + * The communications that take place are: * + * - to bring up a link between the two programs * + * - to take down a link * + * - to send coordinates to a program * + * - to receive coordinates from a program * + * - to send a damage report to a program * + * - to receive a damage report from a program * + * * + * The method of communication is entirey transparent to the * + * users of the game. So long as the same interface is used, * + * this module could be replaced by one which used a different * + * communications protocol. * + * * + * The interface consists of two parameters. The first parameter * + * is the operation code - indicating which function to perform. * + * The second parameter is a buffer area which is used to pass * + * information between the communicating programs. * + * * + * The result of any operation is returned to the calling program * + * in the RETURN-CODE system variable. A zero value indicates * + * success and a non-zero value indicates some error - In this * + * example program, the error handling is very simple - in that * + * the programs will stop if any error is received. You may, * + * however, decide to provide more intelligent error handling, in * + * which the user of the game may be given alternative courses of * + * action when such an error occurs. * + * * + ******************************************************************* + Special-names. + call-convention 3 is api. + + Working-Storage Section. + copy "appc.cpy". + copy "acssvc.cpy". + + *----------------------------------------------------------------- + * Working variables + *----------------------------------------------------------------- + 01 tp-name pic x(64) value spaces. + 78 tp-name-len value 64. + 01 tp-id pic x(8) value spaces. + 01 lu-alias pic x(8) value spaces. + 01 plu-alias pic x(8) value spaces. + 01 conv-id pic x(4) value spaces. + 01 mode-name pic x(8) value spaces. + 78 mode-name-len value 8. + + 01 what-received pic 9(4) comp-x. + 01 request-to-send-received pic 9(2) comp-x. + 01 state-flag pic 9(2) comp-x. + 88 Sending-State value 1. + 88 Receiving-State value 0. + + 01 data-buffer-length pic 9(4) comp-5. + 01 data-buffer-ptr usage pointer. + 01 data-buffer-address + redefines data-buffer-ptr. + 03 data-buffer-offset pic 9(4) comp-5. + 03 data-buffer-selector pic 9(4) comp-5. + 01 alloc-flags pic 9(4) comp-5 value 1. + 01 key-char pic x. + + + *----------------------------------------------------------------- + * following items used for constructing error message + *----------------------------------------------------------------- + 01 bin-dword. + 03 bin-dword-msw pic 9(4) comp-x. + 03 bin-dword-lsw pic 9(4) comp-x. + 01 bin-val. + 03 bin-val-1 pic 9(2) comp-x. + 03 bin-val-2 pic 9(2) comp-x. + + 01 hex-idx-1 pic 9(2) comp-x. + 01 hex-idx-2 pic 9(2) comp-x. + 01 hex-disp pic x(4). + 01 hex-string pic x(16) + value "0123456789ABCDEF". + 01 clear-char pic x value " ". + 01 clear-attr pic 9(2) comp-x value 7. + 01 screen-pos pic 9(4) comp-x value h"0100". + 01 error-msg. + 03 filler pic x(25) + value 'APPC/ACSSVC Error Verb=x"'. + 03 error-1 pic x(4). + 03 filler pic x(17) + value '" Primary Code=x"'. + 03 error-2 pic x(4). + 03 filler pic x(19) + value '" Secondary Code=x"'. + 03 error-3 pic x(4). + 03 error-4 pic x(4). + 03 filler pic x value '"'. + + *----------------------------------------------------------------- + * interface paramters + LINKAGE SECTION. + *----------------------------------------------------------------- + 01 Comm-Code Pic 9(2) Comp. + 01 Comm-Buffer Pic x(12). + + *----------------------------------------------------------------- + 01 Shared-Segment-Buffer Pic x(12). + * This is a special linkage item - not used as a parameter - + * but as a buffer whose address is set to a shared unnamed + * segment, allocated later on. This type of memory is + * required by some APPC verbs - see later for details + * + *----------------------------------------------------------------- + + + *================================================================= + * + *---------------------Call Interface------------------------------ + PROCEDURE DIVISION using + by value Comm-Code + by reference Comm-Buffer. + *----------------------------------------------------------------- + *================================================================= + + + *----------------------------------------------------------------- + Evaluate-Operation. + * work out which high level operation to perform + * + *----------------------------------------------------------------- + Evaluate Comm-Code + When 1 Perform Bring-Up-Link + When 2 Perform Take-Down-Link + When 3 Perform Send-Coords + When 4 Perform Receive-Coords + When 5 Perform Send-Report + When 6 Perform Receive-Report + When other move 1 to Return-Code + End-Evaluate + move 0 to Return-Code + Exit Program. + + *----------------------------------------------------------------- + Error-Exit. + * quick exit in case of error during APPC + * + *----------------------------------------------------------------- + move 1 to Return-Code + Exit Program. + + *----------------------------------------------------------------- + Bring-Up-Link. + * High level function to initiate a communication between + * two transaction programs playing the game. + * + * The verbs issued to start a conversation are different + * for each program - only one end may start the communication + * with a MC-ALLOCATE verb - this is received at the other end + * by a RECEIVE-ALLOCATE verb. + * + * The LU-ALIAS, partner LU-ALIAS, MODE-NAME and TP-NAME which + * are defined in the configuration profile for this + * communication are placed in variables for various verbs to + * use. These names must match up with those defined in the + * configuration currently active - switch to the + * communications Manager session and check to see that the + * correct profile is loaded. + * + * Some fields passed in the Verb Control Block have to be + * defined in EBCDIC - all of these fields are converted from + * ASCII using a special utility routine provided as part + * of the Communications Manager software (ie. ACSSVC.DLL) - + * this is done initially and the converted fields are saved in + * temporary variables for later use. + * + * The other verbs (seen in capitals) are used to request + * resources of APPC before a conversation starts (TP-STARTED) + * and is only required on the MC-ALLOCATE side. The other + * verb (ie MC-FLUSH) causes the allocation request to be sent + * to the remote machine immediately - this is because send + * buffers are not normally sent off until a buffer becomes + * full - so as to minimise on transmissions. The MC-FLUSH + * verb is useful in this situation if you want a remote + * program to connect immediately. + * + * Comm-buffer is used to tell this module which program is + * calling it - so that it can decide which set of verbs to + * issue. + * + *----------------------------------------------------------------- + If Comm-Buffer = "PLAYER1" + * local end + * initialise configuration names + move 'DEMOPLU1' to plu-alias + move 'DEMOLU1 ' to lu-alias + move 'DEMOMODE' to mode-name + move 'BATTLE ' to tp-name + * convert to EBCDIC + Perform Convert-Tp-Name + Perform Convert-Mode-Name + * issue APPC verbs to request resources and send + * immediate an allocation request to the remote machine + Perform TP-STARTED + Perform MC-ALLOCATE + Perform MC-FLUSH + Else + * remote end + * initialise configuration name + move 'BATTLE ' to Tp-Name + * convert to EBCDIC + Perform Convert-Tp-Name + * issue APPC verb to receive allocation request + Perform RECEIVE-ALLOCATE + End-If + * allocate a buffer to be used by send and receive verbs + Perform Allocate-Shared-Memory. + + *----------------------------------------------------------------- + Allocate-Shared-Memory. + * Send and receive verbs: MC-SEND-DATA and MC-RECEIVE-AND-WAIT + * require the data buffer used as one of their parameters to + * be an unnamed shared segment - this is allocated with + * the DosAllocSeg api call with alloc-flag = 1 + * + *----------------------------------------------------------------- + move zero to Data-Buffer-Offset + move Length of Comm-Buffer to Data-Buffer-Length + move 1 to Alloc-Flags + * for COBOL/2 Toolset, do next statement + * call "cobolapi" + call "__DosAllocSeg" using + by value Alloc-Flags + by reference Data-Buffer-Selector + by value Data-Buffer-Length + If RETURN-CODE not = zero + Go to Error-Exit + End-If. + + + *----------------------------------------------------------------- + Take-Down-Link. + * This high level routine stops a conversation and releases + * resources used by the conversation. + * + * The conversation is stopped at the sending end, ie the + * machine at which the last send verb was issued, with + * the verb MC-DEALLOCATE. + * + * The MC-DEALLOCATE verb is issued with type FLUSH which + * performs the same function as MC-FLUSH before the + * deallocation is sent - causing any unsent buffers to be + * transmitted. + * + * The MC-RECEIVE-AND-WAIT is the verb issued at the receiving + * end, ie the machine at which the last receive verb was + * issued. This verb waits until the deallocation signal + * arrives from the sending end. + * + * The TP-ENDED verb is used to release resources at both + * ends of the terminated conversation. + * + *----------------------------------------------------------------- + If Sending-State + Perform MC-DEALLOCATE + Else + Perform MC-RECEIVE-AND-WAIT + End-If + Perform TP-ENDED. + + + *----------------------------------------------------------------- + Send-Coords. + * This high level operation sends coordinates contained in + * the buffer to be sent to the remote machine and then makes + * ready to receive a damage report from it. + * + * MC-SEND-DATA causes the contents of the buffer to be sent + * to the particular LU defined. + * + * After successful completion of MC-SEND-DATA , the + * conversation is placed in receive state by the + * MC-PREPARE-TO-RECEIVE verb - this is in readiness to receive + * the damage report of the coordinates specified. + * + * The MC-PREPARE-TO-RECEIVE also flushes the send buffer so + * that nothing is left before any receive verbs take place. + * + *----------------------------------------------------------------- + set address of Shared-Segment-Buffer to Data-Buffer-Ptr + move Comm-Buffer to Shared-Segment-Buffer + Perform MC-SEND-DATA + Perform MC-PREPARE-TO-RECEIVE. + + *----------------------------------------------------------------- + Receive-Report. + * The damage report is received using the verb + * MC-RECEIVE-AND-WAIT. This verb waits indefinitely for the + * remote machine to send data. When something is received + * a check is made that the data received is complete - if you + * are sending large amounts of information, data may be + * contained in several buffers and the 'what-received' verb + * contains a code to indicate if the buffer is complete or + * not. This routine performs a loop issuing the verb until + * the last buffer arrives. + * + *----------------------------------------------------------------- + move zero to what-received + perform until what-received = ap-data-complete + Perform MC-RECEIVE-AND-WAIT + end-perform + set address of Shared-Segment-Buffer to Data-Buffer-Ptr + move Shared-Segment-Buffer to Comm-Buffer. + + + *----------------------------------------------------------------- + Receive-Coords. + * The coordinates are received using the MC-RECEIVE-AND-WAIT + * verb. The buffer is received followed by a signal from the + * remote machine that it is ready to receive - so that the + * local end can send the damage report. The signal passed to + * the MC-RECEIVE-AND-WAIT verb is contained in the + * 'what-received' field. + * + *----------------------------------------------------------------- + move zero to what-received + perform until what-received = ap-send + Perform MC-RECEIVE-AND-WAIT + end-perform + set address of Shared-Segment-Buffer to Data-Buffer-Ptr + move Shared-Segment-Buffer to Comm-Buffer. + + + *----------------------------------------------------------------- + Send-Report. + * This sends the buffer using an MC-SEND-DATA verb followed + * by MC-FLUSH to transmit the buffer. + * + *----------------------------------------------------------------- + set address of Shared-Segment-Buffer to Data-Buffer-Ptr + move Comm-Buffer to Shared-Segment-Buffer + Perform MC-SEND-DATA + Perform MC-FLUSH. + + + *================================================================= + *================================================================= + *----------------------------------------------------------------- + * The conversion routines below use a service utility called + * the Common Services Programming Interface. It provides: + * - ASCII/EBCDIC conversion in both directions + * - traces API verbs and data + * - provides translation tables for specified code pages + * - records messages in CM message log + * - sends network management messages to a network + * management service + * + * Here we only use it for ASCII-EBCDIC using the CONVERT verb + * + *----------------------------------------------------------------- + * ASCII-EBCDIC conversion routines + + Convert-Mode-Name. + move all x"00" to VCB + move sv-convert to opcode-cvt + move sv-ascii-to-ebcdic to direction-cvt + move sv-a to char-set-cvt + move mode-name-len to len-cvt + set src-ptr-cvt to address of mode-name + set targ-ptr-cvt to address of mode-name + perform Execute-Acssvc-Verb + perform Check-Error. + + Convert-Tp-Name. + move all x"00" to VCB + move sv-convert to opcode-cvt + move sv-ascii-to-ebcdic to direction-cvt + move sv-ae to char-set-cvt + move tp-name-len to len-cvt + set src-ptr-cvt to address of tp-name + set targ-ptr-cvt to address of tp-name + perform Execute-Acssvc-Verb + perform Check-Error. + + *----------------------------------------------------------------- + * + * The following routines define the call interfaces to the + * various APPC verbs required above + * + * + *----------------------------------------------------------------- + + *----------------------------------------------------------------- + Receive-Allocate. + * wait receipt of allocation request from local machine + * and then start a new transaction program + * + * The VCB should always be initialized with low values before + * any fields are loaded. The verb returns a tp-id and a + * conv-id which are to be used by subsequent verbs during the + * conversation. + * + * LU-Alias, PLU-Alias and mode name of the session are also + * returned. + * + * A check on the return codes should always be made after + * issuing a verb. In this case an error causes an immediate + * return to the calling program to occur. + * + *----------------------------------------------------------------- + move all x"00" to VCB + move ap-receive-allocate to opcode-ral + move tp-name to tp-name-ral + set Receiving-State to True + perform Execute-Appc-Verb + perform Check-Error + move tp-id-ral to tp-id + move conv-id-ral to conv-id + move lu-alias-ral to lu-alias + move plu-alias-ral to plu-alias + move mode-name-ral to mode-name. + + *----------------------------------------------------------------- + MC-Receive-and-Wait. + * wait for data or signal to be sent. The 'what-received' + * field is returned by this call and indicates the type of + * information sent eg. data buffer or a signal to start + * sending data. + * + * The buffer that the data is sent to MUST be a shared, + * unnamed segment of memory. This is allocated using the + * DosAllocSeg function call (with flags=1). + * + *----------------------------------------------------------------- + set Receiving-State to True + move all x"00" to VCB + move ap-m-receive-and-wait to opcode-mrw + move ap-mapped-conversation to opext-mrw + move tp-id to tp-id-mrw + move conv-id to conv-id-mrw + set dptr-mrw to Data-Buffer-Ptr + move Data-Buffer-Length to max-len-mrw + perform Execute-Appc-Verb + If prim-rc-mda not = h"0009" + * if primary return code = h"0009" + * don't treat as error - returned when receiving + * deallocation signal from MC-DEALLOCATE verb + perform check-error + End-If + move what-rcvd-mrw to what-received + move rts-rcvd-mrw to request-to-send-received. + + + *----------------------------------------------------------------- + MC-Allocate. + * send an allocaton request to a remote machine to start a + * conversation. This verbs requires certain names defined in + * the configuration profile. + * + *----------------------------------------------------------------- + move all x"00" to VCB + move ap-m-allocate to opcode-mal + move ap-mapped-conversation to opext-mal + move 1 to opext-mal + move tp-id to tp-id-mal + move ap-confirm-sync-level to sync-lvl-mal + move ap-when-session-allocated to rtn-ctl-mal + move plu-alias to plu-alias-mal + move mode-name to mode-name-mal + move tp-name to tp-name-mal + move ap-none to security-mal + set Sending-State to True + perform Execute-Appc-Verb + perform Check-Error + move conv-id-mal to conv-id. + + *----------------------------------------------------------------- + MC-Send-Data. + * send a buffer to the remote machine. The buffer MUST be + * a shared unnamed segment of memory. This is allocated using + * the DosAllocSeg function call (with flags=1). + * + *----------------------------------------------------------------- + set Sending-State to True + move all x"00" to VCB + move ap-m-send-data to opcode-msd + move ap-mapped-conversation to opext-msd + move tp-id to tp-id-msd + move conv-id to conv-id-msd + move data-buffer-length to dlen-msd + set dptr-msd to data-buffer-ptr + perform Execute-Appc-Verb + perform Check-Error + move rts-rcvd-msd to request-to-send-received. + + *----------------------------------------------------------------- + MC-Deallocate. + * close a conversation + * + *----------------------------------------------------------------- + set Sending-State to True + move all x"00" to VCB + move ap-m-deallocate to opcode-mda + move ap-mapped-conversation to opext-mda + move tp-id to tp-id-mda + move conv-id to conv-id-mda + move ap-flush to dealloc-type-mda + perform Execute-Appc-Verb + perform Check-Error. + + *----------------------------------------------------------------- + MC-Flush. + * cause any unsent data to be transmitted immediately + * + *----------------------------------------------------------------- + move all x"00" to VCB + move ap-m-flush to opcode-fls + move ap-mapped-conversation to opext-fls + move tp-id to tp-id-fls + move conv-id to conv-id-fls + perform Execute-Appc-Verb + perform Check-Error. + + *----------------------------------------------------------------- + MC-Prepare-To-Receive. + * cause a change of conversation state from send to receive - + * this must be done before a MC-SEND-DATA verb can be issued + * by the remote end - when it is in receive state. This verb + * causes the local end to go into receive state. + * + *----------------------------------------------------------------- + set Receiving-State to True + move all x"00" to VCB + move ap-m-prepare-to-receive to opcode-ptr + move ap-mapped-conversation to opext-ptr + move tp-id to tp-id-ptr + move conv-id to conv-id-ptr + move ap-flush to ptr-type-ptr + perform Execute-Appc-Verb + perform Check-Error. + + *----------------------------------------------------------------- + TP-Started. + * allocate resources for conversation + * + *----------------------------------------------------------------- + move all x"00" to VCB + move ap-tp-started to opcode-tps + move lu-alias to lu-alias-tps + move tp-name to tp-name-tps + perform Execute-Appc-Verb + perform Check-Error + move tp-id-tps to tp-id. + + *----------------------------------------------------------------- + TP-Ended. + * release resources used by earlier conversation + * + *----------------------------------------------------------------- + move all x"00" to VCB + move ap-tp-ended to opcode-tpe + move tp-id to tp-id-tpe + perform Execute-Appc-Verb. + + *----------------------------------------------------------------- + Execute-Appc-Verb. + * interface to appc/acssvc uses load-time dynamic linking + * two methods may be employed: + * - to specify IMPORTS statements in .DEF file + * - to use ACS.LIB link library + * + * (both methods are used in BATTLE.CMD) + * + *----------------------------------------------------------------- + call "__APPC" using by reference vcb. + + *----------------------------------------------------------------- + Execute-Acssvc-Verb. + * + *----------------------------------------------------------------- + call "__ACSSVC" using by reference vcb. + + *----------------------------------------------------------------- + Check-Error. + * if any error on the primary return code - convert error + * to hex display, display error, wait for key and exit program + * + *----------------------------------------------------------------- + if prim-rc-vcb not = 0 + move opcode-vcb to bin-val + perform bin-to-hexdisp + move hex-disp to error-1 + move prim-rc-vcb to bin-val + perform bin-to-hexdisp + move hex-disp to error-2 + move sec-rc-vcb to bin-dword + move bin-dword-msw to bin-val + perform bin-to-hexdisp + move hex-disp to error-3 + move bin-dword-lsw to bin-val + perform bin-to-hexdisp + move hex-disp to error-4 + call "cbl_clear_scr" + using clear-char + clear-attr + call "cbl_set_csr_pos" using screen-pos + display error-msg + display "press any key to continue" + call "cbl_read_kbd_char" + using key-char + go to Error-Exit + end-if. + + *----------------------------------------------------------------- + Bin-to-Hexdisp. + * converts bin-val - a binary word value into a displayable + * hex value that can be inserted into the error message string + * + *----------------------------------------------------------------- + divide bin-val-1 by 16 + giving hex-idx-1 remainder hex-idx-2 + add 1 to hex-idx-1 hex-idx-2 + move hex-string(hex-idx-1:1) to hex-disp(1:1) + move hex-string(hex-idx-2:1) to hex-disp(2:1) + divide bin-val-2 by 16 + giving hex-idx-1 remainder hex-idx-2 + add 1 to hex-idx-1 hex-idx-2 + move hex-string(hex-idx-1:1) to hex-disp(3:1) + move hex-string(hex-idx-2:1) to hex-disp(4:1). + diff --git a/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.CMD b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.CMD new file mode 100644 index 0000000..6b2831b --- /dev/null +++ b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.CMD @@ -0,0 +1,177 @@ +@echo off +cls +echo COBOL Advanced Program to Program (APPC) Demonstration +echo ------------------------------------------------------ +echo Battleships game +echo ---------------- +if %1. == . goto noparam +if %1 == shared set appcmd=shared & goto okparam +if %1 == SHARED set appcmd=shared & goto okparam +if %1 == static set appcmd=static & goto okparam +if %1 == STATIC set appcmd=static & goto okparam +if %1 == animate set appcmd=animate & goto okparam +if %1 == ANIMATE set appcmd=animate & goto okparam +:noparam +echo usage: +echo BATTLE ANIMATE - create run files ready for ANIMATION +echo BATTLE STATIC - create run files by linking with STATIC +echo run-time support (LCOBOL.LIB) +echo BATTLE SHARED - create run files by linking with SHARED +echo run-time support (COBLIB.LIB) +goto end + +:okparam +echo ------------------------------------------------------------------------ +echo Copying ADIS modules: +copy \cobol\lib\ADIS*.OBJ +copy \cobol\lib\ADIS.DEF +if not exist ADIS.OBJ goto noadis +if not exist ADISINIT.OBJ goto noadis +if not exist ADISKEY.OBJ goto noadis +if not exist ADISDYNA.OBJ goto noadis +if not exist ADIS.DEF goto noadis +echo ADIS+ADISINIT+ADISKEY+ADISDYNA >ADIS.LNK +if %appcmd% == shared goto shared + +echo LIBRARY INITINSTANCE >BATTAPPC.DEF +echo PROTMODE >>BATTAPPC.DEF +echo DATA NONSHARED >>BATTAPPC.DEF +echo EXPORTS BATTAPPC @1 >>BATTAPPC.DEF +echo IMPORTS APPC.APPC >>BATTAPPC.DEF +echo IMPORTS ACSSVC.ACSSVC >>BATTAPPC.DEF +goto %appcmd% + +:ANIMATE +echo Creating run files for Animation... +echo ------------------------------------------------------------------------ +echo Compiling... +echo cobol battlel anim; +cobol battlel anim; +if not exist battlel.gnt goto compilerr +echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +echo cobol battler anim; +cobol battler anim; +if not exist battler.gnt goto compilerr +echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +echo cobol battappc anim opt(0); +cobol battappc anim omf(obj) opt(0); +if not exist battappc.obj goto compilerr +if exist battappc.int erase battappc.int +link battappc,,,coblib+os2,battappc.def; +echo Compiling finished. +echo ------------------------------------------------------------------------ +echo Copy following files to remote machine: +echo BATTLER.* +echo BATTAPPC.* +echo To run on local machine enter: ANIMATE BATTLEL +echo To run on remote machine enter: ANIMATE BATTLER +goto end + +:STATIC +echo Creating run files with static run time system... +echo ------------------------------------------------------------------------ +echo Compiling... +echo cobol battlel; +cobol battlel; +if not exist battlel.obj goto compilerr +echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +echo cobol battler; +cobol battler; +if not exist battler.obj goto compilerr +echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +echo cobol battappc; +cobol battappc; +if not exist battappc.obj goto compilerr +echo Compiling finished. +echo ------------------------------------------------------------------------ + +echo Linking... +: In this example, the sub program battappc.obj is linked on its +: own into a dll program. You could, if you prefer link this object +: in directly with the main program to create one executable - this is +: what has been done for the example of linking with a shared run time below. +: Same point applies to the ADIS sub program modules. + +echo link battlel /stack:3500,,,lcobol+os2; +link battlel /stack:3500,,,lcobol+os2; +if not exist battlel.exe goto linkerr +echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +echo link battler /stack:3500,,,lcobol+os2; +link battler /stack:3500,,,lcobol+os2; +if not exist battler.exe goto linkerr +echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +echo link battappc,,,lcobol+os2,battappc.def; +link battappc,,,lcobol+os2,battappc.def; +if not exist battappc.dll goto linkerr +echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +echo link @adis.lnk,,,lcobol+os2,adis.def; +link @adis.lnk,,,lcobol+os2,adis.def; +if not exist adis.dll goto linkerr +echo Linking finished. +echo ------------------------------------------------------------------------ + +echo Copy following files to remote machine: +echo BATTLER.EXE +echo BATTAPPC.DLL +echo ADIS.DLL +echo To run on local machine enter: BATTLEL +echo To run on remote machine enter: BATTLER +echo Ensure directories containing .DLL files are on LIBPATH +goto end + +:SHARED +echo Creating run files with shared run time system... +echo ------------------------------------------------------------------------ +echo Compiling... +echo cobol battlel; +cobol battlel; +if not exist battlel.obj goto compilerr +echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +echo cobol battler; +cobol battler; +if not exist battler.obj goto compilerr +echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +echo cobol battappc; +cobol battappc; +if not exist battappc.obj goto compilerr +echo Compiling finished +echo ------------------------------------------------------------------------ + +echo Linking... +echo link battlel+battappc+@adis.lnk,,,coblib+os2+acs.lib; +link battlel+battappc+@adis.lnk,,,coblib+os2+c:\cmlib\acs.lib; +if not exist battlel.exe goto linkerr +echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +echo link battler+battappc+@adis.lnk,,,coblib+os2+acs.lib; +link battler+battappc+@adis.lnk,,,coblib+os2+c:\cmlib\acs.lib; +if not exist battler.exe goto linkerr +echo Linking finished +echo ------------------------------------------------------------------------ + +echo Copy following file to remote machine: +echo BATTLER.EXE + +echo To run on local machine enter: BATTLEL +echo To run on remote machine enter: BATTLER +goto end + +:linkerr +echo Linking error. Batch aborted. +goto end + +:compilerr +echo Compliation error. Batch aborted. +goto end + +:noadis +echo ADIS Modules not found... compilation aborted. +echo copy from your COBDIR directory: +echo ADIS.OBJ, ADISKEY.OBJ, ADISINIT.OBJ, ADISDYNA.OBJ and ADIS.DEF + +:end +if exist *.obj erase *.obj +if exist *.lnk erase *.lnk +if exist *.def erase *.def +if exist *.map erase *.map +set appcmd= + diff --git a/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.CPY b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.CPY new file mode 100644 index 0000000..b39d3df --- /dev/null +++ b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.CPY @@ -0,0 +1,409 @@ + ******************************************************************* + * * + * * + * (C) Micro Focus Ltd. 1990 * + * * + * BATTLE.CPY * + * * + * Common procedure division code for both player programs * + * * + ******************************************************************* + + Battle-Ships. + Perform Start-Ships + Perform Play-Ships + Perform End-Ships + STOP RUN. + + Start-Ships. + Move all "01" to Grid-Att-Table + *----------------------------------------------------------------- + * the following procedures calls have been commented to show + * possible enhancements you may like to make to allow players + * to define grids dynamically and validate grids. + * + *----------------------------------------------------------------- + * Perform Setup-Grid-Coords + * Perform Validate-Grid-Coords + Display Battle-Screen + Perform Connect-Opponent. + + Play-Ships. + *----------------------------------------------------------------- + * Battleship is played by taking turns. Player 1 always starts + * first. So while player 1 has its turn, player 2 is + * servicing player 1's turn eg. receiving coordinates, + * assessing damage and reporting back. + * When it is player 2's turn, the roles are reversed, such + * that player 2 is now sending coordinates and player 1 is + * servicing player 2. This continues until one of the players + * has sunk all the ships of the other player. + * + *----------------------------------------------------------------- + Perform Until Game-Over + If Player-Id = "PLAYER1" + Perform Local-Turn + If not Game-Over + Perform Remote-Turn + End-If + Else + Perform Remote-Turn + If not Game-Over + Perform Local-Turn + End-If + End-If + End-Perform. + + End-Ships. + Perform Disconnect-Opponent + Perform Display-Game-Outcome + Perform Get-Keystroke. + + *----------------------------------------------------------------- + * Each turn consists of getting grid coordinates, sending the + * coordinates to the opponent, waiting for a damage report and + * assessing that damage. The opponents turn acts in reverse + * to your turn - so while you send grid coordinates it is + * waiting to receive them at the remote end and when you wait + * for a damage report it is assessing the damage caused and + * then it sends the damage report to you etc. + * + *----------------------------------------------------------------- + Local-Turn. + Perform Get-Coords + Perform Send-Grid-Coords + Perform Receive-Opponent-Damage + Perform Assess-Opponent-Damage + Display Battle-Damage + Display Battle-Field. + + *----------------------------------------------------------------- + * The remote turn consists of receiving grid coordinates from + * the opponent, assessing the damage caused and returning a + * damage report to the opponent. While this procedure is + * running on this machine, the remote machine is running the + * Local-Turn procedure. + * + *----------------------------------------------------------------- + Remote-Turn. + Perform Opponents-Turn + Perform Receive-Grid-Coords + Perform Assess-Own-Damage + Display Battle-Damage + Display Battle-Field + Perform Send-Own-Damage. + + + Get-Coords. + Move "YOUR TURN" to Screen-Msg-1 + Display Battle-Turn + Move spaces to Grid-Coordinates + Accept Battle-Coords + If Not (Grid-1 = "Q" OR Grid-1 = "q") + Perform until (Grid-1 >="A" AND Grid-1 <= "M" AND + Grid-2 >="1" AND Grid-2 <= "9") + If Grid-1 >= 'a' AND Grid-1 <= 'z' + * fold to upper case + Subtract 32 from Grid-1-Asc + Else + Move "Invalid Coordinates" to Screen-Msg-4 + Display Battle-Msg + Accept Battle-Coords + Move spaces to Screen-Msg-4 + Display Battle-Msg + End-If + End-Perform + End-if + Move "AWAITING REPORT" to Screen-Msg-1 + Move spaces to Screen-Msg-2 + Display Battle-Msg-1-2. + + Opponents-Turn. + Move "OPPONENTS TURN" to Screen-Msg-1 + Display Battle-Turn. + + Assess-Opponent-Damage. + Perform Evaluate-Grid-Position + Evaluate Damage-Msg + When "MISS" Perform Miss-Ship + When "HIT" Perform Hit-Ship + When "SINK" Perform Sink-Ship + When "WIN" Perform Win-Battle + End-Evaluate. + + Miss-Ship. + Move 3 to Grid-Att-Array(Grid-Row,Grid-Col) + Move "YOU MISSED" to Screen-Msg-2. + Hit-Ship. + Move 4 to Grid-Att-Array(Grid-Row,Grid-Col) + Move "YOU HIT SHIP" to Screen-Msg-2. + Sink-Ship. + Perform Display-Sunk-Ship + Move "YOU SUNK SHIP" to Screen-Msg-2. + Win-Battle. + Perform Display-Sunk-Ship + Move "YOU SUNK SHIPS" to Screen-Msg-2 + Set Win-Game to True. + + Display-Sunk-Ship. + Move Sink-Coords to Sunk-Ship-Locations + Perform varying Ship-Sector from 1 by 1 until Ship-Sector > 4 + Move Sunk-Ship-Row of Sunk-Ship(Ship-Sector) to Temp-Row + Move Sunk-Ship-Col of Sunk-Ship(Ship-Sector) to Temp-Col + If Temp-Row not = 0 AND Temp-Col not = 0 + Move 0 to Grid-Att-Array(Temp-Row,Temp-Col) + End-If + End-Perform. + + Assess-Own-Damage. + Perform Evaluate-Grid-Position + Move Grid-Array(Grid-Row,Grid-Col) to Target-Object + If Target-Object = space + * a miss + Move "MISS" to Damage-Msg + Move "OPPONENT MISSED SHIP" to Screen-Msg-2 + Else + * a hit + Move "HIT" to Damage-Msg + Move "OPPONENT HIT SHIP" to Screen-Msg-2 + Evaluate Target-Object + When "B" + When "A" + When "F" + When "G" + When "*" Perform Check-Ship-Sunk + When other Move "MISS" to Damage-Msg + Move "OPPONENT MISSED SHIP" + to Screen-Msg-2 + End-Evaluate + End-If. + + + Evaluate-Grid-Position. + Move Grid-1 to Grid-Chr + Subtract 64 from Grid-Asc + Move Grid-Asc to Grid-Col + Move Grid-2 to Grid-Chr + Subtract 48 from Grid-Asc + Move Grid-Asc to Grid-Row. + + Check-Ship-Sunk. + Move Grid-Array(Grid-Row,Grid-Col) to Target-Object + Move "*" to Grid-Array(Grid-Row,Grid-Col) + * assume sunk unless we can prove otherwise + Set Ship-Sunk to True + Move low-values to Sunk-Ship-Locations + Perform Check-Horizontal-Axis + If Ship-Sunk + Perform Check-Vertical-Axis + If Ship-Sunk + Move "SINK" to Damage-Msg + Move "OPPONENT SUNK SHIP" to Screen-Msg-2 + Perform varying Ship-Sector from 1 by 1 + until Ship-Sector > 4 + Move Sunk-Ship-Row of Sunk-Ship(Ship-Sector) + to Temp-Row + Move Sunk-Ship-Col of Sunk-Ship(Ship-Sector) + to Temp-Col + If Temp-Row not = 0 AND Temp-Col not = 0 + Move space to Grid-Array(Temp-Row,Temp-Col) + End-If + End-Perform + Move Sunk-Ship-Locations to Sink-Coords + Perform Check-All-Sunk + End-If + End-If. + + Check-Horizontal-Axis. + Set Not-End-of-Ship to true + * go to far left of ship + Move Grid-Col to Temp-Col + Perform until Temp-Col= 0 OR + (Grid-Array(Grid-Row,Temp-Col) not = "*" AND + Grid-Array(Grid-Row,Temp-Col) not = Target-Object) + Subtract 1 from Temp-Col + End-Perform + Add 1 to Temp-Col + * start scanning right + Move 1 to Ship-Sector + Perform until End-Of-Ship or Ship-Not-Sunk + Evaluate Grid-Array(Grid-Row,Temp-Col) + When Target-Object Set Ship-Not-Sunk to True + When "*" + Move Temp-Col to Sunk-Ship-Col of + Sunk-Ship(Ship-Sector) + If Sunk-Ship-Row of Sunk-Ship(Ship-Sector) = zero + Move Grid-Row to Sunk-Ship-Row of + Sunk-Ship(Ship-Sector) + End-If + When other Set End-Of-Ship to true + End-Evaluate + Add 1 to Ship-Sector + If Temp-Col = Max-Col + Set End-Of-Ship to true + End-If + Add 1 to Temp-Col + End-Perform. + + Check-Vertical-Axis. + Set Not-End-of-Ship to true + * go to top of ship + Move Grid-Row to Temp-Row + Perform until Temp-Row = 0 OR + (Grid-Array(Temp-Row,Grid-Col) not = "*" AND + Grid-Array(Temp-Row,Grid-Col) not = Target-Object) + Subtract 1 from Temp-Row + End-Perform + Add 1 to Temp-Row + * start scanning down + Move 1 to Ship-Sector + Perform until End-Of-Ship or Ship-Not-Sunk + Evaluate Grid-Array(Temp-Row,Grid-Col) + When Target-Object Set Ship-Not-Sunk to True + When "*" + Move Temp-Row to Sunk-Ship-Row(Ship-Sector) + If Sunk-Ship-Col(Ship-Sector) = zero + Move Grid-Col to Sunk-Ship-Col(Ship-Sector) + End-If + When other Set End-Of-Ship to true + End-Evaluate + Add 1 to Ship-Sector + If Temp-Row = Max-Row + Set End-Of-Ship to true + End-If + Add 1 to Temp-Row + End-Perform. + + Check-All-Sunk. + If No-Ships-Left + Move "OPPONENT SUNK SHIPS" to Screen-Msg-2 + Move "WIN " to Damage-Msg + Set Lose-Game to True + End-If. + + Display-Game-Outcome. + If Win-Game + Move "YOU WIN! G A M E O V E R" to Screen-Msg-3 + Else + Move "YOU LOSE! G A M E O V E R" to Screen-Msg-3 + End-If + Display Battle-Over. + + Game-Quit. + Move " QUIT GAME " to Screen-Msg-3 + Display Battle-Over + Stop Run. + + Get-keystroke. + Call x"83" using key-char + Call x"e4". + + + *----------------------------------------------------------------- + * Routines to communicate with opponent + *----------------------------------------------------------------- + + *----------------------------------------------------------------- + Connect-Opponent. + * This sets up a conversation with the opponent + * + *----------------------------------------------------------------- + Move Connect-Code to Battle-Op-Code + Move Player-Id to Battle-Buffer + Perform Communicate-Opponent. + + *----------------------------------------------------------------- + Disconnect-Opponent. + * This brings down a conversation with the opponent at the end + * of a game + * + *----------------------------------------------------------------- + Move Disconnect-Code to Battle-Op-Code + Perform Communicate-Opponent. + + *----------------------------------------------------------------- + Send-Own-Damage. + * Send damage report to opponent - the damage is contained + * in the call parameter Battle-Buffer it contains either: + * "MISS" - indicating opponent missed + * "HIT" - indicating opponent hit part of a ship + * "SINK" - indicating opponent hit and sunk a ship + * "WIN" - indicating opponent hit and sunk last remaining + * ship and has won the game + * the coordinates for a sunk ship are also provided so that + * the opponent can mark the position on their screen. + * + * You may like to enhance the program so that more information + * is sent regarding the type of ship that was sunk or hit - + * this information could then be displayed on the opponent's + * screen. + * + *----------------------------------------------------------------- + Move Send-Report-Code to Battle-Op-Code + If Ship-Sunk or Lose-Game + Move Damage-Msg to Battle-Buffer(1:4) + Move Sink-Coords to Battle-Buffer(5:8) + Else + Move Damage-Msg to Battle-Buffer + End-If + Perform Communicate-Opponent. + + *----------------------------------------------------------------- + Receive-Opponent-Damage. + * The damage report received is the same as that sent above. + * + *----------------------------------------------------------------- + Move Receive-Report-Code to Battle-Op-Code + Perform Communicate-Opponent + If Battle-Buffer(1:4) = "SINK" or Battle-Buffer(1:4) = "WIN " + Move Battle-Buffer(1:4) to Damage-Msg + Move Battle-Buffer(5:8) to Sink-Coords + Else + Move Battle-Buffer to Damage-Msg + End-If. + + *----------------------------------------------------------------- + Send-Grid-Coords. + * Send coordinates in Battle-Buffer to opponent + * + *----------------------------------------------------------------- + Move Send-Coords-Code to Battle-Op-Code + Move Grid-Coordinates to Battle-Buffer + Perform Communicate-Opponent + If Battle-Buffer(1:1) = "Q" or Battle-Buffer(1:1) = "q" + Perform Game-Quit + End-If. + + *----------------------------------------------------------------- + Receive-Grid-Coords. + * receive coordinates in Battle-Buffer from opponent + * + *----------------------------------------------------------------- + Move Receive-Coords-Code to Battle-Op-Code + Perform Communicate-Opponent + If Battle-Buffer(1:1) = "Q" or Battle-Buffer(1:1) = "q" + Perform Game-Quit + End-If. + Move Battle-Buffer to Grid-Coordinates. + + *----------------------------------------------------------------- + Communicate-Opponent. + * Call communications module. + * The communications module is treated as a black box - this + * program is not concerned with how the communication is + * achieved - It only understands several high level + * operations that can be called to talk between itself and the + * remote program. You could conceivably change the + * communications module to use some other protocol - this + * program should not have to change. + * + *----------------------------------------------------------------- + Call "BATTAPPC" using + by value Battle-Op-Code + by reference Battle-Buffer + If Return-Code > 0 + * Error handling here is very simple. + * You may like to enhance this area by implementing + * some sort of recovery routine + STOP RUN + End-If. diff --git a/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.SS b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.SS new file mode 100644 index 0000000..4de0875 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.SS @@ -0,0 +1,357 @@ + ******************************************************************* + * * + * * + * (C) Micro Focus Ltd. 1990 * + * * + * BATTLE.SS * + * * + * COBOL Advanced Program to Program (APPC) Demonstration * + * * + * Screen Section copy file * + * This code was produced by the Screens Utility and then * + * amended to use dynamic screen attributes * + * * + ******************************************************************* + + 01 Battle-Screen. + 02 LINE 1 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT + VALUE " ". + 02 COL 47 BACKGROUND-COLOR 1 FOREGROUND-COLOR 3 HIGHLIGHT VALUE + "Micro Focus". + 02 COL 58 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ". + 02 LINE 2 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT + VALUE " ". + 02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 3 HIGHLIGHT VALUE + "B A T T L E S H I P S". + 02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ". + 02 LINE 3 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT + VALUE " + -" ". + 02 LINE 4 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT + VALUE " A B C D E F G H + -"I J K L M ". + 02 LINE 5 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT + VALUE " ÉÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍ + -"ÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍ» ". + 02 LINE 6 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT + VALUE " ". + 02 COL 22 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " 1 º ". + 02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " º 1 ". + 02 LINE 7 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT + VALUE " ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄ + -"ÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ ". + 02 LINE 8 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT + VALUE " 2 º ". + 02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " º 2 ". + 02 LINE 9 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT + VALUE " Grid Coordinates: ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄ + -"ÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ ". + 02 LINE 10 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 3 + HIGHLIGHT VALUE " ". + 02 COL 4 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " 3 º". + 02 COL 26 BACKGROUND-COLOR 1 HIGHLIGHT VALUE " ". + 02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " º 3 ". + 02 LINE 11 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 + HIGHLIGHT VALUE " ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄ + -"ÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ ". + 02 LINE 12 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 + HIGHLIGHT VALUE " Damage Report: 4 º ". + 02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " º 4 ". + 02 LINE 13 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 + HIGHLIGHT VALUE " ". + 02 COL 22 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ ". + 02 LINE 14 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 + HIGHLIGHT VALUE " 5 º ". + 02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " º 5 ". + 02 LINE 15 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 + HIGHLIGHT VALUE " key: ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄ + -"ÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ ". + 02 LINE 16 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 + HIGHLIGHT VALUE " A Aircraft Carrier 6 º ". + 02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " º 6 ". + 02 LINE 17 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 + HIGHLIGHT VALUE " B Battleship ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄ + -"ÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ ". + 02 LINE 18 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 + HIGHLIGHT VALUE " F Frigate 7 º ". + 02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " º 7 ". + 02 LINE 19 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 + HIGHLIGHT VALUE " G Gun Boat ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄ + -"ÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ ". + 02 LINE 20 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 + HIGHLIGHT VALUE " * Damaged Ship 8 º ". + 02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " º 8 ". + 02 LINE 21 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 + HIGHLIGHT VALUE " ". + 02 COL 2 BACKGROUND-COLOR 4 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ". + 02 COL 4 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " hit ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄ + -"ÄÅÄÄÄÅÄÄĶ ". + + 02 LINE 22 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 + HIGHLIGHT VALUE " ". + 02 COL 2 BACKGROUND-COLOR 0 FOREGROUND-COLOR 0 HIGHLIGHT VALUE + " ". + 02 COL 4 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " sink 9 º ". + 02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ³ ". + 02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " º 9 ". + 02 LINE 23 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 + HIGHLIGHT VALUE " ". + 02 COL 2 BACKGROUND-COLOR 3 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " ". + 02 COL 4 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE + " miss ÈÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍ + -"ÍÏÍÍÍÏÍÍͼ ". + 02 LINE 24 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT + VALUE " A B C D E F G H + -"I J K L M ". + 02 LINE 6 COL 27. + 02 Battle-Field. + 03 OCCURS 9. + 04 OCCURS 13. + 05 BACKGROUND-COLOR Grid-Att-Array + FOREGROUND-COLOR 6 HIGHLIGHT PIC X FROM Grid-Array. + 05 COL + 4. + 04 LINE + 2 COL - 52. + 02 Battle-Coords LINE 10 COL 2 BACKGROUND-COLOR 1 HIGHLIGHT + PIC XX USING Grid-Coordinates. + 02 Battle-Msg LINE 11 COL 2 BACKGROUND-COLOR 1 HIGHLIGHT + PIC X(20) USING Screen-Msg-4. + 02 Battle-Msg-1-2. + 03 Battle-Turn LINE 6 COL 2 BACKGROUND-COLOR 1 HIGHLIGHT + PIC X(20) FROM Screen-Msg-1. + 03 Battle-Damage LINE 13 COL 2 BACKGROUND-COLOR 1 HIGHLIGHT + PIC X(20) FROM Screen-Msg-2. + 02 Battle-Over LINE 25 COL 35 BACKGROUND-COLOR 0 BLINK + HIGHLIGHT PIC X(33) FROM Screen-Msg-3. diff --git a/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.WKS b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.WKS new file mode 100644 index 0000000..d770310 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.WKS @@ -0,0 +1,139 @@ + ******************************************************************* + * * + * * + * (C) Micro Focus Ltd. 1990 * + * * + * BATTLEL.WKS * + * * + * COBOL Advanced Program to Program (APPC) Demonstration * + * * + * working-storage copy file * + * * + ******************************************************************* + + *----------------------------------------------------------------- + * Grid-Table - contains locations of ships + *----------------------------------------------------------------- + 01 Grid-Table redefines Battle-Grid. + 03 filler Occurs 9. + 05 Grid-Array Pic X Occurs 13. + + *----------------------------------------------------------------- + * Grid-Att-Table - contains opponent damage locations as + * different attributes eg hit=red, miss=cyan + *----------------------------------------------------------------- + 01 Grid-Att-Table. + 03 filler Occurs 9. + 05 Grid-Att-Array Pic 9(2) Occurs 13. + + *----------------------------------------------------------------- + * Grid-Coordinates - coordinates in form eg. 'G9' + *----------------------------------------------------------------- + 01 Grid-Coordinates. + 03 Grid-1 Pic X. + 03 Grid-1-Asc redefines Grid-1 Pic 9(2) Comp-X. + 03 Grid-2 Pic X. + + *----------------------------------------------------------------- + * Grid-Asc - ascii value of Grid-Chr used for decoding + * coordinate + *----------------------------------------------------------------- + 01 Grid-Chr Pic X. + 01 Grid-Asc redefines Grid-Chr Pic 9(2) Comp-X. + + *----------------------------------------------------------------- + * Grid-Row,Grid-Col - decoded x and y offsets into Grid-Table + *----------------------------------------------------------------- + 01 Grid-Pos. + 03 Grid-Row Pic 9(2) Comp-X. + 03 Grid-Col Pic 9(2) Comp-X. + + *----------------------------------------------------------------- + * Temp-Row,Temp-Col - temporary data used by various routines + *----------------------------------------------------------------- + 01 Temp-Row Pic 9(2) Comp-X. + 01 Temp-Col Pic 9(2) Comp-X. + + *----------------------------------------------------------------- + * Max-Row,Max-Col - upper limits of grid + *----------------------------------------------------------------- + 01 Max-Row Pic 9(2) Comp-X Value 9. + 01 Max-Col Pic 9(2) Comp-X Value 13. + + *----------------------------------------------------------------- + * Sunk-Ship-Locations - grid positions of a sunk ship to be + * provided to opponent + *----------------------------------------------------------------- + 01 Sunk-Ship-Locations. + 03 Sunk-Ship Occurs 4. + 05 Sunk-Ship-Row Pic 9(2) Comp-X. + 05 Sunk-Ship-Col Pic 9(2) Comp-X. + *----------------------------------------------------------------- + * Ship-Sector - sub-division of a ship across several locations + *----------------------------------------------------------------- + 01 Ship-Sector Pic 9(2) Comp-X. + + *----------------------------------------------------------------- + * Key-Char - contains a keyboard response character + *----------------------------------------------------------------- + 01 Key-Char Pic X. + + *----------------------------------------------------------------- + * Damage-Msg - contains damage report to be sent/received + * to/from opponent eg 'HIT','MISS''SINK' etc. + *----------------------------------------------------------------- + 01 Damage-Msg Pic X(4). + + *----------------------------------------------------------------- + * Sink-Coords - temporary store for holding sunk ship locations + *----------------------------------------------------------------- + 01 Sink-Coords Pic X(8). + + *----------------------------------------------------------------- + * Target-Object - contains character found at grid location + *----------------------------------------------------------------- + 01 Target-Object Pic X. + + *----------------------------------------------------------------- + * operation codes used to interface to communication module + *----------------------------------------------------------------- + 78 Connect-Code Value 1. + 78 Disconnect-Code Value 2. + 78 Send-Coords-Code Value 3. + 78 Receive-Coords-Code Value 4. + 78 Send-Report-Code Value 5. + 78 Receive-Report-Code Value 6. + + *----------------------------------------------------------------- + * Screen-Msgs - Different messages that may appear on screen + *----------------------------------------------------------------- + 01 Screen-Msgs. + 03 Screen-Msg-1 Pic X(25). + 03 Screen-Msg-2 Pic X(20). + 03 Screen-Msg-3 Pic X(30). + 03 Screen-Msg-4 Pic X(20). + + + *----------------------------------------------------------------- + * Flags - defines various conditions + *----------------------------------------------------------------- + 01 Flags. + 03 filler Pic 9(2) Comp Value 0. + 88 Win-Game Value 1. + 88 Lose-Game Value 2. + 88 Game-Over Value 1,2. + 03 filler Pic 9(2) Comp. + 88 Ship-Not-Sunk Value 0. + 88 Ship-Sunk Value 1. + 03 filler Pic 9(2) Comp Value 0. + 88 End-Of-Ship Value 1. + 88 Not-End-Of-Ship Value 0. + + + *----------------------------------------------------------------- + * Battle-Buffer + * Battle-Op-Code + * - are call parameters to communications module + *----------------------------------------------------------------- + 01 Battle-Buffer Pic x(12). + 01 Battle-Op-Code Pic 9(2) Comp-X. diff --git a/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLEL.CBL b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLEL.CBL new file mode 100644 index 0000000..b640953 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLEL.CBL @@ -0,0 +1,88 @@ + $set mf ans85 noosvs + ******************************************************************* + * * + * * + * (C) Micro Focus Ltd. 1990 * + * * + * BATTLEL.CBL * + * * + * COBOL Advanced Program to Program (APPC) Demonstration * + * * + * Battleships * + * player 1 * + * * + ******************************************************************* + + WORKING-STORAGE SECTION. + + 01 Player-Id Pic x(7) value 'PLAYER1'. + + *----------------------------------------------------------------- + * Battle-Grid defines the grid positions of different ships + * on this side. It is up to each player to specify these + * positions and follow certain requirements of the game. + * + * The requirements are: + * - ships are identified by the following letters: + * A for Aircraft Carrier + * B for Battleship + * F for Frigate + * G for Gun Boat + * + * - ships can be any length - it is up to the players to + * decide how long each ship is + * + * - ships must not be located in adjacent grid locations + * + * - ships can only be aligned vertically or horizontally + * + * There is no verification done on the setup you choose - so + * it is quite possible to cheat. You must also recompile this + * program when you want to change the battle grid. + * + * A possible enhancement which you may like to make yourself + * would be to provide code which allows each player to define + * his/her own grid details and validate the grid dynamically - + * thus removing the need to recompile every time. + * + *----------------------------------------------------------------- + + 01 Battle-Grid. + 88 No-Ships-Left value spaces. + 03 filler pic x(13) value 'BBB '. + 03 filler pic x(13) value ' AAAA '. + 03 filler pic x(13) value ' '. + 03 filler pic x(13) value ' B G F '. + 03 filler pic x(13) value ' B F '. + 03 filler pic x(13) value ' B G'. + 03 filler pic x(13) value ' G '. + 03 filler pic x(13) value ' '. + 03 filler pic x(13) value ' FF '. + + + *----------------------------------------------------------------- + COPY "BATTLE.WKS". + * BATTLE.WKS is a copy file that contains common + * working-storage section items for PLAYER1 and PLAYER2 + * + *----------------------------------------------------------------- + + SCREEN SECTION. + *----------------------------------------------------------------- + COPY "BATTLE.SS". + * BATTLE.SS is a copy file containing a screen section for + * displaying the battle field. The screen section was designed + * using the SCREENS utility. + * + *----------------------------------------------------------------- + + PROCEDURE DIVISION. + *----------------------------------------------------------------- + COPY "BATTLE.CPY". + * BATTLE.CPY is a copy file containing the common procedure + * division code for both players + * + *----------------------------------------------------------------- + + + diff --git a/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLER.CBL b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLER.CBL new file mode 100644 index 0000000..08feca6 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/APPCDEMO/BATTLER.CBL @@ -0,0 +1,84 @@ + $set mf ans85 noosvs + ******************************************************************* + * * + * * + * (C) Micro Focus Ltd. 1990 * + * * + * BATTLER.CBL * + * * + * COBOL Advanced Program to Program (APPC) Demonstration * + * * + * Battleships * + * player 2 * + * * + ******************************************************************* + + WORKING-STORAGE SECTION. + + 01 Player-Id pic x(7) value 'PLAYER2'. + *----------------------------------------------------------------- + * Battle-Grid defines the grid positions of different ships + * on this side. It is up to each player to specify these + * positions and follow certain requirements of the game. + * + * The requirements are: + * - ships are identified by the following letters: + * A for Aircraft Carrier + * B for Battleship + * F for Frigate + * G for Gun Boat + * + * - ships can be any length - it is up to the players to + * decide how long each ship is + * + * - ships must not be located in adjacent grid locations + * + * - ships can only be aligned vertically or horizontally + * + * There is no verification done on the setup you choose - so + * it is quite possible to cheat. You must also recompile this + * program when you want to change the battle grid. + * + * A possible enhancement which you may like to make yourself + * would be to provide code which allows each player to define + * his/her own grid details and validate the grid dynamically - + * thus removing the need to recompile every time. + * + *----------------------------------------------------------------- + + 01 Battle-Grid. + 88 No-Ships-Left value spaces. + 03 filler pic x(13) value 'G '. + 03 filler pic x(13) value ' FF BBB '. + 03 filler pic x(13) value ' '. + 03 filler pic x(13) value ' A G '. + 03 filler pic x(13) value ' A '. + 03 filler pic x(13) value ' A '. + 03 filler pic x(13) value ' A G F '. + 03 filler pic x(13) value ' F '. + 03 filler pic x(13) value ' BBB '. + + *----------------------------------------------------------------- + COPY "BATTLE.WKS". + * BATTLE.WKS is a copy file that contains common + * working-storage section items for PLAYER1 and PLAYER2 + * + *----------------------------------------------------------------- + + SCREEN SECTION. + *----------------------------------------------------------------- + COPY "BATTLE.SS". + * BATTLE.SS is a copy file containing a screen section for + * displaying the battle field. The screen section was designed + * using the SCREENS utility. + * + *----------------------------------------------------------------- + + PROCEDURE DIVISION. + *----------------------------------------------------------------- + COPY "BATTLE.CPY". + * BATTLE.CPY is a copy file containing the common procedure + * division code for both players + * + *----------------------------------------------------------------- + diff --git a/Microsoft COBOL v45/DEMO/ASMDEMO/ADD.CBL b/Microsoft COBOL v45/DEMO/ASMDEMO/ADD.CBL new file mode 100644 index 0000000..5b89334 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/ASMDEMO/ADD.CBL @@ -0,0 +1,51 @@ + $set mf ans85 noosvs + ******************************************************************* + * * + * * + * (C) Micro Focus Ltd. 1989 * + * * + * ADD.CBL * + * * + * This program shows how to call the assembler routine ADDEM.ASM. * + * It can be called dynamically as a .EXE or .DLL file, or * + * statically linked. * + * * + * To statically link you must compile this program with the * + * LITLINK directive (or change the call below to call "__addem"). * + * * + * To dynamically link, compile the program as it is without the * + * LITLINK directive. On OS/2 you must create a .DLL from * + * ADDEM.OBJ using the .DEF file supplied, and place the .DLL file * + * in a directory on your LIBPATH. * + * * + * The assembler routine gets the value of the first parameter, * + * adds it to the value of second-param and returns the result * + * in res-ult. * + * * + ******************************************************************* + + working-storage section. + 01 comp-fields. + 03 first-param pic 99 comp value 3. + 03 second-param pic 99 comp value 5. + 03 res-ult pic 99 comp. + + 01 display-first-param pic Z9. + 01 display-second-param pic Z9. + 01 display-res-ult pic Z9. + + procedure division. + + * call to assembler routine + call "addem" using first-param, second-param, res-ult. + + *set up display fields + move first-param to display-first-param. + move second-param to display-second-param. + move res-ult to display-res-ult. + + * display results of the call + display display-first-param " + " + display-second-param " = " + display-res-ult. + stop run. diff --git a/Microsoft COBOL v45/DEMO/ASMDEMO/ADDEM.ASM b/Microsoft COBOL v45/DEMO/ASMDEMO/ADDEM.ASM new file mode 100644 index 0000000..c440944 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/ASMDEMO/ADDEM.ASM @@ -0,0 +1,59 @@ +; +; (C) Micro Focus Ltd, 1989 +; +; This routine is called by the cobol program ADD.CBL +; To assemble and link the routine to a .EXE file simply type: +; +; MASM ADDEM; +; LINK ADDEM; +; +public addem ;module id + +cseg segment para public 'CODE' +assume cs:cseg + +first_param equ dword ptr [bp+6] ;pointer to first parameter +second_param equ dword ptr [bp+10] ;pointer to second parameter +res_ult equ dword ptr [bp+14] ;pointer to third parameter + +addem proc far + push bp ;preserve bp + mov bp,sp ;put current stack pointer in bp + push ds ;preserve ds,si,di,flags + push si + push di + pushf + + mov ax,dseg ;initialize ds + mov ds,ax + + ; THE NEXT 6 STATEMENTS ARE THE VARIABLE PART + ; OF THIS ROUTINE. MOST EVERYTHING ELSE IS NEEDED + ; FOR EVERY ASSEMBLER ROUTINE CALLED BY COBOL. + les di,first_param ;get address of first parameter + mov al,es:[di] ;get value of first parameter + les di,second_param ;get address of second parameter + add al,es:[di] ;add value of 2nd param to first + + les di,res_ult ;get address of res_ult + stosb ;return result to cobol program + + xor ax,ax ;set return code, 0 in ax = success + + popf ;restore registers + pop di + pop si + pop ds + pop bp + + ret ;far return +addem endp +cseg ends + +dseg segment para public 'DATA' + your_data db 'data' + ; INCLUDE YOUR DATA HERE +dseg ends + +end + diff --git a/Microsoft COBOL v45/DEMO/ASMDEMO/ADDEM.DEF b/Microsoft COBOL v45/DEMO/ASMDEMO/ADDEM.DEF new file mode 100644 index 0000000..18ba1ce --- /dev/null +++ b/Microsoft COBOL v45/DEMO/ASMDEMO/ADDEM.DEF @@ -0,0 +1,4 @@ +; module definition file for ADDEM under OS/2 +LIBRARY INITINSTANCE ; ADIS is a DLL +CODE LOADONCALL ; load when needed +EXPORTS ADDEM @1 ; entry is ADDEM diff --git a/Microsoft COBOL v45/DEMO/ASMDEMO/ADDEM.OBJ b/Microsoft COBOL v45/DEMO/ASMDEMO/ADDEM.OBJ new file mode 100644 index 0000000..d581876 Binary files /dev/null and b/Microsoft COBOL v45/DEMO/ASMDEMO/ADDEM.OBJ differ diff --git a/Microsoft COBOL v45/DEMO/CALC.CBL b/Microsoft COBOL v45/DEMO/CALC.CBL new file mode 100644 index 0000000..ac7e711 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/CALC.CBL @@ -0,0 +1,175 @@ + $SET WARNING(3) NOOSVS ANS85 mf + SPECIAL-NAMES. + crt status is key-status. + WORKING-STORAGE SECTION. + 78 Return-key value X"3030". + 78 Equals-key value X"333D". + 01 key-status. + 03 key-type pic x. + 88 function-key value "1". + 88 data-key value "3". + 03 key-code-1 pic 99 comp-x. + 03 key-code-1-x redefines + key-code-1 pic x. + 88 Operator-entered value "*" "-" "/" "+". + 88 CLear-key value "C" "c". + 03 key-code-2 pic x. + 01 redefines key-status. + 03 pic xx. + 88 escape-key-pressed value X"3100". + * Answer needed "=" or + 88 answer-needed value Return-key Equals-key. + 03 pic x. + 01 set-bit-pairs pic 99 comp-x value 1. + 01 data-key-control. + 03 data-key-setting pic 99 comp-x. + 88 key-is-disabled value zero. + 88 act-as-a-function-key value 1. + 88 character-into-field value 2. + 03 pic x value "3". + 03 first-data-key pic x. + 03 number-of-data-keys pic 99 comp-x value 1. + 01 user-key-control. + 03 User-key-setting pic 99 comp-x value 1. + 03 pic x value "1". + 03 first-user-key pic 99 comp-x value 0. + 03 number-of-keys pic 99 comp-x value 1. + 78 No-of-data-keys value 7. + 01 keys-to-enable pic x(no-of-data-keys) + value "/*-+Cc=". + 01 redefines keys-to-enable. + 03 key-to-enable occurs no-of-data-keys times + indexed by key-enable-index pic x. + 01 Entered-Value PIC S9(11)V9(7) BINARY. + 01 Saved-Value PIC S9(11)V9(7) BINARY. + 01 saved-operator pic x. + 01 is-there-a-key-waiting pic x comp-x. + 88 no-key-waiting value zero. + 88 key-waiting value 1 thru 255. + 01 pic 99 comp-x. + 88 calculation-ok value zero. + 88 numeric-overflow value 1. + SCREEN SECTION. + 01 Calculator-screen. + 05 BLANK SCREEN. + 05 LINE 1 COL 1 VALUE "ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»". + 05 LINE 2 COL 1 VALUE "º ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» º". + 05 LINE 3 COL 1 VALUE "º º º º". + 05 LINE 4 COL 1 VALUE "º ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ º". + 05 LINE 5 COL 1 VALUE "º ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿ º". + 05 LINE 6 COL 1 VALUE "º ³ ³³ ³³ ³³ ³ º". + 05 LINE 7 COL 1 VALUE "º ÀÄÄÄÙÀÄÄÄÙÀÄÄÄÙÀÄÄÄÙ º". + 05 LINE 8 COL 1 VALUE "º ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿ º". + 05 LINE 9 COL 1 VALUE "º ³ ³³ ³³ ³³ ³ º". + 05 LINE 10 COL 1 VALUE "º ÀÄÄÄÙÀÄÄÄÙÀÄÄÄÙ³ ³ º". + 05 LINE 11 COL 1 VALUE "º ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿³ ³ º". + 05 LINE 12 COL 1 VALUE "º ³ ³³ ³³ ³³ ³ º". + 05 LINE 13 COL 1 VALUE "º ÀÄÄÄÙÀÄÄÄÙÀÄÄÄÙÀÄÄÄÙ º". + 05 LINE 14 COL 1 VALUE "º ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿ º". + 05 LINE 15 COL 1 VALUE "º ³ ³³ ³³ ³³ ³ º". + 05 LINE 16 COL 1 VALUE "º ÀÄÄÄÙÀÄÄÄÙÀÄÄÄÙ³ ³ º". + 05 LINE 17 COL 1 VALUE "º ÚÄÄÄÄÄÄÄÄ¿ÚÄÄÄ¿³ ³ º". + 05 LINE 18 COL 1 VALUE "º ³ ³³ ³³ ³ º". + 05 LINE 19 COL 1 VALUE "º ÀÄÄÄÄÄÄÄÄÙÀÄÄÄÙÀÄÄÄÙ º". + 05 LINE 20 COL 1 VALUE "ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ". + 05 HIGHLIGHT. + 10 entry-field. + 15 LINE 3 COL 5 PIC -(11)9.9(7) + USING Entered-Value PROMPT spaces. + 10 LINE 6 COL 7 VALUE "C". + 10 COL 12 VALUE "/". + 10 COL 17 VALUE "*". + 10 COL 22 VALUE "-". + 10 LINE 9 COL 7 VALUE "7". + 10 COL 12 VALUE "8". + 10 COL 17 VALUE "9". + 10 LINE 10 COL 22 VALUE "+". + 10 LINE 12 COL 7 VALUE "4". + 10 COL 12 VALUE "8". + 10 COL 17 VALUE "6". + 10 LINE 15 COL 7 VALUE "1". + 10 COL 12 VALUE "2". + 10 COL 17 VALUE "3". + 10 LINE 16 COL 22 VALUE "=". + 10 LINE 18 COL 9 VALUE "0". + 10 COL 17 VALUE ".". + PROCEDURE DIVISION. + main-1. + perform initialization-routines + DISPLAY Calculator-screen + perform with test after until escape-key-pressed + if operator-entered or numeric-overflow + * Position the cursor at the first integer position of the + * entry field which waiting for a character to be pressed + if numeric-overflow + display low-values at 0321 + else + display low-values at 0316 + end-if + * Leave the previous value in th field until a value is + * entered + set no-key-waiting to true + perform with test after until key-waiting + call X"D9" using is-there-a-key-waiting + end-perform + move zero to entered-value + end-if + display Entry-field + ACCEPT Calculator-screen + if data-key or answer-needed + perform data-key-terminated-accept + end-if + end-perform + exit program + STOP RUN. + data-key-terminated-accept. + evaluate true + when Operator-entered + if saved-operator not = spaces + perform calculate-answer + * Display current intermediate result whilst waiting for next + * keystoke which will require the field to be cleared + display Entry-field + end-if + move key-code-1-x to saved-operator + move entered-value to saved-value + when CLear-key + move zero to entered-value saved-value + move spaces to saved-operator + when answer-needed + perform calculate-answer + move spaces to saved-operator + end-evaluate. + calculate-answer. + set calculation-ok to true + evaluate saved-operator + when "*" + compute entered-value = saved-value * entered-value + on size error perform size-error-action + when "-" + compute entered-value = saved-value - entered-value + on size error perform size-error-action + when "+" + compute entered-value = saved-value + entered-value + on size error perform size-error-action + when "/" + compute entered-value = saved-value / entered-value + on size error perform size-error-action + end-evaluate. + size-error-action. + move zero to entered-value saved-value + move spaces to saved-operator + display "Numeric Overflow " at 0305 with highlight + set numeric-overflow to true. + initialization-routines. + * activate "*" "/" "-" "+" "C" "c" and "=" + * to terminate an accept. + set act-as-a-function-key to true + perform varying key-enable-index from 1 by 1 + until key-enable-index > No-of-data-keys + move key-to-enable(key-enable-index) to first-data-key + call X"AF" using set-bit-pairs data-key-control + end-perform + move zero to entered-value saved-value + * Enable function key zero - The Escape key. + call X"AF" using set-bit-pairs user-key-control. diff --git a/Microsoft COBOL v45/DEMO/CALENDAR.CBL b/Microsoft COBOL v45/DEMO/CALENDAR.CBL new file mode 100644 index 0000000..09160d3 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/CALENDAR.CBL @@ -0,0 +1,158 @@ + $SET ans85 noosvs noqual noalter nobell warning(3) noseg align(1) + WORKING-STORAGE SECTION. + 01 wrk-date. + 03 yymmdd-yy PIC 99. + 03 yymmdd-mm PIC 99. + 03 yymmdd-dd PIC 99. + 01 date-year PIC 99 COMP-X. + 01 date-lyear PIC 99 COMP-X. + 88 leap-year VALUE 1. + 01 am-pm-fld PIC XX. + 01 hh-fld PIC 99. + 01 month-values. + 03 FILLER PIC X(9) VALUE " JANUARY ". + 03 FILLER PIC X(9) VALUE " FEBUARY ". + 03 FILLER PIC X(9) VALUE " MARCH ". + 03 FILLER PIC X(9) VALUE " APRIL ". + 03 FILLER PIC X(9) VALUE " MAY ". + 03 FILLER PIC X(9) VALUE " JUNE ". + 03 FILLER PIC X(9) VALUE " JULY ". + 03 FILLER PIC X(9) VALUE " AUGUST ". + 03 FILLER PIC X(9) VALUE "SEPTEMBER". + 03 FILLER PIC X(9) VALUE " OCTOBER ". + 03 FILLER PIC X(9) VALUE "NOVEMBER ". + 03 FILLER PIC X(9) VALUE "DECEMBER ". + 01 month-value REDEFINES month-values OCCURS 12 PIC X(9). + 01 no-of-days-in-month-table PIC X(24) + VALUE "312831303130313130313031". + 01 no-of-days-in-month REDEFINES + no-of-days-in-month-table + OCCURS 12 PIC 99. + 01 day-flds. + 03 OCCURS 5. + 05 OCCURS 7. + 07 scr-day-fld PIC 99 COMP-X. + 03 day-36 PIC 99 COMP-X. + 03 day-37 PIC 99 COMP-X. + 01 FILLER REDEFINES day-flds. + 03 day-fld OCCURS 37 PIC 99 COMP-X. + 01 hi-flds. + 03 OCCURS 5. + 05 OCCURS 7. + 07 scr-hi-fld PIC X(80). + 03 hi-36 PIC X(80). + 03 hi-37 PIC X(80). + 01 FILLER REDEFINES hi-flds. + 03 hi-fld OCCURS 37 PIC X(80). + 88 highlight-fld VALUE "HIGHLIGHT". + 01 day-of-year-group. + 03 FILLER PIC XX. + 03 day-of-year PIC 999. + 01 day-of-week-fld PIC 99. + 01 time-fld. + 03 time-fld-hh PIC 99. + 03 time-fld-mm PIC 99. + 03 FILLER PIC X(4). + 01 day-index PIC 99 COMP-X. + 01 count-fld PIC 99 COMP-X. + 01 century-fld PIC 99 COMP-X. + 01 non-full-week-days PIC 99 COMP-X. + 01 day-of-month-day-1 PIC 99 COMP-X. + 01 no-of-full-weeks-in-month PIC 99 COMP-X. + 01 current-day-scr-fld-index PIC 99 COMP-X. + / + Screen SECTION. + 01 calender-screen. + 03 BLANK screen. + 03 LINE 3 COL 64 PIC Z9 FROM hh-fld. + 03 COL 67 PIC 99 FROM time-fld-mm. + 03 COL 70 PIC XX FROM am-pm-fld. + 03 LINE 5 COL 53 PIC 99 FROM century-fld. + 03 COL 55 PIC 99 FROM yymmdd-yy. + 03 COL 60 PIC X(9) FROM month-value(yymmdd-mm). + 03 COL 72 PIC 99 FROM century-fld. + 03 COL 74 PIC 99 FROM yymmdd-yy. + 03 LINE 7 COL 51. + 03 OCCURS 5. + 05 OCCURS 7. + 07 PIC ZZ FROM scr-day-fld BLANK WHEN ZERO + CONTROL IS scr-hi-fld. + 07 COL + 3. + 05 LINE + 1 COL - 28. + 03 LINE 12. + 03 COL 51 PIC ZZ FROM day-fld(36) BLANK WHEN ZERO + CONTROL IS hi-fld(36). + 03 COL 55 PIC ZZ FROM day-fld(37) BLANK WHEN ZERO + CONTROL IS hi-fld(37). + 03 COL 74 PIC 999 FROM day-of-year. + 03 LINE 3 COL 57 VALUE "Time:". + 03 LINE 3 COL 66 VALUE ":". + 03 LINE 6 COL 52 VALUE "S M T W T F S". + 03 LINE 12 COL 61 VALUE "Day of Year:". + / + PROCEDURE DIVISION. + Calender-Main SECTION. + PERFORM Init-Date-Manipulation. + DISPLAY calender-screen. + Program-Exit. + EXIT PROGRAM. + STOP RUN. + Init-Date-Manipulation. + INITIALIZE day-flds hi-flds + ACCEPT wrk-date FROM DATE + ACCEPT time-fld FROM TIME + ACCEPT day-of-week-fld FROM DAY-OF-WEEK + ACCEPT day-of-year-group FROM DAY + PERFORM Find-Day-1-Of-Month + PERFORM Set-Time + PERFORM Set-Century + PERFORM Set-Day-Flds. + / + Find-Day-1-Of-Month. + DIVIDE yymmdd-dd BY 7 GIVING no-of-full-weeks-in-month + REMAINDER non-full-week-days + IF day-of-week-fld < (non-full-week-days - 1) + ADD 7 TO day-of-week-fld + END-IF + COMPUTE day-of-month-day-1 = day-of-week-fld - + (non-full-week-days - 2) + IF day-of-month-day-1 > 7 + SUBTRACT 7 FROM day-of-month-day-1 + END-IF. + Set-Time. + IF time-fld-hh > 12 + SUBTRACT 12 FROM time-fld-hh GIVING hh-fld + MOVE "PM" TO am-pm-fld + ELSE + MOVE "AM" TO am-pm-fld + MOVE time-fld-hh TO hh-fld + END-IF. + Set-Century. + IF yymmdd-yy < 88 + MOVE "20" TO century-fld + ELSE + MOVE "19" TO century-fld + END-IF. + Set-Day-Flds. + MOVE ZERO TO count-fld + IF yymmdd-mm = 2 + COMPUTE date-lyear = yymmdd-yy / 4 + COMPUTE date-lyear = date-lyear * 4 + COMPUTE date-year = date-lyear - yymmdd-yy + COMPUTE date-year = date-year / 4 + IF leap-year + ADD 1 to no-of-days-in-month(yymmdd-mm) + END-IF + END-IF + PERFORM VARYING DAY-INDEX FROM 1 BY 1 UNTIL DAY-INDEX > 37 + IF day-index >= day-of-month-day-1 and + < (day-of-month-day-1 + + no-of-days-in-month(yymmdd-mm)) + ADD 1 TO count-fld + MOVE count-fld TO day-fld(day-index) + ELSE + MOVE ZERO TO day-fld(day-index) + END-PERFORM + COMPUTE yymmdd-dd = yymmdd-dd + day-of-month-day-1 - 1 + SET highlight-fld(yymmdd-dd) TO TRUE. + \ No newline at end of file diff --git a/Microsoft COBOL v45/DEMO/CASE.CBL b/Microsoft COBOL v45/DEMO/CASE.CBL new file mode 100644 index 0000000..739bab7 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/CASE.CBL @@ -0,0 +1,1166 @@ + $set ans85 noosvs comp mf + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * CASE.CBL * + * * + * This program converts the case of COBOL source code * + * files in several ways, producing, for example, uppercase * + * reserved words and lower case data names. * + * * + * Instructions for use are presented when it is first * + * executed. * + * * + * This source file actually contains two separate * + * programs, one called from the other. This type of source * + * file is known as a multi-program source. Compiling this * + * source file will result in the creation of two separate * + * OBJs, as if two separate programs had been compiled, one * + * after the other. The two OBJs will be called CASE and * + * CASECONV, CASECONV taking its name from the PROGRAM-ID * + * line in the second program. * + * * + * Compile the program and link the two OBJs created in the * + * usual way. * + * * + ************************************************************ + identification division. + program-id. case. + environment division. + file-control. + select input-file assign input-file-name + organization is line sequential + file status is file-status. + + select output-file assign output-file-name + organization is line sequential + file status is file-status. + + data division. + + file section. + + fd input-file. + 01 input-record pic x(80). + + fd output-file. + 01 output-record pic x(80). + + working-storage section. + 01 temp-00 . + 03 temp-00-0101 pic x(0078) value "Instructions for using + - " the CASE utility for altering the case of COBOL source:". + 03 filler pic x(0082). + 03 temp-00-0301 pic x(0077) value "CASE + - " ". + 03 filler pic x(0086). + 03 temp-00-0504 pic x(0062) value "src-file-spec: full pa + - "thname and file name for the source file". + 03 filler pic x(0015). + 03 temp-00-0601 pic x(0065) value "target-file-spec: full + - " pathname and file name for the target file". + 03 filler pic x(0021). + 03 temp-00-0707 pic x(0060) value "resvd-word: U means co + - "nvert all reserved words to UPPER case". + 03 filler pic x(0032). + 03 temp-00-0819 pic x(0029) value "L means convert to LOW + - "ER case". + 03 filler pic x(0051). + 03 temp-00-0919 pic x(0062) value "F means convert first + - "character to UPPER, all others to LOWER ". + 03 temp-00-1001 pic x(0062) value " data-name: U me + - "ans convert all data names to UPPER case". + 03 filler pic x(0036). + 03 temp-00-1119 pic x(0029) value "L means convert to LOW + - "ER case". + 03 filler pic x(0051). + 03 temp-00-1219 pic x(0062) value "F means convert first + - "character to UPPER, all others to LOWER ". + 03 temp-00-1301 pic x(0079) value " procedure: U me + - "ans convert all procedure and section names to UPPER case". + 03 filler pic x(0019). + 03 temp-00-1419 pic x(0029) value "L means convert to LOW + - "ER case". + 03 filler pic x(0051). + 03 temp-00-1519 pic x(0061) value "F means convert first + - "character to UPPER, all others to LOWER". + 03 filler pic x(0081). + 03 temp-00-1701 pic x(0054) value "eg. CASE C:\WORK\MYPRO + - "G.CBL D:\MYDIR\NEWPROG.CBL U F L". + 03 filler pic x(0106). + 03 temp-00-1901 pic x(0080) value "The other use of this + - "utility is to convert a COBOL source file to ""SENTENCE"". + - "". + 03 temp-00-2001 pic x(0080) value "ie. the first characte + - "r found after a period is UPPER case, all others are LOWER". + 03 filler pic x(0080). + 03 temp-00-2201 pic x(0050) value "eg. CASE C:\WORK\MYPRO + - "G.CBL D:\MYDIR\NEWPROG.CBL S". + 03 filler pic x(0030). + 77 prog-line-no pic 9(6) comp. + 77 prog-line-no-disp pic z(6). + 77 start-ind pic 99 comp. + 77 char-ind pic 99 comp. + 77 buffer-char-ind pic 99 comp. + + 77 file-flag pic x. + 88 end-of-file value "Y". + + 77 error-flag pic x. + 88 error-found value "Y". + + 77 file-status pic xx. + + 77 input-file-name pic x(80). + + 77 output-file-name pic x(80). + + 77 q-answer pic x. + + 77 no-list pic x(6). + 88 no-list-true value "Nolist" "NOLIST" "nolist" "NoList". + 77 syntax-error pic x(80) + value "Syntax error in parameters - Program Terminated". + 01 out-err. + 03 oe1 pic x(20) + value "Target file exists:". + 03 oe2 pic x(15) value "Are you sure?". + 01 in-err. + 03 ie1 pic x(27) + value "Source file not found for:". + 03 in-err-fname pic x(53). + 01 dup-err. + 03 de1 pic x(37) + value "Source and target file are the same:". + 03 dup-err-fname pic x(43). + + 78 upper-case value "UPPER-CASE". + 78 lower-case value "lower-case". + 78 first-char value "First-Character-Upper". + 78 sentence-case value "Sentence-type-case". + + 01 final-message-1. + 03 fm1 pic x(31) value " About to convert:". + 03 disp-inp pic x(49). + 03 fm2 pic x(31) value " to:". + 03 disp-out pic x(49). + 01 final-message-2-1. + 03 fm3 pic x(31) value " Converting Reserved words to:". + 03 res-inp pic x(49). + 03 fm4 pic x(31) value " Data names to:". + 03 dat-inp pic x(49). + 03 fm5 pic x(31) value " Procedure names to:". + 03 pro-inp pic x(49). + 01 final-message-2-2. + 03 fm6 pic x(31) value " Converting entire file to:". + 03 fm7 pic x(49) value "Sentence case". + 01 final-message-3. + 03 fm8 pic x(31) value "--- No screen listing ---". + 01 final-message-4. + 03 fm9 pic x(31) value " Do you wish to continue ? ". + + 01 command-tail. + 03 command-tail-char pic x occurs 81. + + 01 buffer-string. + 03 buffer-char pic x occurs 80. + + 01 case-linkage. + 03 case-flags. + 05 lnk-reserved-case pic x. + 88 lnk-reserved-case-ok + value "u" "l" "f" "U" "L" "F" "S" "s". + * note that the resreved case flag is also used to determine if + * the conversion is to be a "sentence" type conversion. + 05 lnk-data-name-case pic x. + 88 lnk-data-name-case-ok + value "u" "l" "f" "U" "L" "F". + 05 lnk-proc-case pic x. + 88 lnk-proc-case-ok + value "u" "l" "f" "U" "L" "F". + 03 record-area pic x(80). + + procedure division. + runstart section. + display spaces upon crt + perform get-command-line + if not error-found + perform test-case-flags + if error-found + perform command-line-error + else + perform open-input-file + if error-found + perform input-file-error + else + display spaces upon crt + perform check-output-file + if not error-found + open output output-file + perform convert-file + close input-file + close output-file + end-if + end-if + end-if + end-if + exit program + stop run. + + get-command-line section. + accept command-tail from command-line + if command-tail = spaces + perform command-line-prompt + display "Enter Parameters" + accept command-tail + if command-tail = spaces + set error-found to true + display syntax-error + end-if + end-if + if not error-found + perform split-off-names + if input-file-name = spaces + or output-file-name = spaces + or lnk-reserved-case = spaces + or lnk-data-name-case = spaces + or lnk-proc-case = spaces + perform command-line-error + else + if input-file-name = output-file-name + perform duplicate-file-name-error + end-if + end-if + end-if. + + open-input-file section. + open input input-file + if file-status not = "00" + set error-found to true + close input-file + end-if. + + check-output-file section. + open input output-file + if file-status = "00" + close output-file + perform check-for-overwrite + end-if. + + convert-file section. + move input-file-name to disp-inp + move output-file-name to disp-out + evaluate lnk-reserved-case + when "U" + when "u" + move upper-case to res-inp + when "L" + when "l" + move lower-case to res-inp + when "F" + when "f" + move first-char to res-inp + when "S" + when "s" + move sentence-case to res-inp + end-evaluate + evaluate lnk-data-name-case + when "U" + when "u" + move upper-case to dat-inp + when "L" + when "l" + move lower-case to dat-inp + when "F" + when "f" + move first-char to dat-inp + end-evaluate + evaluate lnk-proc-case + when "U" + when "u" + move upper-case to pro-inp + when "L" + when "l" + move lower-case to pro-inp + when "F" + when "f" + move first-char to pro-inp + end-evaluate + display final-message-1 at 0301 + if lnk-reserved-case = "S" or "s" + display final-message-2-2 at 0601 + else + display final-message-2-1 at 0601 + end-if + if no-list-true + display final-message-3 at 1001 + end-if + display final-message-4 at 1201 + move "Y" to q-answer + accept q-answer at 1233 + + if q-answer = "y" or "Y" + display "Converting - Please Wait" at 1401 + perform read-input-file + move 1 to prog-line-no + perform until end-of-file + move prog-line-no to prog-line-no-disp + move input-record to record-area + call "CASECONV" using case-linkage + move record-area to output-record + write output-record + if not no-list-true + move prog-line-no-disp to output-record(1:6) + display output-record + else + display prog-line-no-disp at 1425 + end-if + add 1 to prog-line-no + perform read-input-file + end-perform + display " " + display " " + display "Conversion complete" + else + set error-found to true + end-if. + + split-off-names section. + move 1 to start-ind + perform find-leading-spaces + perform get-input-file-name + perform find-leading-spaces + perform get-output-file-name + perform find-leading-spaces + perform get-reserved-flag + if lnk-reserved-case = "S" or "s" + move "S" to lnk-data-name-case + move "S" to lnk-proc-case + else + perform find-leading-spaces + perform get-data-name-flag + perform find-leading-spaces + perform get-proc-name-flag + end-if + perform find-leading-spaces + perform get-nolist-flag. + + find-leading-spaces section. + perform varying char-ind from start-ind by 1 until + (char-ind > 80) + or not (command-tail-char(char-ind) = (spaces or ",")) + end-perform + move char-ind to start-ind. + + get-input-file-name section. + move spaces to buffer-string + move 1 to buffer-char-ind + perform varying char-ind from start-ind by 1 until + char-ind > 80 or command-tail-char(char-ind) = spaces + move command-tail-char(char-ind) to + buffer-char(buffer-char-ind) + add 1 to buffer-char-ind + end-perform + move buffer-string to input-file-name + move char-ind to start-ind. + + get-output-file-name section. + move spaces to buffer-string + move 1 to buffer-char-ind + perform varying char-ind from start-ind by 1 until + char-ind > 80 or command-tail-char(char-ind) = spaces + move command-tail-char(char-ind) to + buffer-char(buffer-char-ind) + add 1 to buffer-char-ind + end-perform + move buffer-string to output-file-name + move char-ind to start-ind. + + get-reserved-flag section. + if start-ind < 80 + move command-tail-char(start-ind) to lnk-reserved-case + add 1 to start-ind + end-if. + + get-data-name-flag section. + if start-ind < 80 + move command-tail-char(start-ind) to lnk-data-name-case + add 1 to start-ind + end-if. + + get-proc-name-flag section. + if start-ind < 80 + move command-tail-char(start-ind) to lnk-proc-case + add 1 to start-ind + end-if. + + get-nolist-flag section. + move spaces to buffer-string + move 1 to buffer-char-ind + perform varying char-ind from start-ind by 1 until + char-ind > 80 or command-tail-char(char-ind) = spaces + move command-tail-char(char-ind) to + buffer-char(buffer-char-ind) + add 1 to buffer-char-ind + end-perform + move buffer-string to no-list. + + check-for-overwrite section. + display out-err at 0101 + move "Y" to q-answer + accept q-answer at 0137 + if q-answer = "y" or "Y" + next sentence + else + set error-found to true + end-if. + + input-file-error section. + set error-found to true + move input-file-name to in-err-fname + display in-err. + + command-line-error section. + perform command-line-prompt + display syntax-error + set error-found to true. + + command-line-prompt section. + display temp-00. + + duplicate-file-name-error section. + move input-file-name to dup-err-fname + set error-found to true + display dup-err. + + read-input-file section. + read input-file + at end + set end-of-file to true + end-read. + + test-case-flags section. + if lnk-reserved-case = "S" or "s" + next sentence + else + if lnk-reserved-case-ok and + lnk-data-name-case-ok and lnk-proc-case-ok + next sentence + else + set error-found to true + end-if + end-if. + + end program case. + + + identification division. + program-id. caseconv. + *************************************************************** + * This program accepts one 80 character line of COBOL code in its + * linkage section. This line of code is returned to the calling + * program with the line of code changed according to the + * following rules: + * + * There are 3 parameters passed in linkage section: + * + * lnk-reserved-case can have values U, L and F + * lnk-data-name-case can have values U, L and F + * lnk-proc-case can have values U, L and F + * + * the first parameter controls the case of reserved words + * the second parameter controls the case of data names + * the third parameter controls the procedure and section names + * + * All the above can be independantly changed so that they are + * in: + * + * UPPER-CASE + * lower-case or + * First-Character-Upper-Case + * + * according to the respective value of the parameter + * + * One additional function of this program is controlled by + * passing the value "S" in lnk-reserved-case. In this case, the + * other parameters are ignored and the entire line is converted + * so that the case is made "Sentence like". ie. the first + * alphabetic character found after a period is capitalised. + *************************************************************** + working-storage section. + 01 temp-char pic x. + 01 temp-char-9 redefines temp-char pic 99 comp. + * This next variable, and its associated 88 is used to determine + * whether to capitalize the next character in the case of "F" + * type conversion. The setting in the 88 is to capitalize after + * a space, a hyphen etc. This can be changed to suit your + * requirements. + + 01 prev-char pic x. + 88 prev-char-separator + value "(" ":" "-" space "0" thru "9". + 77 ind-1 pic 9(4) comp. + 77 ind-2 pic 9(4) comp. + 78 editfun value x"bb". + 78 spacebreak value x"c5". + 78 yes value 1. + 78 nay value 0. + 01 literal pic 99 comp value zero. + 01 reserved pic 99 comp value zero. + 01 new-sentence-expected pic 99 comp value 1. + 01 start-of-sentence pic 99 comp value 1. + 01 perf-name-expected pic 99 comp value zero. + 01 alt1-name-expected pic 99 comp value zero. + 01 alt2-name-expected pic 99 comp value zero. + 01 go-name-expected pic 99 comp value zero. + 01 pic-name-expected pic 99 comp value zero. + 01 sub pic 99 comp value zero. + 01 start-sub pic 99 comp value zero. + 01 end-sub pic 99 comp value zero. + 01 res-sub pic 99 comp value zero. + 01 res-len pic 99 comp value zero. + 01 res-word-buffer. + 02 res-word-buffer-char pic x occurs 65. + 01 filler redefines res-word-buffer. + 02 res19. + 03 res18. + 04 res17. + 05 res16. + 06 res15. + 07 res14. + 08 res13. + 09 res12. + 10 res11. + 11 res10. + 12 res09. + 13 res08. + 14 res07. + 15 res06. + 16 res05. + 17 res04. + 18 res03. + 19 res02 pic xx. + 19 filler pic x. + 18 filler pic x. + 17 filler pic x. + 16 filler pic x. + 15 filler pic x. + 14 filler pic x. + 13 filler pic x. + 12 filler pic x. + 11 filler pic x. + 10 filler pic x. + 09 filler pic x. + 08 filler pic x. + 07 filler pic x. + 06 filler pic x. + 05 filler pic x. + 04 filler pic x. + 03 filler pic x. + 02 filler pic x(46). + 01 char-to-bin. + 02 char pic x. + 01 char9 redefines char-to-bin pic 99 comp. + 01 ulcase pic 99 comp value 0. + 01 locase pic 99 comp value 1. + 01 editstart pic 9(4) comp value zero. + 01 templen pic 9(4) comp value zero. + 01 editlen pic 9(4) comp value zero. + 01 editfunction pic 9(4) comp value 0. + + *list of no of reserved words for ANS85 + 78 res-word-count-2 value 24. + 78 res-word-count-3 value 24. + 78 res-word-count-4 value 51. + 78 res-word-count-5 value 43. + 78 res-word-count-6 value 48. + 78 res-word-count-7 value 41. + 78 res-word-count-8 value 40. + 78 res-word-count-9 value 23. + 78 res-word-count-10 value 23. + 78 res-word-count-11 value 17. + 78 res-word-count-12 value 15. + 78 res-word-count-13 value 9. + 78 res-word-count-14 value 6. + 78 res-word-count-15 value 4. + 78 res-word-count-16 value 2. + 78 res-word-count-19 value 1. + + 01 r2tab pic x(48) value "ATBYCDFDGOIDIFINISNOOFONORRDSDTOUPCF + -"CHDEPFPHRFRH". + 01 filler redefines r2tab. + 02 r2entry pic xx occurs res-word-count-2. + 01 r3tab pic x(72) value "ADDALLANDARECRTDAYEGIEMIENDEOPESIFOR + -"KEYNOTOFFPICRUNSETTABTOPUSEI-OSUMANY". + 01 filler redefines r3tab. + 02 r3entry pic xxx occurs res-word-count-3. + 01 r4tab. + 02 filler pic x(128) value "ALSOAREACALLCOMPCOPYCORRDATADATEDOWN + -"ELSEEXITFILEFROMINTOJUSTKEPTLEFTLESSLINEMODEMOVENEXTOPENPAGEREAD + -"REELSAMESENDSIGNSIZESORTSTOP". + 02 filler pic x(76) value + -"TAPETEXTTHANTHENTHRUTIMETYPEUNITUPONWHENWITHZEROSYNCCODELASTPLUS + -"TESTTHENTRUE". + 01 filler redefines r4tab. + 02 r4entry pic x(4) occurs res-word-count-4. + 01 r5tab. + 02 filler pic x(128) value "AFTERALTERAREASBLANKBLOCKCLOSECOBOLC + -"OMMACOUNTEQUALERROREVERYFIRSTINDEXINPUTLABELLIMITLINESMERGEQUEUE + -"QUOTERERUNSPACESTARTSYSINTAB". + 02 filler pic x(87) value + -"LETIMESUNTILUSAGEUSINGVALUEWORDSWRITEZEROSENTERRIGHTFINALGROUPRE + -"SETCLASSORDEROTHERPURGE". + 01 filler redefines r5tab. + 02 r5entry pic x(5) occurs res-word-count-5. + 01 r6tab. + 02 filler pic x(128) value "ACCEPTACCESSASSIGNAUTHORBEFOREBOTTOM + -"CANCELCOMMITCOMP-3CURSORDELETEDIVIDEENABLEEXTENDFILLERGIVINGLENG + -"THLIMITSLINAGEMANUALMEMORYNA". + 02 filler pic x(124) value + -"TIVEOCCURSOUTPUTQUOTESRANDOMRECORDRETURNREWINDSEARCHSELECTSOURCE + -"SPACESSTATUSSTRINGSWITCHSYSOUTUNLOCKVALUESZEROESCOMP-3COLUMN". + 02 filler pic x(42) value + -"DETAILREPORTNUMBERBINARYCOMMONEND-IFGLOBAL". + 01 filler redefines r6tab. + 02 r6entry pic x(6) occurs res-word-count-6. + 01 r7tab. + 02 filler pic x(128) value "COMPUTECONSOLEDISABLEDISPLAYDYNAMICF + -"OOTINGGREATERINDEXEDINSPECTINVALIDLEADINGLINKAGEMESSAGEMODULESNU + -"MERICOMITTEDPERFORMPICTUREPO". + 02 filler pic x(124) value + -"INTERPROCEEDPROGRAMRECEIVERECORDSRELEASEREMOVALRENAMESRESERVEREW + -"RITEROUNDEDSECTIONSEGMENTTHROUGHVARYINGINITIALCONTROLHEADING". + 02 filler pic x(35) value + -"REPORTSCONTENTEND-ADDPADDINGREPLACE". + 01 filler redefines r7tab. + 02 r7entry pic x(7) occurs res-word-count-7. + 01 r8tab. + 02 filler pic x(128) value "CODE-SETCONTAINSCURRENCYDIVISIONEXCE + -"SS-3FORMFEEDJAPANESEMULTIPLEMULTIPLYNEGATIVEOPTIONALOVERFLOWPOSI + -"TIONPOSITIVEREVERSEDROLLBACK". + 02 filler pic x(128) value + -"SENTENCESEPARATESEQUENCESTANDARDSUBTRACTSYMBOLICTALLYINGTERMINAL + -"TRAILINGUNSTRINGCONTROLSGENERATEINDICATEINITIATEPRINTINGSUPPRESS + -"". + 02 filler pic x(64) value + -"RELATIVESECURITYALPHABETCONTINUEEND-READEVALUATEEXTERNALEND-CALL + -"". + 01 filler redefines r8tab. + 02 r8entry pic x(8) occurs res-word-count-8. + 01 r9tab. + 02 filler pic x(126) value "ADVANCINGAUTOMATICCHARACTERCRT-UNDER + -"DEBUGGINGDELIMITEDDELIMITERDEPENDINGEXCEPTIONEXCLUSIVEJUSTIFIEDP + -"ROCEDUREREDEFINESREMAINDER". + 02 filler pic x(81) value + -"REPLACINGREPORTINGTERMINATEASCENDINGALTERNATECOLLATINGEND-STARTE + -"ND-WRITEREFERENCE". + 01 filler redefines r9tab. + 02 r9entry pic x(9) occurs res-word-count-9. + 01 r10tab. + 02 filler pic x(090) value "ALPHABETICAREA-VALUECHARACTERSDUPLIC + -"ATESPROCEDURESREFERENCESSEQUENTIALSORT-MERGESTANDARD-1". + 02 filler pic x(060) value "DEBUG-ITEMDEBUG-LINEDEBUG-NAMEHIGH-V + -"ALUEPROGRAM-IDDESCENDING". + 02 filler pic x(080) value "CONVERTINGEND-DELETEEND-RETURNEND-SE + -"ARCHEND-STRINGINITIALIZESTANDARD-2END-DIVIDE". + 01 filler redefines r10tab. + 02 r10entry pic x(10) occurs res-word-count-10. + 01 r11tab. + 02 filler pic x(088) value "CLOCK-UNITSDEBUG-SUB-1DEBUG-SUB-2DEB + -"UG-SUB-3DESTINATIONEND-OF-PAGEENVIRONMENTHIGH-VALUES". + 02 filler pic x(033) value "SUB-QUEUE-1SUB-QUEUE-2SUB-QUEUE-3". + 02 filler pic x(011) value "I-O-CONTROL". + 02 filler pic x(055) value + "DAY-OF-WEEKEND-COMPUTEEND-PERFORMEND-RECEIVEEND-REWRITE". + 01 filler redefines r11tab. + 02 r11entry pic x(11) occurs res-word-count-11. + 01 r12tab. + 02 filler pic x(084) value "COMMAND-LINEDATE-WRITTENDECLARATIVES + -"FILE-CONTROLINPUT-OUTPUTINSTALLATIONORGANIZATION". + 02 filler pic x(096) value "SYNCHRONIZEDLINE-COUNTERPAGE-COUNTER + -"ALPHANUMERICEND-EVALUATEEND-MULTIPLYEND-SUBTRACTEND-UNSTRING". + 01 filler redefines r12tab. + 02 r12entry pic x(12) occurs res-word-count-12. + 01 r13tab. + 02 filler pic x(078) value "COMMUNICATIONCOMPUTATIONALCONFIGURAT + -"IONCORRESPONDINGDATE-COMPILEDDECIMAL-POINT". + 02 filler pic x(039) value "LOCKLOW-VALUESEGMENT-LIMITSPECIAL-NA + -"MES". + 01 filler redefines r13tab. + 02 r13entry pic x(13) occurs res-word-count-13. + 01 r14tab. + 02 filler pic x(084) value "DEBUG-CONTENTSIDENTIFICATIONLINAGE-C + -"OUNTERLOCKLOW-VALUESNUMERIC-EDITEDPACKED-DECIMAL". + 01 filler redefines r14tab. + 02 r14entry pic x(14) occurs res-word-count-14. + 01 r15tab. + 02 filler pic x(060) value "COMPUTATIONAL-3OBJECT-COMPUTERSOURCE + -"-COMPUTERWORKING-STORAGE". + 01 filler redefines r15tab. + 02 r15entry pic x(15) occurs res-word-count-15. + 01 r16tab. + 02 filler pic x(032) value "ALPHABETIC-LOWERALPHABETIC-UPPER". + 01 filler redefines r16tab. + 02 r16entry pic x(16) occurs res-word-count-16. + 01 r19tab. + 02 filler pic x(019) value "ALPHANUMERIC-EDITED". + 01 filler redefines r19tab. + 02 r19entry pic x(19) occurs res-word-count-19. + + 01 ws-case-linkage. + 03 ws-case-flags. + 05 def-reserved-case pic x. + 05 def-sentence-case redefines def-reserved-case pic x. + 05 def-data-name-case pic x. + 05 def-proc-case pic x. + 03 so-rec. + 05 so-rec-chr pic x occurs 80. + + linkage section. + 01 case-linkage. + 03 case-flags. + 05 lnk-reserved-case pic x. + 05 lnk-data-name-case pic x. + 05 lnk-proc-case pic x. + 03 record-area pic x(80). + + procedure division using case-linkage. + main-prog section. + move case-linkage to ws-case-linkage. + if ws-case-flags = spaces or so-rec = spaces + next sentence + else + perform case + move ws-case-linkage to case-linkage. + exit program. + stop run. + + case section. + move nay to perf-name-expected. + move nay to alt1-name-expected. + move nay to alt2-name-expected. + move nay to go-name-expected. + move nay to pic-name-expected. + move nay to literal. + case1. + move 8 to start-sub. + if so-rec-chr(7) = "*" + go to case-end. + case2. + if new-sentence-expected = 1 + move 1 to start-of-sentence + else + move 0 to start-of-sentence. + perform next-word. + if start-sub > 72 + go to case-end. + if literal = yes + move end-sub to start-sub + go to case2. + move start-sub to sub. + if reserved = yes + if def-reserved-case = "N" + move end-sub to start-sub + go to case2. + if pic-name-expected = yes + go to case3. + if reserved = nay + go to case4. + case3. + move res-len to editlen. + move sub to editstart. + if def-sentence-case = "S" or "s" + perform convert-to-sentence + else + if def-reserved-case = "F" or "f" + perform convert-to-first + else + if def-reserved-case = "U" or "u" + perform convert-to-upper + else + if def-reserved-case = "L" or "l" + perform convert-to-lower. + move end-sub to start-sub. + go to case2. + case4. + if start-sub = 8 + go to case6. + if perf-name-expected = yes + go to case6. + if alt1-name-expected = yes + go to case6. + if alt2-name-expected = yes + go to case6. + if go-name-expected = yes + go to case6. + if def-data-name-case= "N" + move end-sub to start-sub + go to case2. + case5. + move res-len to editlen. + move sub to editstart. + if def-sentence-case = "S" or "s" + perform convert-to-sentence + else + if def-data-name-case = "F" or "f" + perform convert-to-first + else + if def-data-name-case= "U" or "u" + perform convert-to-upper + else + if def-data-name-case = "L" or "l" + perform convert-to-lower. + move end-sub to start-sub. + go to case2. + case6. + move nay to perf-name-expected. + move alt1-name-expected to alt2-name-expected. + move nay to alt1-name-expected. + if def-proc-case = "N" + move end-sub to start-sub + go to case2. + case7. + move res-len to editlen. + move sub to editstart. + if def-sentence-case = "S" or "s" + perform convert-to-sentence + else + if def-proc-case = "F" or "f" + perform convert-to-first + else + if def-proc-case = "U" or "u" + perform convert-to-upper + else + if def-proc-case = "L" or "l" + perform convert-to-lower. + move end-sub to start-sub. + go to case2. + case-end. + exit. + next-word section. + next-w1. + perform find-char. + if start-sub > 72 + go to next-wend. + if char = quote + if literal = yes + move nay to literal + add 1 to start-sub + go to next-w1 + else + move yes to literal + add 1 to start-sub + go to next-w1. + if char = "." + move 1 to new-sentence-expected + if literal = nay + move nay to perf-name-expected + alt1-name-expected + alt2-name-expected + go-name-expected + pic-name-expected + add 1 to start-sub + go to next-w1 + else + add 1 to start-sub + go to next-w1. + if literal = yes + add 1 to start-sub + go to next-w1. + move start-sub to end-sub. + move 1 to res-sub. + move spaces to res-word-buffer. + next-w2. + move char to res-word-buffer-char(res-sub). + add 1 to end-sub. + add 1 to res-sub. + if end-sub > 72 + go to next-w3. + move so-rec-chr(end-sub) to char. + if char = space + go to next-w3 + else if char = "." + move 1 to new-sentence-expected + go to next-w3. + go to next-w2. + next-w3. + perform reserved-or-not. + next-wend. + exit. + reserved-or-not section. + reserv1. + move 65 to editlen. + move 1 to editstart. + perform convert-resv-to-upper. + move nay to reserved. + move res-sub to res-len. + subtract 1 from res-len. + if res-sub < 3 or res-sub > 20 + go to r20. + subtract 2 from res-sub. + go to r2 r3 r4 r5 r6 r7 r8 r9 r10 r11 r12 r13 r14 r15 + r16 r20 r20 r19 + depending on res-sub. + r2. + move 0 to res-sub. + r2a. + add 1 to res-sub. + if res-sub > res-word-count-2 go to r20. + if res02 = r2entry(res-sub) + move yes to reserved + go to r20. + go to r2a. + r3. + move 0 to res-sub. + r3a. + add 1 to res-sub. + if res-sub > res-word-count-3 go to r20. + if res03 = r3entry(res-sub) + move yes to reserved + go to r20. + go to r3a. + r4. + move 0 to res-sub. + r4a. + add 1 to res-sub. + if res-sub > res-word-count-4 go to r20. + if res04 = r4entry(res-sub) + move yes to reserved + go to r20. + go to r4a. + r5. + move 0 to res-sub. + r5a. + add 1 to res-sub. + if res-sub > res-word-count-5 go to r20. + if res05 = r5entry(res-sub) + move yes to reserved + go to r20. + go to r5a. + r6. + move 0 to res-sub. + r6a. + add 1 to res-sub. + if res-sub > res-word-count-6 go to r20. + if res06 = r6entry(res-sub) + move yes to reserved + go to r20. + go to r6a. + r7. + move 0 to res-sub. + r7a. + add 1 to res-sub. + if res-sub > res-word-count-7 go to r20. + if res07 = r7entry(res-sub) + move yes to reserved + go to r20. + go to r7a. + r8. + move 0 to res-sub. + r8a. + add 1 to res-sub. + if res-sub > res-word-count-8 go to r20. + if res08 = r8entry(res-sub) + move yes to reserved + go to r20. + go to r8a. + r9. + move 0 to res-sub. + r9a. + add 1 to res-sub. + if res-sub > res-word-count-9 go to r20. + if res09 = r9entry(res-sub) + move yes to reserved + go to r20. + go to r9a. + r10. + move 0 to res-sub. + r10a. + add 1 to res-sub. + if res-sub > res-word-count-10 go to r20. + if res10 = r10entry(res-sub) + move yes to reserved + go to r20. + go to r10a. + r11. + move 0 to res-sub. + r11a. + add 1 to res-sub. + if res-sub > res-word-count-11 go to r20. + if res11 = r11entry(res-sub) + move yes to reserved + go to r20. + go to r11a. + r12. + move 0 to res-sub. + r12a. + add 1 to res-sub. + if res-sub > res-word-count-12 go to r20. + if res12 = r12entry(res-sub) + move yes to reserved + go to r20. + go to r12a. + r13. + move 0 to res-sub. + r13a. + add 1 to res-sub. + if res-sub > res-word-count-13 go to r20. + if res13 = r13entry(res-sub) + move yes to reserved + go to r20. + go to r13a. + r14. + move 0 to res-sub. + r14a. + add 1 to res-sub. + if res-sub > res-word-count-14 go to r20. + if res14 = r14entry(res-sub) + move yes to reserved + go to r20. + go to r14a. + r15. + move 0 to res-sub. + r15a. + add 1 to res-sub. + if res-sub > res-word-count-15 go to r20. + if res15 = r15entry(res-sub) + move yes to reserved + go to r20. + go to r15a. + r16. + move 0 to res-sub. + r16a. + add 1 to res-sub. + if res-sub > res-word-count-16 go to r20. + if res16 = r16entry(res-sub) + move yes to reserved + go to r20. + go to r16a. + r19. + move 0 to res-sub. + r19a. + add 1 to res-sub. + if res-sub > res-word-count-19 go to r20. + if res19 = r19entry(res-sub) + move yes to reserved + go to r20. + go to r19a. + r20. + if reserved = nay go to reserv-end. + if res-word-buffer not = "TO" + move nay to go-name-expected. + if res-word-buffer = "PIC" or "PICTURE" or "VALUE" + move yes to pic-name-expected + go to reserv-end + else + move nay to pic-name-expected. + if res-word-buffer = "PERFORM" or "THRU" or "THROUGH" + move yes to perf-name-expected + go to reserv-end. + if res-word-buffer = "ALTER" + move yes to alt1-name-expected + go to reserv-end. + if res-word-buffer = "GO" + move yes to go-name-expected + go to reserv-end. + reserv-end. + exit. + convert-to-upper section. + move editstart to ind-1. + move 1 to ind-2. + convert-to-upper-loop. + move so-rec-chr(ind-1) to temp-char + if temp-char-9 < 123 and temp-char-9 > 96 + subtract 32 from temp-char-9 + move temp-char to so-rec-chr(ind-1). + add 1 to ind-1 + add 1 to ind-2. + if ind-2 not > editlen + go to convert-to-upper-loop. + + convert-to-sentence section. + move editstart to ind-1. + move 1 to ind-2. + convert-to-sentence-loop. + move so-rec-chr(ind-1) to temp-char. + if start-of-sentence = 1 + if temp-char-9 < 123 and temp-char-9 > 96 + subtract 32 from temp-char-9 + move temp-char to so-rec-chr(ind-1) + move 0 to new-sentence-expected + move 0 to start-of-sentence + else + if temp-char-9 < 91 and temp-char-9 > 64 + move 0 to new-sentence-expected + move 0 to start-of-sentence + else + next sentence + else + if temp-char-9 < 91 and temp-char-9 > 64 + add 32 to temp-char-9 + move temp-char to so-rec-chr(ind-1). + add 1 to ind-1 + add 1 to ind-2. + if ind-2 not > editlen + go to convert-to-sentence-loop. + + + convert-to-first section. + move editstart to ind-1. + move 1 to ind-2. + convert-to-first-loop. + move so-rec-chr(ind-1) to temp-char. + move so-rec-chr(ind-1 - 1) to prev-char + if prev-char-separator + if temp-char-9 < 123 and temp-char-9 > 96 + subtract 32 from temp-char-9 + move temp-char to so-rec-chr(ind-1) + else + next sentence + else + if temp-char-9 < 91 and temp-char-9 > 64 + add 32 to temp-char-9 + move temp-char to so-rec-chr(ind-1). + add 1 to ind-1 + add 1 to ind-2. + if ind-2 not > editlen + go to convert-to-first-loop. + + convert-to-lower section. + move editstart to ind-1. + move 1 to ind-2. + convert-to-lower-loop. + move so-rec-chr(ind-1) to temp-char + if temp-char-9 < 91 and temp-char-9 > 64 + add 32 to temp-char-9 + move temp-char to so-rec-chr(ind-1). + add 1 to ind-1 + add 1 to ind-2. + if ind-2 not > editlen + go to convert-to-lower-loop. + + convert-resv-to-upper section. + move editstart to ind-1. + move 1 to ind-2. + convert-resv-to-upper-loop. + move res-word-buffer-char(ind-1) to temp-char + if temp-char-9 < 123 and temp-char-9 > 96 + subtract 32 from temp-char-9 + move temp-char to res-word-buffer-char(ind-1). + add 1 to ind-1 + add 1 to ind-2. + if ind-2 not > editlen + go to convert-resv-to-upper-loop. + + find-char section. + if start-sub < 73 + if so-rec-chr(start-sub) = space + add 1 to start-sub + go to find-char + else + move so-rec-chr(start-sub) to char + else + move space to char. + + end program caseconv. diff --git a/Microsoft COBOL v45/DEMO/DECLARE.CBL b/Microsoft COBOL v45/DEMO/DECLARE.CBL new file mode 100644 index 0000000..74eb40f --- /dev/null +++ b/Microsoft COBOL v45/DEMO/DECLARE.CBL @@ -0,0 +1,55 @@ + $set ans85 mf noosvs + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * DECLARE.CBL * + * * + * This program demonstrates how to use declaratives. * + * * + ************************************************************ + + select input-file assign to file-name + organization sequential + file status is file-stat. + + data division. + file section. + + fd input-file. + 01 input-rec pic x(80). + + working-storage section. + 01 file-stat. + 03 f-stat-1 pic x. + 03 f-stat-2 pic x. + 03 f-stat-2-bin redefines f-stat-2 + pic 9(2) comp-x. + 01 stat-disp. + 03 disp1 pic x. + 03 filler pic x. + 03 disp2 pic 9(3). + + procedure division. + declaratives. + dec-laratives section. + use after standard error procedure on input-file. + move f-stat-1 to disp1 + if f-stat-1 = "9" + move f-stat-2-bin to disp2 + else + move f-stat-2 to disp2 + end-if + display "file status :" at 1029 + display stat-disp at 1049 + stop run. + end declaratives. + + main section. + sta-rt. + display spaces upon crt + display "enter a non-existant file name :" at 0810 + accept file-name at 0849 + open input input-file + display "Open worked. Try a different filename." + stop run. diff --git a/Microsoft COBOL v45/DEMO/DIOPHANT.CBL b/Microsoft COBOL v45/DEMO/DIOPHANT.CBL new file mode 100644 index 0000000..c9bbe4a --- /dev/null +++ b/Microsoft COBOL v45/DEMO/DIOPHANT.CBL @@ -0,0 +1,143 @@ + $set ans85 noosvs mf + + PROGRAM-ID. DIOPHANT. + ****************************************************************** + * + * (C) Micro Focus Ltd. 1989 + * + * DIOPHANT.CBL + * + * DIOPHANTINE - solve linear equation Ax + By = C + * for integers x and y. + * + * Method: + * if A > B + * swap A and B + * fi + * + * when A = 0 + * set x = 0, y = C/B as solution, and fail if non-integer + * when A = 1 + * set x = C, y = 0 as solution + * otherwise + * let D = largest integer < (B/A) + * let E = largets integer < (C/A) + * let F = B - A*D + * let G = C - A*E + * then Ax + By = C becomes + * Ax + (F + A*D)y = (G + A*E) + * so x + (F/A + D)y = (G/A + E) + * and (F/A)y + v = G/A (since everything else is integral) + * so solve + * Fy + Av = G for integers y and v + * + * in COBOL terms: + * + * divide B by A giving D remainder F + * divide C by A giving E remainder G + * solve Av + Fw = G for integers v and w + * set x = E - Dw + v, y = w as solution + * + * if swapped + * swap x and y + * fi + * + * + ****************************************************************** + WORKING-STORAGE SECTION. + 01 InitA PIC s9(9) comp-5. + 01 InitB PIC s9(9) comp-5. + 01 InitC PIC s9(9) comp-5. + 01 SolvX PIC s9(9) comp-5. + 01 SolvY PIC s9(9) comp-5. + 01 FailFg PIC X. + 88 OK VALUE 'Y'. + 88 BAD VALUE 'N'. + 88 TRY VALUE '?'. + LOCAL-STORAGE SECTION. + 01 D PIC s9(9) comp-5. + 01 E PIC s9(9) comp-5. + 01 F PIC s9(9) comp-5. + 01 G PIC s9(9) comp-5. + 01 V PIC s9(9) comp-5. + 01 TEMP PIC s9(9) comp-5. + LINKAGE SECTION. + 01 A PIC s9(9) comp-5. + 01 B PIC s9(9) comp-5. + 01 C PIC s9(9) comp-5. + 01 X PIC s9(9) comp-5. + 01 Y PIC s9(9) comp-5. + PROCEDURE DIVISION. + MAIN SECTION. + DISPLAY "Solve Ax + By = C for integers x and y" + DISPLAY "Enter value for A: " with no advancing + ACCEPT InitA + DISPLAY "Enter value for B: " with no advancing + ACCEPT InitB + DISPLAY "Enter value for C: " with no advancing + ACCEPT InitC + SET TRY TO TRUE + CALL 'SOLVE' USING BY VALUE InitA InitB InitC + BY REFERENCE SolvX SolvY + + IF OK + DISPLAY "Solution is: x = " SolvX ", y = " SolvY + ELSE + DISPLAY "No Solution exists." + END-IF + STOP RUN. + + SOLVE-DIOPHANTINE SECTION. + ENTRY 'SOLVE' USING BY VALUE A B C BY REFERENCE X Y. + + IF A > B + * Use TEMP as a flag to indicate swapped or not. + MOVE 1 TO TEMP + CALL 'SWAP2' USING A B + ELSE + MOVE 0 TO TEMP + END-IF + + EVALUATE A + WHEN 0 + DIVIDE C BY B GIVING D REMAINDER E + IF E = 0 + MOVE 0 TO X + MOVE D TO Y + SET OK TO TRUE + ELSE + * No solution exists. + SET BAD TO TRUE + MOVE 0 TO X, Y + END-IF + + WHEN 1 + MOVE C TO X + MOVE 0 TO Y + SET OK TO TRUE + + WHEN OTHER + * We must delve deeper to find a solution. + DIVIDE B BY A GIVING D REMAINDER F + DIVIDE C BY A GIVING E REMAINDER G + + CALL 'SOLVE' USING BY VALUE A F G BY REFERENCE v Y + + COMPUTE X = E - ( D * Y ) + v + + END-EVALUATE + + IF TEMP = 1 + CALL 'SWAP2' USING X Y + END-IF + + EXIT PROGRAM. + + + * Second level program to swap 2 variables using local temp variable. + SWAPPER SECTION. + ENTRY 'SWAP2' USING X Y. + MOVE X TO TEMP + MOVE Y TO X + MOVE TEMP TO Y + EXIT PROGRAM. diff --git a/Microsoft COBOL v45/DEMO/EXPAND.CBL b/Microsoft COBOL v45/DEMO/EXPAND.CBL new file mode 100644 index 0000000..d49c5b0 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/EXPAND.CBL @@ -0,0 +1,41 @@ + $set ans85 mf noosvs + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * EXPAND.CBL * + * * + * This program demonstrates a special expanding accept. * + * It uses the SIZE IS clause of the SCREEN SECTION to * + * dynamically alter the size of the data item being * + * accepted. * + * * + * The program repeats the same ACCEPT twenty times * + * each time increasing the size of the data item by 1. * + * * + ************************************************************ + special-names. + cursor is cursor-pos. + working-storage section. + 01 buffer pic x(20). + 01 buf-size pic 99. + 01 cursor-pos. + 02 line-p pic 99. + 02 col-p pic 99. + screen section. + 01 screen-1. + 02 value "Expanding accept (" line 1 column 1. + 02 pic x(20) using buffer SIZE IS buf-size line 1 column + 1 + auto. + 02 value ")" line 1 column + 1. + procedure division. + main-para. + display space upon crt. + move 1 to buf-size, line-p, col-p. + perform with test after until buf-size = 20 + display screen-1 + accept screen-1 + add 1 to buf-size, col-p + end-perform. + stop run. + diff --git a/Microsoft COBOL v45/DEMO/EXTFILE.CBL b/Microsoft COBOL v45/DEMO/EXTFILE.CBL new file mode 100644 index 0000000..5f1b8b4 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/EXTFILE.CBL @@ -0,0 +1,152 @@ + $set ans85 mf noosvs + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * EXTFILE.CBL * + * * + * This program demonstrates how to use EXTERNAL files. * + * It calls WRITEFIL to write some records to a data * + * file and READFILE to read the same records back * + * (without opening or closing the file between calls). * + * READFILE displays the output. * + * * + ************************************************************ + identification division. + program-id. extfile. + environment division. + input-output section. + file-control. + select finfile assign to "isamfil.dat" + organization is indexed + record key is fd-tran-date + access mode is dynamic. + + file section. + fd finfile + is external + record contains 50 characters. + 01 fd-finfile-record. + 05 fd-tran-date pic x(4). + 05 fd-with-or-dep pic x(2). + 05 fd-amount pic 9(5)v99. + + + procedure division. + main-line. + perform open-file + perform write-to-the-file + perform start-file + perform read-the-file + perform close-file + stop run. + + open-file. + open i-o finfile. + + start-file. + move 1111 to fd-tran-date + start finfile key = fd-tran-date. + + write-to-the-file. + call "writefil". + + read-the-file. + call "readfile". + + close-file. + close finfile. + end program extfile. + ************************************************************ + identification division. + program-id. readfile. + environment division. + input-output section. + file-control. + select finfile assign to "isamfil.dat" + organization is indexed + record key is fd-tran-date + access mode is dynamic. + + file section. + fd finfile + is external + record contains 50 characters. + 01 fd-finfile-record. + 05 fd-tran-date pic x(4). + 05 fd-with-or-dep pic x(2). + 05 fd-amount pic 9(5)v99. + + working-storage section. + 01 ws-end-of-file pic 9 value 0. + 01 ws-subtotal pic s9(5)v99 value 0. + 01 ws-total pic -(4)9.99. + + procedure division. + main-line. + perform read-the-file. + perform until ws-end-of-file = 1 + perform calculate-totals + perform read-the-file + end-perform. + perform display-output. + exit program. + stop run. + + read-the-file. + read finfile next record at end move 1 to ws-end-of-file. + + calculate-totals. + evaluate fd-with-or-dep + when "WI" + subtract fd-amount from ws-subtotal + when "DE" + add fd-amount to ws-subtotal + end-evaluate. + + display-output. + move ws-subtotal to ws-total + display "account balance = ", ws-total. + + end program readfile. + ************************************************************ + identification division. + program-id. writefil. + environment division. + input-output section. + file-control. + select finfile assign to "isamfil.dat" + organization is indexed + record key is fd-tran-date + access mode is dynamic. + + file section. + fd finfile + is external + record contains 50 characters. + 01 fd-finfile-record. + 05 fd-tran-date pic x(4). + 05 fd-with-or-dep pic x(2). + 05 fd-amount pic 9(5)v99. + + procedure division. + main-line. + perform write-records + exit program + stop run. + + write-records. + + * write a WIthdrawal record + move 1111 to fd-tran-date. + move 'WI' to fd-with-or-dep. + move 23.55 to fd-amount. + write fd-finfile-record. + + * write a DEposit record + move 2222 to fd-tran-date. + move 'DE' to fd-with-or-dep. + move 123.55 to fd-amount. + write fd-finfile-record. + + end program writefil. diff --git a/Microsoft COBOL v45/DEMO/FUNKEY.CBL b/Microsoft COBOL v45/DEMO/FUNKEY.CBL new file mode 100644 index 0000000..1ce0920 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/FUNKEY.CBL @@ -0,0 +1,54 @@ + $set noosvs mf ans85 + ************************************************************ + * * + * (C) Micro Focus Ltd. 1991 * + * * + * FUNKEY.CBL * + * * + * This program demonstrates how to decode function keys * + * using the x"af" call. * + * * + ************************************************************ + special-names. + crt status is key-status. + + working-storage section. + 01 flag pic 9(2) comp-x value 1. + 01 user-key-control. + 05 enable-fn-keys pic 9(2) comp-x value 1. + 05 filler pic x value "1". + 05 first-user-key pic 9(2) comp-x value 1. + 05 number-of-keys pic 9(2) comp-x value 10. + + 01 key-status. + 05 key-type pic x. + 05 key-code-1 pic 9(2) comp-x. + 05 filler pic x. + 01 any-data pic x. + 01 key-code-1-display pic z9. + + procedure division. + perform enable-keys + perform accept-function-key + perform tell-which-key-was-pressed + perform stop-run. + + enable-keys. + call x"af" using flag user-key-control. + + accept-function-key. + display spaces upon crt + display "Press a function key: F1 to F10" at 0505 + accept any-data at 0540. + + tell-which-key-was-pressed. + evaluate key-type + when 0 display "You pressed " at 0705 + when 1 + move key-code-1 to key-code-1-display + display "You pressed function key" at 0705 + display key-code-1-display at 0730 + end-evaluate. + + stop-run. + stop run. diff --git a/Microsoft COBOL v45/DEMO/LOGOPER.CBL b/Microsoft COBOL v45/DEMO/LOGOPER.CBL new file mode 100644 index 0000000..e8fa54b --- /dev/null +++ b/Microsoft COBOL v45/DEMO/LOGOPER.CBL @@ -0,0 +1,208 @@ + $set ans85 noosvs mf + ******************************************************************* + * * + * (C) Micro Focus Ltd. 1990 * + * * + * LOGOPER.CBL * + * * + * This program gives an example of how to use the logical * + * call-by-name routines. It uses three, namely * + * * + * "CBL_OR" * + * "CBL_AND" * + * "CBL_XOR" * + * * + * The program also uses a selection of other call-by-name * + * routines, mainly for screen handling. * + * * + * The program puts a string of characters on the screen with * + * various attributes. These attributes are then manipulated * + * via the logical call-by-name routines - according to which * + * key has been pressed on the keyboard. * + * * + * The program tends to use values in Hex, where their * + * significance is bitwise. * + * * + * The layout of a screen attribute byte is given below to * + * illustrate the effect that the logical call-by-names are * + * having. * + * * + * Attribute Byte * + * -------------- * + * Bit 7 6 5 4 3 2 1 0 * + * BL BR BG BB FI FR FG FB * + * * + * where: * + * BL - make the foreground blink * + * BR, BG, BB - The RGB colour value for the background * + * FI - make the foreground colour high intensity * + * FR, FG, FB - The RGB colour value for the foreground * + * * + * The RGB table is: * + * R G B Colour High Intensity Colour * + * 0 0 0 Black Grey * + * 0 0 1 Blue Light Blue * + * 0 1 0 Green Light Green * + * 0 1 1 Cyan Light Cyan * + * 1 0 0 Red Light Red * + * 1 0 1 Magenta Light Magenta * + * 1 1 0 Brown Yellow * + * 1 1 1 White Bright White * + * * + ******************************************************************* + working-storage section. + 01 clr-char pic x value space. + 01 clr-attr pic x value x"0f". + + 78 text-start value 29. + 78 text-len value 23. + 78 text-end value 51. + + 01 text-scr-pos. + 03 text-row pic 9(2) comp-x value 12. + 03 text-col pic 9(2) comp-x value text-start. + 01 text-char-buffer pic x(text-len) + value "Text-in-various-colours". + 01 text-attr-buffer. + 03 first-word pic x(4) value all x"0f". + 03 second-word pic x(4) value all x"2c". + 03 third-word pic x(7) value all x"14". + 03 third-space pic x value x"30". + 03 fourth-word pic x(7) value all x"59". + 01 text-length pic 9(4) comp-x value text-len. + + 01 char-read pic x. + 01 char-length pic 9(9) comp-5 value 1. + + 01 quit-flag pic 9 comp-x. + 88 not-ready-to-quit value 0. + 88 ready-to-quit value 1. + + 01 csr-pos. + 03 csr-row pic 9(2) comp-x value 12. + 03 csr-col pic 9(2) comp-x value 39. + 01 csr-attr pic x. + 01 csr-length pic 9(4) comp-x value 1. + + 01 blink-mask pic x value x"80". + 01 steady-mask pic x value x"7f". + + 01 invert-mask pic x(text-len) value all x"7f". + + 78 instr-len value 41. + 01 instr-length pic 9(4) comp-x value instr-len. + 01 instr pic x(instr-len) + value "Press (L)eft, (R)ight, (I)nvert or (Q)uit". + 01 instr-pos. + 03 instr-row pic 9(2) comp-x value 8. + 03 instr-col pic 9(2) comp-x value 19. + + procedure division. + + main section. + perform init-screen + set not-ready-to-quit to true + perform until ready-to-quit + perform read-keyboard + evaluate char-read + when "L" + perform csr-move-left + when "R" + perform csr-move-right + when "I" + perform invert-text + when "Q" + set ready-to-quit to true + end-evaluate + end-perform + stop run + . + + init-screen section. + call "cbl_clear_scr" using clr-char + clr-attr + call "cbl_write_scr_chars" using instr-pos + instr + instr-length + call "cbl_write_scr_chars" using text-scr-pos + text-char-buffer + text-length + perform put-attrs-on-screen + perform blink-cursor + . + + read-keyboard section. + call "cbl_read_kbd_char" using char-read + call "cbl_toupper" using char-read + by value char-length + . + + + csr-move-left section. + perform steady-cursor + subtract 1 from csr-col + if csr-col < text-start + move text-end to csr-col + end-if + perform blink-cursor + . + + csr-move-right section. + perform steady-cursor + add 1 to csr-col + if csr-col > text-end + move text-start to csr-col + end-if + perform blink-cursor + . + + + blink-cursor section. + * + * Turn on the blink bit at the current attribute. + * + call "cbl_read_scr_attrs" using csr-pos + csr-attr + csr-length + call "cbl_or" using blink-mask + csr-attr + by value 1 + call "cbl_write_scr_attrs" using csr-pos + csr-attr + csr-length + . + + steady-cursor section. + * + * Turn off the blink bit at the current attribute. + * + call "cbl_read_scr_attrs" using csr-pos + csr-attr + csr-length + call "cbl_and" using steady-mask + csr-attr + by value 1 + call "cbl_write_scr_attrs" using csr-pos + csr-attr + csr-length + . + + invert-text section. + * + * invert the bits that set the foreground colour, the background + * colour, and the intensity bits, but leave the blink bit alone. + * + call "cbl_read_scr_attrs" using text-scr-pos + text-attr-buffer + text-length + call "cbl_xor" using invert-mask + text-attr-buffer + by value text-len + perform put-attrs-on-screen + . + + put-attrs-on-screen section. + call "cbl_write_scr_attrs" using text-scr-pos + text-attr-buffer + text-length + . diff --git a/Microsoft COBOL v45/DEMO/MUDEMO/MUDEMO.CBL b/Microsoft COBOL v45/DEMO/MUDEMO/MUDEMO.CBL new file mode 100644 index 0000000..be734c1 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/MUDEMO/MUDEMO.CBL @@ -0,0 +1,143 @@ + $set ans85 noosvs mf + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * MUDEMO.CBL * + * * + * MULTI-USER * + * ========== * + * DEMONSTRATION PROGRAM * + * ===================== * + * * + * This program demonstrates the file and record locking * + * facilities of this COBOL system. This is the * + * main program in a suite of programs that demonstrate * + * how to use this COBOL in a multi-user environment. * + * * + ************************************************************ + + configuration section. + special-names. + console is crt. + + data division. + + working-storage section. + 01 mudemo01-00 . + 03 filler pic x(0407). + 03 mudemo01-00-0608 pic x(0060) value "This is a demonstratio + - "n program for use with COBOL. ". + 03 FILLER PIC X(0100). + 03 MUDEMO01-00-0808 PIC X(0058) VALUE "This program demonstra + - "tes how multi-user COBOL can ". + 03 filler pic x(0102). + 03 mudemo01-00-1008 pic x(0028) value "lock both records and + - "files.". + 03 FILLER PIC X(0212). + 03 MUDEMO01-00-1308 PIC X(0062) VALUE "the program allows an + - "indexed file to be opened in a number of". + 03 filler pic x(0098). + 03 mudemo01-00-1508 pic x(0046) value "modes, which demonstra + - "te the locking facility.". + 03 FILLER PIC X(0114). + 03 MUDEMO01-00-1708 PIC X(0063) VALUE "for more information o + - "n locking refer to the Operating Guide. ". + 03 filler pic x(0097). + 03 mudemo01-00-1908 pic x(0007) value " ". + 03 filler pic x(0146). + 03 mudemo01-00-2101 pic x(0080) value "---------------------- + - "----------------------------------------------------------". + + 01 options. + 03 filler pic x(02). + 03 option-1 pic x(07) + value "1.Input". + 03 filler pic x(02). + 03 option-2 pic x(25) + value "2.I-O Lock Mode Automatic". + 03 filler pic x(02). + 03 option-3 pic x(22) + value "3.I-O Lock Mode Manual". + 03 filler pic x(02). + 03 option-4 pic x(08) + value "4.Output". + 03 filler pic x(02). + 03 option-5 pic x(06) + value "5.Exit". + + + 01 date-to-day. + 03 days pic 99. + 03 filler pic x. + 03 month pic 99. + 03 filler pic x. + 03 year pic 99. + + 01 up-to-date-time. + 03 hours pic 99. + 03 filler pic x. + 03 mins pic 99. + + 01 temp-date. + 03 temp-year pic xx. + 03 temp-month pic xx. + 03 temp-day pic xx. + 01 temp-time. + 03 temp-hours pic 99. + 03 temp-mins pic 99. + 03 temp-rest pic 9999. + + 01 choice pic 9 value 0. + + ********************************************************** + * Main Program * + ********************************************************** + + procedure division. + ent-ry. + display space + display mudemo01-00 + perform display-date + perform display-time + display options at 2201 + display "INPUT CHOICE [ ]" at 2431 upon crt-under. + + re-enter-choice. + accept choice at 2445. + evaluate choice + when 1 call "STOCKIN" + cancel "STOCKIN" + when 2 call "STOCKIOA" + cancel "STOCKIOA" + when 3 call "STOCKIOM" + cancel "STOCKIOM" + when 4 call "STOCKOUT" + cancel "STOCKOUT" + when 5 go to endit + when other go to re-enter-choice + end-evaluate. + go to ent-ry. + + endit. + stop run. + + + *********************************************************** + * Date and Time Routines * + *********************************************************** + + display-date. + accept temp-date from date. + move temp-day to days. + move temp-month to month. + move temp-year to year. + display "Date / /" at 0164. + display date-to-day at 0169. + + display-time. + accept temp-time from time. + move temp-hours to hours. + move temp-mins to mins. + display "Time :" at 0264. + display up-to-date-time at 0269. diff --git a/Microsoft COBOL v45/DEMO/MUDEMO/STOCKIN.CBL b/Microsoft COBOL v45/DEMO/MUDEMO/STOCKIN.CBL new file mode 100644 index 0000000..e84bfaf --- /dev/null +++ b/Microsoft COBOL v45/DEMO/MUDEMO/STOCKIN.CBL @@ -0,0 +1,392 @@ + $set ans85 mf noosvs + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * STOCKIN.CBL * + * * + * MULTI-USER * + * ========== * + * DEMONSTRATION PROGRAM * + * ===================== * + * * + * This program demonstrates the file and record locking * + * facilities of this MULTI-USER. This * + * subprogram, which is called by MUDEMO, acquires no * + * locks because it OPENs for INPUT only. * + * * + ************************************************************ + special-names. + console is crt. + input-output section. + file-control. + select stock-file assign "MUSTOCK.DAT" + organization indexed + access dynamic + record key stock-key + status file-status + lock mode automatic. + / + data division. + + *********************************************************** + * File Definition * + *********************************************************** + + file section. + fd stock-file. + 01 stock-record. + 03 stock-key pic 9(06). + 03 stock-data. + 05 stock-description-1 pic x(53). + 05 stock-description-2 pic x(53). + 05 stock-description-3 pic x(53). + 05 stock-held pic 9(06). + 05 stock-cost pic 9(06)v99. + / + working-storage section. + 01 stock-00 . + 03 stock-00-0101 pic x(0080) value "---------------------- + - "----------------------------------------------------------". + 03 stock-00-0201 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-0280 pic x(0001) value "|". + 03 stock-00-0301 pic x(0001) value "|". + 03 filler pic x(0031). + 03 stock-00-0333 pic x(0011) value " Acme Inc. ". + 03 filler pic x(0020). + 03 stock-00-0364 pic x(0017) value "Date / / |". + 03 stock-00-0401 pic x(0001) value "|". + 03 filler pic x(0031). + 03 stock-00-0433 pic x(0011) value "===========". + 03 filler pic x(0020). + 03 stock-00-0464 pic x(0017) value "Time : |". + 03 stock-00-0501 pic x(0001) value "|". + 03 filler pic x(0027). + 03 stock-00-0529 pic x(0020) value "Stock Control System". + 03 filler pic x(0031). + 03 stock-00-0580 pic x(0001) value "|". + 03 stock-00-0601 pic x(0001) value "|". + 03 filler pic x(0027). + 03 stock-00-0629 pic x(0020) value "====================". + 03 filler pic x(0031). + 03 stock-00-0680 pic x(0001) value "|". + 03 stock-00-0701 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-0780 pic x(0001) value "|". + 03 stock-00-0801 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-0880 pic x(0001) value "|". + 03 stock-00-0901 pic x(0025) value "| Stock Code [ + - " ]". + 03 filler pic x(0054). + 03 stock-00-0980 pic x(0001) value "|". + 03 stock-00-1001 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1080 pic x(0001) value "|". + 03 stock-00-1101 pic x(0022) value "| Stock Description [ + - "". + 03 FILLER PIC X(0053). + 03 STOCK-00-1176 PIC X(0005) VALUE "] |". + 03 stock-00-1201 pic x(0001) value "|". + 03 filler pic x(0020). + 03 stock-00-1222 pic x(0001) value "[". + 03 filler pic x(0053). + 03 stock-00-1276 pic x(0005) value "] |". + 03 stock-00-1301 pic x(0001) value "|". + 03 filler pic x(0020). + 03 stock-00-1322 pic x(0001) value "[". + 03 filler pic x(0053). + 03 stock-00-1376 pic x(0005) value "] |". + 03 stock-00-1401 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1480 pic x(0001) value "|". + 03 stock-00-1501 pic x(0025) value "| Stock Held [ + - " ]". + 03 filler pic x(0054). + 03 stock-00-1580 pic x(0001) value "|". + 03 stock-00-1601 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1680 pic x(0001) value "|". + 03 stock-00-1701 pic x(0028) value "| Cost per Unit [ + - " ]". + 03 filler pic x(0051). + 03 stock-00-1780 pic x(0001) value "|". + 03 stock-00-1801 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1880 pic x(0001) value "|". + 03 stock-00-1901 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1980 pic x(0001) value "|". + 03 stock-00-2101 pic x(0080) value "---------------------- + - "----------------------------------------------------------". + 03 stock-00-2201 pic x(0040) + value "-----Open Mode----Lock Mode--Last Operat". + 03 stock-00-2241 pic x(0040) + value "ion-----------Outcome------File Status--". + 03 filler pic x(1037). + + 01 stock-01 redefines stock-00 . + 03 filler pic x(0658). + 03 stock-01-code pic 9(0006). + 03 filler pic x(0158). + 03 stock-01-description-1 pic x(0053). + 03 filler pic x(0027). + 03 stock-01-description-2 pic x(0053). + 03 filler pic x(0027). + 03 stock-01-description-3 pic x(0053). + 03 filler pic x(0103). + 03 stock-01-held pic 9(0006). + 03 filler pic x(0154). + 03 stock-01-cost pic $$$$$9.99. + 03 filler pic x(0579). + 03 choice pic 9. + + *********************************************************** + * File Status Variables * + *********************************************************** + + 01 file-status. + 03 status-1 pic x. + 03 status-2 pic x. + + 01 binary-status redefines file-status pic 9(04) comp. + *********************************************************** + * Date and Time Variables * + *********************************************************** + + 01 date-to-day. + 03 days pic 99. + 03 filler pic x. + 03 month pic 99. + 03 filler pic x. + 03 year pic 99. + + 01 up-to-date-time. + 03 hours pic 99. + 03 filler pic x. + 03 mins pic 99. + + 01 temp-date. + 03 temp-year pic xx. + 03 temp-month pic xx. + 03 temp-day pic xx. + 01 temp-time. + 03 temp-hours pic 99. + 03 temp-mins pic 99. + 03 temp-rest pic 9999. + + *********************************************************** + * Information Line Declaration * + *********************************************************** + + 01 status-line. + 03 filler pic x(02). + 03 open-mode pic x(14). + 03 filler pic x(02). + 03 lock-mode pic x(09) + value "---------". + 03 filler pic x(03). + 03 last-operation pic x(11). + 03 filler pic x(03). + 03 was-it-successful pic x(20). + 03 filler pic x(08). + 03 error-code. + 05 stat-1 pic x. + 05 filler pic x. + 05 stat-2 pic 9(03). + + 01 hyphen-line pic x(80) + value all "-". + + 01 yesno pic x. + + 01 inpopt. + 03 filler pic x(10). + 03 inpopt-00 pic x(0056) value "1. Read on Key 2. Re + - "ad next 3. start not < 4. exit". + + *********************************************************** + * Program for input only * + *********************************************************** + + procedure division. + main. + initialize choice + stock-01. + display space. + display stock-00. + display inpopt at 2301. + display "Input Choice [ ]" at 2433 upon crt-under. + open input stock-file. + move "----Open Input" to open-mode. + move "-Open Input" to last-operation. + perform status-check. + if was-it-successful not = "----------Successful" + move "----Closed----" to open-mode + display hyphen-line at 2201 upon crt-under + display status-line at 2201 upon crt-under + go to endit. + + *********************************************************** + * Main Loop * + *********************************************************** + + ent-ry. + perform display-date. + perform display-time. + display hyphen-line at 2201 upon crt-under + display status-line at 2201 upon crt-under + accept stock-01. + evaluate choice + when 1 perform read-on-key + when 2 perform read-next + when 3 perform start-not-less-than + when 4 go to wrap-up + end-evaluate. + go to ent-ry. + + *********************************************************** + * Closing-Down Paragraphs * + *********************************************************** + + wrap-up. + close stock-file. + move "----Closed----" to open-mode. + move "------Closed" to last-operation. + perform status-check. + display hyphen-line at 2201 upon crt-under. + display status-line at 2201 upon crt-under. + + endit. + display "Do you wish to restart (Y/N) [ ]" + at 2424 upon crt-under. + accept yesno at 2454. + if yesno = "Y" or "y" + go to main + else if yesno = "N" or "n" + exit program + else + go to endit + end-if. + + + *********************************************************** + * File-Handling Paragraphs * + *********************************************************** + + read-on-key. + move "Read on key" to last-operation. + perform move-key-from-screen-to-rec. + read stock-file. + perform status-check. + perform move-from-rec-to-screen. + display stock-01. + + read-next. + move "--Read Next" to last-operation. + read stock-file next. + perform status-check. + perform move-from-rec-to-screen. + display stock-01. + + start-not-less-than. + move "Start not <" to last-operation. + perform move-key-from-screen-to-rec. + start stock-file key not less than stock-key. + perform status-check. + + *********************************************************** + * File Status Checking Routines. * + *********************************************************** + + status-check. + move status-1 to stat-1 + move status-2 to stat-2 + evaluate status-1 + when "0" + move "----------Successful" to was-it-successful + when "1" + move "---------End of file" to was-it-successful + when "2" + move "---------Invalid Key" to was-it-successful + when "9" + perform look-up-error thru error-end + end-evaluate. + + *********************************************************** + * Look Up Error Number * + *********************************************************** + + look-up-error. + move low-values to status-1. + move binary-status to stat-2. + evaluate stat-2 + when 002 + move "-------File not open" to was-it-successful + when 007 + move "Disk space exhausted" to was-it-successful + when 013 + move "------File not found" to was-it-successful + when 024 + move "----------Disk error" to was-it-successful + when 041 + move "---Corrupt ISAM file" to was-it-successful + when 065 + move "---------File locked" to was-it-successful + when 068 + move "-------Record locked" to was-it-successful + when 139 + move "Record inconsistency" to was-it-successful + when 146 + move "---No current record" to was-it-successful + when 180 + move "------File malformed" to was-it-successful + when 208 + move "-------Network error" to was-it-successful + when 213 + move "------Too many locks" to was-it-successful + end-evaluate. + error-end. + exit. + + + *********************************************************** + * Subroutines for moving Data to and from the Screen * + *********************************************************** + + move-key-from-screen-to-rec. + move stock-01-code to stock-key. + + move-from-screen-to-rec. + move stock-01-code to stock-key. + move stock-01-description-1 to stock-description-1. + move stock-01-description-2 to stock-description-2. + move stock-01-description-3 to stock-description-3. + move stock-01-held to stock-held. + move stock-01-cost to stock-cost. + + move-from-rec-to-screen. + move stock-key to stock-01-code. + move stock-description-1 to stock-01-description-1. + move stock-description-2 to stock-01-description-2. + move stock-description-3 to stock-01-description-3. + move stock-held to stock-01-held. + move stock-cost to stock-01-cost. + + *********************************************************** + * Date and Time Routines. * + *********************************************************** + + display-date. + accept temp-date from date. + move temp-day to days. + move temp-month to month. + move temp-year to year. + display date-to-day at 0369. + + display-time. + accept temp-time from time. + move temp-hours to hours. + move temp-mins to mins. + display up-to-date-time at 0469. diff --git a/Microsoft COBOL v45/DEMO/MUDEMO/STOCKIOA.CBL b/Microsoft COBOL v45/DEMO/MUDEMO/STOCKIOA.CBL new file mode 100644 index 0000000..ff5060d --- /dev/null +++ b/Microsoft COBOL v45/DEMO/MUDEMO/STOCKIOA.CBL @@ -0,0 +1,416 @@ + $set ans85 noosvs mf + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * STOCKIOA.CBL * + * * + * MULTI-USER * + * ========== * + * DEMONSTRATION PROGRAM * + * ===================== * + * * + * This program demonstrates the file and record locking * + * facilities of this MULTI-USER COBOL. This * + * subprogram, which is called by MUDEMO, locks single * + * records automatically. This is the default locking in * + * this COBOL multi-user environment. * + * * + ************************************************************ + + configuration section. + special-names. + console is crt. + input-output section. + file-control. + select stock-file assign "MUSTOCK.DAT" + organization indexed + access dynamic + record key stock-key + status file-status + lock mode automatic. + / + data division. + + *********************************************************** + * File Definition * + *********************************************************** + + file section. + fd stock-file. + 01 stock-record. + 03 stock-key pic 9(06). + 03 stock-data. + 05 stock-description-1 pic x(53). + 05 stock-description-2 pic x(53). + 05 stock-description-3 pic x(53). + 05 stock-held pic 9(06). + 05 stock-cost pic 9(06)v99. + / + working-storage section. + 01 stock-00 . + 03 stock-00-0101 pic x(0080) value "---------------------- + - "----------------------------------------------------------". + 03 stock-00-0201 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-0280 pic x(0001) value "|". + 03 stock-00-0301 pic x(0001) value "|". + 03 filler pic x(0031). + 03 stock-00-0333 pic x(0011) value " Acme Inc. ". + 03 filler pic x(0020). + 03 stock-00-0364 pic x(0017) value "Date / / |". + 03 stock-00-0401 pic x(0001) value "|". + 03 filler pic x(0031). + 03 stock-00-0433 pic x(0011) value "===========". + 03 filler pic x(0020). + 03 stock-00-0464 pic x(0017) value "Time : |". + 03 stock-00-0501 pic x(0001) value "|". + 03 filler pic x(0027). + 03 stock-00-0529 pic x(0020) value "Stock Control System". + 03 filler pic x(0031). + 03 stock-00-0580 pic x(0001) value "|". + 03 stock-00-0601 pic x(0001) value "|". + 03 filler pic x(0027). + 03 stock-00-0629 pic x(0020) value "====================". + 03 filler pic x(0031). + 03 stock-00-0680 pic x(0001) value "|". + 03 stock-00-0701 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-0780 pic x(0001) value "|". + 03 stock-00-0801 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-0880 pic x(0001) value "|". + 03 stock-00-0901 pic x(0025) value "| Stock Code [ + - " ]". + 03 filler pic x(0054). + 03 stock-00-0980 pic x(0001) value "|". + 03 stock-00-1001 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1080 pic x(0001) value "|". + 03 stock-00-1101 pic x(0022) value "| Stock Description [ + - "". + 03 FILLER PIC X(0053). + 03 STOCK-00-1176 PIC X(0005) VALUE "] |". + 03 stock-00-1201 pic x(0001) value "|". + 03 filler pic x(0020). + 03 stock-00-1222 pic x(0001) value "[". + 03 filler pic x(0053). + 03 stock-00-1276 pic x(0005) value "] |". + 03 stock-00-1301 pic x(0001) value "|". + 03 filler pic x(0020). + 03 stock-00-1322 pic x(0001) value "[". + 03 filler pic x(0053). + 03 stock-00-1376 pic x(0005) value "] |". + 03 stock-00-1401 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1480 pic x(0001) value "|". + 03 stock-00-1501 pic x(0025) value "| Stock Held [ + - " ]". + 03 filler pic x(0054). + 03 stock-00-1580 pic x(0001) value "|". + 03 stock-00-1601 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1680 pic x(0001) value "|". + 03 stock-00-1701 pic x(0028) value "| Cost per Unit [ + - " ]". + 03 filler pic x(0051). + 03 stock-00-1780 pic x(0001) value "|". + 03 stock-00-1801 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1880 pic x(0001) value "|". + 03 stock-00-1901 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1980 pic x(0001) value "|". + 03 stock-00-2101 pic x(0080) value "---------------------- + - "----------------------------------------------------------". + 03 stock-00-2201 pic x(0040) + value "-----Open Mode----Lock Mode--Last Operat". + 03 stock-00-2241 pic x(0040) + value "ion-----------Outcome------File Status--". + 03 filler pic x(1037). + + 01 stock-01 redefines stock-00 . + 03 filler pic x(0658). + 03 stock-01-code pic 9(0006). + 03 filler pic x(0158). + 03 stock-01-description-1 pic x(0053). + 03 filler pic x(0027). + 03 stock-01-description-2 pic x(0053). + 03 filler pic x(0027). + 03 stock-01-description-3 pic x(0053). + 03 filler pic x(0103). + 03 stock-01-held pic 9(0006). + 03 filler pic x(0154). + 03 stock-01-cost pic $$$$$9.99. + 03 filler pic x(0579). + 03 choice pic 9. + + *********************************************************** + * File Status Variables * + *********************************************************** + + 01 file-status. + 03 status-1 pic x. + 03 status-2 pic x. + + 01 binary-status redefines file-status pic 9(04) comp. + + *********************************************************** + * Date and Time Variables * + *********************************************************** + + 01 date-to-day. + 03 days pic 99. + 03 filler pic x. + 03 month pic 99. + 03 filler pic x. + 03 year pic 99. + + 01 up-to-date-time. + 03 hours pic 99. + 03 filler pic x. + 03 mins pic 99. + + 01 temp-date. + 03 temp-year pic xx. + 03 temp-month pic xx. + 03 temp-day pic xx. + 01 temp-time. + 03 temp-hours pic 99. + 03 temp-mins pic 99. + 03 temp-rest pic 9999. + + *********************************************************** + * Information Line * + *********************************************************** + + 01 status-line. + 03 filler pic x(02). + 03 open-mode pic x(14). + 03 filler pic x(02). + 03 lock-mode pic x(09) + value "Automatic". + 03 filler pic x(03). + 03 last-operation pic x(11). + 03 filler pic x(03). + 03 was-it-successful pic x(20). + 03 filler pic x(08). + 03 error-code. + 05 stat-1 pic x. + 05 filler pic x. + 05 stat-2 pic 9(03). + + 01 hyphen-line pic x(80) + value all "-". + + 01 yesno pic x. + + 01 inpopt. + 03 inpopt-00 pic x(0040) + value "1.Read on Key 2.Read next 3.Start not ". + 03 inpopt-01 pic x(0040) + value "< 4.Write 5.Rewrite 6.Delete 7.Exit". + + ********************************************************** + * Program for locking single records automatically * + ********************************************************** + + procedure division. + main. + initialize choice + stock-01. + display space. + display stock-00. + display inpopt at 2301. + display "Input Choice [ ]" at 2433 upon crt-under. + open i-o stock-file. + move "---Open I-O---" to open-mode. + move "-Open I-O--" to last-operation. + perform status-check. + if was-it-successful not = "----------Successful" + move "----Closed----" to open-mode + display hyphen-line at 2201 upon crt-under + display status-line at 2201 upon crt-under + go to endit. + + *********************************************************** + * MAIN LOOP * + *********************************************************** + + ent-ry. + accept temp-date from date. + perform display-date. + accept temp-time from time. + perform display-time. + display hyphen-line at 2201 upon crt-under + display status-line at 2201 upon crt-under + accept stock-01. + evaluate choice + when 1 perform read-on-key + when 2 perform read-next + when 3 perform start-not-less-than + when 4 perform write-record + when 5 perform rewrite-record + when 6 perform delete-record + when 7 go to wrap-up + end-evaluate. + go to ent-ry. + + *********************************************************** + * Close down paragraphs * + *********************************************************** + + wrap-up. + close stock-file. + move "----Closed----" to open-mode. + move "------Closed" to last-operation. + perform status-check. + display hyphen-line at 2201 upon crt-under. + display status-line at 2201 upon crt-under. + + endit. + display "Do you wish to restart (Y/N) [ ]" + at 2424 upon crt-under. + accept yesno at 2454. + evaluate yesno + when "Y" go to main + when "y" go to main + when "N" exit program + when "n" exit program + when other go to endit + end-evaluate. + + *********************************************************** + * File Handling Routines * + *********************************************************** + + read-on-key. + move "Read on key" to last-operation. + perform move-key-from-screen-to-rec. + read stock-file. + perform status-check. + perform move-from-rec-to-screen. + display stock-01. + + read-next. + move "--Read Next" to last-operation. + read stock-file next. + perform status-check. + perform move-from-rec-to-screen. + display stock-01. + + start-not-less-than. + move "Start not <" to last-operation. + perform move-key-from-screen-to-rec. + start stock-file key not less than stock-key. + perform status-check. + + write-record. + move "---Write---" to last-operation. + perform move-from-screen-to-rec. + write stock-record. + perform status-check. + + rewrite-record. + move "--Rewrite--" to last-operation. + perform move-from-screen-to-rec. + rewrite stock-record. + perform status-check. + + delete-record. + move "--Delete---" to last-operation. + perform move-key-from-screen-to-rec. + delete stock-file. + perform status-check. + + *********************************************************** + * File Status Checking Routines. * + *********************************************************** + + status-check. + move status-1 to stat-1 + move status-2 to stat-2 + evaluate status-1 + when "0" + move "----------Successful" to was-it-successful + when "1" + move "---------End of file" to was-it-successful + when "2" + move "---------Invalid Key" to was-it-successful + when "9" + perform look-up-error thru error-end + end-evaluate. + *********************************************************** + * Look up error number * + *********************************************************** + + look-up-error. + move low-values to status-1. + move binary-status to stat-2. + evaluate stat-2 + when 002 + move "-------File not open" to was-it-successful + when 007 + move "Disk space exhausted" to was-it-successful + when 013 + move "------File not found" to was-it-successful + when 024 + move "----------Disk error" to was-it-successful + when 041 + move "---Corrupt ISAM file" to was-it-successful + when 065 + move "---------File locked" to was-it-successful + when 068 + move "-------Record locked" to was-it-successful + when 139 + move "Record inconsistency" to was-it-successful + when 146 + move "---No current record" to was-it-successful + when 180 + move "------File malformed" to was-it-successful + when 208 + move "-------Network error" to was-it-successful + when 213 + move "------Too many locks" to was-it-successful + end-evaluate. + error-end. + exit. + + + *********************************************************** + * Move data to and from the screen * + *********************************************************** + + move-key-from-screen-to-rec. + move stock-01-code to stock-key. + + move-from-screen-to-rec. + move stock-01-code to stock-key. + move stock-01-description-1 to stock-description-1. + move stock-01-description-2 to stock-description-2. + move stock-01-description-3 to stock-description-3. + move stock-01-held to stock-held. + move stock-01-cost to stock-cost. + + move-from-rec-to-screen. + move stock-key to stock-01-code. + move stock-description-1 to stock-01-description-1. + move stock-description-2 to stock-01-description-2. + move stock-description-3 to stock-01-description-3. + move stock-held to stock-01-held. + move stock-cost to stock-01-cost. + + *********************************************************** + * Date and Time Routines * + *********************************************************** + + display-date. + move temp-day to days. + move temp-month to month. + move temp-year to year. + display date-to-day at 0369. + + display-time. + move temp-hours to hours. + move temp-mins to mins. + display up-to-date-time at 0469. diff --git a/Microsoft COBOL v45/DEMO/MUDEMO/STOCKIOM.CBL b/Microsoft COBOL v45/DEMO/MUDEMO/STOCKIOM.CBL new file mode 100644 index 0000000..3ac1ff1 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/MUDEMO/STOCKIOM.CBL @@ -0,0 +1,440 @@ + $set ans85 noosvs mf + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * STOCKIOM.CBL * + * * + * MULTI-USER * + * ========== * + * DEMONSTRATION PROGRAM * + * ===================== * + * * + * This program demonstrates the file and record locking * + * facilities of this MULTI-USER COBOL. This * + * subprogram, which is called by MUDEMO, locks * + * multiple records. The records must be locked manually. * + * * + ************************************************************ + + special-names. + console is crt. + input-output section. + file-control. + select stock-file assign "MUSTOCK.DAT" + organization indexed + access dynamic + record key stock-key + + *********************************************************** + * Extra syntax for locking * + *********************************************************** + + lock mode manual + with lock on multiple records + status file-status. + / + data division. + + *********************************************************** + * File Definition * + *********************************************************** + + file section. + fd stock-file. + 01 stock-record. + 03 stock-key pic 9(06). + 03 stock-data. + 05 stock-description-1 pic x(53). + 05 stock-description-2 pic x(53). + 05 stock-description-3 pic x(53). + 05 stock-held pic 9(06). + 05 stock-cost pic 9(06)v99. + / + working-storage section. + 01 stock-00 . + 03 stock-00-0101 pic x(0080) value "---------------------- + - "----------------------------------------------------------". + 03 stock-00-0201 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-0280 pic x(0001) value "|". + 03 stock-00-0301 pic x(0001) value "|". + 03 filler pic x(0031). + 03 stock-00-0333 pic x(0011) value " Acme Inc. ". + 03 filler pic x(0020). + 03 stock-00-0364 pic x(0017) value "Date / / |". + 03 stock-00-0401 pic x(0001) value "|". + 03 filler pic x(0031). + 03 stock-00-0433 pic x(0011) value "===========". + 03 filler pic x(0020). + 03 stock-00-0464 pic x(0017) value "Time : |". + 03 stock-00-0501 pic x(0001) value "|". + 03 filler pic x(0027). + 03 stock-00-0529 pic x(0020) value "Stock Control System". + 03 filler pic x(0031). + 03 stock-00-0580 pic x(0001) value "|". + 03 stock-00-0601 pic x(0001) value "|". + 03 filler pic x(0027). + 03 stock-00-0629 pic x(0020) value "====================". + 03 filler pic x(0031). + 03 stock-00-0680 pic x(0001) value "|". + 03 stock-00-0701 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-0780 pic x(0001) value "|". + 03 stock-00-0801 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-0880 pic x(0001) value "|". + 03 stock-00-0901 pic x(0025) value "| Stock Code [ + - " ]". + 03 filler pic x(0054). + 03 stock-00-0980 pic x(0001) value "|". + 03 stock-00-1001 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1080 pic x(0001) value "|". + 03 stock-00-1101 pic x(0022) value "| Stock Description [ + - "". + 03 FILLER PIC X(0053). + 03 STOCK-00-1176 PIC X(0005) VALUE "] |". + 03 stock-00-1201 pic x(0001) value "|". + 03 filler pic x(0020). + 03 stock-00-1222 pic x(0001) value "[". + 03 filler pic x(0053). + 03 stock-00-1276 pic x(0005) value "] |". + 03 stock-00-1301 pic x(0001) value "|". + 03 filler pic x(0020). + 03 stock-00-1322 pic x(0001) value "[". + 03 filler pic x(0053). + 03 stock-00-1376 pic x(0005) value "] |". + 03 stock-00-1401 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1480 pic x(0001) value "|". + 03 stock-00-1501 pic x(0025) value "| Stock Held [ + - " ]". + 03 filler pic x(0054). + 03 stock-00-1580 pic x(0001) value "|". + 03 stock-00-1601 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1680 pic x(0001) value "|". + 03 stock-00-1701 pic x(0028) value "| Cost per Unit [ + - " ]". + 03 filler pic x(0051). + 03 stock-00-1780 pic x(0001) value "|". + 03 stock-00-1801 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1880 pic x(0001) value "|". + 03 stock-00-2101 pic x(0080) value "---------------------- + - "----------------------------------------------------------". + 03 stock-00-2201 pic x(0040) + value "-----Open Mode----Lock Mode--Last Operat". + 03 stock-00-2241 pic x(0040) + value "ion-----------Outcome------File Status--". + 03 filler pic x(1117). + + 01 stock-01 redefines stock-00 . + 03 filler pic x(0658). + 03 stock-01-code pic 9(0006). + 03 filler pic x(0158). + 03 stock-01-description-1 pic x(0053). + 03 filler pic x(0027). + 03 stock-01-description-2 pic x(0053). + 03 filler pic x(0027). + 03 stock-01-description-3 pic x(0053). + 03 filler pic x(0103). + 03 stock-01-held pic 9(0006). + 03 filler pic x(0154). + 03 stock-01-cost pic $$$$$9.99. + 03 filler pic x(0579). + 03 choice pic 9. + + *********************************************************** + * File Status Variables * + *********************************************************** + + 01 file-status. + 03 status-1 pic x. + 03 status-2 pic x. + + 01 binary-status redefines file-status pic 9(04) comp. + + *********************************************************** + * Date and Time Variables * + *********************************************************** + + 01 date-to-day. + 03 days pic 99. + 03 filler pic x. + 03 month pic 99. + 03 filler pic x. + 03 year pic 99. + + 01 up-to-date-time. + 03 hours pic 99. + 03 filler pic x. + 03 mins pic 99. + + 01 temp-date. + 03 temp-year pic xx. + 03 temp-month pic xx. + 03 temp-day pic xx. + 01 temp-time. + 03 temp-hours pic 99. + 03 temp-mins pic 99. + 03 temp-rest pic 9999. + + + *********************************************************** + * Information Line * + *********************************************************** + + 01 status-line. + 03 filler pic x(02). + 03 open-mode pic x(14). + 03 filler pic x(02). + 03 lock-mode pic x(09) + value "-Manual--". + 03 filler pic x(03). + 03 last-operation pic x(11). + 03 filler pic x(03). + 03 was-it-successful pic x(20). + 03 filler pic x(08). + 03 error-code. + 05 stat-1 pic x. + 05 filler pic x. + 05 stat-2 pic 9(03). + + 01 hyphen-line pic x(80) + value all "-". + + 01 yesno pic x. + + 01 inpopt. + 03 inpopt-00 pic x(0040) + value "1.Read on Key 2.Read next 3.Read on ke". + 03 inpopt-01 pic x(0040) + value "y with kept lock 4.Read next kept lock ". + 03 inpopt-02 pic x(0040) + value " 5.Start not < 6.Write 7.Rewr". + 03 inpopt-03 pic x(0040) + value "ite 8.Delete 9.Unlock 0.Exit". + + ********************************************************** + * Program for locking multiple records manually * + ********************************************************** + + procedure division. + main. + initialize choice + stock-01. + display space. + display stock-00. + display inpopt at 2201. + display "Input Choice [ ]" at 2433 upon crt-under. + open i-o stock-file. + move "---Open I-O---" to open-mode. + move "-Open I-O--" to last-operation. + perform status-check. + if was-it-successful not = "----------Successful" + move "----Closed----" to open-mode + display hyphen-line at 2101 upon crt-under + display status-line at 2101 upon crt-under + go to endit. + + ent-ry. + accept temp-date from date. + perform display-date. + accept temp-time from time. + perform display-time. + display hyphen-line at 2101 upon crt-under + display status-line at 2101 upon crt-under + accept stock-01. + evaluate choice + when 0 go to wrap-up + when 1 perform read-on-key + when 2 perform read-next + when 3 perform read-with-kept-lock + when 4 perform read-next-with-kept-lock + when 5 perform start-not-less-than + when 6 perform write-record + when 7 perform rewrite-record + when 8 perform delete-record + when 9 perform unlock-file + when other go to ent-ry + end-evaluate. + go to ent-ry. + + wrap-up. + close stock-file. + move "----Closed----" to open-mode. + move "------Closed" to last-operation. + perform status-check. + display hyphen-line at 2101 upon crt-under. + display status-line at 2101 upon crt-under. + + endit. + display "Do you wish to restart (Y/N) [ ]" + at 2424 upon crt-under. + accept yesno at 2454. + evaluate yesno + when "Y" go to main + when "y" go to main + when "N" exit program + when "n" exit program + when other go to endit + end-evaluate. + + *********************************************************** + * File Handling Routines * + *********************************************************** + + read-on-key. + move "Read on key" to last-operation. + perform move-key-from-screen-to-rec. + read stock-file. + perform status-check. + perform move-from-rec-to-screen. + display stock-01. + + read-next. + move "--Read Next" to last-operation. + read stock-file next. + perform status-check. + perform move-from-rec-to-screen. + display stock-01. + + read-with-kept-lock. + move "Read k lock" to last-operation. + perform move-key-from-screen-to-rec. + read stock-file with kept lock. + perform status-check. + perform move-from-rec-to-screen. + display stock-01. + + read-next-with-kept-lock. + move "Rd next kl-" to last-operation. + read stock-file next with kept lock. + perform status-check. + perform move-from-rec-to-screen. + display stock-01. + + start-not-less-than. + move "Start not <" to last-operation. + perform move-key-from-screen-to-rec. + start stock-file key not less than stock-key. + perform status-check. + + write-record. + move "---Write---" to last-operation. + perform move-from-screen-to-rec. + write stock-record. + perform status-check. + + rewrite-record. + move "--Rewrite--" to last-operation. + perform move-from-screen-to-rec. + rewrite stock-record. + perform status-check. + + delete-record. + move "--Delete---" to last-operation. + perform move-key-from-screen-to-rec. + delete stock-file. + perform status-check. + + unlock-file. + move "00" to file-status. + move "--Unlock---" to last-operation. + unlock stock-file. + perform status-check. + + *********************************************************** + * File Status Checking Routines. * + *********************************************************** + + status-check. + move status-1 to stat-1 + move status-2 to stat-2 + evaluate status-1 + when "0" + move "----------Successful" to was-it-successful + when "1" + move "---------End of file" to was-it-successful + when "2" + move "---------Invalid Key" to was-it-successful + when "9" + perform look-up-error thru error-end + end-evaluate. + + *********************************************************** + * Look Up Error Number * + *********************************************************** + + look-up-error. + move low-values to status-1. + move binary-status to stat-2. + evaluate stat-2 + when 002 + move "-------File not open" to was-it-successful + when 007 + move "Disk space exhausted" to was-it-successful + when 013 + move "------File not found" to was-it-successful + when 024 + move "----------Disk error" to was-it-successful + when 041 + move "---Corrupt ISAM file" to was-it-successful + when 065 + move "---------File locked" to was-it-successful + when 068 + move "-------Record locked" to was-it-successful + when 139 + move "Record inconsistency" to was-it-successful + when 146 + move "---No current record" to was-it-successful + when 180 + move "------File malformed" to was-it-successful + when 208 + move "-------Network error" to was-it-successful + when 213 + move "------Too many locks" to was-it-successful + end-evaluate. + error-end. + exit. + + + *********************************************************** + * Move data to and from the screen * + *********************************************************** + + move-key-from-screen-to-rec. + move stock-01-code to stock-key. + + move-from-screen-to-rec. + move stock-01-code to stock-key. + move stock-01-description-1 to stock-description-1. + move stock-01-description-2 to stock-description-2. + move stock-01-description-3 to stock-description-3. + move stock-01-held to stock-held. + move stock-01-cost to stock-cost. + + move-from-rec-to-screen. + move stock-key to stock-01-code. + move stock-description-1 to stock-01-description-1. + move stock-description-2 to stock-01-description-2. + move stock-description-3 to stock-01-description-3. + move stock-held to stock-01-held. + move stock-cost to stock-01-cost. + + *********************************************************** + * Date and Time Routines * + *********************************************************** + + display-date. + move temp-day to days. + move temp-month to month. + move temp-year to year. + display date-to-day at 0369. + + display-time. + move temp-hours to hours. + move temp-mins to mins. + display up-to-date-time at 0469. diff --git a/Microsoft COBOL v45/DEMO/MUDEMO/STOCKOUT.CBL b/Microsoft COBOL v45/DEMO/MUDEMO/STOCKOUT.CBL new file mode 100644 index 0000000..18cb05e --- /dev/null +++ b/Microsoft COBOL v45/DEMO/MUDEMO/STOCKOUT.CBL @@ -0,0 +1,374 @@ + $set ans85 noosvs mf + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * STOCKOUT.CBL * + * * + * MULTI-USER * + * ========== * + * DEMONSTRATION PROGRAM * + * ===================== * + * * + * This program demonstrates the file and record locking * + * facilities of this MULTI-USER COBOL. This * + * subprogram, which is called from MUDEMO, locks the * + * whole data file MUSTOCK.DAT, because the access mode * + * is output only. * + * * + ************************************************************ + + special-names. + console is crt. + input-output section. + file-control. + select stock-file assign "MUSTOCK.DAT" + organization indexed + access dynamic + record key stock-key + status file-status + lock mode automatic. + / + data division. + + *********************************************************** + * FILE DEFINITION * + *********************************************************** + + file section. + fd stock-file. + 01 stock-record. + 03 stock-key pic 9(06). + 03 stock-data. + 05 stock-description-1 pic x(53). + 05 stock-description-2 pic x(53). + 05 stock-description-3 pic x(53). + 05 stock-held pic 9(06). + 05 stock-cost pic 9(06)v99. + / + working-storage section. + 01 stock-00 . + 03 stock-00-0101 pic x(0080) value "---------------------- + - "----------------------------------------------------------". + 03 stock-00-0201 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-0280 pic x(0001) value "|". + 03 stock-00-0301 pic x(0001) value "|". + 03 filler pic x(0031). + 03 stock-00-0333 pic x(0011) value " Acme Inc. ". + 03 filler pic x(0020). + 03 stock-00-0364 pic x(0017) value "Date / / |". + 03 stock-00-0401 pic x(0001) value "|". + 03 filler pic x(0031). + 03 stock-00-0433 pic x(0011) value "===========". + 03 filler pic x(0020). + 03 stock-00-0464 pic x(0017) value "Time : |". + 03 stock-00-0501 pic x(0001) value "|". + 03 filler pic x(0027). + 03 stock-00-0529 pic x(0020) value "Stock Control System". + 03 filler pic x(0031). + 03 stock-00-0580 pic x(0001) value "|". + 03 stock-00-0601 pic x(0001) value "|". + 03 filler pic x(0027). + 03 stock-00-0629 pic x(0020) value "====================". + 03 filler pic x(0031). + 03 stock-00-0680 pic x(0001) value "|". + 03 stock-00-0701 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-0780 pic x(0001) value "|". + 03 stock-00-0801 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-0880 pic x(0001) value "|". + 03 stock-00-0901 pic x(0025) value "| Stock Code [ + - " ]". + 03 filler pic x(0054). + 03 stock-00-0980 pic x(0001) value "|". + 03 stock-00-1001 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1080 pic x(0001) value "|". + 03 stock-00-1101 pic x(0022) value "| Stock Description [ + - "". + 03 FILLER PIC X(0053). + 03 STOCK-00-1176 PIC X(0005) VALUE "] |". + 03 stock-00-1201 pic x(0001) value "|". + 03 filler pic x(0020). + 03 stock-00-1222 pic x(0001) value "[". + 03 filler pic x(0053). + 03 stock-00-1276 pic x(0005) value "] |". + 03 stock-00-1301 pic x(0001) value "|". + 03 filler pic x(0020). + 03 stock-00-1322 pic x(0001) value "[". + 03 filler pic x(0053). + 03 stock-00-1376 pic x(0005) value "] |". + 03 stock-00-1401 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1480 pic x(0001) value "|". + 03 stock-00-1501 pic x(0025) value "| Stock Held [ + - " ]". + 03 filler pic x(0054). + 03 stock-00-1580 pic x(0001) value "|". + 03 stock-00-1601 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1680 pic x(0001) value "|". + 03 stock-00-1701 pic x(0028) value "| Cost per Unit [ + - " ]". + 03 filler pic x(0051). + 03 stock-00-1780 pic x(0001) value "|". + 03 stock-00-1801 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1880 pic x(0001) value "|". + 03 stock-00-1901 pic x(0001) value "|". + 03 filler pic x(0078). + 03 stock-00-1980 pic x(0001) value "|". + 03 stock-00-2101 pic x(0080) value "---------------------- + - "----------------------------------------------------------". + 03 stock-00-2201 pic x(0040) + value "-----Open Mode----Lock Mode--Last Operat". + 03 stock-00-2241 pic x(0040) + value "ion-----------Outcome------File Status--". + 03 filler pic x(1037). + + 01 stock-01 redefines stock-00 . + 03 filler pic x(0658). + 03 stock-01-code pic 9(0006). + 03 filler pic x(0158). + 03 stock-01-description-1 pic x(0053). + 03 filler pic x(0027). + 03 stock-01-description-2 pic x(0053). + 03 filler pic x(0027). + 03 stock-01-description-3 pic x(0053). + 03 filler pic x(0103). + 03 stock-01-held pic 9(0006). + 03 filler pic x(0154). + 03 stock-01-cost pic $$$$$9.99. + 03 filler pic x(0579). + 03 choice pic 9. + + *********************************************************** + * File Status Variables * + *********************************************************** + + 01 file-status. + 03 status-1 pic x. + 03 status-2 pic x. + + 01 binary-status redefines file-status pic 9(04) comp. + + *********************************************************** + * Date and Time Variables * + *********************************************************** + + 01 date-to-day. + 03 days pic 99. + 03 filler pic x. + 03 month pic 99. + 03 filler pic x. + 03 year pic 99. + + 01 up-to-date-time. + 03 hours pic 99. + 03 filler pic x. + 03 mins pic 99. + + 01 temp-date. + 03 temp-year pic xx. + 03 temp-month pic xx. + 03 temp-day pic xx. + 01 temp-time. + 03 temp-hours pic 99. + 03 temp-mins pic 99. + 03 temp-rest pic 9999. + + *********************************************************** + * Information Line * + *********************************************************** + + 01 status-line. + 03 filler pic x(02). + 03 open-mode pic x(14). + 03 filler pic x(02). + 03 lock-mode pic x(09) + value "---------". + 03 filler pic x(03). + 03 last-operation pic x(11). + 03 filler pic x(03). + 03 was-it-successful pic x(20). + 03 filler pic x(08). + 03 error-code. + 05 stat-1 pic x. + 05 filler pic x. + 05 stat-2 pic 9(03) value 0. + + 01 hyphen-line pic x(80) + value all "-". + + 01 yesno pic x. + + 01 inpopt. + 03 filler pic x(26). + 03 inpopt-00 pic x(0030) + value " 1. Write record 2. Exit". + + ********************************************************** + * Program for an input-only file * + ********************************************************** + + procedure division. + main. + initialize choice + stock-01. + display space. + display stock-00. + display inpopt at 2301. + display "Input Choice [ ]" at 2433 upon crt-under. + open output stock-file. + move "---Open Output" to open-mode. + move "Open Output" to last-operation. + perform status-check. + if was-it-successful not = "----------Successful" + move "----Closed----" to open-mode + display hyphen-line at 2201 upon crt-under + display status-line at 2201 upon crt-under + go to endit. + + *********************************************************** + * MAIN LOOP * + *********************************************************** + + ent-ry. + accept temp-date from date. + perform display-date. + accept temp-time from time. + perform display-time. + display hyphen-line at 2201 upon crt-under + display status-line at 2201 upon crt-under + accept stock-01. + evaluate choice + when 1 perform write-rec + when 2 go to wrap-up + end-evaluate. + go to ent-ry. + + *********************************************************** + * Close down paragraphs * + *********************************************************** + + wrap-up. + close stock-file. + move "----Closed----" to open-mode. + move "--Close----" to last-operation. + perform status-check. + display hyphen-line at 2201 upon crt-under. + display status-line at 2201 upon crt-under. + + + endit. + display "Do you wish to restart (Y/N) [ ]" + at 2424 upon crt-under. + accept yesno at 2454. + if yesno = "Y" or "y" + go to main + else if yesno = "N" or "n" + exit program + else + go to endit + end-if. + + *********************************************************** + * File Handling Routines * + *********************************************************** + + write-rec. + move "------Write" to last-operation. + perform move-from-screen-to-rec. + write stock-record. + perform status-check. + + *********************************************************** + * File status checking routines. * + *********************************************************** + + status-check. + move status-1 to stat-1 + move status-2 to stat-2 + evaluate status-1 + when "0" + move "----------Successful" to was-it-successful + when "1" + move "---------End of file" to was-it-successful + when "2" + move "---------Invalid Key" to was-it-successful + when "9" + perform look-up-error thru error-end + end-evaluate. + *********************************************************** + * Look up error number * + *********************************************************** + + look-up-error. + move low-values to status-1. + move binary-status to stat-2. + evaluate stat-2 + when 002 + move "-------File not open" to was-it-successful + when 007 + move "Disk space exhausted" to was-it-successful + when 013 + move "------File not found" to was-it-successful + when 024 + move "----------Disk error" to was-it-successful + when 041 + move "---Corrupt ISAM file" to was-it-successful + when 065 + move "---------File locked" to was-it-successful + when 068 + move "-------Record locked" to was-it-successful + when 139 + move "Record inconsistancy" to was-it-successful + when 146 + move "---No current record" to was-it-successful + when 180 + move "------File malformed" to was-it-successful + when 208 + move "-------Network error" to was-it-successful + when 213 + move "------Too many locks" to was-it-successful + end-evaluate. + error-end. + exit. + + + *********************************************************** + * Move data to and from the screen * + *********************************************************** + + move-from-screen-to-rec. + move stock-01-code to stock-key. + move stock-01-description-1 to stock-description-1. + move stock-01-description-2 to stock-description-2. + move stock-01-description-3 to stock-description-3. + move stock-01-held to stock-held. + move stock-01-cost to stock-cost. + + move-from-rec-to-screen. + move stock-key to stock-01-code. + move stock-description-1 to stock-01-description-1. + move stock-description-2 to stock-01-description-2. + move stock-description-3 to stock-01-description-3. + move stock-held to stock-01-held. + move stock-cost to stock-01-cost. + + *********************************************************** + * Date and Time Routines * + *********************************************************** + + display-date. + move temp-day to days. + move temp-month to month. + move temp-year to year. + display date-to-day at 0369. + + display-time. + move temp-hours to hours. + move temp-mins to mins. + display up-to-date-time at 0469. diff --git a/Microsoft COBOL v45/DEMO/NESTED.CBL b/Microsoft COBOL v45/DEMO/NESTED.CBL new file mode 100644 index 0000000..d5790b1 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/NESTED.CBL @@ -0,0 +1,69 @@ + $set ans85 nestcall noosvs mf + ******************************************************************* + * * + * * + * (C) Micro Focus Ltd. 1989 * + * * + * NESTED.CBL * + * * + * This demo shows how to structure a nested COBOL program. * + * There are two nested programs NEST1 and NEST2 each of which * + * have their own local data. It also demonstrates a simple use * + * of GLOBAL data. * + * * + ******************************************************************* + identification division. + program-id. main. + working-storage section. + 01 counter is global pic 9999. + 01 local-item pic x(20) value all 'a'. + + procedure division. + move 1 to counter. + display 'in main program, '. + display ' value of global counter = ', counter. + display ' value of ''local-item'' = ', local-item. + display 'calling nest1'. + display ' '. + + call 'nest1'. + display 'back in main program, '. + display ' value of global counter = ', counter. + display ' value of ''local-item'' = ', local-item. + display ' '. + + display 'calling nest2, '. + call 'nest2'. + display 'back in main program, '. + display ' value of global counter = ', counter. + display ' value of ''local-item'' = ', local-item. + display ' '. + stop run. + + * Here is the first nested program. + * Nested programs can access any GLOBAL data and have their own + * local data. + identification division. + program-id. nest1. + working-storage section. + 01 local-item pic x(20) value all 'b'. + procedure division. + add 1 to counter. + display 'in nest1, adding one to counter '. + display ' value of ''local-item'' = ', local-item. + display ' '. + end program nest1. + + * here is the second nested program + identification division. + program-id. nest2. + working-storage section. + 01 local-item pic x(20) value all 'c'. + procedure division. + add 1 to counter. + display 'in nest2, adding one to counter '. + display ' value of ''local-item'' = ', local-item. + display ' '. + end program nest2. + + end program main. diff --git a/Microsoft COBOL v45/DEMO/POPUP.CBL b/Microsoft COBOL v45/DEMO/POPUP.CBL new file mode 100644 index 0000000..7b0da0f Binary files /dev/null and b/Microsoft COBOL v45/DEMO/POPUP.CBL differ diff --git a/Microsoft COBOL v45/DEMO/PRINTESC.CBL b/Microsoft COBOL v45/DEMO/PRINTESC.CBL new file mode 100644 index 0000000..9af3d5e --- /dev/null +++ b/Microsoft COBOL v45/DEMO/PRINTESC.CBL @@ -0,0 +1,58 @@ + $set ans85 noosvs mf + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * PRINTESC.CBL * + * * + * This program demonstrates how to send escape * + * sequences to a printer. In this case, an Okidata 93 * + * parallel printer was used and the escape sequences in * + * question were to set form length to either "7" or * + * "11". To determine the proper escape sequences for * + * the printer in question, consult your printer manual. * + * * + ************************************************************ + + file-control. + select print-file assign "LPT1". + + data division. + file section. + fd print-file. + 01 print-record pic x(60). + + working-storage section. + + 01 form-length-11 pic x(4) value x"1b43000b". + 01 form-length-7 pic x(4) value x"1b430007". + 01 form-feed pic x value x"0c". + 01 first-line pic x(10) value "First Line". + 01 last-line pic x(9) value "Last Line". + + procedure division. + main-line. + open output print-file. + perform set-printer-to-7-inches. + perform set-printer-to-11-inches. + main-line-end. + + exit program. + close print-file. + stop run. + exit-program-end. + + set-printer-to-7-inches. + write print-record from form-length-7. + write print-record from first-line. + write print-record from form-feed. + write print-record from last-line. + set-printer-to-7-inches-end. + + set-printer-to-11-inches. + write print-record from form-length-11. + write print-record from first-line. + write print-record from form-feed. + write print-record from last-line. + set-printer-to-11-inches-end. + \ No newline at end of file diff --git a/Microsoft COBOL v45/DEMO/REPORT.CBL b/Microsoft COBOL v45/DEMO/REPORT.CBL new file mode 100644 index 0000000..482dc87 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/REPORT.CBL @@ -0,0 +1,64 @@ + $set ans85 noosvs mf + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * REPORT.CBL * + * * + * This is a REPORT WRITER sample. * + * * + ************************************************************ + environment division. + input-output section. + file-control. + select datafile assign to "data1.dat" + organization is line sequential. + select print-file assign to "idw.dat". + data division. + file section. + fd datafile. + 01 filler pic x(80). + fd print-file + record contains 80 characters + report is control-break. + 01 out-buffer pic x(80). + working-storage section. + 01 temp-buffer. + 05 data1 pic x(15). + 05 filler pic x(65). + 01 flags. + 05 eof-flag pic xxx value "no ". + 88 end-of-file value "yes". + report section. + rd control-break + controls are final data1 + page limit is 63 lines + heading 1 + first detail 5 + last detail 10. + 01 type is page heading. + 05 line number 1. + 10 column number 50 pic xxxx value "page". + 10 column number 55 pic zzzz9 source page-counter. + 01 detail-line type is detail. + 05 line number plus 1. + 10 column number 5 pic x(15) source data1. + 01 type is control footing final. + 05 line number plus 5. + 10 column number 24 pic x(13) value "this is final". + procedure division. + open input datafile. + open output print-file. + initiate control-break. + read datafile into temp-buffer + at end move "yes" to eof-flag. + perform 010-read-and-print until end-of-file. + terminate control-break. + close datafile print-file. + stop run. + + 010-read-and-print. + generate detail-line. + read datafile into temp-buffer + at end move "yes" to eof-flag. + \ No newline at end of file diff --git a/Microsoft COBOL v45/DEMO/SMPLACCP.CBL b/Microsoft COBOL v45/DEMO/SMPLACCP.CBL new file mode 100644 index 0000000..188fa8c --- /dev/null +++ b/Microsoft COBOL v45/DEMO/SMPLACCP.CBL @@ -0,0 +1,32 @@ + $set ans85 noosvs mf + ******************************************************************* + * * + * (C) Micro Focus Ltd. 1990 * + * * + * SMPLACCP.CBL * + * * + * This program demonstrates some simple screen handling * + * extensions. It uses DISPLAY and ACCEPT statements to show how * + * you could achieve password masking and reverse-video. * + * * + ******************************************************************* + special-names. + console is crt. + + working-storage section. + 01 into-field pic x(10). + 01 pass-word pic x(08). + + procedure division. + display spaces upon crt. + display "Please enter your password" at 0310 upon + crt-under. + accept pass-word at 0338 with no-echo. + display "Enter data to be accepted" at 0510. + accept into-field at 0538 with + reverse-video + blink. + display "The data you entered was => " at 0710. + display into-field at 0738. + + stop run. diff --git a/Microsoft COBOL v45/DEMO/SORTDEMO.CBL b/Microsoft COBOL v45/DEMO/SORTDEMO.CBL new file mode 100644 index 0000000..8e80c76 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/SORTDEMO.CBL @@ -0,0 +1,2014 @@ + $set ans85 vsc2 nobound noqual noalter norw mf noms + ************************************************************ + * * + * SORTDEMO.CBL * + * * + * This program demonstrates using API function calls * + * in a COBOL program. A number of sort routines are * + * also demonstrated: * + * COBOL table, COBOL file, exchange, shell, * + * insertion, heap, quick and bubble sorts. * + * * + ************************************************************ + * Version: 1.5.5 (phase 4) + * + * Called Routines: DosBeep - sounds the speaker + * DosSleep - delays program execution + * VioGetConfig - gets the hardware video + * configuration + * VioGetMode - gets the video mode + * VioSetMode - dets the video mode + * VioWrtCharStrAtt - writes a character string and + * attributes to the screen + * VioWrtNCell - writes one character and its + * attribute to the screen + * KbdFlushBuffer - flushes the keyboard buffer + * KbdCharIn - reads one character from the + * keyboard buffer + * + ***************************************************************** + * + * + * System Requirements: IBM PC or compatible + * running DOS 3.x + * IBM PS/2 Model 30 + * IBM PC/AT or compatible + * IBM PS/2 Model 50,60,70,80 + * running DOS 3.x or OS/2 + * + ***************************************************************** + * + * Compile and link notes: This program must be BOUND to run under + * DOS. + * + * Assuming the files for the COBOL compiler and Animator are + * correctly installed: + * + * To compile, the following files must be present: + * ------------------------------------------------ + * SORTDEMO.CBL + * + * To link, the following files must be present: + * --------------------------------------------- + * LCOBOL.LIB )(Must be in current directory, or available + * OS2.LIB )(on the path defined by the LIB environment + * (variable. + * LINK.EXE (OS/2 Linker) + * + * + * To bind (for use on DOS), the following files must be present: + * -------------------------------------------------------------- + * API.LIB (must be in current directory) + * BIND.EXE + * CBLBIND.LIB )(can be in any directory which must be + * CBLBIND.NOT )(specified on the BIND command line + * OS2.LIB ) + * + * + * For DOS + * ------- + * compile the program as shown below: + * COBOL SORTDEMO.CBL OPTSPEED NOTRICKLE ; + * + * then link (using OS/2 linker): + * LINK SORTDEMO/NOD,,,COBLIB+OS2; + * or + * LINK SORTDEMO/NOD,,,LCOBOL+OS2; + * + * and bind (assuming all files in current directory): + * BIND SORTDEMO CBLBIND.LIB OS2.LIB -N @CBLBIND.NOT + * + * + * For OS/2, + * --------- + * compile the program as shown below: + * COBOL SORTDEMO.CBL OPTSPEED NOTRICKLE ; + * + * then link: + * LINK SORTDEMO/NOD,,,COBLIB+OS2 ; + * or + * LINK SORTDEMO/NOD,,,LCOBOL+OS2 ; + * + * To run on DOS or OS/2, + * SORTDEMO + * + ***************************************************************** + * + * Animation notes: + * ---------------- + * When animating VIO API function calls, it is necessary to + * use the FLASH-CALLS directive to ensure that the user screen + * is written to by the VIO calls rather than the Animator + * screen. Try Animating with and without this directive to see + * the effect. + * + *----------------------------------------------------------------- + * + * To Animate the program (OS/2 only), + * ---------------------------------- + * + * compile the program as shown below: + * COBOL SORTDEMO.CBL ANIM ; + * + * Then, to animate: + * ANIMATE SORTDEMO FLASH-CALLS + * + * + / + ***************************************************************** + environment division. + configuration section. + special-names. + call-convention 3 is api. + + input-output section. + file-control. + select sort-file assign to "sorttemp" + sort status is sort-status. + data division. + file section. + sd sort-file. + 01 sort-rec. + 05 sort-key pic 99. + 05 sort-color pic x. + 05 sort-bar pic x(50). + + ***************************************************************** + working-storage section. + ***************************************************************** + * + * Constants section + * + + 78 escape-key-pressed value x"1b". + 78 up-arrow-scan-code value 72. + 78 down-arrow-scan-code value 80. + + 78 cobol-table-line-number value 4. + 78 cobol-line-number value 5. + 78 exchange-line-number value 6. + 78 quick-line-number value 7. + 78 shell-line-number value 8. + 78 heap-line-number value 9. + 78 insert-line-number value 10. + 78 bubble-line-number value 11. + 78 randomize-line-number value 13. + 78 sound-sw-line-number value 15. + 78 speed-up-line-number value 16. + 78 slow-down-line-number value 17. + 78 speed-counter-line-number value 19. + 78 prompt-line-number value 22. + 78 message-line-number value 25. + + 78 cobol-table-literal value "Cobol table". + 78 cobol-literal value "cobol File". + 78 exchange-literal value "Exchange". + 78 quick-literal value "Quick". + 78 shell-literal value "Shell". + 78 heap-literal value "Heap". + 78 insert-literal value "Insert". + 78 bubble-literal value "Bubble". + 78 randomize-literal value "Randomize". + * + * End of constants section + * + + 01 seed pic 9(12) comp-5. + 01 mod pic 9(12) comp-5. + 01 rand pic 9v9(11) comp-5. + 01 integer pic 999 comp-5. + 01 sort-status pic xx. + + 01 stack-sub pic 9(4) comp-5. + 01 upper-stack occurs 6 times pic 9(4) comp-5. + 01 lower-stack occurs 6 times pic 9(4) comp-5. + 01 pivot-element pic 99 comp-5. + + 01 array. + 05 a-data occurs 50 times. + 10 a-length pic 99 comp-5. + 10 a-color pic x. + 10 a-string pic x(50). + 01 backup-array. + 05 ba-data occurs 50 times. + 10 ba-length pic 99 comp-5. + 10 ba-color pic x. + 10 ba-string pic x(50). + 01 array-max pic 99 comp-5. + 01 sub pic 99 comp-5. + 01 sub-1 pic 99 comp-5. + 01 sub-2 pic 99 comp-5. + 01 sub-x redefines sub-2 pic x. + 01 max-loop pic 99 comp-5. + 01 last-element-saved pic 99 comp-5. + 01 last-choice pic x value space. + + 01 swap-line pic 99 comp-5. + 01 swap-line-1 pic 99 comp-5. + 01 temp-sub pic 99 comp-5. + 01 max-limit pic 99 comp-5. + 01 parent pic 99 comp-5. + 01 child pic 99 comp-5. + 01 smallest-line pic 9(4) comp-5. + 01 offset pic 99 comp-5. + + 01 bar pic x(50) value all x"dc". + + 01 hold-array-element. + 05 h-length pic 99 comp-5. + 05 h-color pic x. + 05 h-string pic x(50). + + 01 start-time. + 05 start-hr pic 99. + 05 start-min pic 99. + 05 start-sec pic 99. + 05 start-hsec pic 99. + 05 start-decimal redefines start-hsec pic v99. + 01 end-time. + 05 end-hr pic 99. + 05 end-min pic 99. + 05 end-sec pic 99. + 05 end-hsec pic 99. + 05 end-decimal redefines end-hsec pic v99. + + 01 start-time-secs pic 9(4)v99. + 01 end-time-secs pic 9(4)v99. + 01 elapsed pic 9999v99. + + 01 pause pic 9(4) comp-5. + 01 pause-dword pic 9(8) comp-5. + 01 frequency pic 9(4) comp-5 value zeros. + 01 freq pic 9(4) comp-5. + + 01 time-screen-line pic 99. + + 01 updated-screen-sw pic xxx value "OFF". + 01 halt-sw pic xxx. + 01 auto-sound-toggle-sw pic xxx value "ON". + + 01 hilite-screen-data-item. + 05 filler pic xx value spaces. + 05 hilite-item pic x(12). + 05 filler pic x value space. + 05 disp-elapsed pic x(7). + 05 filler pic x(6) value spaces. + + 01 edited-elapsed pic zzzz.zz. + 01 edited-elapsed-red redefines edited-elapsed pic x(7). + + 01 menu-screen-buffer-data. + 02 filler. + 05 filler pic x(30) value "ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»". + 05 filler pic x(30) value "º COBOL SORTING DEMO º". + 05 filler pic x(30) value "º º". + 05 filler pic x(30) value "º Cobol table º". + 05 filler pic x(30) value "º cobol File º". + 05 filler pic x(30) value "º Exchange º". + 05 filler pic x(30) value "º Quick º". + 05 filler pic x(30) value "º Shell º". + 05 filler pic x(30) value "º Heap º". + 05 filler pic x(30) value "º Insertion º". + 05 filler pic x(30) value "º Bubble º". + 05 filler pic x(30) value "º º". + 05 filler pic x(30) value "º Randomize º". + 05 filler pic x(30) value "º º". + 05 filler pic x(3) value "º ". + 05 ms-toggle-sound-var + pic x(6) value "Toggle". + 05 filler pic x(8) value " sound: ". + 05 sound-sw pic xxx value "OFF". + 05 filler pic x(10) value " º". + * 05 filler pic x(30) value "º º". + 02 menu-screen-speed-up-line. + 05 filler pic x(3) value "º ". + 05 ms-speed-up-var pic x(24). + 05 filler pic x(3) value " º". + 02 menu-screen-slow-down-line. + 05 filler pic x(3) value "º ". + 05 ms-slow-down-var pic x(25). + 05 filler pic xx value " º". + 02 filler. + 05 filler pic x(30) value "º º". + 05 filler pic x(23) value "º Speed (X/100 sec.): ". + 05 disp-pause pic zzz9. + 05 filler pic x(3) value " º". + 05 filler pic x(30) value "º º". + 05 filler pic x(30) value "º Type first character of º". + 02 menu-screen-choice-line. + 05 filler pic x(19) value "º choice (CFEQSHIBR". + 05 ms-speed-up-char pic x. + 05 ms-slow-down-char pic x. + 05 ms-toggle-sound-char pic x. + 05 filler pic x(8) value "): º". + 02 filler. + 05 filler pic x(30) value "º or ESC key to end program: º". + 05 filler pic x(30) value "ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ". + + 01 menu-screen-buffer redefines menu-screen-buffer-data + occurs 24 times. + 05 menu-screen-line pic x(30). + 01 menu-screen-sub-max pic 99 comp-5 value 24. + 01 menu-screen-sub pic 99 comp-5. + 01 menu-screen-hilite-attr pic x value x"0f". + 01 menu-screen-normal-attr pic x value x"07". + 01 menu-screen-revvid-attr pic x value x"70". + 01 menu-screen-speed-up-msg pic x(24) value + "< Will speed up the sort". + 01 menu-screen-slow-down-msg pic x(25) value + "> Will slow down the sort". + 01 menu-screen-toggle-sound-msg pic x(6) value + "Toggle". + 01 menu-screen-speed-up-lit pic x value "<". + 01 menu-screen-toggle-sound-lit pic x value "T". + 01 menu-screen-slow-down-lit pic x value ">". + 01 menu-screen-cobol-lit-tab pic x(11) value "Cobol table". + 01 menu-screen-cobol-lit pic x(10) value "cobol File". + + 01 msg-line pic x(30). + 01 msg-attr pic x value x"87". + 01 cobol-msg pic x(30) value + "Cobol sort only when speed = 0". + 01 wait-msg pic x(30) value + " Please standby". + + / + ***************************************************************** + * + * General OS/2 parameters + * + ***************************************************************** + + 01 handle-zeros pic 9(4) comp-5 value 0. + * + * screen-line = row, on screen, starting from 0. + * screen-col = Column, on screen, starting from 0. + * + 01 screen-line pic 9(4) comp-5. + 01 screen-col pic 9(4) comp-5. + * + ***************************************************************** + * Parameters for VioWerNCell + ***************************************************************** + * + * VioWrtNCell writes one character and one attribute to the + * screen 'n' number of times. + * + * The field "NUM-CHARS-ON-SCREEN" = the number of times + * to write the character/ + * attribute to the + * screen. + * + 01 viowrtncell-data. + 05 viowrtncell-char pic x value space. + 05 viowrtncell-attr pic x value x"07". + 01 viowrtncell-count pic 9(4) comp-5. + 01 num-chars-on-screen pic 9(4) comp-5. + * + ***************************************************************** + * Parameters for VioWrtCharStrAtt + ***************************************************************** + * + * VioWrtCharStrAtt writes a string and its attributes to the + * screen. + * + * The data item "VIOWRTCHARSTRATT-LENGTH" = the number of + * characters and + * attributes to + * write. + * + 01 viowrtcharstratt-data pic x(50). + 01 viowrtcharstratt-attr pic x. + 01 viowrtcharstratt-length pic 9(4) comp-5 value 50. + * + ***************************************************************** + * Parameter for VioGetConfig + ***************************************************************** + * + * VioGetConfig identifies the type of video card and video + * monitor on the target machine. + * + * The field "VIOGETCONFIG-LENGTH" specifies the length, + * in words, of the group item "VIOGETCONFIG". + * + * The field "VIOGETCONFIG-ADAPTER" specifies the type of + * video card you have: + * = 0 = monochrome + * = 1 = CGA + * = 2 = EGA + * = 3 = VGA + * = 7 = PS/2 adapter 8514/A + * + * The field "VIOGETCONFIG-DISPLAY specifies the type of + * computer monitor you have: + * = 0 = monochrome + * = 1 = CGA + * = 2 = EGA + * = 3 = PS/2 monochrome 8503 + * = 4 = PS/2 color 8512/8513 + * = 9 = PS/2 color 8514 + * + 01 viogetconfig-data. + 05 viogetconfig-length pic 9(4) comp-5 value 10. + 05 viogetconfig-adapter pic 9(4) comp-5. + 05 viogetconfig-display pic 9(4) comp-5. + 05 filler pic 9(8) comp-5. + * + ***************************************************************** + * Parameters for VioGetMode and VioSetMode + ***************************************************************** + * + * This parameter to the routine (VioGetMode and VioSetMode) that + * identifies the software video mode. + * This information is needed to determine + * how many columns, rows and colors the video adapter and + * monitor can handle. + * . + * The field "VIOMODE-LENGTH" specifies the length, + * in words, of the group item "VIOMODE-DATA". + * + * The fields returned are as follows: + * ----------------------------------- + * + * VIOMODE-MODE will = 1 if the target machine is in color mode. + * = 0 if the target machine in monochrome mode. + * VIOMODE-COLORS will = 0 if the number of available colors = 2 + * = 2 if the number of available colors = 16 + * The number of colors available is controlled + * by the type of adapter and monitor. + * A monochrome adapter has only 2 available + * colors; a color graphics system can have + * a maximum of 16 colors. + * + * VIOMODE-COLS = the number of text columns available to the + * program. + * VIOMODE-ROWS = the number of text rows available to the + * program. + * + 01 viomode-data. + 05 viomode-length pic 9(4) comp-5 value 8. + 05 viomode-mode pic 99 comp-5. + 05 viomode-colors pic 99 comp-5. + 05 viomode-cols pic 9(4) comp-5. + 05 viomode-rows pic 9(4) comp-5. + * + ***************************************************************** + * This area saves the original video mode data. After the + * program is finished,the user's video mode will be restored. + ***************************************************************** + * + 01 viomode-save-data pic x(16). + * + ***************************************************************** + * Parameters for KbdCharIn + ***************************************************************** + * + * KbdCharIn gets one character from the keyboard buffer with no + * echo. + * + * KBDCHARIN-CHAR = the character from the keyboard buffer. + * + * KBDCHARIN-SCAN = the scan code of the character. + * + * KBDCHARIN-WAIT-FLAG = 0 = instructs the function to wait + * until there is character + * available. + * = 1 = don't wait for a character if + 01 kbdcharin-wait-flag pic 9(4) comp-5 value 0. + 01 kbdcharin-data. + 05 kbdcharin-char pic x. + 05 kbdcharin-scan pic 99 comp-5. + 05 kbdcharin-status pic 99 comp-5. + 05 filler pic 9(14) comp-5. + + + / + ***************************************************************** + procedure division. + ***************************************************************** + 10000-start-section section. + 10000-start. + perform 20000-initialize + perform 21000-get-character + perform 30000-sort-and-input-loop thru 30000-exit + until kbdcharin-char = escape-key-pressed + perform 40000-restore-users-video-mode + perform 20400-clear-the-screen + stop run. + 10000-exit. + exit. + + / + ***************************************************************** + 20000-initialize. + ***************************************************************** + move 0 to pause + move pause to disp-pause + move spaces to ms-speed-up-var + move spaces to ms-toggle-sound-var + move menu-screen-slow-down-msg to ms-slow-down-var + move space to ms-speed-up-char + move space to ms-toggle-sound-char + move menu-screen-slow-down-lit to ms-slow-down-char + perform 20100-get-video-config-info + perform 20200-get-video-mode + perform 20300-set-video-mode + perform 20400-clear-the-screen + perform 20500-flush-kbd-buffer + perform 20600-init-unsorted-array + perform 20700-display-unsorted-bars + perform 20800-display-menu-screen. + 20000-exit. + exit. + ***************************************************************** + 20100-get-video-config-info. + ***************************************************************** + * + * Get the video configuration of the machine. This determines + * whether or not to use color display attributes and how many + * bars can be displayed. + * + * All OS/2 API functions are called like far PASCAL routines: + * i.e. you must supply the parameters in reverse order or use + * call-convention 3. We use call-convention 3, having called it + * api. Also, the API names must be LITLINKED so that they will be + * satisfied at link time by referencing OS2.LIB. In order to + * force this for each name, the name must be prefixed by + * double-underscore ("__"). + * + call api "__VioGetConfig" using + by value handle-zeros + by reference viogetconfig-data + by value handle-zeros + if return-code not = zeros + display "ERROR IN VioGetConfig" + go to 99999-os2-error-abort. + 20100-exit. + exit. + + ***************************************************************** + 20200-get-video-mode. + ***************************************************************** + * + * Get the current video mode. + * + call api "__VioGetMode" using + by reference viomode-data + by value handle-zeros + if return-code not = zeros + display "ERROR IN VioGetMode" + go to 99999-os2-error-abort + end-if + * + * Save the current mode data to restore the user's + * mode at the end of the job. + * + move viomode-data to viomode-save-data. + 20200-exit. + exit. + + ***************************************************************** + 20300-set-video-mode. + ***************************************************************** + * + * Set the video mode. + * + evaluate viogetconfig-adapter + when 0 perform 20322-set-mono-video-mode + when 1 perform 20324-set-cga-video-mode + when 2 perform 20326-set-ega-video-mode + when 3 perform 20328-set-vga-video-mode + when 7 perform 20328-set-vga-video-mode + when other + display "ERROR - UNRECOGNISED VIDEO ADAPTER" + go to 99999-os2-error-abort + end-evaluate + move 80 to viomode-cols + perform 20330-call-viosetmode + if return-code not = zeros + display "ERROR IN SETTING VIDEO MODE" + go to 99999-os2-error-abort + end-if. + 20300-exit. + exit. + + ***************************************************************** + 20322-set-mono-video-mode. + ***************************************************************** + move 25 to viomode-rows + move 0 to viomode-mode + move 0 to viomode-colors + move 2000 to num-chars-on-screen. + 20322-exit. + exit. + + ***************************************************************** + 20324-set-cga-video-mode. + ***************************************************************** + * + * If a CGA adapter but a monochrome screen, setup + * in monochrome mode. + * + if viogetconfig-display = zeros + perform 20322-set-mono-video-mode + else + move 25 to viomode-rows + move 1 to viomode-mode + move 4 to viomode-colors + move 2000 to num-chars-on-screen + end-if. + 20324-exit. + exit. + + ***************************************************************** + 20326-set-ega-video-mode. + ***************************************************************** + * + * If a EGA adapter but a monochrome screen, setup + * in monochrome mode. + * + if viogetconfig-display = zeros + perform 20322-set-mono-video-mode + else + move 43 to viomode-rows + move 1 to viomode-mode + move 4 to viomode-colors + move 3440 to num-chars-on-screen + end-if. + 20326-exit. + exit. + + ***************************************************************** + 20328-set-vga-video-mode. + ***************************************************************** + * + * If a VGA adapter but a monochrome screen, setup + * in monochrome mode. + * + if viogetconfig-display = zeros + perform 20322-set-mono-video-mode + else + move 50 to viomode-rows + move 1 to viomode-mode + move 4 to viomode-colors + move 4000 to num-chars-on-screen + end-if. + 20328-exit. + exit. + + ***************************************************************** + 20330-call-viosetmode. + ***************************************************************** + * + * Sets the video mode. + * + * Inputs to the routine are the following: + * + * viomode-data = Contains the video mode data + * + call api "__VioSetMode" using + by reference viomode-data + by value handle-zeros. + 20330-exit. + exit. + + ***************************************************************** + 20400-clear-the-screen. + ***************************************************************** + * + * Clear the screen by writing 1 space to every character position + * on the screen. + * + move 0 to screen-line + move 0 to screen-col + move num-chars-on-screen to viowrtncell-count + * + * VioWrtNCell writes one character and attribute, (a single + * character and its attribute are refered to as a "cell") + * to the screen 'viowrtncell-count' times. + * + call api "__VioWrtNCell" using + by reference viowrtncell-data + by value viowrtncell-count + by value screen-line + by value screen-col + by value handle-zeros + if return-code not = zeros + display "ERROR IN CLEARING THE SCREEN" + go to 99999-os2-error-abort + end-if. + 20400-exit. + exit. + + ***************************************************************** + 20500-flush-kbd-buffer. + ***************************************************************** + * + * Flushes the keyboard buffer. + * + call api "__KbdFlushBuffer" using + by value handle-zeros + if return-code not = zeros + display "ERROR IN FLUSHING THE KEYBOARD BUFFER" + go to 99999-os2-error-abort. + 20500-exit. + exit. + + / + ***************************************************************** + 20600-init-unsorted-array. + ***************************************************************** + * + * Initialize the arrays "ARRAY" and "BACKUP-ARRAY" with + * the length of each bar on the screen, and the color of + * each bar. + * + * "Array" is used as a scratch area. Each entry in the array + * is initialized with a value from 1 to the maximum number + * screen lines. When we picking random numbers, they must + * be between 1 and the maximum number of screen lines. In + * picking a random number, use the random number as an + * index into "array" and zero out that entry. In this way, it + * will be known that the random number is chosen. + * For example, if random number "5" is picked, zeros are moved + * to "a-length (5)". If random number "5" is picked + * again, it can seen that "a-length (5)" = zeros and it is + * therefore known that the number "5" has been + * previously chosen and another must be generated. + * + move viomode-rows to array-max + perform varying sub from 1 by 1 + until sub > array-max + move sub to a-length (sub) + end-perform + * + * Initialize the random number seed. + * + perform 20610-get-starting-time + compute seed = start-time-secs / 86400 * 259199 + * + perform varying sub from 1 by 1 + until sub > array-max + * + * Pick a random number (integer). + * + perform 20620-get-random-integer + * + * Continue to generate random numbers until one is generated + * that has not been picked before. + * + perform 20620-get-random-integer thru 20620-exit + until a-length (integer) not = zeros + * + * A unique random number (integer) is chosen. Initialize + * length and color fields of the backup array. + * + move a-length (integer) to ba-length (sub) + move zero to a-length (integer) + move ba-length (sub) to sub-2 + move bar (1:sub-2) to ba-string (sub) + if viomode-colors = 0 + move x"07" to sub-x + end-if + perform until sub-2 < 16 + subtract 15 from sub-2 + end-perform + inspect ba-color (sub) + replacing characters by sub-x + end-perform. + 20600-exit. + exit. + + ***************************************************************** + 20610-get-starting-time. + ***************************************************************** + * + * Accepts the system time and computes the number of seconds + * since midnight. + * + accept start-time from time + compute start-time-secs = ((start-hr * 60) * 60) + + (start-min * 60) + + start-sec + + start-decimal. + 20610-exit. + exit. + + + ***************************************************************** + 20620-get-random-integer. + ***************************************************************** + * + * Compute a random number integer (integer). + * + compute mod = seed * 7141 + 54773 + divide mod by 259119 giving mod remainder seed + compute rand = seed / 259119 + compute integer = 1 + (array-max) * rand. + 20620-exit. + exit. + + ***************************************************************** + 20700-display-unsorted-bars. + ***************************************************************** + * + * Displays the unsorted bars on the screen. + * + move 50 to viowrtcharstratt-length + move 0 to screen-col + perform varying sub from 1 by 1 + until sub > array-max + move ba-data (sub) to a-data (sub) + compute screen-line = sub - 1 + move a-string (sub) to viowrtcharstratt-data + move a-color (sub) to viowrtcharstratt-attr + perform 20710-call-viowrtcharstratt + end-perform + if msg-line not = spaces + move spaces to msg-line + perform 30110-update-message-line + end-if. + 20700-exit. + exit. + + ***************************************************************** + 20705-display-sorted-bars. + ***************************************************************** + * + * Displays the sorted bars on the screen. + * + move 50 to viowrtcharstratt-length + move 0 to screen-col + perform varying sub from 1 by 1 + until sub > array-max + compute screen-line = sub - 1 + move a-string (sub) to viowrtcharstratt-data + move a-color (sub) to viowrtcharstratt-attr + perform 20710-call-viowrtcharstratt + end-perform + if msg-line not = spaces + move spaces to msg-line + perform 30110-update-message-line + end-if. + 20705-exit. + exit. + + ***************************************************************** + 20710-call-viowrtcharstratt. + ***************************************************************** + * + * Writes a string and its attributes the the screen. + * + * The following inputs must be initialized: + * + * : viowrtcharstratt-data with the + * string one wants to write + * : viowrtcharstratt-att with the + * attribute characters one wants + * to write. Note that the first + * attribute is used for every + * character to write. + * : viowrtcharstratt-length = + * length of the string (and + * attribute) to write. + * : screen-line = the screen row to + * to write on, starting from 0. + * : screen-col = the screen column to + * write on starting from 0. + * + call api "__VioWrtCharStrAtt" using + by reference viowrtcharstratt-data + by value viowrtcharstratt-length + by value screen-line + by value screen-col + by reference viowrtcharstratt-attr + by value handle-zeros + if return-code not = zeros + display "ERROR IN VioWrtCharStrAtt" + go to 99999-os2-error-abort. + 20710-exit. + exit. + + ***************************************************************** + 20800-display-menu-screen. + ***************************************************************** + * + * Displays the menu screen. + * + move 50 to screen-col + move 30 to viowrtcharstratt-length + move menu-screen-hilite-attr to viowrtcharstratt-attr + perform varying menu-screen-sub from 1 by 1 + until menu-screen-sub > menu-screen-sub-max + compute screen-line = menu-screen-sub - 1 + move menu-screen-line (menu-screen-sub) to + viowrtcharstratt-data + perform 20710-call-viowrtcharstratt + end-perform + * + * Write the "COBOL" sort line in a different attribute, if + * necessary. + * + if pause not = 0 + perform 20810-unhilite-cobol-sort + end-if + * + * Clear the message line. + * + move spaces to viowrtcharstratt-data + compute screen-line = message-line-number - 1 + perform 20710-call-viowrtcharstratt. + 20800-exit. + exit. + + ****************************************************************** + 20810-unhilite-cobol-sort. + ***************************************************************** + * + * Print "Cobol" on the menu, in dim attributes. Because + * it is printed with dim attributes, this indicates + * that the option may not chosen. + * + + compute screen-line = cobol-table-line-number - 1 + move 51 to screen-col + move spaces to hilite-screen-data-item + move menu-screen-cobol-lit-tab to hilite-item + move menu-screen-normal-attr to viowrtcharstratt-attr + move hilite-screen-data-item to viowrtcharstratt-data + move 28 to viowrtcharstratt-length + perform 20710-call-viowrtcharstratt. + compute screen-line = cobol-line-number - 1 + move 51 to screen-col + move spaces to hilite-screen-data-item + move menu-screen-cobol-lit to hilite-item + move menu-screen-normal-attr to viowrtcharstratt-attr + move hilite-screen-data-item to viowrtcharstratt-data + move 28 to viowrtcharstratt-length + perform 20710-call-viowrtcharstratt. + 20810-exit. + exit. + + ***************************************************************** + 21000-get-character. + ***************************************************************** + * + * Get a character from the keyboard (with no echo). + * + call api "__KbdCharIn" using + by reference kbdcharin-data + by value kbdcharin-wait-flag + by value handle-zeros + if return-code not = zeros + display "ERROR IN KbdCharIn" + go to 99999-os2-error-abort. + 21000-exit. + exit. + + / + ***************************************************************** + 30000-sort-and-input-loop. + ***************************************************************** + * + * A character (kbdcharin-char) has been input. If it is a + * recognized character, act on it; else, get another. + * + * Performed until kbdcharin-char = hex 1B + * (i.e. the ESCAPE key is pressed). + * + evaluate true + when kbdcharin-char = "C" or "c" + perform 30150-cobol-table-sort + when kbdcharin-char = "F" or "f" + perform 30100-cobol-sort + when kbdcharin-char = "E" or = "e" + perform 30200-exchange-sort + when kbdcharin-char = "Q" or = "q" + perform 30300-quick-sort + when kbdcharin-char = "S" or = "s" + perform 30400-shell-sort + when kbdcharin-char = "H" or = "h" + perform 30500-heap-sort + when kbdcharin-char = "I" or = "i" + perform 30600-insert-sort + when kbdcharin-char = "B" or = "b" + perform 30700-bubble-sort + when kbdcharin-char = ">" or = "." + perform 30800-slow-down-the-sort + when kbdcharin-char = "<" or = "," + perform 30900-speed-up-the-sort + when kbdcharin-char = "T" or = "t" + perform 31000-toggle-sound + when kbdcharin-char = "R" or "r" + perform 31100-randomize-array + end-evaluate + * + * Check for up arrow and down arrow keystrokes. + * + evaluate true + also true + when kbdcharin-char = x"00" or = x"e0" + also kbdcharin-scan = up-arrow-scan-code + perform 31200-select-previous-choice + when kbdcharin-char = x"00" or = x"e0" + also kbdcharin-scan = down-arrow-scan-code + perform 31300-select-next-choice + end-evaluate + * + * Get next keystroke from the user + * + perform 21000-get-character. + 30000-exit. + exit. + + **************************************************************** + 30100-cobol-sort. + **************************************************************** + * + * This routine will perform a COBOL file sort. + * + * Note that a COBOL sort will only be performed if the program is + * running at full speed, i.e., pause = 0 (the "<" key was + * typed until the speed, as displayed on the menu screen, = + * zeros). + * + if pause not = 0 + move cobol-msg to msg-line + perform 30110-update-message-line + else + move kbdcharin-char to last-choice + if msg-line not = spaces + move spaces to msg-line + perform 30110-update-message-line + end-if + * + * Highlight the entry. + * + move spaces to hilite-screen-data-item + move zeros to elapsed + move cobol-line-number to time-screen-line + move cobol-literal to hilite-item + move menu-screen-revvid-attr to viowrtcharstratt-attr + perform 30120-write-time-on-screen + move "ON" to updated-screen-sw + perform 20700-display-unsorted-bars + perform 20610-get-starting-time + * + sort sort-file + on ascending key sort-key + input procedure is sort-input-procedure-section + output procedure is sort-output-procedure-section + * + * The sort has completed. Now, clear the highlight around + * the elapsed time. + * + perform 30140-clear-time-hilight + end-if. + 30100-exit. + exit. + + ***************************************************************** + 30110-update-message-line. + ***************************************************************** + * + * This section of code writes the "error msg" line to the screen. + * + move msg-attr to viowrtcharstratt-attr + move msg-line to viowrtcharstratt-data + move 30 to viowrtcharstratt-length + compute screen-line = message-line-number - 1 + move 50 to screen-col + perform 20710-call-viowrtcharstratt. + 30110-exit. + exit. + + ***************************************************************** + 30120-write-time-on-screen. + ***************************************************************** + * + * Writes the elapsed time to the screen. + * + * Inputs to this routine are the following: + * + * elapsed = the elapsed time in seconds. + * viowrtcharstratt-attr = the attribute to use when the + * elapsed time is written to the + * screen. + * time-screen-line = the screen line to write on. + * + move 28 to viowrtcharstratt-length + move elapsed to edited-elapsed + move edited-elapsed-red to disp-elapsed + compute screen-line = time-screen-line - 1 + move 51 to screen-col + move hilite-screen-data-item to viowrtcharstratt-data + perform 20710-call-viowrtcharstratt. + 30120-exit. + exit. + + ***************************************************************** + 30130-update-time-on-screen. + ***************************************************************** + * + * Updates the screen with the elapsed time. + * + * Inputs to this routine are the following: + * + * start-time-secs = The start time, in seconds. + * time-screen-line = The screen line (relative from 0) to + * write the elapsed time on. + * + accept end-time from time + compute end-time-secs = ((end-hr * 60) * 60) + + (end-min * 60) + + end-sec + + end-decimal + compute elapsed = end-time-secs - start-time-secs + move menu-screen-revvid-attr to viowrtcharstratt-attr + perform 30120-write-time-on-screen. + 30130-exit. + exit. + + ***************************************************************** + 30140-clear-time-hilight. + ***************************************************************** + * + * Clears the highlight attribute around the elapsed time. + * + move menu-screen-hilite-attr to viowrtcharstratt-attr + perform 30120-write-time-on-screen. + 30140-exit. + exit. + / + ****************************************************************** + 30150-cobol-table-sort. + ****************************************************************** + * + * This routine will perform a sort using the MF table sort. + * + * The program must be running at full speed for this option to be + * accepted. + * + if pause not = 0 + move cobol-msg to msg-line + perform 30110-update-message-line + else + move kbdcharin-char to last-choice + if msg-line not = spaces + move spaces to msg-line + perform 30110-update-message-line + end-if + * + * Highlight the entry + * + move spaces to hilite-screen-data-item + move zeros to elapsed + move cobol-table-line-number to time-screen-line + move cobol-table-literal to hilite-item + move menu-screen-revvid-attr to viowrtcharstratt-attr + perform 30120-write-time-on-screen + move "ON" to updated-screen-sw + perform 20700-display-unsorted-bars + perform 20610-get-starting-time + * + sort a-data on ascending a-length + * + perform 20705-display-sorted-bars + perform 30130-update-time-on-screen + perform 30140-clear-time-hilight + end-if. + 30150-exit. + exit. + / + ***************************************************************** + 30200-exchange-sort. + ***************************************************************** + * + * The exchange sort (starting with the first element in the + * array) compares each element of array with every + * following element. If any of the following elements are + * smaller the the current element, swap the 2 elements. + * Continue through the array to the end. + * + move kbdcharin-char to last-choice + move exchange-line-number to time-screen-line + move exchange-literal to hilite-item + move "ON" to updated-screen-sw + perform 20700-display-unsorted-bars + perform 20610-get-starting-time + perform varying sub from 1 by 1 + until sub > array-max + move sub to smallest-line + compute temp-sub = sub + 1 + perform varying sub-1 from temp-sub by 1 + until sub-1 > array-max + if a-length (sub-1) < + a-length (smallest-line) + move sub-1 to smallest-line + end-if + end-perform + if smallest-line > sub + move sub to swap-line + move smallest-line to swap-line-1 + perform 30210-swap-two-bars + end-if + end-perform + * + * The sort is complete. Clear the screen highlight + * around the elapsed time. + * + perform 30140-clear-time-hilight. + 30200-exit. + exit. + + ***************************************************************** + 30210-swap-two-bars. + ***************************************************************** + * + * Swaps two elements in array and updatesthe screen. + * + * Inputs to this routine are the following: + * + * swap-line + * = specifies the subscript of one member to swap. + * swap-line-1 + * = specifies the subscript of the other member to + * swap. + * + move a-data (swap-line) to hold-array-element + move a-data (swap-line-1) to a-data (swap-line) + move hold-array-element to a-data (swap-line-1) + + compute screen-line = swap-line - 1 + move 0 to screen-col + move swap-line to freq + perform 30220-write-one-bar-to-screen + + compute screen-line = swap-line-1 - 1 + move 0 to screen-col + move swap-line-1 to freq + perform 30220-write-one-bar-to-screen. + 30210-exit. + exit. + + ***************************************************************** + 30220-write-one-bar-to-screen. + ***************************************************************** + * + * Writes one bar to the screen. + * + * Inputs to this routine are the following: + * + * array = contains one element to be written + * freq = subscript into the array + * screen-col = col number, minus 1, on screen to write to + * screen-line = line number, minus 1, to write to + * + move 50 to viowrtcharstratt-length + move a-string (freq) to viowrtcharstratt-data + move a-color (freq) to viowrtcharstratt-attr + perform 20710-call-viowrtcharstratt + perform 30230-call-dos-beep + perform 30130-update-time-on-screen. + 30220-exit. + exit. + + ***************************************************************** + 30230-call-dos-beep. + ***************************************************************** + * + * Beeps the speaker. + * + * Inputs to this routine are the following: + * + * PAUSE = The number of 1/100 second increments to sound + * the speaker. + * FREQ = The frequency in hertz to beep. + * + if pause not = zeros + move pause to pause-dword + if sound-sw = "ON " + compute frequency = 50 * a-length (freq) + multiply 8 by pause + call api "__DosBeep" using + by value frequency + by value pause + move pause-dword to pause + else + multiply 8 by pause-dword + call api "__DosSleep" using by value pause-dword + end-if + end-if. + 30230-exit. + exit. + + / + ***************************************************************** + 30300-quick-sort. + ***************************************************************** + * + * The quick sort routine works by picking a "pivot" element in + * the array. It will move all larger elements to one + * side of the pivot and all smaller elements to the other + * side. The subscript information of the 2 members just + * swapped then is saved on a stack; the routine is entered + * again. This is repeated until the stack is exhasted. + * + move kbdcharin-char to last-choice + move quick-line-number to time-screen-line + move quick-literal to hilite-item + move "ON" to updated-screen-sw + perform 20700-display-unsorted-bars + perform 20610-get-starting-time + move 1 to lower-stack (1) + move array-max to upper-stack (1) + move 1 to stack-sub + perform until stack-sub = zeros + if lower-stack (stack-sub) not < + upper-stack (stack-sub) + subtract 1 from stack-sub + else + move lower-stack (stack-sub) to sub + move upper-stack (stack-sub) to sub-1 + move a-length (sub-1) to pivot-element + perform 30310-select-member-to-swap thru 30310-exit + until sub not < sub-1 + move upper-stack (stack-sub) to sub-1 + move upper-stack (stack-sub) to swap-line + move sub to swap-line-1 + perform 30210-swap-two-bars + perform 30320-adjust-stack + add 1 to stack-sub + end-if + end-perform + * + * The sort is completed. Clear the screen highlight around + * the elapsed time. + * + perform 30140-clear-time-hilight. + 30300-exit. + exit. + + ***************************************************************** + 30310-select-member-to-swap. + ***************************************************************** + * + * performed until sub not < sub-1 + * + perform until ((sub not < sub-1) + or (a-length (sub) > pivot-element)) + add 1 to sub + end-perform + perform until ((sub not < sub-1) + or (a-length (sub-1) < pivot-element)) + subtract 1 from sub-1 + end-perform + if sub < sub-1 + move sub to swap-line + move sub-1 to swap-line-1 + perform 30210-swap-two-bars + end-if. + 30310-exit. + exit. + + ***************************************************************** + 30320-adjust-stack. + ***************************************************************** + if (sub - lower-stack (stack-sub)) < + (upper-stack (stack-sub) - sub) + move lower-stack (stack-sub) to + lower-stack (stack-sub + 1) + compute upper-stack (stack-sub + 1) = sub - 1 + compute lower-stack (stack-sub) = sub + 1 + else + compute lower-stack (stack-sub + 1) = sub + 1 + move upper-stack (stack-sub) to + upper-stack (stack-sub + 1) + compute upper-stack (stack-sub) = sub - 1 + end-if. + 30320-exit. + exit. + + / + ***************************************************************** + 30400-shell-sort. + ***************************************************************** + * + * The shell sort begins by (1) comparing far-apart elements + * (separated by the value of the offset variable, which is + * initially half the distance between the first and the last + * elements), and then by (2) comparing closer elements. + * When offset = 1, a bubble sort is being performed. + * + move kbdcharin-char to last-choice + move shell-line-number to time-screen-line + move shell-literal to hilite-item + move "ON" to updated-screen-sw + perform 20700-display-unsorted-bars + perform 20610-get-starting-time + compute offset = array-max / 2 + perform until offset < 1 + compute max-limit = array-max - offset + move 1 to sub-2 + perform until sub-2 < 1 + move zeros to sub-2 + perform varying sub-1 from 1 by 1 + until sub-1 > max-limit + compute swap-line-1 = sub-1 + offset + if a-length (sub-1) > + a-length (swap-line-1) + move sub-1 to swap-line + perform 30210-swap-two-bars + move sub-1 to sub-2 + end-if + end-perform + compute max-limit = sub-1 - offset + end-perform + compute offset = offset / 2 + end-perform + * + * The sort has completed. Clear the screen highlight + * around the elapsed time. + * + perform 30140-clear-time-hilight. + 30400-exit. + exit. + + / + ***************************************************************** + 30500-heap-sort. + ***************************************************************** + * + * The heap sort calls two other procedures: "30510-percolate-up" + * and "30520-percolate-down". + * The percolate-up procedure turns array into a "heap" as shown + * below: + * + * array(1) + * / \ + * array(2) array(3) + * / \ / \ + * array(4) array(5) array(6) array(7) + * / \ / \ / \ / \ + * ... ...... ...... ...... ... + * + * where each "PARENT" (e.g. array(1), array(2)...) is larger + * than its "CHILD" [e.g. array(1) is a parent for + * array(2)]. + * + * Therefore, after the first "PERFORM VARYING", the largest + * array member will be in array(1). + * + * The second "PERFORM VARYING" swaps the element in array(1) with + * the element in the variable "ARRAY-MAX", rebuilds the + * heap with percolate-down for array-max - 1 and loops. + * This is continued until the array is sorted. + * + move kbdcharin-char to last-choice + move heap-line-number to time-screen-line + move heap-literal to hilite-item + move "ON" to updated-screen-sw + perform 20700-display-unsorted-bars + perform 20610-get-starting-time + perform varying sub from 2 by 1 + until sub > array-max + perform 30510-percolate-up + end-perform + perform varying sub from array-max by -1 + until sub < 2 + move sub to swap-line + move 1 to swap-line-1 + perform 30210-swap-two-bars + compute sub-1 = sub - 1 + perform 30520-percolate-down + end-perform + * + * The sort is completed. now, clear the screen highlight + * around the elapsed time. + * + perform 30140-clear-time-hilight. + 30500-exit. + exit. + + ***************************************************************** + 30510-percolate-up. + ***************************************************************** + move sub to sub-2 + move "OFF" to halt-sw + perform until ((sub-2 = 1) + or (halt-sw = "ON")) + compute parent = sub-2 / 2 + if a-length (sub-2) > a-length (parent) + move parent to swap-line + move sub-2 to swap-line-1 + perform 30210-swap-two-bars + move parent to sub-2 + else + move "ON" to halt-sw + end-if + end-perform. + 30510-exit. + exit. + + ***************************************************************** + 30520-percolate-down. + ***************************************************************** + move 1 to sub-2 + move "OFF" to halt-sw + perform until halt-sw = "ON" + compute child = 2 * sub-2 + if child > sub-1 + move "ON" to halt-sw + else + compute swap-line = child + 1 + if swap-line not > sub-1 + if a-length (swap-line) > + a-length (child) + compute child = child + 1 + end-if + end-if + if a-length (sub-2) < a-length (child) + move sub-2 to swap-line + move child to swap-line-1 + perform 30210-swap-two-bars + move child to sub-2 + else + move "ON" to halt-sw + end-if + end-if + end-perform. + 30520-exit. + exit. + + / + ***************************************************************** + 30600-insert-sort. + ***************************************************************** + * + * The insert sort compares the length of each successive element + * in array with the lengths of all the preceding elements. + * When the proper place in the array for the element is + * found insert the element and move all following elements + * down one place. + * + move kbdcharin-char to last-choice + move insert-line-number to time-screen-line + move insert-literal to hilite-item + move "ON" to updated-screen-sw + perform 20700-display-unsorted-bars + perform 20610-get-starting-time + perform varying sub from 2 by 1 + until sub > array-max + move "OFF" to halt-sw + move a-data (sub) to hold-array-element + move sub to sub-1 + perform until ((sub-1 < 2) + or (halt-sw = "ON")) + if a-length (sub-1 - 1) > h-length + move a-data (sub-1 - 1) to + a-data (sub-1) + compute screen-line = sub-1 - 1 + move 0 to screen-col + move sub-1 to freq + perform 30220-write-one-bar-to-screen + subtract 1 from sub-1 + else + move "ON" to halt-sw + end-if + end-perform + move hold-array-element to a-data (sub-1) + compute screen-line = sub-1 - 1 + move 0 to screen-col + move sub-1 to freq + perform 30220-write-one-bar-to-screen + end-perform + * + * The sort is completed. Clear the screen highlight + * around the elapsed time. + * + perform 30140-clear-time-hilight. + 30600-exit. + exit. + + / + ***************************************************************** + 30700-bubble-sort. + ***************************************************************** + * + * The bubble sort will search through array and compare + * adjacent elements with the current element. If the + * adjacent element is less than the current element, they + * will be swapped. This is done until no more elements are + * swapped. + * + move kbdcharin-char to last-choice + move bubble-line-number to time-screen-line + move bubble-literal to hilite-item + move "ON" to updated-screen-sw + perform 20700-display-unsorted-bars + perform 20610-get-starting-time + move array-max to max-loop + move 99 to last-element-saved + perform until last-element-saved = zeros + move zeros to last-element-saved + perform varying sub from 1 by 1 + until sub > (max-loop - 1) + if a-length (sub) > a-length (sub + 1) + move sub to swap-line swap-line-1 + add 1 to swap-line-1 + perform 30210-swap-two-bars + move sub to last-element-saved + end-if + end-perform + move last-element-saved to max-loop + end-perform + * + * The sort is completed. Clear the screen highlight + * around the elapsed time. + * + perform 30140-clear-time-hilight. + 30700-exit. + exit. + + / + ***************************************************************** + 30800-slow-down-the-sort. + ***************************************************************** + * + * User typed the ">" key, increase the time the beep sounds. + * + if pause not = 30 + add 1 to pause + if pause = 1 + if auto-sound-toggle-sw = "ON" + move "ON " to sound-sw + move "ON" to updated-screen-sw + move "OFF" to auto-sound-toggle-sw + end-if + end-if + move pause to disp-pause + perform 30810-update-speed-variables + if updated-screen-sw = "ON" + move "OFF" to updated-screen-sw + perform 20700-display-unsorted-bars + perform 20800-display-menu-screen + else + perform 30820-update-screen-speed + perform 30830-update-screen-prompts + end-if + end-if. + 30800-exit. + exit. + + ***************************************************************** + 30810-update-speed-variables. + ***************************************************************** + evaluate pause + when 30 move spaces to ms-slow-down-var + move space to ms-slow-down-char + when 29 move menu-screen-slow-down-msg to + ms-slow-down-var + move menu-screen-slow-down-lit to + ms-slow-down-char + when 1 move menu-screen-speed-up-msg + to ms-speed-up-var + move menu-screen-speed-up-lit + to ms-speed-up-char + move menu-screen-toggle-sound-msg + to ms-toggle-sound-var + move menu-screen-toggle-sound-lit + to ms-toggle-sound-char + when 0 move spaces to ms-speed-up-var + move space to ms-speed-up-char + move space to ms-toggle-sound-var + move space to ms-toggle-sound-char + end-evaluate. + 30810-exit. + exit. + + ***************************************************************** + 30820-update-screen-speed. + ***************************************************************** + * + * Updates the speed counter on the screen. + * + move 30 to viowrtcharstratt-length + compute screen-line = speed-counter-line-number - 1 + move 50 to screen-col + move menu-screen-line (speed-counter-line-number) to + viowrtcharstratt-data + move menu-screen-hilite-attr to viowrtcharstratt-attr + perform 20710-call-viowrtcharstratt. + 30820-exit. + exit. + + ***************************************************************** + 30830-update-screen-prompts. + ***************************************************************** + * + * This routine updates the prompts on the screen that inform the + * user that they can speed up or slow down the sort at will by + * using the "<" and ">" keys. + * + * Also updated is the "Cobol" sort menu entry. If the speed of + * the sort is zero, "Cobol" is printed in bold characters, + * otherwise, it is printed in dim characters (indicating the + * the option can not be chosen). + * + move 30 to viowrtcharstratt-length + move menu-screen-hilite-attr to viowrtcharstratt-attr + move 50 to screen-col + evaluate true + when pause = 30 or = 29 + perform 30840-write-slow-down-prompts + when pause = 0 + perform 30850-write-speed-up-prompts + perform 30860-hilite-cobol-sort + when pause = 1 + perform 30850-write-speed-up-prompts + perform 20810-unhilite-cobol-sort + end-evaluate + if msg-line not = spaces + move spaces to msg-line + perform 30110-update-message-line + end-if. + 30830-exit. + exit. + + ***************************************************************** + 30840-write-slow-down-prompts. + ***************************************************************** + * + * This routine writes the prompts that tells the user how to + * use the ">" key. + * + move menu-screen-slow-down-line to + viowrtcharstratt-data + compute screen-line = slow-down-line-number - 1 + perform 20710-call-viowrtcharstratt + move menu-screen-choice-line to viowrtcharstratt-data + compute screen-line = prompt-line-number - 1 + perform 20710-call-viowrtcharstratt. + 30840-exit. + exit. + + ***************************************************************** + 30850-write-speed-up-prompts. + ***************************************************************** + * + * This routine writes the prompts that tells the user how to + * use the "<" key. + * + move menu-screen-speed-up-line to + viowrtcharstratt-data + compute screen-line = speed-up-line-number - 1 + perform 20710-call-viowrtcharstratt + move menu-screen-choice-line to viowrtcharstratt-data + compute screen-line = prompt-line-number - 1 + perform 20710-call-viowrtcharstratt. + 30850-exit. + exit. + + ***************************************************************** + 30860-hilite-cobol-sort. + ***************************************************************** + * + * Print "Cobol" on the menu, in highlighted attributes. Because + * it is printed in highlighted attributes, this indicates + * that the option may chosen. + * + move 28 to viowrtcharstratt-length + compute screen-line = cobol-table-line-number - 1 + move 51 to screen-col + move spaces to hilite-screen-data-item + move menu-screen-cobol-lit-tab to hilite-item + move menu-screen-hilite-attr to viowrtcharstratt-attr + move hilite-screen-data-item to viowrtcharstratt-data + perform 20710-call-viowrtcharstratt. + move 28 to viowrtcharstratt-length + compute screen-line = cobol-line-number - 1 + move 51 to screen-col + move spaces to hilite-screen-data-item + move menu-screen-cobol-lit to hilite-item + move menu-screen-hilite-attr to viowrtcharstratt-attr + move hilite-screen-data-item to viowrtcharstratt-data + perform 20710-call-viowrtcharstratt. + 30860-exit. + exit. + + ***************************************************************** + 30900-speed-up-the-sort. + ***************************************************************** + * + * User typed the "<" key, decrease the time the beep sounds. + * + if pause not = zeros + subtract 1 from pause + if pause = zeros + if sound-sw = "ON " + move "OFF" to sound-sw + move "ON" to auto-sound-toggle-sw + move "ON" to updated-screen-sw + end-if + end-if + move pause to disp-pause + perform 30810-update-speed-variables + if updated-screen-sw = "ON" + move "OFF" to updated-screen-sw + perform 20700-display-unsorted-bars + perform 20800-display-menu-screen + else + perform 30820-update-screen-speed + perform 30830-update-screen-prompts + end-if + end-if. + 30900-exit. + exit. + + ***************************************************************** + 31000-toggle-sound. + ***************************************************************** + * + * Toggle the sound on or off. + * + if pause not = zeros + move "OFF" to auto-sound-toggle-sw + if sound-sw = "OFF" + move "ON " to sound-sw + else + move "OFF" to sound-sw + end-if + move 30 to viowrtcharstratt-length + compute screen-line = sound-sw-line-number - 1 + move 50 to screen-col + move menu-screen-line (sound-sw-line-number) to + viowrtcharstratt-data + move menu-screen-hilite-attr to viowrtcharstratt-attr + perform 20710-call-viowrtcharstratt + if msg-line not = spaces + move spaces to msg-line + perform 30110-update-message-line + end-if + end-if. + 31000-exit. + exit. + + **************************************************************** + 31100-randomize-array. + **************************************************************** + * + * Re-randomize the bars on the screen. + * + move spaces to hilite-screen-data-item + move randomize-literal to hilite-item + move randomize-line-number to time-screen-line + move zeros to elapsed + move menu-screen-revvid-attr to viowrtcharstratt-attr + perform 30120-write-time-on-screen + move spaces to msg-line + move wait-msg to msg-line + perform 30110-update-message-line + perform 20600-init-unsorted-array + perform 20700-display-unsorted-bars + perform 20800-display-menu-screen. + 31100-exit. + exit. + + ***************************************************************** + 31200-select-previous-choice. + ***************************************************************** + * + * The up-arrow key was typed. Depending on the last choice + * taken, perform the proper sort. + * + evaluate true + when last-choice = space + perform 30700-bubble-sort + move "B" to last-choice + when last-choice = "F" or = "f" + perform 30100-cobol-sort + move "C" to last-choice + when last-choice = "E" or = "e" + perform 30100-cobol-sort + move "F" to last-choice + when last-choice = "Q" or = "q" + perform 30200-exchange-sort + move "E" to last-choice + when last-choice = "S" or = "s" + perform 30300-quick-sort + move "Q" to last-choice + when last-choice = "H" or = "h" + perform 30400-shell-sort + move "S" to last-choice + when last-choice = "I" or = "i" + perform 30500-heap-sort + move "H" to last-choice + when last-choice = "B" or = "b" + perform 30600-insert-sort + move "I" to last-choice + when last-choice = "C" or "c" + perform 30700-bubble-sort + move "B" to last-choice + end-evaluate. + 31200-exit. + exit. + + ***************************************************************** + 31300-select-next-choice. + ***************************************************************** + * + * The down-arrow key was typed. Depending on the last sort + * execute the proper sort. + * + evaluate true + when last-choice = space + perform 30100-cobol-sort + move "C" to last-choice + when last-choice = "C" or "c" + perform 30100-cobol-sort + move "F" to last-choice + when last-choice = "F" or "f" + perform 30200-exchange-sort + move "E" to last-choice + when last-choice = "E" or = "e" + perform 30300-quick-sort + move "Q" to last-choice + when last-choice = "Q" or = "q" + perform 30400-shell-sort + move "S" to last-choice + when last-choice = "S" or = "s" + perform 30500-heap-sort + move "H" to last-choice + when last-choice = "H" or = "h" + perform 30600-insert-sort + move "I" to last-choice + when last-choice = "I" or = "i" + perform 30700-bubble-sort + move "B" to last-choice + when last-choice = "B" or = "b" + perform 30100-cobol-sort + move "C" to last-choice + end-evaluate. + 31300-exit. + exit. + + ***************************************************************** + 40000-restore-users-video-mode. + ***************************************************************** + * + * Restore the original video mode before quitting. + * + move viomode-save-data to viomode-data. + perform 20330-call-viosetmode. + 40000-exit. + exit. + + ***************************************************************** + 99999-os2-error-abort. + ***************************************************************** + * + * Reports an OS/2 API error. + * + * Inputs to the routine are the following: + * + * RETURN-CODE = OS/2 error code returned from the OS/2 + * routine. + * + display "AX = " , return-code + display "PROGRAM IS ABORTING" + stop run. + 99999-exit. + exit. + + / + ***************************************************************** + sort-input-procedure-section section. + sort-input-start. + ***************************************************************** + perform varying sub from 1 by 1 + until sub > array-max + release sort-rec from a-data (sub) + end-perform. + sort-input-exit. + exit. + + ***************************************************************** + sort-output-procedure-section section. + sort-output-start. + ***************************************************************** + perform varying sub from 1 by 1 + until sub > array-max + return sort-file into a-data (sub) + compute screen-line = sub - 1 + move sub to freq + move 0 to screen-col + move 50 to viowrtcharstratt-length + move a-string (freq) to viowrtcharstratt-data + move a-color (freq) to viowrtcharstratt-attr + perform 20710-call-viowrtcharstratt + end-perform + perform 30130-update-time-on-screen. + sort-output-exit. + exit. + + \ No newline at end of file diff --git a/Microsoft COBOL v45/DEMO/SQL/SQLCA.CPY b/Microsoft COBOL v45/DEMO/SQL/SQLCA.CPY new file mode 100644 index 0000000..36943d9 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/SQL/SQLCA.CPY @@ -0,0 +1,20 @@ + 01 SQLCA. + 05 SQLCAID PIC X(8). + 05 SQLCABC PIC S9(9) COMP-5. + 05 SQLCODE PIC S9(9) COMP-5. + 05 SQLERRM. + 49 SQLERRML PIC S9(4) COMP-5. + 49 SQLERRMC PIC X(70). + 05 SQLERRP PIC X(8). + 05 SQLERRD PIC S9(9) COMP-5 OCCURS 6. + 05 SQLWARN. + 10 SQLWARN0 PIC X. + 10 SQLWARN1 PIC X. + 10 SQLWARN2 PIC X. + 10 SQLWARN3 PIC X. + 10 SQLWARN4 PIC X. + 10 SQLWARN5 PIC X. + 10 SQLWARN6 PIC X. + 10 SQLWARN7 PIC X. + 05 SQLEXT PIC X(8). + diff --git a/Microsoft COBOL v45/DEMO/SQL/SQLDDLEX.CBL b/Microsoft COBOL v45/DEMO/SQL/SQLDDLEX.CBL new file mode 100644 index 0000000..62fd59e --- /dev/null +++ b/Microsoft COBOL v45/DEMO/SQL/SQLDDLEX.CBL @@ -0,0 +1,970 @@ + $set mf warning(3) + $set sql sqlinit + *************************************************************** + * * + * (c) Micro Focus Ltd. 1990 * + * * + * SQLDDLEX * + * * + * This program executes single or multiple SQL DDL * + * Data Definition Language statements from a file * + * defined by user parameters. * + * Parameters may be command line, file or interactive. * + * SQL DDL statements must be delimited, the delimiter * + * is specified by user parameter, the default is <;> * + * (semi-colon). * + * * + * FILES * + * ===== * + * * + * 1. parameter-ds * + * * + * This file is read-only, and can contain parameters * + * to control the execution of the program in 'batch' * + * or 'detached' run modes. * + * * + * The name of this file is hard coded. * + * * + * 2. message-ds * + * * + * This file is write-only, and logs program activity. * + * Each run appends to the file, so occasional clearing * + * is required. * + * * + * The name of this file is hard coded. * + * * + * 3. dbmddl-ds * + * * + * This file is read-only, and contains the OS/2 * + * Database Manager SQL Data Definition Language (DDL) * + * which is to be executed against the database * + * in the parameters. * + * * + * The name of this file is specified by parameter. * + * * + * RUNNING * + * ======= * + * * + * The program is controlled by parameters. * + * The parameters may be specified interactively, * + * in a file, and on the command line. * + * * + * These methods of specifying parameters may be * + * mixed by entering the correct run MODE TYPE (MT) * + * parameter when invoking the program. * + * * + *************************************************************** + environment division. + *===================== + configuration section. + *====================== + special-names. + *============== + command-line is os2-cmd-line. + * + input-output section. + *===================== + * + file-control. + *============= + * + select parameter-ds + assign to dynamic parameter-ds-z1 + organization is line sequential + file status is file-status-z1 + . + select message-ds + assign to dynamic message-ds-z1 + organization is line sequential + file status is file-status-z1 + . + select dbmddl-ds + assign to dynamic dbmddl-ds-z1 + organization is line sequential + file status is file-status-z1 + . + + data division. + *============== + + file section. + *============= + + fd parameter-ds + recording mode v. + *================= + + 01 parameter-rec. + 03 parameter-line pic x(80). + + fd message-ds. + *============== + + 01 message-rec. + 03 message-line pic x(80). + + fd dbmddl-ds. + *============= + + 01 dbmddl-rec. + 03 dbmddl-line pic x(80). + * Redefines enables character by character move of DDL + * into the PREPARE buffer to remove redundant spaces + 03 dbmddl-char + redefines + dbmddl-line pic x + occurs 80. + + working-storage section. + *======================== + * + exec sql include sqlca end-exec. + + exec sql begin declare section end-exec. + + * Large buffer for SQL PREPARE + 01 dbm-util-a0. + 03 dbm-statement-a0. + 49 dbm-statement-len-a0 pic s9(4) comp-5. + 49 dbm-statement-text-a0 pic x(32640). + + exec sql end declare section end-exec. + + * Area for set up of PREPARE buffer defined as occurs + * to enable character by character move / space stripping + 01 dbm-util-a1. + 03 dbm-statement-a1. + 49 dbm-ddl-char-a1 pic x + occurs 32640. + + * Log file formatted message area + 01 message-line-01-a1. + 03 message-lines-a1. + 05 mess-line-1-a1. + 07 margin-a1 pic x(20). + 07 literal-1-1-a1 pic x(8). + 07 date-a1 pic x(8). + 07 literal-1-2-a1 pic x(8). + 07 time-a1 pic x(6). + 07 space-1-1-a1 pic x(30). + 05 mess-line-2-a1. + 07 mess-text-a1. + 09 param-name-a1 pic x(2). + 09 space-2-1-a1 pic x(6). + 09 param-value-a1 pic x(32). + 09 space-2-2-a1 pic x(30). + 07 mess-dbmcode-a1 pic -9(9). + 03 message-line-n-a1 + redefines + message-lines-a1 pic x(80) + occurs 2. + + * Flags, hard coded names, counts, file status etc + 01 utils-z1. + 03 delimiter-found-z1 pic s9(4) comp-5. + 03 dbm-statement-found-z1 pic s9(4) comp-5. + 03 date-z1 pic x(6). + 03 time-z1 pic x(8). + 03 parameter-ds-z1 pic x(64) + value + 'd:\test\SQLDDLEX\SQLDDLEX.par'. + 03 end-parameter-ds-z1 pic s9(4) comp-5 + value -1. + 03 end-dbmddl-ds-z1 pic s9(4) comp-5 + value -1. + 03 message-ds-z1 pic x(64) + value + 'd:\test\SQLDDLEX\SQLDDLEX.log '. + 03 dbmddl-ds-z1 pic x(64). + + 03 dbm-message-z1. + 05 dbm-message-text-z1 pic x(70). + 05 dbmcode-z1 pic -9(9). + 03 dbm-error-z1 pic s9(4) comp-5 + value -1. + 03 dbm-codes-allowable-z1. + 05 allow-dbmcode-z1 pic s9(4) comp-5. + 03 files-opened-z1. + 05 message-ds-open-z1 pic s9(4) comp-5. + 05 parameter-ds-open-z1 pic s9(4) comp-5. + 05 dbmddl-ds-open-z1 pic s9(4) comp-5. + 03 file-status-z1 pic x(2). + 03 last-file-status-z1. + 05 last-file-status-x-z1 pic x. + 05 last-file-status-b-z1 pic 99 comp-x. + 03 display-file-status-z1. + 05 literal-status-z1 pic xx + value "9/". + 05 display-status-z1 pic 999. + 03 current-file-z1 pic x(12) + value space. + 03 mt-parameter-found-z1 pic s9(4) comp-5. + 03 mode-type-save-z1 pic x(2). + 03 char-sub-1-z1 pic s9(4) comp-5. + 03 char-sub-2-z1 pic s9(4) comp-5. + 03 dbm-statement-sub-z1 pic s9(4) comp-5. + 03 ddl-char-action-z1 pic s9(4) comp-5. + + * Area for parameter storage in correct pictures + 01 parameters-z2. + 03 mode-z2 pic x. + 03 db-z2 pic x(8). + 03 delimiter-z2 pic x + value ";". + 03 dbmddl-ds-z2 pic x(64). + + * Area for parameter specification + 01 parameter-util-z3. + 03 param-cmd-line-z3. + 05 param-cmd-line-1-z3 pic x(120). + 03 parameter-name-z3 pic x(4). + 03 parameter-value-z3 pic x(64). + 03 parameter-error-z3 pic s9(4) comp-5 + value -1. + 03 last-parameter-z3 pic s9(4) comp-5 + value -1. + 03 parameter-table-z3. + 05 parameter-1-z3 pic x(2) + value 'MT'. + 05 parameter-1-ok-z3 pic s9(4) comp-5. + 05 parameter-2-z3 pic x(2) + value 'DB'. + 05 parameter-2-ok-z3 pic s9(4) comp-5. + 05 parameter-3-z3 pic x(2) + value 'DL'. + 05 parameter-3-ok-z3 pic s9(4) comp-5. + 05 parameter-4-z3 pic x(2) + value 'FN'. + 05 parameter-4-ok-z3 pic s9(4) comp-5. + 03 parameters-z3 + redefines + parameter-table-z3 occurs 4. + 05 parameter-name-n-z3 pic x(2). + 05 parameter-ok-n-z3 pic s9(4) comp-5. + 03 parameter-subscript-z3 pic s9(4) comp-5. + 03 get-pars-type-z3 pic x. + + * Temporary area for parameters whilst checked + 01 parameter-util-z4. + 03 param-cmd-line-z4. + 05 param-cmd-line-1-z4 pic x(120). + 03 parameter-name-z4 pic x(4). + 03 parameter-value-z4 pic x(64). + 03 parameter-error-z4 pic s9(4) comp-5 + value -1. + 03 parameter-table-z4. + 05 param-val-1-z4 pic x(64). + 05 param-val-2-z4 pic x(64). + 05 param-val-3-z4 pic x(64). + 05 param-val-4-z4 pic x(64). + 03 parameters-z4 + redefines + parameter-table-z4 occurs 4. + 05 param-val-n-z4 pic x(64). + 03 parameter-subscript-z4 pic s9(4) comp-5. + + * Data items for DBM CALL to start_using_database + 01 dbm-call. + 03 spare1 pic 9(4) comp-5 value 0. + 03 db-length pic 9(4) comp-5 value 0. + 03 spare2 pointer. + 03 database pic x(10). + 03 d-use pic 9(4) comp-5. + 03 u pic x redefines d-use. + + procedure division. + *=================== + * + a-1-start. + *========== + * + * Start up and main control + perform a-2-initial + if parameter-error-z3 negative + if parameter-ok-n-z3(2) positive + and parameter-ok-n-z3(4) positive + perform a-3-main + else + move "Not all mandatory parameters specified" + to message-line + perform z-1-write-message-rec + end-if + end-if + perform z-9-stop + . + * + a-2-initial. + *============ + * + * Examine command line invoking program and ensure + * at least MT (mode type) parameter specified + * + * Initialise log for this run, control parameter read and check + * + move -1 to message-ds-open-z1 + move -1 to parameter-ds-open-z1 + move -1 to allow-dbmcode-z1 + accept param-cmd-line-z4 from os2-cmd-line + unstring param-cmd-line-z4 + delimited by space + into + param-val-n-z4(1) + param-val-n-z4(2) + param-val-n-z4(3) + param-val-n-z4(4) + end-unstring + move -1 to mt-parameter-found-z1 + perform with test before + varying parameter-subscript-z4 + from 1 + by 1 + until parameter-subscript-z4 > 4 + or mt-parameter-found-z1 positive + move space to parameter-name-z4 + move space to parameter-value-z4 + unstring param-val-n-z4(parameter-subscript-z4) + delimited by "=" + into + parameter-name-z4 + parameter-value-z4 + end-unstring + if parameter-name-z4 = "MT" + move 1 to mt-parameter-found-z1 + move parameter-value-z4 to mode-type-save-z1 + end-if + end-perform + move 'Messages' to current-file-z1 + open extend message-ds + if file-status-z1 = '00' + move 1 to message-ds-open-z1 + else + move file-status-z1 to last-file-status-z1 + perform z-4-bad-file-status + perform z-9-stop + end-if + accept date-z1 from date + accept time-z1 from time + move space to message-line-01-a1 + move "===> SQLDDLEX" to margin-a1 + move " Date: " to literal-1-1-a1 + move date-z1 to date-a1 + move " Time: " to literal-1-2-a1 + move time-z1 to time-a1 + move message-line-n-a1(1) to message-line + perform z-1-write-message-rec + move space to message-line-01-a1 + if mt-parameter-found-z1 negative + move "No mode type parameter specified" + to message-line + perform z-1-write-message-rec + move 1 to parameter-error-z3 + end-if + perform with test before + varying parameter-subscript-z3 + from 1 by 1 + until parameter-subscript-z3 > 4 + move -1 + to parameter-ok-n-z3(parameter-subscript-z3) + end-perform + perform a-4-help + perform a-9-parameter-sequence + . + * + a-3-main. + *========= + * + * + * Parameters are OK, so now open up the DDL file and start + * using the correct datbase. + * + * Control for the reception and execution of DDL statements + * + move 'SQLDDL' to current-file-z1 + open input dbmddl-ds + if file-status-z1 = '00' + move 1 to dbmddl-ds-open-z1 + else + move file-status-z1 to last-file-status-z1 + perform z-4-bad-file-status + perform z-9-stop + end-if + move "++++++++ DDL follows (if found) ++++++++" + to message-line + perform z-1-write-message-rec + move db-z2 to database + move zero to db-length + inspect database + tallying db-length + for characters before initial space + * Value 83 here causes character in u data item of CALL + * This sets database usage to SHARE + move 83 to d-use + call "__SQLGSTPD" + using sqlca + if sqlcode not = 0 + perform z-2-dbm-error + end-if + call "__SQLGSTRD" + using database + spare2 + sqlca + by value d-use + by value db-length + by value spare1 + if sqlcode not = 0 + perform z-2-dbm-error + end-if + perform with test before + until end-dbmddl-ds-z1 positive + or dbm-error-z1 positive + perform b-3-1-get-ddl-statement + if dbm-statement-found-z1 positive + perform b-3-2-exec-ddl-statement + end-if + end-perform + . + * + a-4-help. + *========= + * + * If no parameters specified or help requested + * put parameter details into LG + * + if param-cmd-line-z4 = space + or param-cmd-line-z4 = "H" + or param-cmd-line-z4 = "h" + or param-cmd-line-z4 = "HELP" + or param-cmd-line-z4 = "Help" + or param-cmd-line-z4 = "help" + move 1 to parameter-error-z3 + move "Parameter names and meaning/values follow." + to message-line + perform z-1-write-message-rec + move "Parameters can be in any sequence." + to message-line + perform z-1-write-message-rec + perform z-1-write-message-rec + move "MT=0" + to message-line + perform z-1-write-message-rec + move "DL=" + to message-line + perform z-1-write-message-rec + move "FN=" + to message-line + perform z-1-write-message-rec + perform z-1-write-message-rec + end-if + . + * + a-5-file-parameters. + *==================== + * + * Initialisation and control of reception of file parameters + * + if parameter-error-z3 negative + move 'Parameters' to current-file-z1 + open input parameter-ds + if file-status-z1 = '00' + move 1 to parameter-ds-open-z1 + else + move file-status-z1 to last-file-status-z1 + perform z-4-bad-file-status + perform z-9-stop + end-if + perform b-2-1-get-pars-f + end-if + . + * + a-6-command-parameters. + *======================= + * + * Control of reception of command line parameters + * + if parameter-error-z3 negative + perform b-2-0-get-pars-c + end-if + . + * + a-7-interactive-parameters. + *=========================== + * + * Control of reception of interactive parameters + * + if parameter-error-z3 negative + perform b-2-2-get-pars-i + end-if + . + * + a-9-parameter-sequence. + *======================= + * + * LOTS OF CHOICE HERE - ALL POSSIBLE COMBINATIONS + * You may want to comment out the ones you don't want active + * + * The differing sequence of reading parameters may offer a + * suitable choice for your environment or specific needs + * + * NOTE that the MT parameter is ONLY valid on the command line + * + if parameter-error-z3 negative + evaluate true + when mode-type-save-z1 = "1" + perform a-6-command-parameters + when mode-type-save-z1 = "2" + perform a-5-file-parameters + when mode-type-save-z1 = "3" + perform a-7-interactive-parameters + when mode-type-save-z1 = "4" + perform a-6-command-parameters + perform a-5-file-parameters + when mode-type-save-z1 = "5" + perform a-5-file-parameters + perform a-6-command-parameters + when mode-type-save-z1 = "6" + perform a-6-command-parameters + perform a-7-interactive-parameters + when mode-type-save-z1 = "7" + perform a-7-interactive-parameters + perform a-6-command-parameters + when mode-type-save-z1 = "8" + perform a-5-file-parameters + perform a-7-interactive-parameters + when mode-type-save-z1 = "9" + perform a-7-interactive-parameters + perform a-5-file-parameters + when mode-type-save-z1 = "10" + perform a-6-command-parameters + perform a-7-interactive-parameters + perform a-5-file-parameters + when mode-type-save-z1 = "11" + perform a-7-interactive-parameters + perform a-6-command-parameters + perform a-5-file-parameters + when mode-type-save-z1 = "12" + perform a-6-command-parameters + perform a-5-file-parameters + perform a-7-interactive-parameters + when mode-type-save-z1 = "13" + perform a-5-file-parameters + perform a-6-command-parameters + perform a-7-interactive-parameters + when mode-type-save-z1 = "14" + perform a-5-file-parameters + perform a-7-interactive-parameters + perform a-6-command-parameters + when mode-type-save-z1 = "15" + perform a-7-interactive-parameters + perform a-5-file-parameters + perform a-6-command-parameters + when other + move "Invalid mode type (MT) specified follows:" + to message-line + perform z-1-write-message-rec + move mode-type-save-z1 + to message-line + perform z-1-write-message-rec + move 1 to parameter-error-z3 + end-evaluate + end-if + . + * + b-2-0-get-pars-c. + *================= + * + * Get parameters from the command line + * LOG the source and each parameter + * + move 'Command line parameters:' + to message-line + perform z-1-write-message-rec + perform with test before + varying parameter-subscript-z4 + from 1 + by 1 + until parameter-subscript-z4 > 4 + or parameter-error-z3 positive + or last-parameter-z3 positive + move space to parameter-name-z4 + move space to parameter-value-z4 + unstring param-val-n-z4(parameter-subscript-z4) + delimited by "=" + into + parameter-name-z4 + parameter-value-z4 + end-unstring + if parameter-name-z4 = space + move 1 to last-parameter-z3 + else + move parameter-name-z4 + to parameter-name-z3 + move parameter-value-z4 + to parameter-value-z3 + move 'C' to get-pars-type-z3 + perform c-2-0-what-par + end-if + end-perform + . + * + b-2-1-get-pars-f. + *================= + * + * Get and control check for parameters from the parameter file + * LOG the source and each parameter + * + move 'File parameters file name follows:' + to message-line + perform z-1-write-message-rec + move parameter-ds-z1 + to message-line + perform z-1-write-message-rec + perform until end-parameter-ds-z1 = 1 + or parameter-error-z3 positive + read parameter-ds + at end + move 1 to end-parameter-ds-z1 + end-read + if end-parameter-ds-z1 negative + unstring parameter-line + delimited by '=' + into parameter-name-z3 + parameter-value-z3 + end-unstring + move 'F' to get-pars-type-z3 + perform c-2-0-what-par + end-if + end-perform + . + * + b-2-2-get-pars-i. + *================= + * + * Get and control check for parameters from the screen + * LOG the source and each parameter + * + move 'Interactive parameters:' + to message-line + perform z-1-write-message-rec + perform varying parameter-subscript-z3 + from 2 + by 1 + until parameter-subscript-z3 > 4 + move parameter-name-n-z3(parameter-subscript-z3) + to parameter-name-z3 + if parameter-ok-n-z3(parameter-subscript-z3) + negative + display 'Please enter value for ' + parameter-name-z3 + accept parameter-value-z3 + move 'I' to get-pars-type-z3 + perform c-2-0-what-par + end-if + end-perform + . + * + b-3-1-get-ddl-statement. + *======================== + * + * Move the DDL file SQL statements into the PREPARE buffer + * one character at a time, ignoring redundant spaces and comments + * until the delimiter is reached or file end on the DDL file + * LOG each line read from the DDL file + * + move -1 to delimiter-found-z1 + move zero to dbm-statement-sub-z1 + move -1 to dbm-statement-found-z1 + perform until delimiter-found-z1 positive + or end-dbmddl-ds-z1 positive + perform z-3-read-dbmddl-ds + if end-dbmddl-ds-z1 negative + move dbmddl-rec to message-line + perform z-1-write-message-rec + perform with test before + varying char-sub-1-z1 + from 1 by 1 + until char-sub-1-z1 > 80 + if char-sub-1-z1 < 80 + add 1 char-sub-1-z1 + giving char-sub-2-z1 + end-if + if dbmddl-char(char-sub-1-z1) + = space + and dbmddl-char(char-sub-2-z1) + = space + move 0 to ddl-char-action-z1 + end-if + if dbmddl-char(char-sub-1-z1) + not = space + and dbmddl-char(char-sub-1-z1) + not = delimiter-z2 + and dbmddl-char(char-sub-1-z1) + not = "-" + move 1 to ddl-char-action-z1 + add 1 to dbm-statement-sub-z1 + move dbmddl-char(char-sub-1-z1) + to dbm-ddl-char-a1(dbm-statement-sub-z1) + move 1 to dbm-statement-found-z1 + end-if + if dbmddl-char(char-sub-1-z1) + = space + and dbmddl-char(char-sub-2-z1) + not = space + move 2 to ddl-char-action-z1 + add 1 to dbm-statement-sub-z1 + move dbmddl-char(char-sub-1-z1) + to dbm-ddl-char-a1(dbm-statement-sub-z1) + end-if + if dbmddl-char(char-sub-1-z1) + = space + and char-sub-1-z1 = 80 + move 2 to ddl-char-action-z1 + add 1 to dbm-statement-sub-z1 + move dbmddl-char(char-sub-1-z1) + to dbm-ddl-char-a1(dbm-statement-sub-z1) + end-if + if dbmddl-char(char-sub-1-z1) + = "-" + and dbmddl-char(char-sub-2-z1) + = "-" + move 3 to ddl-char-action-z1 + move 80 to char-sub-1-z1 + end-if + if dbmddl-char(char-sub-1-z1) + = delimiter-z2 + move 4 to ddl-char-action-z1 + move 1 to delimiter-found-z1 + move dbm-statement-sub-z1 + to dbm-statement-len-a0 + end-if + end-if + end-perform + move dbm-statement-a1 to dbm-statement-text-a0 + . + * + b-3-2-exec-ddl-statement. + *========================= + * + * PREPARE and EXECUTE the DDL statement from the buffer + * LOG the SQLCODEs + * + exec sql + prepare dbmddl1 + from :dbm-statement-a0 + end-exec + if sqlcode not = 0 + perform z-2-dbm-error + end-if + move "**** PREPARE SQL CODE:" + to dbm-message-text-z1 + move sqlcode to dbmcode-z1 + move dbm-message-z1 to message-line + perform z-1-write-message-rec + exec sql + execute dbmddl1 + end-exec + if sqlcode not = 0 + perform z-2-dbm-error + end-if + move "**** EXECUTE SQL CODE:" + to dbm-message-text-z1 + move sqlcode to dbmcode-z1 + move dbm-message-z1 to message-line + perform z-1-write-message-rec + . + * + c-2-0-what-par. + *=============== + * + * Determine which parameter type is current + * Control specific check for each type + * + move space to mess-line-2-a1 + string parameter-name-z3 delimited by space + "=" delimited by size + into param-name-a1 + end-string + move parameter-value-z3 to param-value-a1 + move mess-line-2-a1 to message-line + perform z-1-write-message-rec + evaluate true + when parameter-name-z3 = 'MT' + perform c-2-2-mode + when parameter-name-z3 = 'DB' + perform c-2-3-db + when parameter-name-z3 = 'DL' + perform c-2-4-dl + when parameter-name-z3 = 'FN' + perform c-2-5-fn + when other + perform c-2-1-pars-error + end-evaluate + . + * + c-2-1-pars-error. + *================= + * + * LOG parameter error and current parameter + * + move 1 to parameter-error-z3 + if get-pars-type-z3 not = 'C' + and parameter-name-z3 = 'MT' + move 'MT invalid from file or interactive' + to message-line + perform z-1-write-message-rec + else + move 'Unknown or invalid parameter specified' + to message-line + perform z-1-write-message-rec + end-if + move 'See last parameter in above list.' + to message-line + perform z-1-write-message-rec + . + * + c-2-2-mode. + *=========== + * + * Specific check/move for MODE TYPE + * + if parameter-error-z3 negative + move parameter-value-z3 to mode-z2 + move 1 to parameter-ok-n-z3(1) + if get-pars-type-z3 not = 'C' + perform c-2-1-pars-error + end-if + end-if + . + * + c-2-3-db. + *========= + * + * Specific check/move for DATABASE + * + if parameter-error-z3 negative + move parameter-value-z3 to db-z2 + move 1 to parameter-ok-n-z3(2) + end-if + . + * + c-2-4-dl. + *========= + * + * Specific check/move for DELIMITER + * + if parameter-error-z3 negative + move parameter-value-z3 to delimiter-z2 + move 1 to parameter-ok-n-z3(3) + end-if + . + * + c-2-5-fn. + *========= + * + * Specific check/move for file name + * + if parameter-error-z3 negative + move parameter-value-z3 to dbmddl-ds-z1 + move parameter-value-z3 to dbmddl-ds-z2 + move 1 to parameter-ok-n-z3(4) + end-if + . + * + z-1-write-message-rec. + *====================== + * + * Write out a line to the LOG File + * + write message-rec + move space to message-line + . + * + z-2-dbm-error. + *============== + * + * SQLCODE was bad, so write message and code to LOG + * + if sqlcode not = allow-dbmcode-z1 + move 1 to dbm-error-z1 + move sqlcode to dbmcode-z1 + move 'sqlcode returned with bad value' + to dbm-message-text-z1 + move dbm-message-z1 to message-line + perform z-1-write-message-rec + move "SQLCA sqlerrmc contents follow:" + to message-line + perform z-1-write-message-rec + move sqlerrmc + to dbm-message-text-z1 + move dbm-message-z1 to message-line + perform z-1-write-message-rec + perform z-9-stop + . + * + z-3-read-dbmddl-ds. + *=================== + * + * Read the DDL file + * + read dbmddl-ds + at end + move 1 to end-dbmddl-ds-z1 + . + * + z-4-bad-file-status. + *==================== + * + * LOG bad file status code + * + move "Bad file status on open." + to message-line + perform z-1-write-message-rec + move "File name and status follow:" + to message-line + perform z-1-write-message-rec + move current-file-z1 + to message-line + perform z-1-write-message-rec + move last-file-status-b-z1 + to display-status-z1 + move display-file-status-z1 + to message-line + perform z-1-write-message-rec + . + * + z-9-stop. + *========= + * + * JOY or MISERY depending on what happened back there + * LOG end of run <==== EYECATCHER <==== + * + move "<=== End of RUN" to message-line + perform z-1-write-message-rec + perform z-9-100 + perform z-9-999 + . + * + z-9-100. + *======== + * + if parameter-ds-open-z1 positive + close parameter-ds + end-if + if message-ds-open-z1 positive + close message-ds + end-if + if dbmddl-ds-open-z1 positive + close dbmddl-ds + end-if + . + * + z-9-999. + *======== + * + * Finally its all over! + * + stop run + . + \ No newline at end of file diff --git a/Microsoft COBOL v45/DEMO/SQL/SQLDEMO.CBL b/Microsoft COBOL v45/DEMO/SQL/SQLDEMO.CBL new file mode 100644 index 0000000..9051b28 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/SQL/SQLDEMO.CBL @@ -0,0 +1,321 @@ + $set ans85 mf noosvs + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989,1991 * + * * + * SQLDEMO.CBL * + * * + * This program demonstrates the use of SQL from within * + * a COBOL program. * + * * + * The program SQLPREP must be compiled and run before * + * this program is compiled to allow successful * + * compilation. * + * * + ************************************************************ + working-storage section. + 78 no-data value 100. + *SQLCODE for no data available + 01 y-or-n pic x. + 01 display-line. + 03 disp-id pic z(5). + 03 filler pic x. + 03 disp-name pic x(9). + 03 filler pic x. + 03 disp-dept pic z(5). + 03 filler pic x. + 03 disp-job pic x(5). + 03 filler pic x. + 03 disp-years pic z(5). + 03 yrs-nul-val redefines disp-years pic x(5). + 03 filler pic x. + 03 disp-salary pic z(7).9(2). + 03 filler pic x. + 03 disp-comm pic z(7).9(2). + 03 com-nul-val redefines disp-comm pic x(10). + 01 disp-n60 pic zz9.9. + + * An SQLCA is needed to communicate with database manager + exec sql include sqlca end-exec + + * Host variables for database interrogation + exec sql begin declare section end-exec + 01 wsid pic s9(4) packed-decimal. + * You may use comp-3, comp-5 or packed-decimal for host variables + 01 nme pic x(9). + 01 dept pic s9(4) packed-decimal. + 01 job pic x(5). + 01 years pic s9(4) packed-decimal. + 01 salary pic s9(5)v9(2) packed-decimal. + 01 comm pic s9(5)v9(2) packed-decimal. + 01 location pic x(13). + 01 deptname pic x(14). + 01 car pic x(20). + 01 n60 pic s9(3)v9 packed-decimal. + 01 avalue pic s9(4) packed-decimal. + * Now two indicator variables are needed because years and comm + * may have null values. Indicator variables must be comp-5. + 01 yrsnul pic s9(4) comp-5. + 01 commnul pic s9(4) comp-5. + * Now the base string for the prepare example + 01 prep pic x(34). + exec sql end declare section end-exec + + procedure division. + perform sub-select + perform select-with-cursor + perform full-select + perform view-example + perform insert-example + perform prepare-example + stop run. + + sub-select. + * This example is a straight forward select statement + * Note the use of indicator variables yrsnul and commnul they + * are negative if the relevant value from the database is null + * + display + "This demo will select from table STAFF of the sample SQL" + display + "database. The selection will be based on the value of the" + display + "column 'ID', the entry with ID equal to the value you enter" + display + "will be displayed" + display "Enter value (table values go from 10 - 350)" + accept avalue + + exec sql + select id, name, dept, job, years, salary, comm + into :wsid, :nme, :dept, :job, :years:yrsnul, + :salary, :comm:commnul + from staff + where id = :avalue + end-exec + + if sqlcode = zero + perform make-line + display display-line + else + if sqlcode = no-data + display "No row with that ID" + else + perform sql-err + end-if + end-if. + + select-with-cursor. + display spaces + display + "This demo will select from table STAFF of the sample SQL" + display + "database. The selection will be based on the value of the" + display + "column ID, all entries with a value greater than the value" + display "you enter will be displayed." + display "Enter cutoff value (table values go from 10 - 350)" + accept avalue + + * Must use a cursor as many values are expected + exec sql + declare c1 cursor for + select id, name, dept, job, years, salary, comm + from staff + where id > :avalue + end-exec + + * Open the cursor to process the database entries + exec sql + open c1 + end-exec + + perform until sqlcode not = zero + * SQLCODE will be zero as long as it has successfully fetched data + exec sql + fetch c1 into :wsid , :nme, :dept, :job, + :years:yrsnul, :salary, :comm:commnul + end-exec + if sqlcode = zero + perform make-line + display display-line + end-if + end-perform. + + full-select. + * This example uses a cursor to handle the data extracted by two + * select statements joined by an intersect statement, other set + * operations may be substituted + * + display spaces + display + "This demo shows the usage of intersect across two tables" + display + "in the same database, the data extracted is the DEPT from" + display "STAFF and the DEPTNUMB from ORG" + perform wait-accept + + exec sql + declare c2 cursor for + select dept from staff + intersect + select deptnumb from org + end-exec + + exec sql + open c2 + end-exec + + perform until sqlcode not = zero + exec sql + fetch c2 into :dept + end-exec + if sqlcode = zero + move dept to disp-dept + display disp-dept + end-if + end-perform. + + view-example. + * This example uses the view PEOPLE_LOC created by DEMO1 + display spaces + display + "This demo will create a view over the two tables ORG and" + display + "STAFF then will extract all data from the view. The result" + display + "of the view is a list of all employees (from STAFF) and" + display "their place of work (from ORG)" + perform wait-accept + + * Once the view is created it may be treated just like a table + exec sql + declare c3 cursor for + select name,location from people_loc + end-exec + + exec sql + open c3 + end-exec + + perform until sqlcode not = zero + exec sql + fetch c3 into :nme,:location + end-exec + if sqlcode = zero + display nme" "location + end-if + end-perform. + + insert-example. + * This example inserts a row into MF_TABLE which is created by + * SQLPREP. The row is then queried and deleted to prevent any + * problems which could be caused if the program was run a second + * time with identical rows in the table. The select would then + * fail as the resultant data would comprise more than one row + * which would require a cursor. Note the use of apostrophe (') + * instead of quotes (") to delimit the SQL character data. + display spaces + display + "This demo will insert a row into the table MF_TABLE which" + display + "is created by DEMO1 and then will query the row. The values" + display "inserted are: Roger, Ferrari 328 GTB, 6.4" + perform wait-accept + + exec sql + insert into mf_table (name, car, nto60) + values ('Roger','Ferrari 328 GTB',6.4) + end-exec + + exec sql + select name,car,nto60 + into :nme,:car,:n60 + from mf_table + where name='Roger' + end-exec + + if sqlcode = zero + move n60 to disp-n60 + display nme" "car" "disp-n60 + else + perform sql-err + end-if + + * Now to delete the row + exec sql + delete from mf_table + where name='Roger' + end-exec. + + prepare-example. + * This example inserts data into MF-TABLE (created by SQLPREP) + * by use of the SQL PREPARE and EXECUTE statements. Note the use + * of the parameter markers '?' which are replaced by the actual + * data during the EXECUTE statement + * + display spaces + display + "This example inserts one row into MF_TABLE using a prepared" + display + "SQL statement, then reads it back. The row inserted is:-" + display "Elaine, Lamborghini, 4.9" + perform wait-accept + move "insert into mf_table values(?,?,?)" to prep + exec sql + prepare prep_stat from :prep + end-exec + if sqlcode not = zero + perform sql-err + else + move "Elaine" to nme + move "Lamborghini" to car + move 4.9 to n60 + exec sql + execute prep_stat using :nme, :car, :n60 + end-exec + end-if + + exec sql + select name,car,nto60 + into :nme, :car, :n60 + from mf_table + where name='Elaine' + end-exec + if sqlcode = zero + move n60 to disp-n60 + display nme" "car" "disp-n60 + else + perform sql-err + end-if + * Now to delete row + exec sql + delete from mf_table + where name='Elaine' + end-exec. + + sql-err. + display "SQL error SQLCODE="sqlcode. + + make-line. + move spaces to display-line + move wsid to disp-id + move nme to disp-name + move dept to disp-dept + move job to disp-job + move salary to disp-salary + * Now check for null values and handle accordingly + if yrsnul < 0 + move "NULL" to yrs-nul-val + else + move years to disp-years + end-if + if commnul < 0 + move "NULL" to com-nul-val + else + move comm to disp-comm + end-if. + + wait-accept. + display "Press return to run demo" + accept y-or-n. diff --git a/Microsoft COBOL v45/DEMO/SQL/SQLGENWS.CBL b/Microsoft COBOL v45/DEMO/SQL/SQLGENWS.CBL new file mode 100644 index 0000000..3301291 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/SQL/SQLGENWS.CBL @@ -0,0 +1,1719 @@ + $set mf warning(3) + $set sql sqlinit sqldb(sample) + *************************************************************** + * * + * (c) Micro Focus Ltd. 1989 * + * * + * SQLGENWS * + * * + * This program generates COBOL Working Storage * + * host variable structures from OS/2 EE Database * + * Manager's catalog - using SYSIBM.SYSCOLUMNS * + * as the source of information to build the * + * COBOL data definitions. Additionally these options * + * are available: * + * * + * Option 1: generate NULL indicator array for the * + * table. * + * * + * Option 2: generate SELECT statement * + * for the table. * + * * + * Option 3: generate FETCH statement * + * for the table. * + * * + * FILES * + * ===== * + * * + * 1. parameter-ds * + * * + * This file is read-only, and can contain parameters * + * to be used for batch or deteached run modes. * + * Parameters must be one per record. * + * * + * The file name is hard coded. * + * * + * 2. target-ds * + * * + * This file is write-only, and will contain the * + * program output for any particular program run and * + * parameter set. * + * * + * The file name is specified by parameter. * + * * + * 3. message-ds * + * * + * This file is write-only, and recieves the program * + * messages for successive executions. Since this * + * file is appended, occassional clear-up is required. * + * * + * The file name is hard coded. * + * * + * * + * RUNNING * + * ======= * + * * + * The program may be controlled by file, interactive * + * or command line parameters. A mixture of these * + * methods is available by specifying the correct * + * MODE TYPE (MT parameter) value. * + * * + * The program output is timestamped to enable parameter* + * and output files to be matched. * + * * + * All parameters are logged in the message-ds file. * + * * + *************************************************************** + environment division. + *===================== + configuration section. + *====================== + special-names. + *============== + command-line is os2-cmd-line. + * + input-output section. + *===================== + * + file-control. + *============= + * + select parameter-ds + assign to dynamic parameter-ds-z1 + organization is line sequential + file status is file-status-z1 + . + select target-ds + assign to dynamic target-ds-z1 + organization is line sequential + file status is file-status-z1 + . + select message-ds + assign to dynamic message-ds-z1 + organization is line sequential + file status is file-status-z1 + . + + data division. + *============== + + file section. + *============= + + fd parameter-ds + recording mode v. + *================= + + 01 parameter-rec. + 03 parameter-line pic x(80). + + fd target-ds. + *============= + + 01 target-rec. + 03 target-line pic x(80). + + fd message-ds. + *============== + + 01 message-rec. + 03 message-line pic x(80). + + working-storage section. + *======================== + * + exec sql include sqlca end-exec. + + exec sql begin declare section end-exec. + + * Area for retrieval of Database Manager system information + * from the catalog table SYSCOLUMNS + 01 sysibm-syscolumns-a0. + 03 name-a0 pic x(18). + 03 tbname-a0 pic x(18). + 03 tbcreator-a0 pic x(8). + 03 coltype-a0 pic x(8). + 03 nulls-a0 pic x. + 03 length-a0 pic s9(4) comp-5. + 03 scale-a0 pic s9(4) comp-5. + 03 colno-a0 pic s9(4) comp-5. + + + * Database host variables used for control and access + 01 dbm-util-a0. + 03 max-columns-a0 pic s9(4) comp-5. + 03 authorisation-id-a0 pic x(8). + 03 table-name-a0 pic x(18). + + exec sql end declare section end-exec. + + * Data items used to create COBOL working storage lines + 01 structure-make-a2. + 03 dataname-a2 pic x(32). + 03 length-char-a2 pic x(5). + 03 scale-char-a2 pic x(2). + 03 length-a2 pic 99999. + 03 scale-a2 pic 99. + 03 do-null-ind-a2 pic s9(4) comp-5. + 03 smallint-pic-a2 pic x(29) + value + "PIC S9(4) COMP-5. ". + 03 smallint-plus-pic-a2 pic x(29) + value + "PIC S9(4) COMP-5+ ". + 03 integer-pic-a2 pic x(29) + value + "PIC S9(9) COMP-5. ". + 03 decimal-pic-a2 pic x(29) + value + "PIC S9(+ ". + 03 char-pic-a2 pic x(29) + value + "PIC X(+ ". + 03 date-pic-a2 pic x(29) + value + "PIC X(10). ". + 03 time-pic-a2 pic x(29) + value + "PIC x(8). ". + 03 timestamp-pic-a2 pic x(29) + value + "PIC X(26). ". + 03 full-stop-a2 pic x + value ".". + + * Area with framework COBOL working storage lines + 01 skeleton-lines-a2. + 03 skeleton-line-a2-n. + 05 skeleton-line-a2-1. + 07 ws-margin-a2-1 pic x(7). + 07 ws-level-a2-1 pic x(8). + 07 ws-dataname-a2-1 pic x(32). + 07 ws-space-a2-1 pic x(4). + 07 ws-pic-a2-1 pic x(29). + 05 skeleton-line-a2-2. + 07 ws-margin-a2-2 pic x(15). + 07 ws-dataname-a2-2 pic x(25). + 07 ws-def-a2-2 pic x(40). + 05 skeleton-line-a2-3. + 07 param-indent-a2-3 pic x(4). + 07 param-name-a2-3 pic x(12). + 07 param-value-a2-3 pic x(64). + 03 skeleton-line-a2 + redefines + skeleton-line-a2-n pic x(80) + occurs 3. + + * Area to store all columns for the specified table + * to avoid multiple retrieval from the database + 01 columns-a3. + 03 fetch-sub-a3 pic s9(4) comp-5. + 03 column-sub-a3 pic s9(4) comp-5. + 03 column-a3 occurs 255. + 05 name-a3 pic x(18). + 05 tbname-a3 pic x(18). + 05 tbcreator-a3 pic x(8). + 05 coltype-a3 pic x(8). + 05 nulls-a3 pic x. + 05 length-a3 pic s9(4) comp-5. + 05 scale-a3 pic s9(4) comp-5. + 05 colno-a3 pic s9(4) comp-5. + + * Same as a3 but with some elements hyphenised + 01 columns-a4. + 03 column-sub-a4 pic s9(4) comp-5. + 03 column-a4 occurs 255. + 05 name-a4 pic x(18). + 05 tbname-a4 pic x(18). + 05 tbcreator-a4 pic x(8). + 05 coltype-a4 pic x(8). + 05 nulls-a4 pic x. + 05 length-a4 pic s9(4) comp-5. + 05 scale-a4 pic s9(4) comp-5. + 05 colno-a4 pic s9(4) comp-5. + + * General flags, file names, status and control items + 01 utils-z1. + 03 date-z1 pic x(6). + 03 time-z1 pic x(8). + 03 parameter-ds-z1 pic x(64) + value + 'd:\test\sqlgenws\sqlgenws.par'. + 03 end-parameter-ds-z1 pic s9(4) comp-5 + value -1. + 03 target-ds-z1 pic x(64). + 03 message-ds-z1 pic x(64) + value + 'd:\test\sqlgenws\sqlgenws.log '. + 03 dbm-message-z1. + 05 dbm-message-text-z1 pic x(72). + 05 dbmcode-z1 pic -9(6). + 03 dbm-codes-allowable-z1. + 05 allow-dbmcode-z1 pic s9(4) comp-5. + 03 files-opened-z1. + 05 target-ds-open-z1 pic s9(4) comp-5. + 05 message-ds-open-z1 pic s9(4) comp-5. + 05 parameter-ds-open-z1 pic s9(4) comp-5. + 03 file-status-z1 pic x(2). + 03 last-file-status-z1. + 05 last-file-status-x-z1 pic x. + 05 last-file-status-b-z1 pic 99 comp-x. + 03 display-file-status-z1. + 05 literal-status-z1 pic xx + value "9/". + 05 display-status-z1 pic 999. + 03 current-file-z1 pic x(12) + value space. + 03 mt-parameter-found-z1 pic s9(4) comp-5. + 03 mode-type-save-z1 pic x(2). + 03 table-name-hyph-z1 pic x(18). + + * ARea for storage of checked parameters in correct pictures + 01 parameters-z2. + * mode-z2 + * database-id-z2 + * authorisation-id-z2 + * table-name-z2 + * target-ds-z2 + * before-text-z2 + * after-text-z2 + * null-indicators-z2 + * select-statement-z2 + * fetch-statement-z2 + 03 mode-z2 pic x. + 03 database-id-z2 pic x(8). + 03 authorisation-id-z2 pic x(8). + 03 table-name-z2 pic x(18). + 03 target-ds-z2 pic x(64). + 03 before-text-z2 pic x(4) + value space. + 03 after-text-z2 pic x(4) + value space. + 03 null-indicators-z2 pic s9(4) comp-5 + value -1. + 03 select-statement-z2 pic s9(4) comp-5 + value -1. + 03 fetch-statement-z2 pic s9(4) comp-5 + value -1. + + * Parameter definition area + 01 parameter-util-z3. + 03 param-cmd-line-z3. + 05 param-cmd-line-1-z3 pic x(120). + 03 parameter-name-z3 pic x(4). + 03 parameter-value-z3 pic x(64). + 03 parameter-error-z3 pic s9(4) comp-5 + value -1. + 03 last-parameter-z3 pic s9(4) comp-5 + value -1. + 03 parameter-table-z3. + 05 parameter-1-z3 pic x(2) + value 'MT'. + 05 parameter-1-ok-z3 pic s9(4) comp-5. + 05 parameter-2-z3 pic x(2) + value 'DB'. + 05 parameter-2-ok-z3 pic s9(4) comp-5. + 05 parameter-3-z3 pic x(2) + value 'AI'. + 05 parameter-3-ok-z3 pic s9(4) comp-5. + 05 parameter-4-z3 pic x(2) + value 'TN'. + 05 parameter-4-ok-z3 pic s9(4) comp-5. + 05 parameter-5-z3 pic x(2) + value 'TF'. + 05 parameter-5-ok-z3 pic s9(4) comp-5. + 05 parameter-6-z3 pic x(2) + value 'BT'. + 05 parameter-6-ok-z3 pic s9(4) comp-5. + 05 parameter-7-z3 pic x(2) + value 'AT'. + 05 parameter-7-ok-z3 pic s9(4) comp-5. + 05 parameter-8-z3 pic x(2) + value 'NI'. + 05 parameter-8-ok-z3 pic s9(4) comp-5. + 05 parameter-9-z3 pic x(2) + value 'SG'. + 05 parameter-9-ok-z3 pic s9(4) comp-5. + 05 parameter-10-z3 pic x(2) + value 'FG'. + 05 parameter-10-ok-z3 pic s9(4) comp-5. + 03 parameters-z3 + redefines + parameter-table-z3 occurs 10. + 05 parameter-name-n-z3 pic x(2). + 05 parameter-ok-n-z3 pic s9(4) comp-5. + 03 parameter-subscript-z3 pic s9(4) comp-5. + + * Temporary area for parameters during checks + 01 parameter-util-z4. + 03 param-cmd-line-z4. + 05 param-cmd-line-1-z4 pic x(120). + 03 parameter-name-z4 pic x(4). + 03 parameter-value-z4 pic x(64). + 03 parameter-error-z4 pic s9(4) comp-5 + value -1. + 03 parameter-table-z4. + 05 param-val-1-z4 pic x(64). + 05 param-val-2-z4 pic x(64). + 05 param-val-3-z4 pic x(64). + 05 param-val-4-z4 pic x(64). + 05 param-val-5-z4 pic x(64). + 05 param-val-6-z4 pic x(64). + 05 param-val-7-z4 pic x(64). + 05 param-val-8-z4 pic x(64). + 05 param-val-9-z4 pic x(64). + 05 param-val-10-z4 pic x(64). + 03 parameters-z4 + redefines + parameter-table-z4 occurs 10. + 05 param-val-n-z4 pic x(64). + 03 parameter-subscript-z4 pic s9(4) comp-5. + + * Data items for DBM CALL to start_using_database + 01 dbm-call. + 03 spare1 pic 9(4) comp-5 value 0. + 03 db-length pic 9(4) comp-5 value 0. + 03 spare2 pointer. + 03 database pic x(10). + 03 d-use pic 9(4) comp-5. + 03 u pic x redefines d-use. + + + procedure division. + *=================== + * + a-1-start. + *========== + * + * Start up and main control + * + perform a-2-initial + if parameter-error-z3 negative + if parameter-ok-n-z3(2) positive + and parameter-ok-n-z3(3) positive + and parameter-ok-n-z3(4) positive + and parameter-ok-n-z3(5) positive + move zero to max-columns-a0 + perform b-3-0-get-max-cols + if max-columns-a0 < 1 + and parameter-error-z3 negative + move + "No table name as specified in parameters" + to message-line + perform z-1-write-message-rec + move 1 to parameter-error-z3 + end-if + perform a-8-prepare-target + perform a-3-main + else + move "Not all mandatory parameters specified" + to message-line + perform z-1-write-message-rec + end-if + end-if + perform z-9-stop + . + * + a-2-initial. + *============ + * + * Check at least mode type (MT) parameter specified + * and initialise LOG, prepare TARGET FILE (TF), + * control parameter reception + * + move -1 to target-ds-open-z1 + move -1 to message-ds-open-z1 + move -1 to parameter-ds-open-z1 + move -1 to allow-dbmcode-z1 + accept param-cmd-line-z4 from os2-cmd-line + unstring param-cmd-line-z4 + delimited by space + into + param-val-n-z4(1) + param-val-n-z4(2) + param-val-n-z4(3) + param-val-n-z4(4) + param-val-n-z4(5) + param-val-n-z4(6) + param-val-n-z4(7) + param-val-n-z4(8) + param-val-n-z4(9) + param-val-n-z4(10) + end-unstring + move -1 to mt-parameter-found-z1 + perform with test before + varying parameter-subscript-z4 + from 1 + by 1 + until parameter-subscript-z4 > 10 + or mt-parameter-found-z1 positive + move space to parameter-name-z4 + move space to parameter-value-z4 + unstring param-val-n-z4(parameter-subscript-z4) + delimited by "=" + into + parameter-name-z4 + parameter-value-z4 + end-unstring + if parameter-name-z4 = "MT" + move 1 to mt-parameter-found-z1 + move parameter-value-z4 to mode-type-save-z1 + end-if + end-perform + move 'Messages' to current-file-z1 + open extend message-ds + if file-status-z1 = '00' + move 1 to message-ds-open-z1 + else + move file-status-z1 to last-file-status-z1 + perform z-4-bad-file-status + perform z-9-stop + end-if + accept date-z1 from date + accept time-z1 from time + move "===> SQLGENWS" to ws-margin-a2-2 + move date-z1 to ws-dataname-a2-2 + move time-z1 to ws-def-a2-2 + move skeleton-line-a2-2 to message-line + perform z-1-write-message-rec + if mt-parameter-found-z1 negative + move "No mode type parameter specified" + to message-line + perform z-1-write-message-rec + move 1 to parameter-error-z3 + end-if + perform with test before + varying parameter-subscript-z3 + from 1 by 1 + until parameter-subscript-z3 > 10 + move -1 + to parameter-ok-n-z3(parameter-subscript-z3) + end-perform + perform a-4-help + perform a-9-parameter-sequence + . + * + a-3-main. + *========= + * + * Acces the speified database with start_using_database, + * control program activities based on parameters + * + move -1 to do-null-ind-a2 + move zero to db-length + move database-id-z2 to database + inspect database + tallying db-length + for characters before initial space + * Value 83 here causes character in u data item of CALL + * This sets database usage to SHARE + move 83 to d-use + call "__SQLGSTPD" + using sqlca + if sqlcode not = 0 + perform z-2-dbm-error + end-if + call "__SQLGSTRD" + using database + spare2 + sqlca + by value d-use + by value db-length + by value spare1 + if sqlcode not = 0 + perform z-2-dbm-error + end-if + move table-name-z2 to table-name-hyph-z1 + inspect table-name-hyph-z1 + replacing all "_" by "-" + perform b-3-1-fetch-syscols + perform b-3-2-declare-table + perform b-3-3-cobol-declare + if null-indicators-z2 positive + move 1 to do-null-ind-a2 + perform b-3-4-null-indicators + move -1 to do-null-ind-a2 + end-if + if select-statement-z2 positive + perform b-3-5-select-statement + end-if + if fetch-statement-z2 positive + perform b-3-6-fetch-statement + end-if + . + * + a-4-help. + *========= + * + * NOTE. READ THIS SECTION FOR HELP ON PARAMETERS + * + * Put help into LOG if command line was blank or help specified + * + if param-cmd-line-z4 = space + or param-cmd-line-z4 = "H" + or param-cmd-line-z4 = "h" + or param-cmd-line-z4 = "HELP" + or param-cmd-line-z4 = "Help" + or param-cmd-line-z4 = "help" + move 1 to parameter-error-z3 + move "Parameter names and meaning/values." + to message-line + perform z-1-write-message-rec + perform z-1-write-message-rec + move "Parameters can be in any sequence." + to message-line + perform z-1-write-message-rec + perform z-1-write-message-rec + move "MT=0 10 + or parameter-error-z3 positive + or last-parameter-z3 positive + move space to parameter-name-z4 + move space to parameter-value-z4 + unstring param-val-n-z4(parameter-subscript-z4) + delimited by "=" + into + parameter-name-z4 + parameter-value-z4 + end-unstring + if parameter-name-z4 = space + move 1 to last-parameter-z3 + else + move parameter-name-z4 + to parameter-name-z3 + move parameter-value-z4 + to parameter-value-z3 + perform c-2-0-what-par + end-if + end-perform + . + * + b-2-1-get-pars-f. + *================= + * + * Get and control check of file parameters + * + perform until end-parameter-ds-z1 = 1 + or parameter-error-z3 positive + read parameter-ds + at end + move 1 to end-parameter-ds-z1 + end-read + if end-parameter-ds-z1 negative + unstring parameter-line + delimited by '=' + into parameter-name-z3 + parameter-value-z3 + end-unstring + perform c-2-0-what-par + end-if + end-perform + . + * + b-2-2-get-pars-i. + *================= + * + * Get and control check of interactive parameters + * + perform varying parameter-subscript-z3 + from 2 + by 1 + until parameter-subscript-z3 > 10 + move parameter-name-n-z3(parameter-subscript-z3) + to parameter-name-z3 + if parameter-ok-n-z3(parameter-subscript-z3) + negative + display 'Please enter value for ' + parameter-name-z3 + accept parameter-value-z3 + perform c-2-0-what-par + end-if + end-perform + . + * + b-3-0-get-max-cols. + *=================== + * + * Get maximum number of columns in the specified table to + * enable program control functions later in the run + * + move authorisation-id-z2 to authorisation-id-a0 + move table-name-z2 to table-name-a0 + exec sql + select max(colno) + into :max-columns-a0 + from SYSIBM.SYSCOLUMNS + where tbcreator = :authorisation-id-a0 + and tbname = :table-name-a0 + end-exec + if sqlcode not = zero + and sqlcode not = -305 + perform z-2-dbm-error + end-if + . + * + b-3-1-fetch-syscols. + *==================== + * + * Read the SYSCOLUMNS information for each column for the specied + * table + * + add 1 to max-columns-a0 + exec sql + declare syscols cursor for + select + name, + tbname, + tbcreator, + coltype, + nulls, + length, + scale, + colno + from SYSIBM.SYSCOLUMNS + where tbcreator = :authorisation-id-a0 + and tbname = :table-name-a0 + order by colno + end-exec + if sqlcode not = zero + perform z-2-dbm-error + end-if + exec sql + open syscols + end-exec + if sqlcode not = zero + perform z-2-dbm-error + end-if + perform with test before + varying fetch-sub-a3 from 1 by 1 + until fetch-sub-a3 > max-columns-a0 + or sqlcode not = zero + exec sql + fetch syscols into + :name-a0, + :tbname-a0, + :tbcreator-a0, + :coltype-a0, + :nulls-a0, + :length-a0, + :scale-a0, + :colno-a0 + end-exec + if sqlcode not = zero + perform z-2-dbm-error + end-if + move sysibm-syscolumns-a0 + to column-a4(fetch-sub-a3) + inspect name-a0 + replacing all "_" by "-" + inspect tbname-a0 + replacing all "_" by "-" + move sysibm-syscolumns-a0 + to column-a3(fetch-sub-a3) + end-perform + exec sql + close syscols + end-exec + if sqlcode not = zero + perform z-2-dbm-error + end-if + . + * + b-3-2-declare-table. + *==================== + * + * Generate SQL table definition for COBOL + * + move " * SQLGENWS produced this" + to target-line + perform z-3-write-target-rec + move " * SQL TABLE DECLARATION" + to target-line + perform z-3-write-target-rec + string " EXEC SQL DECLARE " + delimited by size + tbname-a4(1) delimited by space + " TABLE (" delimited by size + into target-line + end-string + perform z-3-write-target-rec + perform with test before + varying column-sub-a4 + from 1 by 1 + until column-sub-a4 > max-columns-a0 + move space to skeleton-line-a2-2 + move name-a4(column-sub-a4) to ws-dataname-a2-2 + if coltype-a4(column-sub-a4) = 'LONGVAR' + move "LONG VARCHAR +" + to ws-def-a2-2 + end-if + if coltype-a4(column-sub-a4) = 'TIMESTMP' + move "TIMESTAMP +" + to ws-def-a2-2 + end-if + if coltype-a4(column-sub-a4) not = 'LONGVAR' + and coltype-a4(column-sub-a4) not = 'TIMESTMP' + string coltype-a4(column-sub-a4) + delimited by space + " +" delimited by size + into ws-def-a2-2 + end-string + end-if + move length-a4(column-sub-a4) to length-a2 + move length-a2 to length-char-a2 + if coltype-a4(column-sub-a4) = 'CHAR' + or coltype-a4(column-sub-a4) = 'VARCHAR' + string ws-def-a2-2 delimited by "+" + "(" delimited by size + length-char-a2 + delimited by size + ") +" delimited by size + into ws-def-a2-2 + end-string + end-if + move scale-a4(column-sub-a4) to scale-a2 + move scale-a2 to scale-char-a2 + if coltype-a4(column-sub-a4) = 'DECIMAL' + string ws-def-a2-2 delimited by "+" + "(" delimited by size + length-char-a2 + delimited by size + "," delimited by size + scale-char-a2 + delimited by size + ") +" delimited by size + into ws-def-a2-2 + end-string + end-if + if nulls-a4(column-sub-a4) = 'N' + string ws-def-a2-2 delimited by "+" + "NOT NULL +" delimited by size + into ws-def-a2-2 + end-string + end-if + if column-sub-a4 < max-columns-a0 + string ws-def-a2-2 delimited by "+" + "," delimited by size + into ws-def-a2-2 + end-string + else + string ws-def-a2-2 delimited by "+" + " " delimited by size + into ws-def-a2-2 + end-string + end-if + move skeleton-line-a2-2 to target-line + perform z-3-write-target-rec + end-perform + move " )" + to target-line + perform z-3-write-target-rec + move " END-EXEC" + to target-line + perform z-3-write-target-rec + . + * + b-3-3-cobol-declare. + *==================== + * + * Generate database host variables for COBOL working storage + * + move ' * SQLGENWS produced this COBOL' + to target-line + perform z-3-write-target-rec + move ' * SQL host variable structure' + to target-line + perform z-3-write-target-rec + perform with test before + varying column-sub-a3 + from 1 by 1 + until column-sub-a3 > max-columns-a0 + move space to skeleton-line-a2-1 + move space to dataname-a2 + if column-sub-a3 = 1 + perform c-3-1-01-level + end-if + string before-text-z2 delimited by space + name-a3(column-sub-a3) + delimited by space + after-text-z2 delimited by space + into dataname-a2 + end-string + move dataname-a2 to ws-dataname-a2-1 + evaluate true + when coltype-a3(column-sub-a3) = "SMALLINT" + perform c-3-2-smallint + when coltype-a3(column-sub-a3) = "INTEGER" + perform c-3-3-integer + when coltype-a3(column-sub-a3) = "DECIMAL" + perform c-3-4-decimal + when coltype-a3(column-sub-a3) = "CHAR" + perform c-3-5-char + when coltype-a3(column-sub-a3) = "VARCHAR" + perform c-3-6-varchar + when coltype-a3(column-sub-a3) = "LONGVAR" + perform c-3-7-longvar + when coltype-a3(column-sub-a3) = "DATE" + perform c-3-8-date + when coltype-a3(column-sub-a3) = "TIME" + perform c-3-9-time + when coltype-a3(column-sub-a3) = "TIMESTMP" + perform c-3-10-timestmp + when coltype-a3(column-sub-a3) = "FLOAT" + perform c-3-11-float + when other + perform c-3-12-other + end-evaluate + move skeleton-line-a2-1 to target-line + perform z-3-write-target-rec + end-perform + . + * + b-3-4-null-indicators. + *====================== + * + * Generate database NULL indicator variables for the specified + * table + * + move space to skeleton-line-a2-1 + perform with test before + varying column-sub-a3 + from 1 by 1 + until column-sub-a3 > max-columns-a0 + if column-sub-a3 = 1 + perform c-3-13-null-01-03 + end-if + move space to dataname-a2 + string before-text-z2 delimited by space + name-a3(column-sub-a3) + delimited by space + after-text-z2 delimited by space + into dataname-a2 + end-string + move dataname-a2 to ws-dataname-a2-1 + perform c-3-2-smallint + move skeleton-line-a2-1 to target-line + perform z-3-write-target-rec + move space to skeleton-line-a2-1 + end-perform + perform c-3-14-null-03red + . + * + b-3-5-select-statement. + *======================= + * + * Generate a SQL SELECT statement for the specified table + * + move " *" to target-line + perform z-3-write-target-rec + move " * SELECT STATEMENT" to target-line + perform z-3-write-target-rec + move " SELECT" to target-line + perform z-3-write-target-rec + perform with test before + varying column-sub-a4 + from 1 by 1 + until column-sub-a4 > max-columns-a0 - 1 + string " " delimited by size + name-a4(column-sub-a4) delimited by space + "," delimited by size + into target-line + end-string + perform z-3-write-target-rec + end-perform + string " " delimited by size + name-a4(column-sub-a4) delimited by space + into target-line + end-string + perform z-3-write-target-rec + string " FROM " delimited by size + tbname-a4(1) delimited by space + into target-line + perform z-3-write-target-rec + . + * + b-3-6-fetch-statement. + *====================== + * + * Generate a SQL FETCH statement for the spefied table + * + move " *" to target-line + perform z-3-write-target-rec + move " * FETCH STATEMENT" to target-line + perform z-3-write-target-rec + move " FETCH CURSOR-NAME INTO" + to target-line + perform z-3-write-target-rec + perform with test before + varying column-sub-a3 + from 1 by 1 + until column-sub-a3 > max-columns-a0 - 1 + string " :" delimited by size + before-text-z2 delimited by space + name-a3(column-sub-a3) delimited by space + after-text-z2 delimited by space + "," delimited by size + into target-line + end-string + perform z-3-write-target-rec + end-perform + string " :" delimited by size + before-text-z2 delimited by space + name-a3(column-sub-a3) delimited by space + after-text-z2 delimited by space + into target-line + end-string + perform z-3-write-target-rec + . + * + c-2-0-what-par. + *=============== + * + * Determine the current parameter type + * + move space to skeleton-line-a2-3 + string parameter-name-z3 delimited by space + "=" delimited by size + into param-name-a2-3 + end-string + move parameter-value-z3 to param-value-a2-3 + move skeleton-line-a2-3 to message-line + perform z-1-write-message-rec + evaluate true + when parameter-name-z3 = 'MT' + perform c-2-2-mode + when parameter-name-z3 = 'DB' + perform c-2-3-database + when parameter-name-z3 = 'AI' + perform c-2-4-authid + when parameter-name-z3 = 'TN' + perform c-2-5-tablename + when parameter-name-z3 = 'TF' + perform c-2-6-targetfile + when parameter-name-z3 = 'BT' + perform c-2-7-beforetext + when parameter-name-z3 = 'AT' + perform c-2-8-aftertext + when parameter-name-z3 = 'NI' + perform c-2-9-nullindgen + when parameter-name-z3 = 'SG' + perform c-2-10-selectgen + when parameter-name-z3 = 'FG' + perform c-2-11-fetchgen + when other + perform c-2-1-pars-error + end-evaluate + . + * + c-2-1-pars-error. + *================= + * + * LOG a parameter error + * + move 1 to parameter-error-z3 + move 'Unknown or invalid parameter specified' + to message-line + perform z-1-write-message-rec + move 'Parameter as specified follows:' + to message-line + perform z-1-write-message-rec + move parameter-name-z3 to message-line + perform z-1-write-message-rec + . + * + c-2-2-mode. + *=========== + * + * Specific check/move for MODE TYPE parameter + * + if parameter-error-z3 negative + move parameter-value-z3 to mode-z2 + move 1 to parameter-ok-n-z3(1) + end-if + . + * + c-2-3-database. + *=============== + * + * Specific check/move for DATABASE parameter + * + if parameter-value-z3 not = space + move parameter-value-z3 to database-id-z2 + move 1 to parameter-ok-n-z3(2) + else + perform c-2-1-pars-error + end-if + . + * + c-2-4-authid. + *============= + * + * Specific check/move for AUTHORISATION ID parameter + * + if parameter-value-z3 not = space + move parameter-value-z3 to authorisation-id-z2 + move 1 to parameter-ok-n-z3(3) + else + perform c-2-1-pars-error + . + * + c-2-5-tablename. + *================ + * + * Specific check/move for TABLENAME parameter + * + if parameter-value-z3 not = space + move parameter-value-z3 to table-name-z2 + move 1 to parameter-ok-n-z3(4) + else + perform c-2-1-pars-error + . + * + c-2-6-targetfile. + *================= + * + * Specific check/move for TARGETFILE parameter + * + if parameter-value-z3 not = space + move parameter-value-z3 to target-ds-z1 + move parameter-value-z3 to target-ds-z2 + move 1 to parameter-ok-n-z3(5) + else + perform c-2-1-pars-error + . + * + c-2-7-beforetext. + *================= + * + * Spefific check/move for BEFORETEXT parameter + * + if parameter-value-z3 not = space + move parameter-value-z3 to before-text-z2 + else + move space to before-text-z2 + end-if + move 1 to parameter-ok-n-z3(6) + . + * + c-2-8-aftertext. + *================ + * + * Specific check/move for AFTERTEXT parameter + * + if parameter-value-z3 not = space + move parameter-value-z3 to after-text-z2 + else + move space to after-text-z2 + end-if + move 1 to parameter-ok-n-z3(7) + . + * + c-2-9-nullindgen. + *================= + * + * Specific check/move for NULLINDGEN parameter + * + if parameter-value-z3 = 'Y' + move 1 to null-indicators-z2 + end-if + move 1 to parameter-ok-n-z3(8) + . + * + c-2-10-selectgen. + *================= + * + * Specific check/move for SELECTGEN parameter + * + if parameter-value-z3 = 'Y' + move 1 to select-statement-z2 + end-if + move 1 to parameter-ok-n-z3(9) + . + * + c-2-11-fetchgen. + *================ + * + * Specific check/move for FETCHGEN parameter + * + if parameter-value-z3 = 'Y' + move 1 to fetch-statement-z2 + end-if + move 1 to parameter-ok-n-z3(10) + . + * + c-3-1-01-level. + *=============== + * + * Generate COBOL 01 level line + * + move '01 ' to ws-level-a2-1 + string before-text-z2 delimited by space + table-name-hyph-z1 delimited by space + after-text-z2 delimited by space + into dataname-a2 + end-string + string dataname-a2 delimited by space + "." delimited by size + into dataname-a2 + end-string + move dataname-a2 to ws-dataname-a2-1 + move skeleton-line-a2-1 to target-line + perform z-3-write-target-rec + move space to skeleton-line-a2-1 + move space to dataname-a2 + . + * + c-3-2-smallint. + *=============== + * + * Generate COBOL line for database SMALLINT + * + move " 10" to ws-level-a2-1 + if do-null-ind-a2 positive + string ws-dataname-a2-1 delimited by after-text-z2 + "-NULL" delimited by size + after-text-z2 delimited by space + into ws-dataname-a2-1 + end-string + end-if + move smallint-pic-a2 to ws-pic-a2-1 + . + * + c-3-3-integer. + *============== + * + * Generate COBOL line for database INTEGER + * + move " 10" to ws-level-a2-1 + move integer-pic-a2 to ws-pic-a2-1 + . + * + c-3-4-decimal. + *============== + * + * Generate COBOL line for database DECIMAL + * + move " 10" to ws-level-a2-1 + move length-a3(column-sub-a3) to length-a2 + move length-a2 to length-char-a2 + move scale-a3(column-sub-a3) to scale-a2 + move scale-a2 to scale-char-a2 + string decimal-pic-a2 delimited by "+" + length-char-a2 delimited by space + "+" delimited by size + into ws-pic-a2-1 + end-string + if scale-a2 = zero + string ws-pic-a2-1 delimited by "+" + ")." delimited by size + into ws-pic-a2-1 + end-string + else + string ws-pic-a2-1 delimited by "+" + ")V9(" delimited by size + scale-char-a2 delimited by space + ")." delimited by size + into ws-pic-a2-1 + end-string + . + * + c-3-5-char. + *=========== + * + * Generate COBOL line for database CHAR + * + move " 10" to ws-level-a2-1 + move char-pic-a2 to ws-pic-a2-1 + move length-a3(column-sub-a3) to length-a2 + move length-a2 to length-char-a2 + string ws-pic-a2-1 delimited by "+" + length-char-a2 delimited by space + ")." delimited by size + into ws-pic-a2-1 + end-string + . + * + c-3-6-varchar. + *============== + * + * Generate COBOL line for database VARCHAR + * + move " 10" to ws-level-a2-1 + string ws-dataname-a2-1 delimited by space + "." delimited by size + into ws-dataname-a2-1 + end-string + move skeleton-line-a2-1 to target-line + perform z-3-write-target-rec + move space to skeleton-line-a2-1 + move " 49" to ws-level-a2-1 + move space to ws-dataname-a2-1 + string dataname-a2 delimited by after-text-z2 + "-LEN" delimited by size + after-text-z2 delimited by space + into ws-dataname-a2-1 + end-string + move smallint-pic-a2 to ws-pic-a2-1 + move skeleton-line-a2-1 to target-line + perform z-3-write-target-rec + move space to skeleton-line-a2-1 + move " 49" to ws-level-a2-1 + move space to ws-dataname-a2-1 + string dataname-a2 delimited by after-text-z2 + "-TEXT" delimited by size + after-text-z2 delimited by space + into ws-dataname-a2-1 + end-string + move char-pic-a2 to ws-pic-a2-1 + move length-a3(column-sub-a3) to length-a2 + move length-a2 to length-char-a2 + string ws-pic-a2-1 delimited by "+" + length-char-a2 delimited by space + ")." delimited by size + into ws-pic-a2-1 + end-string + . + * + c-3-7-longvar. + *============== + * + * Generate COBOL line for database LONG VARCHAR + * (Same as VARCHAR) + * + perform c-3-6-varchar + . + * + c-3-8-date. + *=========== + * + * Generate COBOL line for database DATE + * + move " 10" to ws-level-a2-1 + move date-pic-a2 to ws-pic-a2-1 + . + * + c-3-9-time. + *=========== + * + * Generate COBOL line for database TIME + * + move " 10" to ws-level-a2-1 + move time-pic-a2 to ws-pic-a2-1 + . + * + c-3-10-timestmp. + *================ + * + * Generate COBOL line for database TIMESTAMP + * + move " 10" to ws-level-a2-1 + move timestamp-pic-a2 to ws-pic-a2-1 + . + * + c-3-11-float. + *============= + * + * Generate warning for database FLOAT datatype + * Not supported in COBOL/2 version + * + move "*******" to target-line + perform z-3-write-target-rec + move "******* WARNING:" to target-line + perform z-3-write-target-rec + move "******* FLOAT DATA TYPE NOT SUPPORTED *******" + to target-line + perform z-3-write-target-rec + . + * + c-3-12-other. + *============= + * + * LOG error and stop run if any other types + * + move "INVALID DATA TYPE IN TABLE" + to message-line + perform z-1-write-message-rec + move "SQLGENWS RUN ABANDONED" + to message-line + perform z-1-write-message-rec + perform z-9-stop + . + * + c-3-13-null-01-03. + *================== + * + * Generate NULL indicator 01 and 03 level + * + move " *" to target-line + perform z-3-write-target-rec + move " * NULL INDICATOR VARIABLES" + to target-line + perform z-3-write-target-rec + move '01 ' to ws-level-a2-1 + string before-text-z2 delimited by space + table-name-hyph-z1 delimited by space + "-NULL-INDS" delimited by size + after-text-z2 delimited by space + "." delimited by size + into dataname-a2 + end-string + move dataname-a2 to ws-dataname-a2-1 + move skeleton-line-a2-1 to target-line + perform z-3-write-target-rec + move space to skeleton-line-a2-1 + move space to dataname-a2 + move ' 03 ' to ws-level-a2-1 + string before-text-z2 delimited by space + table-name-hyph-z1 delimited by space + "-NULLS" delimited by size + after-text-z2 delimited by space + "." delimited by size + into dataname-a2 + end-string + move dataname-a2 to ws-dataname-a2-1 + move skeleton-line-a2-1 to target-line + perform z-3-write-target-rec + move space to skeleton-line-a2-1 + move space to dataname-a2 + . + * + c-3-14-null-03red. + *================== + * + * Generate NULL indicator redefinition line + * + move ' 03 ' to ws-level-a2-1 + string before-text-z2 delimited by space + table-name-hyph-z1 delimited by space + "-NULL" delimited by size + after-text-z2 delimited by space + into dataname-a2 + end-string + move dataname-a2 to ws-dataname-a2-1 + move skeleton-line-a2-1 to target-line + perform z-3-write-target-rec + move space to skeleton-line-a2-1 + move space to dataname-a2 + move "REDEFINES" to ws-dataname-a2-1 + move skeleton-line-a2-1 to target-line + perform z-3-write-target-rec + move space to skeleton-line-a2-1 + move space to dataname-a2 + string before-text-z2 delimited by space + table-name-hyph-z1 delimited by space + "-NULLS" delimited by size + after-text-z2 delimited by space + into dataname-a2 + end-string + move dataname-a2 to ws-dataname-a2-1 + move smallint-plus-pic-a2 + to ws-pic-a2-1 + string ws-pic-a2-1 delimited by "+" + " " delimited by size + into ws-pic-a2-1 + end-string + move skeleton-line-a2-1 to target-line + perform z-3-write-target-rec + move space to skeleton-line-a2-1 + move space to dataname-a2 + move max-columns-a0 to length-a2 + move length-a2 to length-char-a2 + move "OCCURS +" to ws-pic-a2-1 + string ws-pic-a2-1 delimited by "+" + length-char-a2 delimited by size + "." delimited by size + into ws-pic-a2-1 + end-string + move skeleton-line-a2-1 to target-line + perform z-3-write-target-rec + move space to skeleton-line-a2-1 + move space to dataname-a2 + . + * + z-1-write-message-rec. + *====================== + * + * Write a line to the LOG file + * + write message-rec + move space to message-line + . + * + z-2-dbm-error. + *============== + * + * LOG a database error - if SQLCODE bad + * + if sqlcode not = allow-dbmcode-z1 + move sqlcode to dbmcode-z1 + move 'sqlcode returned with bad value' + to dbm-message-text-z1 + move dbm-message-z1 to message-line + perform z-1-write-message-rec + perform z-9-stop + . + * + z-3-write-target-rec. + *===================== + * + * Write a line to the TARGETFILE + * + write target-rec + move space to target-line + . + * + z-4-bad-file-status. + *==================== + * + * Write LOG of file error + * + move "Bad file status on open." + to message-line + perform z-1-write-message-rec + move "File name and status follow:" + to message-line + perform z-1-write-message-rec + move current-file-z1 + to message-line + perform z-1-write-message-rec + move last-file-status-b-z1 + to display-status-z1 + move display-file-status-z1 + to message-line + perform z-1-write-message-rec + . + * + z-9-stop. + *========= + * + * Breathe a sigh of relief and retire. + * LOG the end of run <==== EYECATCHER <==== + * + move "<=== End of RUN" to message-line + perform z-1-write-message-rec + perform z-9-100 + perform z-9-999 + . + * + z-9-100. + *======== + * + if parameter-ds-open-z1 positive + close parameter-ds + end-if + if target-ds-open-z1 positive + close target-ds + end-if + if message-ds-open-z1 positive + close message-ds + end-if + . + * + z-9-999. + *======== + * + * Thats all folks. + * + stop run + . + \ No newline at end of file diff --git a/Microsoft COBOL v45/DEMO/SQL/SQLPREP.CBL b/Microsoft COBOL v45/DEMO/SQL/SQLPREP.CBL new file mode 100644 index 0000000..74474f3 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/SQL/SQLPREP.CBL @@ -0,0 +1,97 @@ + $set ans85 mf noosvs + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * SQLPREP.CBL * + * * + * This program sets up the environment for SQLDEMO.CBL. * + * Both programs demonstrate the use of SQL from within * + * a COBOL program. * + * * + ************************************************************ + * This program should be run before sqldemo. It creates + * the database objects needed by sqldemo. sqldemo cannot + * create then use the object, since, at compile time, the + * object will not exist. Hence, any references to the + * object will be invalid. + ************************************************************ + working-storage section. + 01 y-or-n pic x value "n". + 78 object-exists value -601. + + *SQL error code for database object exists + 01 created-var pic x value "n". + 88 created value "y". + + exec sql include sqlca end-exec + + procedure division. + perform until created + exec sql + create view people_loc as + select name,location + from staff,org + where dept=deptnumb + end-exec + if not (sqlcode = object-exists or zero) + perform sql-error + end-if + if sqlcode = object-exists + display + "View PEOPLE_LOC exists in DB, Delete it and re-create Y/[N]" + accept y-or-n + if y-or-n = "y" or "Y" + exec sql + drop view people_loc + end-exec + if sqlcode = zero + move "n" to created-var + else + perform sql-error + end-if + else + move "y" to created-var + end-if + else + move "y" to created-var + end-if + end-perform + + *Now create table mf_table + move "n" to created-var + perform until created + exec sql + create table mf_table + (name char(9), + car char(20), + nto60 decimal(3,1)) + end-exec + if not (sqlcode = object-exists or zero) + perform sql-error + end-if + if sqlcode = object-exists + display + "Table MF_TABLE exists in DB, Delete it and re-create Y/[N]" + accept y-or-n + if y-or-n = "y" or "Y" + exec sql + drop table mf_table + end-exec + if sqlcode = zero + move "n" to created-var + else + perform sql-error + end-if + else + move "y" to created-var + end-if + else + move "y" to created-var + end-if + end-perform + stop run. + + sql-error. + display "SQL error SQLCODE="sqlcode + stop run. diff --git a/Microsoft COBOL v45/DEMO/SRTDEM.BAT b/Microsoft COBOL v45/DEMO/SRTDEM.BAT new file mode 100644 index 0000000..45e32ff --- /dev/null +++ b/Microsoft COBOL v45/DEMO/SRTDEM.BAT @@ -0,0 +1,247 @@ +echo off +rem Batch File to Compile, Link, Bind and Run the SORTDEMO demonstration +rem program. This batch file can be run from your DOS prompt. +rem v 1.2.3 +cls +echo . +echo *------------------* SORTDEMO Demonstration Program *-----------------* +echo * * +echo * This batch stream demonstrates how a program can be "bound" to * +echo * enable it to run on DOS and OS/2. * +echo * * +echo * Bound programs are linked as OS/2 programs prior to binding. * +echo * Therefore, in order for this batch stream to operate it is * +echo * necessary to have the OS/2 version of the compiler available as * +echo * well as the DOS version. This will ensure that the files needed for * +echo * linking an OS/2 program, and for binding, are all loaded. * +echo * * +echo * Please ensure that you have followed the installation instructions * +echo * for COBOL, using SETUP to load the DOS compiler, the OS/2 compiler * +echo * and the Microsoft Utilities, including the OS/2 specific files. * +echo * * +echo * Press Ctrl+C to exit if you have NOT properly installed your * +echo * COBOL Compiler, or copied the required files. * +echo * * +echo *---------------------------------------------------------------------* +echo . +pause +cls +echo . +echo *------------------* SORTDEMO demonstration program *-----------------* +echo * * +echo * SORTDEMO must be "bound" before it will run under DOS, since it * +echo * contains calls to OS/2 API functions. * +echo * * +echo * To bind the program, the files API.LIB and OS2.LIB must be copied * +echo * into the current directory. They will have been loaded by SETUP * +echo * into the directory you selected for the Microsoft Utilities. * +echo * * +echo * Also, BIND.EXE must be available in the current directory or in a * +echo * directory on the DOS PATH. * +echo * * +echo * Press Ctrl+C to exit if these files are not present. * +echo * * +echo *---------------------------------------------------------------------* +echo . +pause +cls +if %COBDIR%. == . goto errcob +if not exist API.LIB goto errpre +if not exist OS2.LIB goto errpre +if not exist %cobdir%\CBLBIND.NOT goto erros2 +if not exist %cobdir%\CBLBIND.LIB goto erros2 +if %1. == lcobol. if not exist %cobdir%\LCOBOL.LIB goto erros2 +if %1. == LCOBOL. if not exist %cobdir%\LCOBOL.LIB goto erros2 +if %1. == . if not exist %cobdir%\COBLIB.LIB goto erros2 +if %1. == . if not exist %cobdir%\COBLIB.DLE goto erros2 +if not exist SORTDEMO.CBL goto errtic +:cobret +if %1. == animate. goto doanim +if %1. == ANIMATE. goto doanim +cls +echo *---------------------------------------------------------------------* +echo * Compiling the SORTDEMO demonstration program * +echo *---------------------------------------------------------------------* +echo on +COBOL SORTDEMO.CBL OPTSPEED NOTRICKLE ; +echo off +if errorlevel 1 goto nocob +echo *---------------------------------------------------------------------* +echo * Compilation of SORTDEMO has completed successfully * +echo *---------------------------------------------------------------------* +pause +cls +echo *---------------------------------------------------------------------* +echo * Linking the SORTDEMO program * +echo * * +echo * Note that the program is linked to run under OS/2. The binding * +echo * process which follows the link enables it to be run under DOS as * +echo * well as OS/2. * +echo * * +if %1. == lcobol. goto ltxtl +if %1. == LCOBOL. goto ltxtl +echo * The program will be linked to run with the shared run-time, * +echo * COBLIB. The EXE file created requires the file COBLIB.DLE to be * +echo * present in the COBOL system directories in order to operate. * +echo * * +echo * Since the shared run-time handles all memory under DOS, we need * +echo * to free some back to allow the API calls to work. Setting * +echo * environment variable COBPOOL will do this. * +echo * * +echo * Restart this batch file with the parameter, LCOBOL, to see the * +echo * program statically linked so that it is independent of any other * +echo * files at run-time. (i.e. enter SRTDEM LCOBOL) * +goto ltxte +:ltxtl +echo * The program will be statically linked. That is, the COBOL run-time * +echo * support required for this program is linked into the EXE file * +echo * making it independent of any other files at run-time. * +:ltxte +echo * * +echo *---------------------------------------------------------------------* +if %1. == lcobol. goto linkl +if %1. == LCOBOL. goto linkl +:linkc +echo on +LINK SORTDEMO/NOD,,,COBLIB+OS2 ; +SET COBPOOL=10 +echo off +goto linke +:linkl +echo on +LINK SORTDEMO/NOD,,,LCOBOL+OS2 ; +echo off +:linke +if errorlevel == 1 goto linkerr +if not exist SORTDEMO.EXE goto linkerr +echo *---------------------------------------------------------------------* +echo * Linking of SORTDEMO has completed successfully * +echo *---------------------------------------------------------------------* +pause +cls +echo *---------------------------------------------------------------------* +echo * Binding the SORTDEMO program * +echo *---------------------------------------------------------------------* +echo on +BIND SORTDEMO %cobdir%\CBLBIND.LIB OS2.LIB -N @%cobdir%\CBLBIND.NOT +echo off +if errorlevel == 1 goto binderr +echo *---------------------------------------------------------------------* +echo * Binding of SORTDEMO has completed successfully * +echo *---------------------------------------------------------------------* +pause +cls +echo *---------------------------------------------------------------------* +echo * Running SORTDEMO * +echo *---------------------------------------------------------------------* +echo on +SORTDEMO +echo off +if errorlevel == 1 goto runerr +goto endsort +:nocob +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +echo * An error occured while compiling SORTDEMO. Please ensure that you * +echo * have installed all the necessary files. * +echo * * +echo *********************************************************************** +goto endsort +:linkerr +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +echo * An error occured while linking. Please ensure that you have * +echo * installed all the necessary files. * +echo * * +echo *********************************************************************** +goto endsort +:binderr +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +echo * An error occured during the Bind process. Please ensure that you * +echo * have installed all the necessary files and that these files are in * +echo * the current working directory or accessible via the DOS PATH, as * +echo * appropriate. * +echo * * +echo *********************************************************************** +goto endsort +:runerr +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +echo * An error occured while running. Please ensure that you have * +echo * correctly installed the COBOL system. * +echo * * +echo *********************************************************************** +goto endsort +:doanim +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +echo * The SORTDEMO program cannot be Animated on DOS. * +echo * * +echo *********************************************************************** +goto endsort +:errpre +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +echo * One or both of the files API.LIB and OS2.LIB are not in the * +echo * current directory. The bind process will not work correctly without * +echo * these files. Please copy them into the current directory before * +echo * restarting SRTDEM. * +echo * * +echo *********************************************************************** +if not exist %cobdir%\CBLBIND.NOT goto erros2 +if not exist %cobdir%\CBLBIND.LIB goto erros2 +if %1. == LCOBOL. if not exist %cobdir%\LCOBOL.LIB goto erros2 +if %1. == lcobol. if not exist %cobdir%\LCOBOL.LIB goto erros2 +if %1. == . if not exist %cobdir%\COBLIB.LIB goto erros2 +if %1. == . if not exist %cobdir%\COBLIB.DLE goto erros2 +if not exist SORTDEMO.CBL goto errtic +goto endsort +:erros2 +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +if %1. == LCOBOL. goto los2l +if %1. == lcobol. goto los2l +echo * Some or all of the files CBLBIND.LIB, CBLBIND.NOT, COBLIB.LIB and * +echo * COBLIB.DLL which are loaded by SETUP with the OS/2 compiler, are * +goto los2e +:los2l +echo * Some or all of the files CBLBIND.LIB, CBLBIND.NOT, and * +echo * LCOBOL.LIB which are loaded by SETUP with the OS/2 compiler, are * +:los2e +echo * not in the COBOL system directory (identified by the environment * +echo * variable, COBDIR). The link and bind processes in this batch stream * +echo * will not work correctly without these files. Please load them into * +echo * the COBOL system directory before restarting SRTDEM. * +echo * * +echo *********************************************************************** +if not exist SORTDEMO.CBL goto errtic +goto endsort +:errcob +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +echo * The COBDIR environment variable is not set. Please ensure that you * +echo * have installed the COBOL system correctly. * +echo * * +echo *********************************************************************** +goto endsort +:errtic +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +echo * The SORTDEMO program is not in the current directory. Either change * +echo * directory or copy SORTDEMO.CBL from your issue disks. * +echo * * +echo *********************************************************************** +:endsort +echo *---------------------------------------------------------------------* +echo * End of SORTDEMO Demonstration * +echo *---------------------------------------------------------------------* diff --git a/Microsoft COBOL v45/DEMO/SRTDEM.CMD b/Microsoft COBOL v45/DEMO/SRTDEM.CMD new file mode 100644 index 0000000..eeaa1cf --- /dev/null +++ b/Microsoft COBOL v45/DEMO/SRTDEM.CMD @@ -0,0 +1,206 @@ +echo off +rem Batch File to Compile, Link and Run the SORTDEMO demonstration program. +rem This batch file can be run from your OS/2 prompt. If you specify the +rem "animate" parameter to the batch file then the SORTDEMO program will be +rem compiled, linked and then ANIMATED. +rem v 1.2.2 +cls +echo . +echo *------------------* SORTDEMO demonstration program *-----------------* +echo * * +echo * The SORTDEMO program demonstrates how to use OS/2 function calls * +echo * in COBOL programs, and how to animate programs containing such * +echo * calls. This batch stream will compile, link and run, or compile * +echo * and animate the SORTDEMO program. To obtain animation, invoke this * +echo * batch stream with the parameter, ANIMATE. * +echo * * +echo * Please ensure that you have followed the installation instructions * +echo * for COBOL, using SETUP to load the OS/2 compiler and the Microsoft * +echo * Utilities, including the OS/2 specific files. * +echo * * +echo * Press Ctrl+C to exit if you have NOT properly installed your * +echo * COBOL Compiler, or copied the required files. * +echo * * +echo *---------------------------------------------------------------------* +echo . +pause +cls +if %COBDIR%. == . goto errcob +if not exist SORTDEMO.CBL goto errtic +if %1. == animate. goto doanim +if %1. == ANIMATE. goto doanim +: +if %1. == LCOBOL. if not exist %cobdir%\LCOBOL.LIB goto errlib +if %1. == lcobol. if not exist %cobdir%\LCOBOL.LIB goto errlib +if %1. == . if not exist %cobdir%\COBLIB.LIB goto errlib +if %1. == . if not exist %cobdir%\COBLIB.DLL goto errlib +cls +echo *---------------------------------------------------------------------* +echo * Compiling the SORTDEMO demonstration program * +echo *---------------------------------------------------------------------* +echo on +COBOL SORTDEMO.CBL OPTSPEED NOTRICKLE ; +echo off +if errorlevel 1 goto nocob +echo *---------------------------------------------------------------------* +echo * Compilation of SORTDEMO has completed successfully * +echo *---------------------------------------------------------------------* +pause +cls +echo *---------------------------------------------------------------------* +echo * Linking the SORTDEMO program * +echo * * +if %1. == lcobol. goto ltxtl +if %1. == LCOBOL. goto ltxtl +echo * The program will be linked to run with the shared run-time, * +echo * COBLIB. The EXE file created requires the file COBLIB.DLL to be * +echo * present in the current or COBOL system directories in order to * +echo * operate. (The directory must also be on your LIBPATH.) * +echo * * +echo * Restart this batch file with the parameter, LCOBOL, to see the * +echo * program statically linked so that it is independent of any other * +echo * files at run-time. (i.e. enter SRTDEM LCOBOL) * +goto ltxte +:ltxtl +echo * The program will be statically linked. That is, the COBOL run-time * +echo * support required for this program is linked into the EXE file * +echo * making it independent of any other files at run-time. * +:ltxte +echo * * +echo *---------------------------------------------------------------------* +if %1. == LCOBOL. goto linkl +if %1. == lcobol. goto linkl +echo on +LINK SORTDEMO/NOD,,,COBLIB+OS2; +echo off +goto linke +:linkl +echo on +LINK SORTDEMO/NOD,,,LCOBOL+OS2; +echo off +:linke +if errorlevel == 1 goto linkerr +if not exist SORTDEMO.EXE goto linkerr +echo *---------------------------------------------------------------------* +echo * Linking of SORTDEMO has completed successfully * +echo *---------------------------------------------------------------------* +pause +cls +echo *---------------------------------------------------------------------* +echo * Running SORTDEMO * +echo *---------------------------------------------------------------------* +echo on +SORTDEMO +echo off +if errorlevel == 1 goto runerr +cls +echo . +echo *---------------------------------------------------------------------* +echo * * +echo * For an example of how to Animate this program, and others using * +echo * calls to OS/2 API functions, rerun this demo, but with a parameter * +echo * of ANIMATE (i.e. enter SRTDEM ANIMATE) * +echo * * +echo *---------------------------------------------------------------------* +echo . +goto endsort +:doanim +cls +echo *---------------------------------------------------------------------* +echo * Compiling the SORTDEMO demonstration program for Animation * +echo *---------------------------------------------------------------------* +echo on +COBOL SORTDEMO.CBL ANIM; +echo off +if errorlevel 1 goto nocob +echo *---------------------------------------------------------------------* +echo * Compilation of SORTDEMO has completed successfully * +echo *---------------------------------------------------------------------* +pause +cls +echo *---------------------------------------------------------------------* +echo * Animating the SORTDEMO program * +echo * * +echo * The program calls VIO API functions. In order to ensure that these * +echo * write to the user screen rather than the Animator screen, the * +echo * FLASH-CALLS directives is used. * +echo * * +echo *---------------------------------------------------------------------* +pause +echo on +ANIMATE SORTDEMO FLASH-CALLS +echo off +echo *---------------------------------------------------------------------* +echo * If you terminated the Animation without completing the program your * +echo * screen may be in the wrong mode. You can restore the default mode * +echo * using the "MODE" command. For example, enter * +echo * MODE CO80 * +echo *---------------------------------------------------------------------* +goto endsort +:nocob +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +echo * An error occured while compiling SORTDEMO. Please ensure that you * +echo * have installed all the necessary files. * +echo * * +echo *********************************************************************** +goto endsort +:linkerr +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +echo * An error occured while linking. Please ensure that you have * +echo * correctly installed all the necessary files. * +echo * * +echo *********************************************************************** +goto endsort +:runerr +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +echo * An error occured while running. Please ensure that you have * +echo * correctly installed the COBOL system. * +echo * * +echo *********************************************************************** +goto endsort +:errcob +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +echo * The COBDIR environment variable is not set. Please ensure that you * +echo * have installed the COBOL system correctly. * +echo * * +echo *********************************************************************** +goto endsort +:errtic +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +echo * The SORTDEMO program is not in the current directory. Either change * +echo * directory or copy SORTDEMO.CBL from your issue disks. * +echo * * +echo *********************************************************************** +goto endsort +:errlib +echo *********************************************************************** +echo * *** ERROR *** * +echo * * +if %1. == LCOBOL. goto los2l +if %1. == lcobol. goto los2l +echo * One or both of the files COBLIB.LIB and COBLIB.DLL (the shared * +echo * run-time) required for linking and running this program are * +goto los2e +:los2l +echo * The file, LCOBOL.LIB, needed for statically linking this program is * +:los2e +echo * not in the COBOL system directory (identified by the environment * +echo * variable, COBDIR). The link processes in this batch stream will * +echo * not work correctly without these files. Please load them into the * +echo * COBOL system directory before restarting SRTDEM. * +echo * * +echo *********************************************************************** +:endsort +echo *---------------------------------------------------------------------* +echo * End of SORTDEMO Demonstration * +echo *---------------------------------------------------------------------* diff --git a/Microsoft COBOL v45/DEMO/SSCNTRL.CBL b/Microsoft COBOL v45/DEMO/SSCNTRL.CBL new file mode 100644 index 0000000..bba6dfb --- /dev/null +++ b/Microsoft COBOL v45/DEMO/SSCNTRL.CBL @@ -0,0 +1,58 @@ + $set ans85 noosvs mf + ***************************************************************** + * * + * (C) Micro Focus Ltd. 1989 * + * * + * SSCNTRL.CBL * + * * + * Demonstration of the use of dynamic attributes in screen * + * section. This example shows how to use the CONTROL clause * + * in a screen section to indicate invalid fields after an * + * accept statement. Monochrome terminal users can also see * + * the use of attribute strings to set reverse video; color * + * terminal users can "uncomment" the line changing colors to * + * view the use of attribute strings to set colors. * + ***************************************************************** + + working-storage section. + 01 field1 pic x(4) value spaces. + 01 field2 pic x(4) value spaces. + 01 field3 pic x(4) value spaces. + 01 attr-string pic X(50). + + 78 ws-reverse-video value 'reverse-video'. + 78 ws-highlight value 'highlight'. + 78 ws-blink value 'blink'. + 78 ws-red-on-white value 'foreground-color 4 background-color 7'. + + screen section. + 01 blank-screen blank screen. + + 01 screen-1. + 05 line 3 col 15 + value 'Fill the fields with data'. + 05 line 6 col 20 value 'Field 1 : '. + 05 pic xxxx using field1 auto-skip full required. + 05 line 8 col 20 value 'Field 2 : '. + 05 pic xxxx using field2 + control attr-string auto-skip full required. + 05 line 10 col 20 value 'Field 3 : '. + 05 pic xxxx using field3 required. + + 01 error-screen. + 05 line 24 col 10 + value 'Field 2 must contain ''9999'' to terminate'. + + procedure division. + display blank-screen + perform until field2 = '9999' + display screen-1 + accept screen-1 + if field2 not = '9999' + display error-screen +******* move ws-red-on-white to attr-string + move ws-reverse-video to attr-string + end-if + end-perform. + stop run. + diff --git a/Microsoft COBOL v45/DEMO/STATUS.CBL b/Microsoft COBOL v45/DEMO/STATUS.CBL new file mode 100644 index 0000000..29185e8 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/STATUS.CBL @@ -0,0 +1,67 @@ + $set mf noosvs ans85 + ***************************************************************** + * * + * (C) Micro Focus Ltd. 1989 * + * * + * STATUS.CBL * + * * + * This program demonstrates how to interpret values returned * + * in the second of the two status bytes. Status bytes are set * + * up after EVERY file operation (assuming that you have declared* + * them in the select clause) and it is important to check the * + * values returned after every operation. This program shows how* + * to do this. * + * * + * The program tries to open and close a file called INPUT.FIL. * + * If the operations fail it displays the corresponding file * + * status bytes * + * * + ***************************************************************** + + identification division. + program-id. check-file-status. + + select input-file assign "input.fil" + organization sequential + status stat. + + fd input-file. + 01 input-record pic x(80). + + working-storage section. + + * define status bytes and redefinition as follows + * (note that the picture clauses are important) + 01 stat. + 03 s1 pic x. + 03 s2 pic x. + 03 s2-bin redefines s2 + pic 9(2) comp-x. + + * have a display item too. + 01 stat-display. + 03 s1-display pic x. + 03 filler pic x. + 03 s2-display pic 9(3). + + procedure division. + open input input-file. + perform check-status. + + close input-file. + perform check-status. + + stop run. + + check-status. + * a value of "00" indicates a successful operation + if stat not = "00" then + move s1 to s1-display + if s1 = "9" then + move s2-bin to s2-display + else + move s2 to s2-display + end-if + display "operation fails - current status = " + stat-display + end-if. diff --git a/Microsoft COBOL v45/DEMO/TICBUG.CBL b/Microsoft COBOL v45/DEMO/TICBUG.CBL new file mode 100644 index 0000000..0d91623 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/TICBUG.CBL @@ -0,0 +1,238 @@ + $set ans85 mf + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * TICBUG.CBL * + * * + * This program demonstrates how to debug a program. * + * * + ************************************************************ + identification division. + program-id. ticbug. + environment division. + configuration section. + source-computer. ibm-pc. + object-computer. ibm-pc. + special-names. + console is crt. + data division. + working-storage section. + 01 tictac-00. + 02 tictac-q. + 03 game pic x(10) value spaces. + 03 filler-0 pic x(70) value spaces. + 03 question pic x(20) value spaces. + 02 filler. + 03 filler-1 pic x(414) value all spaces. + 03 tictac-00-0735 pic x(17) value "7º 8º 9". + 03 filler-2 pic x(64) value all spaces. + 03 tictac-00-0836 pic x(09) value "º º". + 03 filler-3 pic x(71) value all spaces. + 03 tictac-00-0936 pic x(09) value "º º". + 03 filler-4 pic x(64) value all spaces. + 03 tictac-00-1029 pic x(23) value "ÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍ". + 03 filler-5 pic x(63) value all spaces. + 03 tictac-00-1135 pic x(17) value "4º 5º 6". + 03 filler-6 pic x(64) value all spaces. + 03 tictac-00-1236 pic x(09) value "º º". + 03 filler-7 pic x(71) value all spaces. + 03 tictac-00-1336 pic x(09) value "º º". + 03 filler-8 pic x(64) value all spaces. + 03 tictac-00-1429 pic x(23) value "ÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍ". + 03 filler-9 pic x(63) value all spaces. + 03 tictac-00-1535 pic x(17) value "1º 2º 3". + 03 filler-10 pic x(64) value all spaces. + 03 tictac-00-1636 pic x(09) value "º º". + 03 filler-11 pic x(71) value all spaces. + 03 tictac-00-1736 pic x(09) value "º º". + 03 filler-12 pic x(595) value all spaces. + 01 entry-array. + 03 entry-char pic x occurs 9 times. + 01 check-array. + 03 check pic s99 comp occurs 9 times. + 01 xcount pic 9(2) comp. + 01 ocount pic 9(2) comp. + 01 factor pic s9(2) comp. + 01 char pic x. + 01 char9 redefines char pic 9. + 01 idx pic 9(2) comp. + 01 result pic 9(2) comp. + 01 cursor-pos. + 03 row pic 9(2) comp value 99. + 03 filler pic 9(2) comp value 99. + 01 address-init. + 03 filler pic 9(4) value 1732. + 03 filler pic 9(4) value 1740. + 03 filler pic 9(4) value 1748. + 03 filler pic 9(4) value 1332. + 03 filler pic 9(4) value 1340. + 03 filler pic 9(4) value 1348. + 03 filler pic 9(4) value 0932. + 03 filler pic 9(4) value 0940. + 03 filler pic 9(4) value 0948. + 01 address-array redefines address-init. + 03 addr pic 9(4) occurs 9 times. + 01 location pic 9(4). + 01 game-lines value "147123311113332436978979". + 03 a pic 9 occurs 8 times. + 03 b pic 9 occurs 8 times. + 03 c pic 9 occurs 8 times. + 01 i pic 9(2) comp. + 01 j pic 9(2) comp. + 01 moves pic 9(2) comp. + + 78 clear-screen value x"e4". + 78 sound-bell value x"e5". + + procedure division. + play-game section. + play-1. + perform with test after + until char not = "Y" and char not = "y" + call clear-screen + display + "To select a square type a number between 1 and 9" + upon crt + perform init + move "Shall I start ? " to question + perform get-reply + if char = "Y" + move 10 to check(5) + perform put-move + end-if + perform new-move until game not = spaces + move "Play again ? " to question + perform get-reply + end-perform. + + play-stop. + stop run. + + get-reply section. + display tictac-q at 0201 + accept char at 0317 with no-echo auto-skip + move spaces to question + display tictac-00 at 0201. + + init section. + move "y" to char + move spaces to entry-array + move low-values to check-array + move spaces to game + move zero to moves. + + new-move section. + perform get-move with test after until char9 not = 0 + perform move-check + if game not = "stalemate" + move low-values to check-array + perform check-line varying i from 1 by 1 + until i > 8 or game not = spaces + if game not = "You win" + perform put-move + end-if + if game = "I win" or game = "You win" + perform varying idx from a(j) by b(j) + until idx > c(j) + move addr(idx) to location + move entry-char(idx) to char + display char at location with blink highlight + end-perform + end-if + end-if. + + check-line section. + move zero to xcount,ocount,factor + perform count-up varying idx from a(i) by b(i) + until idx > c(i) + if ocount = 0 or xcount = 0 + evaluate true + when ocount = 2 + if i = 4 + move 6 to j + move zero to xcount,ocount + perform count-up varying idx from a(j) by b(j) + until idx > c(j) + if xcount = 3 + move 6 to i + end-if + end-if + if xcount not = 3 + move 50 to factor + move "I win" to game + move i to j + end-if + when xcount = 2 + move 20 to factor + when ocount = 1 + move 4 to factor + when xcount = 1 + if entry-char(5) = "x" + move 1 to factor + else + move -1 to factor + end-if + when ocount = 0 + if xcount = 0 + move 2 to factor + end-if + end-evaluate + end-if + if xcount = 3 + move "You win" to game + move i to j + else + perform varying idx from a(i) by b(i) until idx > c(i) + if entry-char(idx) = space + add factor to check(idx) + end-if + end-perform + end-if. + + count-up section. + if entry-char(idx) = "X" add 1 to xcount + else if entry-char(idx) = "O" add 1 to ocount. + + put-move section. + move zero to idx + move -99 to factor + perform find-pos varying i from 1 by 1 until i > 9 + move "O" to entry-char(idx) + perform move-check. + + move-check section. + move addr(idx) to location + move entry-char(idx) to char + display char at location + add 1 to moves + if moves > 8 and game = spaces + move "stalemate" to game + end-if. + + find-pos section. + if entry-char(5) = space + move check(5) to factor + move 5 to idx + else + if check(i) not < factor and entry-char(i) = space + move check(i) to factor + move i to idx + end-if + end-if. + + get-move section. + display "Please select an empty square" at 0201 + move 0 to char9 + accept char9 at 0231 with auto-skip + if char9 = 0 + call sound-bell + else + move char9 to idx + if entry-char(idx) = space + move "X" to entry-char(idx) + else + move 0 to char9 + call sound-bell + end-if + end-if. diff --git a/Microsoft COBOL v45/DEMO/TICTAC.CBL b/Microsoft COBOL v45/DEMO/TICTAC.CBL new file mode 100644 index 0000000..0d6646e --- /dev/null +++ b/Microsoft COBOL v45/DEMO/TICTAC.CBL @@ -0,0 +1,239 @@ + $set ans85 mf align(2) + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * TICTAC.CBL * + * * + * This program demonstrates how to use a CRT. * + * * + ************************************************************ + identification division. + program-id. tictac. + environment division. + configuration section. + source-computer. ibm-pc. + object-computer. ibm-pc. + special-names. + console is crt. + data division. + working-storage section. + 01 tictac-00. + 02 tictac-q. + 03 game pic x(10) value spaces. + 03 filler-0 pic x(70) value spaces. + 03 question pic x(20) value spaces. + 02 filler. + 03 filler-1 pic x(414) value all spaces. + 03 tictac-00-0735 pic x(17) value "7º 8º 9". + 03 filler-2 pic x(64) value all spaces. + 03 tictac-00-0836 pic x(09) value "º º". + 03 filler-3 pic x(71) value all spaces. + 03 tictac-00-0936 pic x(09) value "º º". + 03 filler-4 pic x(64) value all spaces. + 03 tictac-00-1029 pic x(23) value "ÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍ". + 03 filler-5 pic x(63) value all spaces. + 03 tictac-00-1135 pic x(17) value "4º 5º 6". + 03 filler-6 pic x(64) value all spaces. + 03 tictac-00-1236 pic x(09) value "º º". + 03 filler-7 pic x(71) value all spaces. + 03 tictac-00-1336 pic x(09) value "º º". + 03 filler-8 pic x(64) value all spaces. + 03 tictac-00-1429 pic x(23) value "ÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍ". + 03 filler-9 pic x(63) value all spaces. + 03 tictac-00-1535 pic x(17) value "1º 2º 3". + 03 filler-10 pic x(64) value all spaces. + 03 tictac-00-1636 pic x(09) value "º º". + 03 filler-11 pic x(71) value all spaces. + 03 tictac-00-1736 pic x(09) value "º º". + 03 filler-12 pic x(595) value all spaces. + 01 entry-array. + 03 entry-char pic x occurs 9 times. + 01 check-array. + 03 check pic s99 comp occurs 9 times. + 01 xcount pic 9(2) comp. + 01 ocount pic 9(2) comp. + 01 factor pic s9(2) comp. + 01 char pic x. + 01 char9 redefines char pic 9. + 01 idx pic 9(2) comp. + 01 result pic 9(2) comp. + 01 cursor-pos. + 03 row pic 9(2) comp value 99. + 03 filler pic 9(2) comp value 99. + 01 address-init. + 03 filler pic 9(4) value 1732. + 03 filler pic 9(4) value 1740. + 03 filler pic 9(4) value 1748. + 03 filler pic 9(4) value 1332. + 03 filler pic 9(4) value 1340. + 03 filler pic 9(4) value 1348. + 03 filler pic 9(4) value 0932. + 03 filler pic 9(4) value 0940. + 03 filler pic 9(4) value 0948. + 01 address-array redefines address-init. + 03 addr pic 9(4) occurs 9 times. + 01 location pic 9(4). + 01 game-lines value "147123311113332436978979". + 03 a pic 9 occurs 8 times. + 03 b pic 9 occurs 8 times. + 03 c pic 9 occurs 8 times. + 01 i pic 9(2) comp. + 01 j pic 9(2) comp. + 01 moves pic 9(2) comp. + + 78 clear-screen value x"e4". + 78 sound-bell value x"e5". + + procedure division. + play-game section. + play-1. + perform with test after + until char not = "Y" and char not = "y" + call clear-screen + display + "To select a square type a number between 1 and 9" + upon crt + perform init + move "Shall I start ? " to question + perform get-reply + if char = "Y" or char = "y" + move 10 to check(5) + perform put-move + end-if + perform new-move until game not = spaces + move "Play again ? " to question + perform get-reply + end-perform. + + play-stop. + display space + stop run. + + get-reply section. + display tictac-q at 0201 + accept char at 0317 with no-echo auto-skip + move spaces to question + display tictac-00 at 0201. + + init section. + move "y" to char + move spaces to entry-array + move low-values to check-array + move spaces to game + move zero to moves. + + new-move section. + perform get-move with test after until char9 not = 0 + perform move-check + if game not = "stalemate" + move low-values to check-array + perform check-line varying i from 1 by 1 + until i > 8 or game not = spaces + if game not = "You win" + perform put-move + end-if + if game = "I win" or game = "You win" + perform varying idx from a(j) by b(j) + until idx > c(j) + move addr(idx) to location + move entry-char(idx) to char + display char at location with blink highlight + end-perform + end-if + end-if. + + check-line section. + move zero to xcount,ocount,factor + perform count-up varying idx from a(i) by b(i) + until idx > c(i) + if ocount = 0 or xcount = 0 + evaluate true + when ocount = 2 + if i = 4 + move 6 to j + move zero to xcount,ocount + perform count-up varying idx from a(j) by b(j) + until idx > c(j) + if xcount = 3 + move 6 to i + end-if + end-if + if xcount not = 3 + move 50 to factor + move "I win" to game + move i to j + end-if + when xcount = 2 + move 20 to factor + when ocount = 1 + move 4 to factor + when xcount = 1 + if entry-char(5) = "x" + move 1 to factor + else + move -1 to factor + end-if + when ocount = 0 + if xcount = 0 + move 2 to factor + end-if + end-evaluate + end-if + if xcount = 3 + move "You win" to game + move i to j + else + perform varying idx from a(i) by b(i) until idx > c(i) + if entry-char(idx) = space + add factor to check(idx) + end-if + end-perform + end-if. + + count-up section. + if entry-char(idx) = "X" add 1 to xcount + else if entry-char(idx) = "O" add 1 to ocount. + + put-move section. + move zero to idx + move -99 to factor + perform find-pos varying i from 1 by 1 until i > 9 + move "O" to entry-char(idx) + perform move-check. + + move-check section. + move addr(idx) to location + move entry-char(idx) to char + display char at location + add 1 to moves + if moves > 8 and game = spaces + move "stalemate" to game + end-if. + + find-pos section. + if entry-char(5) = space + move check(5) to factor + move 5 to idx + else + if check(i) not < factor and entry-char(i) = space + move check(i) to factor + move i to idx + end-if + end-if. + + get-move section. + display "Please select an empty square" at 0201 + move 0 to char9 + accept char9 at 0231 with auto-skip + if char9 = 0 + call sound-bell + else + move char9 to idx + if entry-char(idx) = space + move "X" to entry-char(idx) + else + move 0 to char9 + call sound-bell + end-if + end-if. diff --git a/Microsoft COBOL v45/DEMO/TSTDEBUG.CBL b/Microsoft COBOL v45/DEMO/TSTDEBUG.CBL new file mode 100644 index 0000000..7cfa923 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/TSTDEBUG.CBL @@ -0,0 +1,95 @@ + $set ans85 noosvs mf + ************************************************************ + * * + * (C) Micro Focus Ltd. 1989 * + * * + * TSTDEBUG.CBL * + * * + * This program demonstrates how to make use of * + * the ANSI DEBUGGER facility available within * + * COBOL. ANIMATOR debugging tool is also available * + * and would normally be used in preference to * + * the ANSI debugger Essential lines to include * + * are in upper-case * + * * + * To make use of the ANSI debugging facility * + * the program needs to be run with the +D run * + * time switch. * + * * + * Any line containing a D in column 7 will be * + * treated as a comment line when the * + * WITH DEBUGGING MODE option is removed from the * + * source. * + * * + ************************************************************ + + + environment division. + source-computer. ibm-pc with debugging mode. + object-computer. ibm-pc. + special-names. + console is crt. + file-control. + select file1 assign "tst.fil" + status is file1-stat. + data division. + fd file1. + 01 f1-rec pic x(80). + working-storage section. + 01 counts pic 99 value 1. + 01 file1-stat. + 02 s1 pic x. + 02 s2 pic x. + 01 stat-bin redefines file1-stat pic 9(4) comp. + 01 display-stat. + 02 messag pic x(16) value "RUN-TIME ERROR ". + 02 s1-disp pic x. + 02 filler pic x value space. + 02 s2-disp pic 9(4). + 01 out-buff pic x(80) value all "A". + + *************************************************************** + * * + * OUTS should be 56 bytes + the length of your longest record * + * * + *************************************************************** + + 01 outs pic x(136) value spaces. + / + procedure division. + + *************************************************************** + * * + * DEBUG-ITEM is created by the compiler when the WITH * + * DEBUGGING MODE is specified, and can only be accessed * + * by the use of a MOVE to another 'PIC X(nnn)' field * + * * + *************************************************************** + + declaratives. + animator section. + use for debugging on all procedures. + display "debugging line" at 2430. + add 1 to counts. + move debug-item to outs. + display outs at 2001. + display counts at 2445. + end declaratives. + + main section. + display spaces + open output file1. + if s1 not = 0 perform sect1. + write f1-rec from out-buff. + if s1 not = 0 perform sect1. + close-up section. + close file1. + if s1 not = 0 perform sect1. + stop run. + sect1 section. + move s1 to s1-disp. + move low-values to s1. + move stat-bin to s2-disp. + display display-stat. + + diff --git a/Microsoft COBOL v45/DEMO/TTDEMO.BAT b/Microsoft COBOL v45/DEMO/TTDEMO.BAT new file mode 100644 index 0000000..1a7b96d --- /dev/null +++ b/Microsoft COBOL v45/DEMO/TTDEMO.BAT @@ -0,0 +1,146 @@ +echo off +rem Batch File to Compile, Link and Run the TICTAC demonstration program. +rem This batch file can be run from your DOS prompt. If you specify the +rem "animate" parameter to the batch file then the TICTAC program will be +rem compiled and then ANIMATED. +cls +echo . +echo *------------------* TICTAC demonstration program *-------------------* +echo * * +echo * Please ensure that you have followed the installation instructions * +echo * for COBOL, which are found in the COBOL Getting Started manual. +echo * This means that you have included the directory containing your * +echo * COBOL Compiler on your DOS PATH and you will have to set up the +echo * COBDIR environment variable to also include the COBOL Compiler * +echo * directory. * +echo * * +echo * Press Ctrl+C to exit if you have NOT properly installed your * +echo * COBOL Compiler, or copied the required files. * +echo * * +echo *---------------------------------------------------------------------* +echo . +pause +if not exist TICTAC.CBL goto errtic +:cobret +if %1. == animate. goto doanim +if %1. == ANIMATE. goto doanim +cls +echo *---------------------------------------------------------------------* +echo * Compiling the TICTAC demonstration program * +echo *---------------------------------------------------------------------* +echo on +COBOL TICTAC.CBL; +echo off +if errorlevel 1 goto nocob +echo *---------------------------------------------------------------------* +echo * Compiling successfully completed * +echo *---------------------------------------------------------------------* +pause +cls +echo *---------------------------------------------------------------------* +echo * Linking the TICTAC program * +echo * * +echo * Notice inclusion of ADIS. * +echo * * +if %1. == lcobol. goto ltxtl +if %1. == LCOBOL. goto ltxtl +echo * The program will be linked to run with the shared run-time, * +echo * COBLIB. The EXE file created requires the file COBLIB.DLE to be * +echo * present in the COBOL system directories in order to operate. * +echo * * +echo * Restart this batch file with the parameter, LCOBOL, to see the * +echo * program statically linked so that it is independent of any other * +echo * files at run-time. (i.e. enter TTDEMO LCOBOL) * +goto ltxte +:ltxtl +echo * The program will be statically linked. That is, the COBOL run-time * +echo * support required for this program is linked into the EXE file * +echo * making it independent of any other files at run-time. * +:ltxte +echo * * +echo *---------------------------------------------------------------------* +if %1. == lcobol. goto linkl +if %1. == LCOBOL. goto linkl +:linkc +echo on +LINK TICTAC+ADIS+ADISKEY+ADISINIT/NOD,,,COBLIB+COBAPI ; +echo off +goto linke +:linkl +echo on +LINK TICTAC+ADIS+ADISKEY+ADISINIT/NOD,,,LCOBOL+COBAPI ; +echo off +:linke +echo off +echo *---------------------------------------------------------------------* +echo * Linking successfully completed * +echo *---------------------------------------------------------------------* +pause +cls +echo *---------------------------------------------------------------------* +echo * Running TICTAC * +echo * * +echo * Can you beat the Program? It is possible !! * +echo * * +echo *---------------------------------------------------------------------* +echo on +TICTAC +echo off +echo . +cls +echo *---------------------------------------------------------------------* +echo * * +echo * Have you tried the COBOL ANIMATOR ? * +echo * * +echo * For an example of how to get going with the ANIMATOR, rerun this * +echo * batch file with the "animate" parameter. That is, type the * +echo * following: "TTDEMO ANIMATE" * +echo * * +echo *---------------------------------------------------------------------* +echo . +goto endtic +:doanim +cls +echo *---------------------------------------------------------------------* +echo * Compiling the TICTAC demonstration program for Animation * +echo *---------------------------------------------------------------------* +echo on +COBOL TICTAC.CBL ANIM; +echo off +if errorlevel 1 goto nocob +echo *---------------------------------------------------------------------* +echo * Compiling successfully completed * +echo *---------------------------------------------------------------------* +pause +cls +echo *---------------------------------------------------------------------* +echo * Animating the TICTAC program * +echo *---------------------------------------------------------------------* +echo on +ANIMATE TICTAC +echo off +if errorlevel 1 goto nocob +echo *---------------------------------------------------------------------* +echo * Animating successfully completed * +echo *---------------------------------------------------------------------* +pause +goto endtic +:nocob +echo *********************************************************************** +echo * * +echo * An error occured while running the Compiler. Please ensure that you * +echo * have installed all the necessary files. * +echo * * +echo *********************************************************************** +goto endtic +:errtic +echo *********************************************************************** +echo * * +echo * The TICTAC program is not in the current directory. Either change * +echo * directory or copy TICTAC.CBL from your issue disks. * +echo * * +echo *********************************************************************** +:endtic +echo *---------------------------------------------------------------------* +echo * End of TICTAC Demonstration * +echo *---------------------------------------------------------------------* diff --git a/Microsoft COBOL v45/DEMO/TTDEMO.CMD b/Microsoft COBOL v45/DEMO/TTDEMO.CMD new file mode 100644 index 0000000..5107e28 --- /dev/null +++ b/Microsoft COBOL v45/DEMO/TTDEMO.CMD @@ -0,0 +1,145 @@ +echo off +rem Batch File to Compile, Link and Run the TICTAC demonstration program. +rem This batch file can be run from your OS/2 prompt. If you specify the +rem "animate" parameter to the batch file then the TICTAC program will be +rem compiled and then ANIMATED. +cls +echo . +echo *------------------* TICTAC demonstration program *-------------------* +echo * * +echo * Please ensure that you have followed the installation instructions * +echo * for COBOL, which are found in the COBOL/2 Getting Started manual. * +echo * This means that you have included the directory containing * +echo * containing your COBOL Compiler on your OS/2 PATH and you * +echo * will have set up the COBDIR environment variable to also include * +echo * the COBOL Compiler directory. * +echo * * +echo * Press Ctrl+C to exit if you have NOT properly installed your * +echo * COBOL Compiler, or copied the required files. * +echo * * +echo *---------------------------------------------------------------------* +echo . +pause +if not exist TICTAC.CBL goto errtic +:cobret +if %1. == animate. goto doanim +if %1. == ANIMATE. goto doanim +cls +echo *---------------------------------------------------------------------* +echo * Compiling the TICTAC demonstration program * +echo *---------------------------------------------------------------------* +echo on +COBOL TICTAC.CBL; +echo off +if errorlevel 1 goto nocob +echo *---------------------------------------------------------------------* +echo * Compiling successfully completed * +echo *---------------------------------------------------------------------* +pause +cls +echo *---------------------------------------------------------------------* +echo * Linking the TICTAC program * +echo * * +echo * Notice inclusion of ADIS. * +echo * * +if %1. == lcobol. goto ltxtl +if %1. == LCOBOL. goto ltxtl +echo * The program will be linked to run with the shared run-time, * +echo * COBLIB. The EXE file created requires the file COBLIB.DLE to be * +echo * present in the COBOL system directories in order to operate. * +echo * * +echo * Restart this batch file with the parameter, LCOBOL, to see the * +echo * program statically linked so that it is independent of any other * +echo * files at run-time. (i.e. enter TTDEMO LCOBOL) * +goto ltxte +:ltxtl +echo * The program will be statically linked. That is, the COBOL run-time * +echo * support required for this program is linked into the EXE file * +echo * making it independent of any other files at run-time. * +:ltxte +echo * * +echo *---------------------------------------------------------------------* +if %1. == lcobol. goto linkl +if %1. == LCOBOL. goto linkl +:linkc +echo on +LINK TICTAC+ADIS+ADISKEY+ADISINIT/NOD,,,COBLIB+OS2; +echo off +goto linke +:linkl +echo on +LINK TICTAC+ADIS+ADISKEY+ADISINIT/NOD,,,LCOBOL+OS2; +echo off +:linke +echo off +echo *---------------------------------------------------------------------* +echo * Linking successfully completed * +echo *---------------------------------------------------------------------* +pause +cls +echo *---------------------------------------------------------------------* +echo * Running TICTAC * +echo * * +echo * Can you beat the Program? It is possible !! * +echo * * +echo *---------------------------------------------------------------------* +echo on +TICTAC +echo off +echo . +cls +echo *---------------------------------------------------------------------* +echo * * +echo * Have you tried the COBOL ANIMATOR ? * +echo * * +echo * For an example of how to get going with the ANIMATOR, rerun this * +echo * batch file with the "animate" parameter. That is, type the * +echo * following: "TTDEMO ANIMATE" * +echo * * +echo *---------------------------------------------------------------------* +echo . +goto endtic +:doanim +cls +echo *---------------------------------------------------------------------* +echo * Compiling the TICTAC demonstration program for Animation * +echo *---------------------------------------------------------------------* +echo on +COBOL TICTAC.CBL ANIM; +echo off +if errorlevel 1 goto nocob +echo *---------------------------------------------------------------------* +echo * Compiling successfully completed * +echo *---------------------------------------------------------------------* +pause +cls +echo *---------------------------------------------------------------------* +echo * Animating the TICTAC program * +echo *---------------------------------------------------------------------* +echo on +ANIMATE TICTAC +echo off +if errorlevel 1 goto nocob +echo *---------------------------------------------------------------------* +echo * Animating successfully completed * +echo *---------------------------------------------------------------------* +pause +goto endtic +:nocob +echo *********************************************************************** +echo * * +echo * An error occured while running the Compiler. Please ensure that you * +echo * have installed all the necessary files. * +echo * * +echo *********************************************************************** +:errtic +echo *********************************************************************** +echo * * +echo * The TICTAC program is not in the current directory. Either change * +echo * directory or copy TICTAC.CBL from your issue disks. * +echo * * +echo *********************************************************************** +:endtic +echo *---------------------------------------------------------------------* +echo * End of TICTAC Demonstration * +echo *---------------------------------------------------------------------* diff --git a/Microsoft COBOL v45/DOCS/CBL-CMPT.DOC b/Microsoft COBOL v45/DOCS/CBL-CMPT.DOC new file mode 100644 index 0000000..23d6173 --- /dev/null +++ b/Microsoft COBOL v45/DOCS/CBL-CMPT.DOC @@ -0,0 +1,671 @@ + + CBL-CMPT.DOC File + + Compatibility with Previous Releases of Microsoft(R) COBOL + + (C) Copyright Microsoft Corporation, 1991 + + + Contents + -------- + Introduction + Changes in Microsoft COBOL 4.5 + Changes in Microsoft COBOL 4.0 + Documentation + + + Introduction + ------------ + This document is for use when maintaining applications created using + earlier releases of this product. + + It describes the differences that may cause problems, and includes + documentation of features no longer documented in this system, but + maintained for compatibility. + + Note that the use of the compiler with default settings will cause the + use of new words to become reserved. A list of these words is given + below. + + + Changes in Microsoft COBOL 4.5 + ------------------------------ + Compiling + + o Use of the MF directive when compiling will cause some data names + to be illegal as the reserved word list has been extended. Change + the dataname, use the REMOVE(reservedword) directive or recompile + with MF(6). + + New reserved words included when using MF(7) are: + + ALPHABET ALPHABETIC-LOWER ALPHABETIC-UPPER + ALPHANUMERIC ALPHANUMERIC-EDITED ANY + BINARY CLASS COMMON + COMP-1 COMP-2 COMP-4 + COMPUTATIONAL-1 COMPUTATIONAL-2 COMPUTATIONAL-4 + CONTENT CONTINUE CONVERTING + CYCLE DAY-OF-WEEK DBCS + DISPLAY-1 EJECT END-ADD + END-CALL END-COMPUTE END-DELETE + END-DISPLAY END-DIVIDE END-EVALUATE + END-IF END-MULTIPLY END-PERFORM + END-READ END-RECEIVE END-RETURN + END-REWRITE END-SEARCH END-START + END-STRING END-SUBTRACT END-UNSTRING + END-WRITE EOL EOS + EQUALS EVALUATE EXCEEDS + FALSE FUNCTION GLOBAL + ID INITIALIZE LOWLIGHT + NUMERIC-EDITED ORDER OTHER + PACKED-DECIMAL PADDING PARAGRAPH + PURGE REFERENCE REPLACE + SKIP1 SKIP2 SKIP3 + SORT-RETURN STANDARD-2 TEST + TIME-OUT TIMEOUT TITLE + TRUE UNEQUAL WAIT + WHEN-COMPILED + + Note that most of these words are already reserved under the ANS85 or + VSC2 directives, so will only become new if you are compiling with MF + but without ANS85 or VSC2. + + o RM compatibility + + When compiling for RM compatibility, if the same behavior is required + as with Microsoft COBOL 4.0 then you should compile with the + DETECTLOCK directive. + + o ASSIGN TO PRINTER + + Files defined with ASSIGN TO PRINTER are treated as LINE ADVANCING in + COBOL 4.5. In 4.0, they were treated as LINE SEQUENTIAL. + + o NEXT SENTENCE + + In COBOL 4.0, you could make NEXT SENTENCE jump to the appropriate + end-scope delimiter by using the MF"5" directive (see below). In 4.5 + this directive does not have this effect. + + o Nested Programs + + In V4.0, nested programs could have Configuration Sections. In V4.5 + they cannot. + + o The "DISPLAY ... UPON CRT Attributes Behavior" switch S6 is no longer + documented in the Operating Guide. Here is its description. With the + Enhanced DISPLAY (see the Screen Handling chapter of the Language + Reference Manual), if no attributes are specified on the DISPLAY then, + by default, the attributes already existing in the given area will be + used. If the switch +S6 is specified at run time the normal screen + attributes will be used instead. + + o In earlier versions of this COBOL system all system library routines + were call-by-number. Many of the call-by-name routines in the present + product replace old call-by-number routines. The list below indicates, + for each call-by-name routine that has replaced a call-by-number + routine, the number of the routine it has replaced. In some cases the + call-by-name routine has additional features. + + Name Number + ---- ------ + CBL_READ_SCR_CHARS B7 0 + CBL_READ_SCR_ATTRS B7 2 + CBL_READ_SCR_CHATTRS B8 0 + CBL_WRITE_SCR_CHARS B7 1 + CBL_WRITE_SCR_ATTRS B7 3 + CBL_WRITE_SCR_CHATTRS B8 1 + CBL_WRITE_SCR_TTY 82 + CBL_WRITE_SCR_N_CHAR B7 4 + CBL_WRITE_SCR_N_ATTR B7 5 + CBL_SWAP_SCR_CHATTRS B8 2 + CBL_GET_SCR_SIZE E3 + CBL_SET_CSR_POS E6 + CBL_CLEAR_SCR E4 + CBL_GET_KBD_STATUS D9 + PC_READ_DRIVE 91 5 + PC_SET_DRIVE 91 6 + CBL_READ_DIR 91 7 + CBL_CHANGE_DIR 91 8 + CBL_DELETE_FILE 91 18 + CBL_RENAME_FILE 91 17 + PC_TEST_PRINTER B0 7 + CBL_SPLIT_FILENAME 8C + CBL_JOIN_FILENAME 8D + + o The behavior of COPY ... REPLACING has been changed depending on the + setting of the ANS85 or VSC2(3) directives. Previously all non-COBOL + characters were disallowed in operands to COPY ... REPLACING, and + lowercase and colon were added to the character set. This behavior now + only occurs if the ANS85 or VSC2(3) directive is used. Otherwise, the + operands may contain non-COBOL characters. + + + Changes in Microsoft COBOL 4.0 + ------------------------------ + General + + o When installing on an OS/2 system, SETUP will add PATH and + environment variable information to CONFIG.SYS and not to OS2INIT.CMD + as in previous releases. This conforms with the standard for + installing OS/2 v1.1 and later. + + o The files, DBCS.EXE/.DLL and V-ISAM.DLL are no longer required, and + are not included with this release. + + o The shared run-time files, COBLIB.DLE and COBLIB.DLL are used by the + components of this system, and must be loaded for the system to + operate. COBLIB.DLE is required for DOS, COBLIB.DLL for OS/2. + + o The callable file handler interface is no longer part of this + product. If you wish to use the CALLFH feature, or to call the file + handler directly, you will require a copy of the Micro Focus COBOL/2 + Toolset. + + Compiling + + o The default directives, NOCOPYLBR, ANS85, NOOSVS and MF are now built + into the compiler and are not included in the COBOL.DIR created by + SETUP. ANS85 and OSVS can be changed by SETUP, so that NOANS85 and/or + OSVS are included in the COBOL.DIR created by SETUP. SETUP also + allows selection of SAA and the default linking libraries. + + o VSC2 is now equivalent to VSC2(3). Previously VSC2 was equivalent to + VSC2(2). The directives VSC2 OLDVSC2 have been replaced by VSC2(1). + + o The directive OLDFILEIO has been replaced by the directive IDXFORMAT + which defines the type of indexed file required. IDXFORMAT"2" is + equivalent to OLDFILEIO. + + o The verb, GOBACK, and the special register, RETURN-CODE are now part + of the standard Micro Focus(R) COBOL language and can be used without + needing VSC2 or OSVS. They are enabled by an MF level of 5 or above + (on by default) and can, therefore, be disabled by specifying MF(4). + + o Comments following the PROGRAM-ID, which were allowed in previous + versions, are now not allowed by default. They can, however, be + enabled using the PROGID-COMMENT directive. + + o For interfacing at the assembler level, note that the object segment + class names created by the COBOL compiler have changed in this + release. + + o The default ALPHASTART value has been set to 1 to conform to the + ANSI'85 standard. In previous versions, this was set to 0. If you + have programs that use the ALPHABET clause of the SPECIAL-NAMES + paragraph, you may need to specify the directive ALPHASTART"0" to + maintain the required behavior. + + o ACCEPT .. FROM DAY-OF-WEEK + + The statement + + ACCEPT data-item FROM DAY-OF-WEEK + + incorrectly returned the value 0 for Sunday. It now returns a value + of 7, as documented. + + o COMP-5 + + The default behavior of USAGE COMP-5 data items has been changed. In + previous versions of the product, COMP-5 was treated in a similar + fashion to signed COMP. It is now treated in a similar fashion to + COMP-X, allowing it to be a true binary numeric item using machine + specific byte ordering. This makes it a very efficient data type. + + If you use COMP-5 in existing programs, and depend on its sign + handling, you should compile your programs with the COMP-5"1" + directive. + + o NEXT SENTENCE + + NEXT SENTENCE is handled differently in this version of the product. + In previous versions NEXT SENTENCE would cause control to move to the + end of the sentence (i.e. following the next period) or to the + statement following the next end-scope delimiter. In this version, it + will always go to the end of the sentence, as defined by the ANSI'85 + standard. + + If your program uses NEXT SENTENCE and relies on the change of + control being to the appropriate end-scope delimiter, you can use the + MF"5" directive (but see above for V4.5). Alternatively, change the + NEXT SENTENCE phrases to CONTINUE, which will have the desired + effect. + + o SYMBOLIC CHARACTERS clause + + The default SYMBSTART value has been set to 1 to conform to the + ANSI'85 standard. In previous versions, this was set to 0. If you + have programs that use the SYMBOLIC CHARACTERS clause of the + SPECIAL-NAMES paragraph, you may need to specify the directive + SYMBSTART"0" to maintain the required behavior. + + o RECORDING MODE + + The RECORDING MODE phrase has been amended so that, when it is + explicitly included in an FD, it overrides the RECORD clause in all + cases, with RECORDING MODE F always causing a fixed format file to be + created, and RECORDING MODE V a variable format file. + + If you require the original behavior, whereby RECORDING MODE is + overridden by the RECORD clause, then use the MF"5" directive. + + Note that the RECMODE directive will not override the RECORD clause. + + o REPORT-WRITER reserved words + + The RW directive has been made obsolete by incorporating the REPORT- + WRITER reserved words into the main dialects that support REPORT- + WRITER. If you have a program that uses some REPORT-WRITER reserved + words as data names, and used to be compiled with the NORW directive, + then you need to replace the NORW directive by USE(NORW). This will + cause the REPORT-WRITER reserved words to be removed from the + reserved word list, making them available for use as data names. + + o INSPECT + + The handling of the LEADING phrase in INSPECT has been amended to + make it conform to a recent interpretation of the ANSI'85 standard. + For example, if data-stream contains "//AAA BBB OOO CCC", the + statement + + INSPECT data-stream TALLYING count-field + FOR LEADING "A" "\" " "O" "C" + + returned the value 5 in count-field in previous versions, but now + returns the value 2. This is because the remaining characters in the + LEADING phrase are considered to be ineligible once a match has been + found on one of the characters. + + o COPY filenames + + Since this version now distinguishes between filenames with no + extension, but with a trailing period, and those without a trailing + period (treating the former as a specified extension of spaces), + some COPY statements in existing programs may appear to stop + working. If you want your copy files to have extension .CPY, but + code them in your program with no extension, then you must be sure + that the name does not have a trailing period. For example, change: + + COPY "mycopy.". + + to + + COPY "mycopy". + + Note that + + COPY mycopy. + + is treated as if it has no trailing period, and hence as in previous + versions. + + + Running + + o A large number of the run-time system subprogram calls, provided in + earlier releases as call-by-number calls, have been replaced by named + calls. In addition to making the calls easier to remember and use, + the call-by-name calls can accept parameters defined in any part of + the data division. + + The replaced call-by-number calls are still supported in this + release, and documented below. However, we recommend that you + replace them with the equivalent call-by-name calls as appropriate. + + o Record sizes + + In previous releases, the maximum and minimum record sizes specified + for a variable format file had to be the same in every program + referencing the file. This restriction has been removed, allowing + programs to specify record lengths different to those specified in + the program used to create the file. However, if an attempt is made + to write a record which is smaller than the smallest defined or + larger than the largest defined a run-time error, 9/044, will be + returned. + + Animating + + o The method required to animate programs has changed in this release. + When a program is compiled for animation, using the ANIM directive, + intermediate code files are packaged into .OBJ files and .DLL on + OS/2). These .EXE/.DLL files can be animated in the usual way. The + pure intermediate code files (.INT) are no longer required for + animation. + + o Since the new animation method incorporates a link step, any non- + COBOL .OBJ files can be linked in prior to animation. These will + operate correctly when encountered, though always in zoom mode. This + new technique makes IANIM and augmented INT obsolete, and these + facilities are not supported in this release. + + The same method allows OS/2 API function calls to be resolved prior + to animation, avoiding the need for the Install Function technology + of earlier releases. + + o This release has the +F switch set by default. This will cause + illegal data in numeric fields to be trapped during animation, and + when running intermediate code .OBJ files (run-time system error + 163). This may cause existing programs to fail where they previously + worked. However, trapping such instances will help prevent the + subsequently generated code from failing. All generated programs will + work as at present, always assuming that numeric fields contain + numeric data. + + Linking + + o The linking library, OS2.LIB, should be used instead of DOSCALLS.LIB + when linking applications for use on OS/2(tm). OS2.LIB is supplied as + part of the utilities. (DOSCALLS.LIB can be used provided the + application is not a Presentation Manager application.) + + o The /NOP option is no longer required when linking for use on OS/2. + + o The default environment for applications created using this release + is the shared run-time environment. This is particularly recommended + for use on OS/2, where a single copy of COBLIB.DLL can be shared by + any COBOL application (built to use COBLIB) running in any OS/2 + session. + + To use this environment, the application is linked in the usual way, + using the libraries, COBLIB.LIB, and COBAPI.LIB or OS2.LIB depending + on DOS or OS/2. The EXE files produced will be much smaller since + little run-time system code is included directly. System programs, + such as EXTFH and ADIS, can be linked in with the application, or + linked as standalone sub-programs. Again, for OS/2, if linked as + standalone .DLL files, they can be shared by any number of COBOL + applications. + + Notes: + - These system programs MUST be linked with COBLIB for use with + COBLIB applications. + + - Modules linked with COBLIB cannot be mixed with modules linked + with LCOBOL. Hence, applications must be either all LCOBOL or all + COBLIB. However, COBLIB applications and LCOBOL applications can + be run on the same environment as long as they don't try to call + each other. + + o The linking library (.LIB) files supplied with the system have been + split in a different way to enable reduced disk usage. They now + consist of LCOBOL.LIB, COBLIB.LIB, and COBAPI.LIB. The new LCOBOL + is equivalent to the old PCOBOL. The addition of COBAPI.LIB to + LCOBOL.LIB gives the old LCOBOL. (Users may like to recombine these + libraries using LIB if they wish to retain old working practices.) + For OS/2 operation, LCOBOL.LIB is used in combination with OS2.LIB + (which supersedes DOSCALLS.LIB). + + In the shared run-time system, the default, COBLIB.LIB, is equivalent + to the old PRCOBOL.LIB. Again, either COBAPI.LIB or OS2.LIB is used + in combination with COBLIB.LIB to complete the linking for DOS or + OS/2 respectively. Applications linked with these libraries will be + very much smaller, benefiting from the shared run-time system support + in COBLIB.DLE and COBLIB.DLL. (Note that the application itself can + be bound so that it will run on both DOS and OS/2 provided both + shared run-time system files are present.) + + o If you select a linking environment other than the built-in default, + SETUP will create a default LINKLIB in your COBOL.DIR. The default, + and equivalent of earlier releases, is LINKLIB(LCOBOL+COBAPI). If + you normally use the system on OS/2, use LINKLIB(LCOBOL+OS2). With + this release, the default is to use the COBLIB shared run-time system, + requiring LINKLIB(COBLIB+COBAPI) on DOS, and LINKLIB(COBLIB+OS2) on + OS/2. + + When the default has been set in this way, you can still link for use + in other environments by specifying the relevant libraries on the + LINK command line. However, you should use the /NOD directive when + doing so, otherwise link-time errors may occur. + + o The file handler for indexed files, IXSIO, has been replaced by the + external file handler, EXTFH. This can be linked in exactly the same + way as IXSIO in earlier releases, either linked in with the + application or linked as a standalone system program. + + Programs referencing ANSI'85 EXTERNAL files and normal indexed files + now only use EXTFH rather than two separate file handlers. + + Compatibility issues + + Compiling + + o If you compile your programs on OS/2 using batch files, you will need + to alter the batch files to compile using the command COBOL instead + of PCOBOL. Alternatively, you can copy COBOL.EXE to PCOBOL.EXE in the + COBOL system directory. + + o Programs previously compiled without the ANS85 directive, if + recompiled under this default system, may not work correctly. The + most likely cause is that the new system has ANS85 on by default. + This causes all file status codes to be ANS85 not ANS74 statuses. + The problem can be avoided by using the NOANS85 directive when + compiling any program that is designed to work with ANS74 file + statuses. + + Animating + + o The compiler dictionary structure has been amended. This means that + IDY files created by earlier releases will not be compatible with + ANIMATOR in this system. Hence, you should recompile, with this + release of the compiler, any program you wish to animate. + + Linking + + o .OBJ files created by this release are not compatible with .OBJ files + created by earlier releases. Hence, if you need to rebuild an + application where one of the OBJs has been created using this + release, you must recompile all the programs with this release of the + compiler before linking. + + Running + + o In previous versions of this software, an error is given when an + indexed file is opened if the record lengths of the file do not + exactly match those given in the FD. This has been changed so the + error is only given if an attempt is made to WRITE a record larger + than the maximum or smaller than the minimum. + + o The Report Writer module has been changed so that it is compatible + with IBM(R) OS/VS COBOL when the OSVS directive is used. This is the + ANSI'68 COBOL standard. In previous versions, the default with OSVS + was ANSI'74 COBOL standard report writer. You may have report writer + programs using OSVS features, but requiring ANSI'74 report writer + compatibility. This mix is no longer possible, and you will either + need to remove the OSVS features (try VSC2), or accept ANSI'68 COBOL + report writer standard. + + + Documentation + ------------- + Call-by-number subprogram calls. + + Many of the COBOL system library routines provided in earlier releases as + call-by-number have been replaced by call-by-name routines. We recommend + that you replace all call-by-number routines by their equivalent call-by- + name routines. See your Operating Guide chapter, COBOL System Library + Routines, for details of which call-by-name routines replace these. + + To allow you to maintain existing applications, the documentation for the + replaced call-by-number routines follows: + + + PUT A CHARACTER TO THE SCREEN + + CALL X"82" USING character. + + where: + + character is a PIC X field containing the character to be put on the + screen in the current cursor position. + + The cursor is then advanced one position to the right, or onto the next + line if it is in the rightmost position, or off the screen if it is in + the bottom right-hand corner. + + + READ A CHARACTER FROM THE KEYBOARD + + CALL X"83" USING character. + + where: + + character is a PIC X field to contain the character returned. + + Notes: 1. A call on this subprogram also causes the function key table + to be checked and the result byte updated. + + 2. If the character returned from this subprogram is a carriage- + return character (hex 0D), then the character read from the + keyboard has been recognized by the function key table, and + the result byte of that table should be checked to determine + the actual character which has been pressed. + + 3. If the character read is a 2-byte character (such as a + function key) and it was not matched in the function key + table, then both bytes are returned to this subprogram. The + first call returns a null byte (hex 00) and the next call + returns the scan code (refer to the IBM Personal Computer + Technical Reference Manual for details of scan codes). + + 4. Break can be used to interrupt a running program. However, + if the program was in the middle of a call to this subprogram + at the time, nothing happens until the call on this + subprogram is satisfied by reading another character from the + keyboard. Break is not returned by this routine. + + + SCREEN INPUT AND OUTPUT + + CALL X"B7" USING function, parameter, buffer + + where: + + function is a PIC 99 COMP-X data item and contains a value: + + 0 to read characters from the screen + 1 to write characters to the screen + 2 to read attributes from the screen + 3 to write attributes to the screen + 4 to clear characters from the screen + 5 to clear attributes from the screen + + + parameter is a group item consisting of three data items: + + o a PIC 9(4) COMP-X field showing the length of the data to be + read or written. + + o a PIC 9(4) COMP-X field giving the start position on the screen. + Top left is position 1, 81 is the start of the next line, etc. + + o a PIC 9(4) COMP-X field showing the start position in the buffer. + The starting buffer position is 1. + + buffer is the COBOL data area. It is a PIC X(n) field and may be as + large or small as you require to write your data. + + An entire screen of text or attributes is 2000 bytes. No check is made + that any data to be read will fit into your buffer. Therefore, if the + length specified is greater than the length available in your buffer, any + subsequent data will be corrupted. Buffer is not used with a function of + 4 or 5, but this parameter must still be supplied. + + Note: When writing or clearing characters, the User attribute is imposed + on the character position, unless the User attribute flag is set + off, in which case the current Screen attribute for that character + position is used. + + + SCREEN CELL INPUT AND OUTPUT + + CALL X"B8" using FUNCTION PARAMS CHARBUFF ATTRBUFF + + where parameters are: + + 01 FUNCTION PIC 9(2) COMP-X + + = 0 to read screen to character and attribute buffers + = 1 to write screen from character and attribute buffers + = 2 to swap screen with character and attribute buffers + + 01 PARAMS + 03 P-LENGTH PIC 9(4) COMP-X. + 03 P-SOFFSET PIC 9(4) COMP-X. + 03 P-BOFFSET PIC 9(4) COMP-X. + + P-LENGTH = number of screen cells to read/write/swap + P-SOFFSET = screen offset (1 = top left) + P-BOFFSET = buffer offset (1 = start of buffer) + + 01 CHARBUFF + 03 CHARS PIC X OCCURS n TIMES + + = an array of character bytes + + 01 ATTRBUFF + 03 ATTRS PIC X OCCURS n TIMES + + = an array of associated attribute bytes + + + TEST CONSOLE STATUS + + CALL X"D9" USING parameter. + + where: + + parameter is a PIC 99 COMP-X field and shows the status of the + console: + + zero there is no character waiting to be read from the + keyboard + + non-zero there is a character waiting to be read from the + keyboard + + When a program is being animated in other than zoom mode, this function + always returns a zero (i.e., it never detects a character), because + ANIMATOR always looks for characters. However, the function operates + correctly when zoom mode is used. + + + GET SCREEN SIZE + + CALL X"E3" USING no-lines, no-cols. + + where: + + no-lines is a PIC 99 COMP-X field and shows the number of lines on + the screen. + + no-cols is a PIC 99 COMP-X field and shows the number of columns on + the screen. + + + CLEAR SCREEN + + CALL X"E4". + + This routine clears the entire user screen. + + + MOVE THE CURSOR TO A DEFINED POSITION + + CALL X"E6" USING result, parameter. + + where: + + result is a PIC 99 COMP-X field. It is not used. + + parameter is a group item consisting of two data items: + + o a PIC 99 COMP-X field specifying the row number for the cursor to + be moved to; in the range 0 to 24. + + o a PIC 99 COMP-X field giving the column number for the cursor to + be moved to; in the range 0 to 79. + + + ========================================================================== + Copyright (C) 1991 Microsoft Corporation + Copyright (C) 1991 Micro Focus Ltd diff --git a/Microsoft COBOL v45/DOCS/OPTIMIZE.DOC b/Microsoft COBOL v45/DOCS/OPTIMIZE.DOC new file mode 100644 index 0000000..0222af5 --- /dev/null +++ b/Microsoft COBOL v45/DOCS/OPTIMIZE.DOC @@ -0,0 +1,330 @@ + + CREATING OPTIMIZED PROGRAMS + =========================== + + This document should be regarded as a supplement to the chapter Writing + Programs in your Operating Guide. It gives some guidelines which, if + followed, allow your COBOL system to optimize fully the native code + produced for your programs - resulting in smaller and faster applications. + + + TABLE OF CONTENTS + + INTRODUCTION + DATA DIVISION CONSIDERATIONS + Data Types + Linkage Items + Large Data Divisions + PROCEDURE DIVISION CONSIDERATIONS + Arithmetic Statements + Alphanumeric Data Manipulation + Tables + Conditional Statements + Loops and Subroutines + CALL statements + Large Procedure Divisions + COMPILER DIRECTIVES + EXAMINING THE NATIVE CODE + + + INTRODUCTION + + The guidelines are set out in a "Do this" / "Don't do that" style. Do + remember that these are only guidelines; programs that do not conform to + these guidelines will still run correctly, just less efficiently. + + For further information on many of the topics discussed in this document, + see chapter Compiling and chapter Writing Programs in your Operating + Guide. + + + DATA DIVISION CONSIDERATIONS + + Data Types + ---------- + o Use unsigned COMP-5 or COMP-X numeric data items; preferably COMP-5. + + o Use 2-byte COMP-5 items rather than single byte fields for arithmetic. + + o Do not use numeric items that occupy more than 4 bytes of storage. + + o Do not redefine COMP-5 items to access individual bytes; if access to + individual bytes is required use COMP-X. + + o Use edited items only when necessary and use only simple ones such as + ZZ9. If possible use them in a subroutine so the total number of + edited moves in your program is kept as small as possible. + + o Do not use items defined as EXTERNAL. + + o Align items on even byte boundaries and ensure the stride of a table + is an even number, if possible a power of 2 (pad the table as + necessary). The stride of a table is the size of one element; for + example, the stride of the following table is 2 bytes: + + 01 a occurs 10. + 05 b pic x + 05 c pic x. + + + Linkage Items + ------------- + o Don't make many references to items defined in the Linkage Section + (examples: linkage parameters; x"D0" allocated memory). It is more + efficient to move the data to Working-Storage, manipulate it there, + then move it back again. + + o If a parameter is optional you can detect its presence using the + following syntax: + + IF ADDRESS OF linkage-item NOT = NULL + + + Large Data Divisions + -------------------- + o Ensure the size of your Data Division is less than 64 kilobytes (64K), + keeping the total size as small as possible. In the Procedure Division + the RTS can swap segments, but it cannot page the Data Division. + + o Redefine memory that is only used during certain phases of a program's + execution so that it can be shared by several routines. + + o If more than 64K of data is required use a heap, or use the x"D0" + COBOL System Library Routine to allocate the space dynamically. But + remember x"D0" items have the disadvantage of being Linkage items. + + o Do not use the NOSMALLDD directive unless you have no choice. If + necessary (normally for parameters passed to your program by external + programs), use the SEGCROSS directive so that the performance of most + data accesses is not affected. + + + PROCEDURE DIVISION CONSIDERATIONS + + Arithmetic Statements + --------------------- + o Use simple forms (for example, ADD a TO b) of the arithmetic verbs and + do not use the COMPUTE verb. + + o Do not use the GIVING form of these verbs. If necessary create + temporary variables and code several simple statements to achieve the + same result. For example, write: + + MOVE a TO c + ADD b TO c + + rather than: + + ADD a TO b giving c + + o Do not mix items of different sizes in an arithmetic statement (for + example, try to use all 2-byte items or all 4-byte items). + + o Do not use the REMAINDER, ROUNDED, ON SIZE ERROR or CORRESPONDING + phrases. + + + Alphanumeric Data Manipulation + ------------------------------ + o Reference modified fields are optimized if coded in one of the + following forms: + + item (literal:) + item (literal:literal) + item (literal:variable) + item (variable:variable) + item (variable + literal:literal) + item (variable - literal:literal) + item (variable + literal:variable) + item (variable - literal:variable) + + Other forms of reference modification are inefficient. + + o If the offset or length of the reference modification is a data item, + use a 2-byte COMP-5 item. Define it in Working-Storage. + + o In a MOVE statement, have the source item the same size as or larger + than the target. This prevents space-padding code being generated. + + o Do not use the INITIALIZE verb. + + o Do not use the CORRESPONDING option of the MOVE verb. + + o Do not use the STRING or UNSTRING verbs - they create a lot of code. + For manipulating filenames use the COBOL System Library Routines + CBL_SPLIT_FILENAME and CBL_JOIN_FILENAME. For other purposes, create + your own loops; they will almost always be more efficient. + + + Tables + ------ + o The optimal definition for a subscript is a 2-byte COMP-5 item. + + o Subscripts for items that have the same stride and are used in + consecutive statements are optimized so that they are only evaluated + once. For example: + + 01 A PIC XX OCCURS 10. + 01 B PIC XX OCCURS 10. + 01 C PIC XX OCCURS 10. + 01 D PIC XX OCCURS 10. + . . . + MOVE A(I) TO B(I) + IF C(I) = D(I) + DISPLAY "PASS" + END-IF + + would result in the subscript I being evaluated only once, although it + is used four times in two statements. + + o When compiling your program for use in production, use the NOBOUND + directive so that subscript range checking code is not included. Use + BOUND only when debugging. + + + Conditional Statements + ---------------------- + o Do not use large EVALUATE statements. They are compiled into a series + of IF ... ELSE IF ... statements where the value of the expression is + derived separately for each WHEN clause. + + o Order an EVALUATE statement so that the most commonly satisfied + condition is tried first. Do not use complex expressions or Linkage + items as conditions in an EVALUATE statement; instead, calculate the + value yourself in a Working-Storage item and use that item. + + o Comparing for equality or inequality is more efficient than testing + for "greater than" or "less than", especially with COMP-X or + alphanumeric items. + + o In both alphanumeric and numeric comparisons, have the source and + target items the same size. + + o Use a GO TO ... DEPENDING statement if the range of possible values is + fairly close. Although this construct has the disadvanage of not being + particularly suited to structured programming, it is efficient. + + + Loops and Subroutines + --------------------- + o When incrementing or decrementing a counter, terminate it with a + literal value rather than a value held in a data item. For example, to + execute a loop n times, set the counter to n and then decrement the + counter until it becomes zero, rather than incrementing the counter + from 0 to n. + + o The range of an out-of-line PERFORM statement should not contain the + end of another perform range. (One way to ensure this is to perform + sections only, not paragraphs; however, with carefully structured + programming this should not arise). You can then compile your program + with the generator directive NOTRICKLE, which lets the compiler + produce more efficient code. This coding style generally gives you a + more easily maintained program too. + + o Do not use PERFORM a THRU b as this too can lead to trickling code. + + o Use PERFORM para N TIMES but not the equivalent in-line perform. + + o Put commonly used pieces of code in sections or paragraphs and PERFORM + them. This is saves space for any statement used more than once that + produces more than 4 bytes of generated code (in a NOTRICKLE program). + It is often beneficial even on single statements, for example edited + moves, subprogram calls or file I/O. + + + CALL statements + --------------- + o Try to limit the number of CALL statements a program makes, if + necessary by avoiding splitting it into too many subprograms. + + o CALL statements that do not alter the RETURN-CODE special register or + whose effect on RETURN-CODE are of no interest should use a calling + convention of 4 (the checker directive DEFAULTCALLS can be used to set + this globally). + + o Calls to the COBOL System Library Routines that carry out logical + operations (CBL_AND, etc) are optimized by the generator to actual + machine logical operations, providing the parameters are 8 bytes long + or less. These too should use a calling convention of 4. + + o Use the generator directive NOPARAMCOUNTCHECK if your program is + always called with the correct number of parameters, or if it does not + reference unsupplied parameters. Most programs will fall into this + category. + + + Large Procedure Divisions + ------------------------- + o On DOS or OS/2, code segments are limited in size to 64K. Do not let + the generator decide where to break your program into segments. + Instead segment the program manually, that is, by using the segment + number on a section header, so you can choose where to split it. Avoid + inter-segment PERFORM and GO TO statements. + + o If appropriate the memory needed can be reduced by manually segmenting + a procedure division smaller than 64K. As the RTS can segment-swap + procedural code this is rarely necessary. + + + DIRECTIVES + + A number of checker and generator directives can be used to enable the + native code for a program to be better optimized. Some of these directives + must be used with care; ensure that the behavior that you get with these + directives is acceptable. + + Use the following directives when checking and generating your programs: + + NOALTER + ALIGN(2) + NONESTCALL + OPTSIZE + + Use with care: + + NOTRICKLE + DEFAULTCALLS(4) + NOPARAMCOUNTCHECK + + Use when compiling for production: + + NOANIM + NOBOUND + + Other suggestions (to help prevent inefficient coding): + + REMOVE "UNSTRING" + REMOVE "STRING" + REMOVE "GIVING" + REMOVE "ROUNDED" + REMOVE "COMPUTE" + REMOVE "ERROR" + REMOVE "ALTER" + REMOVE "INITIALIZE" + REMOVE "CORRESPONDING" + REMOVE "TALLYING" + REMOVE "THRU" + REMOVE "THROUGH" + + + EXAMINING THE NATIVE CODE + + You can see the generated code produced for your program, by using the + generator directives ASMLIST() SOURCEASM to produce a .GRP file containing + the assembler and source listing in the same file. + + If the generator considers a statement for optimization, but finds that it + does not conform to the necessary guidelines, the word "BADCODE" appears + next to the statement, on the right-hand side of the listing. But some + statements that have generated inefficient code will not have been + identified in this way; you can usually spot these by looking for a single + statement that has generated a lot of assembler code. + + Try to eliminate or at least reduce the inefficient statements in your + program. But be aware of the law of diminishing returns; as you improve + the efficiency of your program, you will eventually reach a point where a + lot of extra effort will give only small further gains. + + ========================================================================== + Copyright (C) 1991 Microsoft Corporation + Copyright (C) 1991 Micro Focus Ltd diff --git a/Microsoft COBOL v45/DOCS/PACKING.LST b/Microsoft COBOL v45/DOCS/PACKING.LST new file mode 100644 index 0000000..4ae3405 --- /dev/null +++ b/Microsoft COBOL v45/DOCS/PACKING.LST @@ -0,0 +1,844 @@ + + Microsoft COBOL Professional Development System, Version 4.5 + + Product Contents Checklist + + (C) Copyright Microsoft Corporation, 1991 + + + Contents + -------- + Introduction + Documentation + Diskettes + Description of Components + Description of Files + + + Introduction + ------------ + This document describes the contents of the Microsoft COBOL package, + including documentation, diskettes and diskette contents. + + + Documentation + ------------- + The following documentation pieces are provided with the COBOL software + package. + + Installing and Using the Professional Development System + Advanced Topics and Utilities Reference + Operating Guide + Language Reference Manual (volumes 1 and 2) + Error Messages Manual + Compatibility Guide + Conversion Series 1 Operating Guide + Conversion Series 2 Operating Guide + Conversion Series 3 Operating Guide + Conversion Series 5 Operating Guide + Dialect Summary + Pocket Guide + + The following additional documents appear as ASCII text files on the + diskettes. + + PACKING.LST - List of documents and files included in this package + README.DOC - Essential information for this release + CBL-CMPT.DOC - Lists differences between Microsoft COBOL 4.5 and + earlier releases. + + These can be viewed from within SETUP, the installation program, or using + the operating system command, TYPE, or any ASCII text file editor or + listing utility. + + + + Diskettes + --------- + Your COBOL software package includes a set of either 5.25" diskettes or + 3.5" diskettes, low or high density. The contents of each disk are listed + below. Note that files with an "@" character at the start of the + extension are compressed and require PKUNZIP to load them. In general, + the name of the compressed file is the same as the uncompressed file + except that the first character of the extension is replaced by "@". + For some files, this results in two compressed files with the same name. + In this case, the extension of the compressed file is changed and the name + is listed in brackets after the name of the uncompressed file. + + + Low density 5.25 inch disk layout + + Disk 1 / SETUP + BRIEF.@NI CBL-CMPT.DOC COBOL.INI MFCOMPAT.DOC + OPTIMIZE.DOC PACKING.LST PKUNZIP.EXE README.DOC + SETUP.EXE TIMEOUT.DOC + + + Disk 2 + CCI.@BJ COBLIB.DLE COBLIB.DLL HNFDC.@LL + HNFDC.@XE HYHELP.@BR HYHELP.@NF HYHELP.@XE + MSHELP.@LL MSHIF.@LL MSHIF.@XE + + + Disk 3 + ANIMATE.@XE COBFP87.@LE COBFP87.@LL COBFP87D.@IB + COBFP87O.@IB COBIFN.@LL COBOL.@XE GENERATE.@BR + SCREENS.@BR SCREENS.@XE _SORT.@LL _SQLPRE.@LL + + + Disk 4 + ADISCF.@BR ADISCF.@XE ADISCTRL.@ CCIAPPC.@LL + CCIIPX.@XE CCINAMP.@LL CCINAMP2.DLL CCINETB.@LL + CCINETB.@XE CNVCOMP6.@BJ CONVERT3.@XE CONVERT5.@XE + HELPADCF.@BR KEYBCF.@XE REBUILD.@XE REFORM5.@XE + TABX.@XE + + + Disk 5 + ADIS.@BJ ADIS.DEF ADISDYNA.@BJ ADISINIT.@BJ + ADISKEY.@BJ C6DOSIF.@BJ C6DOSLB.@BJ C6OS2IF.@BJ + C6OS2LB.@BJ CBLBIND.@IB CBLBIND.NOT CBLDC001.@BJ + COBAPI.@IB COBINTFN.@BJ COBLIB.@IB EXTERNL.@BJ + EXTERNL.DEF EXTFH.@BJ EXTFH.DEF LCOBOL.@IB + LINITC31.@BJ LINITC31.@SM LINITC32.@BJ LINITC32.@SM + LINITIO.@ LINITIO.@BJ MCS.@BJ MCSETUP.@XE + MFC6INTF.@BJ MINITC.@BJ MINITC.@SM MINITF.@BJ + MINITF.@SM MINITP.@BJ MINITP.@SM SPLIT78.@XE + + + Disk 6 + COBOL.@LP RMSTAT.@BJ RTSBIN.@SM RTSCALL.@BJ + SQLINIT.@BJ _CLASS.@BJ _CODESET.@BJ + + + Disk 7 + ANIMATOR.@BR ANIMRTNS.@LL ANIMRTNS.@XE ANIMUSER.@XE + COBCLI.@BR HELP.@BR HELPNAME.@BR NAME.@BR + UTILERR.@LP UTILS.@LP + + + Disk 8 + CHECK.@BR UTILS.@BR + + + Disk 9 + ADMOUSE.@BL APPC.@EM ASM.@EM CALC.@BL + CALENDAR.@BL CASE.@BL DDE.@EM DECLARE.@BL + DIOPHANT.@BL EXPAND.@BL EXTFILE.@BL FUNKEY.@BL + LOGOPER.@BL MUDEMO.@EM NESTED.@BL PMCALC.@EM + PMHELLO.@BL POPUP.@BL PRINTESC.@BL REPORT.@BL + SMPLACCP.@BL SORTDEMO.@EM SQLDEMO.@EM SSCNTRL.@BL + STATUS.@BL TICBUG.@BL TICTAC.@EM TSTDEBUG.@BL + WINDOWS.@EM + + + Disk 10 + BIND.@XE EXEHDR.@XE EXP.@XE HELPMAKE.@XE + ILINK.@XE ILINKSTB.@VL LIB.@XE LINK.@XE + PWBRMAKE.@XE + + + Disk 11 + API.@IB LRFMERGE.@XE NMAKE.@P NMAKE.@R + NMK.@OM RC.@XE RCPP.@RR RCPP.@XE + RM.@XE SBR-LOAD.@NT TOOLS.@RE UNDEL.@XE + + + Disk 12 + CBLSSEG.@LL CBLWINB.@BJ CBLWINC.@BJ CBLWING.@BJ + CBLWINL.@BJ COBAPIDW.@IB COBAPIW.@IB DWSKEL.DEF + FIXSHIFT.@OM HIMEM.@YS LDLLCEW.@IB LIBENTRY.@BJ + LIBW.@IB LLIBCEW.@IB RAMDRIVE.@YS SDKPAINT.@XE + SDKPAINT.DAT SMARTDRV.@YS WINSTUB.@XE + + + Disk 13 + MOUSE.@OM PWB.@OM PWBCOBOL.@R PWBED.@XE + PWBHELP.@R PWBROWSE.@R PWBUTILS.@R QH.@R + + + Disk 14 Disk 14 + OS2.@IB PWB.@XE PWBCOBOL.@P PWBHELP.@P + PWBROWSE.@P PWBUTILS.@P QH.@P + + + Disk 15 + CANOS2.@LL COBOS2.@LL CVP.@XE CVPACK.@XE + IMPLIB.@XE PMCVAID.@XE PWBC.@P PWBC.@R + + + Disk 16 + CV.@LP LINK.@LP + + + Disk 17 + PWB.@LP + + + Disk 18 + COBOL1.HLP H2CPY.@XE PWB2.HLP QH.@LP + + + + Low density 3.5 inch disk layout + + Disk 1 / SETUP + BRIEF.@NI CBL-CMPT.DOC CCI.@BJ COBLIB.DLE + COBLIB.DLL COBOL.INI HNFDC.@LL HNFDC.@XE + HYHELP.@BR HYHELP.@NF HYHELP.@XE MFCOMPAT.DOC + MSHELP.@LL MSHIF.@LL MSHIF.@XE OPTIMIZE.DOC + PACKING.LST PKUNZIP.EXE README.DOC SETUP.EXE + TIMEOUT.DOC + + + Disk 2 + ADISCF.@BR ADISCF.@XE ADISCTRL.@ ANIMATE.@XE + CCIAPPC.@LL CCIIPX.@XE CCINAMP.@LL CCINAMP2.DLL + CCINETB.@LL CCINETB.@XE CNVCOMP6.@BJ COBFP87.@LE + COBFP87.@LL COBFP87D.@IB COBFP87O.@IB COBIFN.@LL + COBOL.@XE CONVERT3.@XE CONVERT5.@XE GENERATE.@BR + HELPADCF.@BR KEYBCF.@XE REBUILD.@XE REFORM5.@XE + SCREENS.@BR SCREENS.@XE TABX.@XE _SORT.@LL + _SQLPRE.@LL + + + Disk 3 + ADIS.@BJ ADIS.DEF ADISDYNA.@BJ ADISINIT.@BJ + ADISKEY.@BJ C6DOSIF.@BJ C6DOSLB.@BJ C6OS2IF.@BJ + C6OS2LB.@BJ CBLBIND.@IB CBLBIND.NOT CBLDC001.@BJ + COBAPI.@IB COBINTFN.@BJ COBLIB.@IB COBOL.@LP + EXTERNL.@BJ EXTERNL.DEF EXTFH.@BJ EXTFH.DEF + LCOBOL.@IB LINITC31.@BJ LINITC31.@SM LINITC32.@BJ + LINITC32.@SM LINITIO.@ LINITIO.@BJ MCS.@BJ + MCSETUP.@XE MFC6INTF.@BJ MINITC.@BJ MINITC.@SM + MINITF.@BJ MINITF.@SM MINITP.@BJ MINITP.@SM + RMSTAT.@BJ RTSBIN.@SM RTSCALL.@BJ SPLIT78.@XE + SQLINIT.@BJ _CLASS.@BJ _CODESET.@BJ + + + Disk 4 + ANIMATOR.@BR ANIMRTNS.@LL ANIMRTNS.@XE ANIMUSER.@XE + CHECK.@BR COBCLI.@BR HELP.@BR HELPNAME.@BR + NAME.@BR UTILERR.@LP UTILS.@BR UTILS.@LP + + + Disk 5 + ADMOUSE.@BL APPC.@EM ASM.@EM BIND.@XE + CALC.@BL CALENDAR.@BL CASE.@BL DDE.@EM + DECLARE.@BL DIOPHANT.@BL EXEHDR.@XE EXP.@XE + EXPAND.@BL EXTFILE.@BL FUNKEY.@BL HELPMAKE.@XE + ILINK.@XE ILINKSTB.@VL LIB.@XE LINK.@XE + LOGOPER.@BL MUDEMO.@EM NESTED.@BL PMCALC.@EM + PMHELLO.@BL POPUP.@BL PRINTESC.@BL PWBRMAKE.@XE + REPORT.@BL SMPLACCP.@BL SORTDEMO.@EM SQLDEMO.@EM + SSCNTRL.@BL STATUS.@BL TICBUG.@BL TICTAC.@EM + TSTDEBUG.@BL WINDOWS.@EM + + + Disk 6 + API.@IB CBLSSEG.@LL CBLWINB.@BJ CBLWINC.@BJ + CBLWING.@BJ CBLWINL.@BJ COBAPIDW.@IB COBAPIW.@IB + DWSKEL.DEF FIXSHIFT.@OM HIMEM.@YS LDLLCEW.@IB + LIBENTRY.@BJ LIBW.@IB LLIBCEW.@IB LRFMERGE.@XE + NMAKE.@P NMAKE.@R NMK.@OM RAMDRIVE.@YS + RC.@XE RCPP.@RR RCPP.@XE RM.@XE + SBR-LOAD.@NT SDKPAINT.@XE SDKPAINT.DAT SMARTDRV.@YS + TOOLS.@RE UNDEL.@XE WINSTUB.@XE + + + Disk 7 + MOUSE.@OM OS2.@IB PWB.@OM PWB.@XE + PWBCOBOL.@P PWBCOBOL.@R PWBED.@XE PWBHELP.@P + PWBHELP.@R PWBROWSE.@P PWBROWSE.@R PWBUTILS.@P + PWBUTILS.@R QH.@P QH.@R + + + Disk 8 + CANOS2.@LL COBOS2.@LL CV.@LP CVP.@XE + CVPACK.@XE IMPLIB.@XE LINK.@LP PMCVAID.@XE + PWBC.@P PWBC.@R + + + Disk 9 + COBOL1.HLP H2CPY.@XE PWB.@LP PWB2.HLP + QH.@LP + + + + High density 5.25 inch disk layout + + Disk 1 / SETUP + ANIMATE.@XE BRIEF.@NI CBL-CMPT.DOC CCI.@BJ + COBFP87.@LE COBFP87.@LL COBFP87D.@IB COBFP87O.@IB + COBIFN.@LL COBLIB.DLE COBLIB.DLL COBOL.@XE + COBOL.INI GENERATE.@BR HNFDC.@LL HNFDC.@XE + HYHELP.@BR HYHELP.@NF HYHELP.@XE MFCOMPAT.DOC + MSHELP.@LL MSHIF.@LL MSHIF.@XE OPTIMIZE.DOC + PACKING.LST PKUNZIP.EXE README.DOC SCREENS.@BR + SCREENS.@XE SETUP.EXE TIMEOUT.DOC _SORT.@LL + _SQLPRE.@LL + + + Disk 2 + ADIS.@BJ ADIS.DEF ADISCF.@BR ADISCF.@XE + ADISCTRL.@ ADISDYNA.@BJ ADISINIT.@BJ ADISKEY.@BJ + C6DOSIF.@BJ C6DOSLB.@BJ C6OS2IF.@BJ C6OS2LB.@BJ + CBLBIND.@IB CBLBIND.NOT CBLDC001.@BJ CCIAPPC.@LL + CCIIPX.@XE CCINAMP.@LL CCINAMP2.DLL CCINETB.@LL + CCINETB.@XE CNVCOMP6.@BJ COBAPI.@IB COBINTFN.@BJ + COBLIB.@IB COBOL.@LP CONVERT3.@XE CONVERT5.@XE + EXTERNL.@BJ EXTERNL.DEF EXTFH.@BJ EXTFH.DEF + HELPADCF.@BR KEYBCF.@XE LCOBOL.@IB LINITC31.@BJ + LINITC31.@SM LINITC32.@BJ LINITC32.@SM LINITIO.@ + LINITIO.@BJ MCS.@BJ MCSETUP.@XE MFC6INTF.@BJ + MINITC.@BJ MINITC.@SM MINITF.@BJ MINITF.@SM + MINITP.@BJ MINITP.@SM REBUILD.@XE REFORM5.@XE + RMSTAT.@BJ RTSBIN.@SM RTSCALL.@BJ SPLIT78.@XE + SQLINIT.@BJ TABX.@XE _CLASS.@BJ _CODESET.@BJ + + + Disk 3 + ADMOUSE.@BL ANIMATOR.@BR ANIMRTNS.@LL ANIMRTNS.@XE + ANIMUSER.@XE APPC.@EM ASM.@EM CALC.@BL + CALENDAR.@BL CASE.@BL CHECK.@BR COBCLI.@BR + DDE.@EM DECLARE.@BL DIOPHANT.@BL EXPAND.@BL + EXTFILE.@BL FUNKEY.@BL HELP.@BR HELPNAME.@BR + LOGOPER.@BL MUDEMO.@EM NAME.@BR NESTED.@BL + PMCALC.@EM PMHELLO.@BL POPUP.@BL PRINTESC.@BL + REPORT.@BL SMPLACCP.@BL SORTDEMO.@EM SQLDEMO.@EM + SSCNTRL.@BL STATUS.@BL TICBUG.@BL TICTAC.@EM + TSTDEBUG.@BL UTILERR.@LP UTILS.@BR UTILS.@LP + WINDOWS.@EM + + + Disk 4 + API.@IB BIND.@XE CBLSSEG.@LL CBLWINB.@BJ + CBLWINC.@BJ CBLWING.@BJ CBLWINL.@BJ COBAPIDW.@IB + COBAPIW.@IB DWSKEL.DEF EXEHDR.@XE EXP.@XE + FIXSHIFT.@OM HELPMAKE.@XE HIMEM.@YS ILINK.@XE + ILINKSTB.@VL LDLLCEW.@IB LIB.@XE LIBENTRY.@BJ + LIBW.@IB LINK.@XE LLIBCEW.@IB LRFMERGE.@XE + NMAKE.@P NMAKE.@R NMK.@OM PWBRMAKE.@XE + RAMDRIVE.@YS RC.@XE RCPP.@RR RCPP.@XE + RM.@XE SBR-LOAD.@NT SDKPAINT.@XE SDKPAINT.DAT + SMARTDRV.@YS TOOLS.@RE UNDEL.@XE WINSTUB.@XE + + + Disk 5 + CANOS2.@LL COBOS2.@LL CVP.@XE CVPACK.@XE + IMPLIB.@XE MOUSE.@OM OS2.@IB PMCVAID.@XE + PWB.@OM PWB.@XE PWBC.@P PWBC.@R + PWBCOBOL.@P PWBCOBOL.@R PWBED.@XE PWBHELP.@P + PWBHELP.@R PWBROWSE.@P PWBROWSE.@R PWBUTILS.@P + PWBUTILS.@R QH.@P QH.@R + + + Disk 6 + COBOL1.HLP CV.@LP H2CPY.@XE LINK.@LP + PWB.@LP PWB2.HLP QH.@LP + + + + High density 3.5 inch disk layout + + Disk 1 / SETUP + ADISCF.@BR ADISCF.@XE ADISCTRL.@ ANIMATE.@XE + BRIEF.@NI CBL-CMPT.DOC CCI.@BJ CCIAPPC.@LL + CCIIPX.@XE CCINAMP.@LL CCINAMP2.DLL CCINETB.@LL + CCINETB.@XE CNVCOMP6.@BJ COBFP87.@LE COBFP87.@LL + COBFP87D.@IB COBFP87O.@IB COBIFN.@LL COBLIB.DLE + COBLIB.DLL COBOL.@XE COBOL.INI CONVERT3.@XE + CONVERT5.@XE GENERATE.@BR HELPADCF.@BR HNFDC.@LL + HNFDC.@XE HYHELP.@BR HYHELP.@NF HYHELP.@XE + KEYBCF.@XE MFCOMPAT.DOC MSHELP.@LL MSHIF.@LL + MSHIF.@XE OPTIMIZE.DOC PACKING.LST PKUNZIP.EXE + README.DOC REBUILD.@XE REFORM5.@XE SCREENS.@BR + SCREENS.@XE SETUP.EXE TABX.@XE TIMEOUT.DOC + _SORT.@LL _SQLPRE.@LL + + + Disk 2 + ADIS.@BJ ADIS.DEF ADISDYNA.@BJ ADISINIT.@BJ + ADISKEY.@BJ ANIMATOR.@BR ANIMRTNS.@LL ANIMRTNS.@XE + ANIMUSER.@XE C6DOSIF.@BJ C6DOSLB.@BJ C6OS2IF.@BJ + C6OS2LB.@BJ CBLBIND.@IB CBLBIND.NOT CBLDC001.@BJ + CHECK.@BR COBAPI.@IB COBCLI.@BR COBINTFN.@BJ + COBLIB.@IB COBOL.@LP EXTERNL.@BJ EXTERNL.DEF + EXTFH.@BJ EXTFH.DEF HELP.@BR HELPNAME.@BR + LCOBOL.@IB LINITC31.@BJ LINITC31.@SM LINITC32.@BJ + LINITC32.@SM LINITIO.@ LINITIO.@BJ MCS.@BJ + MCSETUP.@XE MFC6INTF.@BJ MINITC.@BJ MINITC.@SM + MINITF.@BJ MINITF.@SM MINITP.@BJ MINITP.@SM + NAME.@BR RMSTAT.@BJ RTSBIN.@SM RTSCALL.@BJ + SPLIT78.@XE SQLINIT.@BJ UTILERR.@LP UTILS.@BR + UTILS.@LP _CLASS.@BJ _CODESET.@BJ + + + Disk 3 + ADMOUSE.@BL API.@IB APPC.@EM ASM.@EM + BIND.@XE CALC.@BL CALENDAR.@BL CASE.@BL + CBLSSEG.@LL CBLWINB.@BJ CBLWINC.@BJ CBLWING.@BJ + CBLWINL.@BJ COBAPIDW.@IB COBAPIW.@IB DDE.@EM + DECLARE.@BL DIOPHANT.@BL DWSKEL.DEF EXEHDR.@XE + EXP.@XE EXPAND.@BL EXTFILE.@BL FIXSHIFT.@OM + FUNKEY.@BL HELPMAKE.@XE HIMEM.@YS ILINK.@XE + ILINKSTB.@VL LDLLCEW.@IB LIB.@XE LIBENTRY.@BJ + LIBW.@IB LINK.@XE LLIBCEW.@IB LOGOPER.@BL + LRFMERGE.@XE MUDEMO.@EM NESTED.@BL NMAKE.@P + NMAKE.@R NMK.@OM PMCALC.@EM PMHELLO.@BL + POPUP.@BL PRINTESC.@BL PWBRMAKE.@XE RAMDRIVE.@YS + RC.@XE RCPP.@RR RCPP.@XE REPORT.@BL + RM.@XE SBR-LOAD.@NT SDKPAINT.@XE SDKPAINT.DAT + SMARTDRV.@YS SMPLACCP.@BL SORTDEMO.@EM SQLDEMO.@EM + SSCNTRL.@BL STATUS.@BL TICBUG.@BL TICTAC.@EM + TOOLS.@RE TSTDEBUG.@BL UNDEL.@XE WINDOWS.@EM + WINSTUB.@XE + + + Disk 4 + CANOS2.@LL COBOS2.@LL CV.@LP CVP.@XE + CVPACK.@XE IMPLIB.@XE LINK.@LP MOUSE.@OM + OS2.@IB PMCVAID.@XE PWB.@OM PWB.@XE + PWBC.@P PWBC.@R PWBCOBOL.@P PWBCOBOL.@R + PWBED.@XE PWBHELP.@P PWBHELP.@R PWBROWSE.@P + PWBROWSE.@R PWBUTILS.@P PWBUTILS.@R QH.@P + QH.@R + + + Disk 5 + COBOL1.HLP H2CPY.@XE PWB.@LP PWB2.HLP + QH.@LP + + + + Description of Components + ------------------------- + The Microsoft COBOL 4.5 package contains the following software + components: + + COBOL Optimizing Compiler - compiles COBOL source code into OBJ files. + + ANIMATOR testing tool - interactive full screen testing, learning and + debugging tool. Includes Cooperative + Animation facility to animate programs in + different sessions/machines. + + Linking Support - Linker, libraries and system programs to + create standalone EXE files for DOS and OS/2 + from the OBJs created by the compiler. + + COBOL Communications - Preparation and run-time support for MCS + Module Support + + Mixed Language Facility - Extra tools, and documentation to aid in + linking COBOL programs with programs of other + languages. + + Screen Painter - SCREENS Screen Painter + + Screen/keyboard - Tools to allow configuration of the extended + Configuration tools ACCEPT/DISPLAY system program, ADIS. + + SETUP installation - Utility to allow efficient installation of + utility this product + + Indexed file maintenance tool + - REBUILD file management utility + + Demonstration programs - Programs that demonstrate some of the + facilities in this package, and batch streams + to compile, link and run, or animate them. + + MF Compatibility Tools - File conversion utility to aid in converting + Micro Focus COBOL systems to compile and + run with this system. + + MS Compatibility Tools - Compatibility documentation and file + conversion utility to aid in converting + Microsoft COBOL v2.2 systems to compile and + run with this system. + + RM Compatibility Tools - Compatibility documentation and file + conversion utility to aid in converting + RM/COBOL applications to compile and run + with this system. + + DG Compatibility Tools - Compatibility documentation and file + conversion utility to aid in converting DG + ICOBOL applications to compile and run with + this system. + + Utilities - LINK, LIB, NMAKE, etc + + Programmer's WorkBench - Integrated development environment. + + CodeView - CodeView Version 3.5 for OS/2 allowing + native code debugging of COBOL programs + and mixed COBOL/C debugging. + + Windows 3.0 Support - Libraries and tools needed to develop + Microsoft Windows 3.0 applications. + + + Description of Files + -------------------- + The files included on the release disks are briefly described below. + Unless otherwise stated, files marked DOS are only required for running + the software on DOS, and those marked OS/2 are only required for running + the software on OS/2. + + Executable files on the disks are one of the following types: + + (DOS) Runs in real mode under DOS 3.3 or above + (OS/2) Runs in protected mode of OS/2 1.1 or above + Runs in either real or protected mode + + + COBOL Optimizing Compiler: + + COBOL.EXE Compiler (Bound) + COBCLI.LBR Complier/ANIMATOR Command Line Interpreter + CHECK.LBR Compiler/ANIMATOR modules + UTILS.LBR Compiler/ANIMATOR run-time support + _SORT.DLL Compiler/ANIMATOR support OS/2 + _SQLPRE.DLL Compiler/ANIMATOR SQL support OS/2 + GENERATE.LBR Compiler - code generation + COBLIB.DLE Shared run-time DOS + COBLIB.DLL Shared run-time OS/2 + + ANIMATOR debugging utility: + + ANIMATE.EXE Animator (Bound) + COBCLI.LBR Complier/ANIMATOR Command Line Interpreter + CHECK.LBR Compiler/ANIMATOR modules + ANIMATOR.LBR ANIMATOR - additional programs + UTILS.LBR Compiler/ANIMATOR run-time support + HELP.LBR ANIMATOR HELP screens (delete if help is not needed) + _SORT.DLL Compiler/ANIMATOR support OS/2 + _SQLPRE.DLL Compiler/ANIMATOR SQL support OS/2 + COBLIB.DLE Shared run-time for DOS DOS + COBLIB.DLL Shared run-time for OS/2 OS/2 + ANIMUSER.EXE Cooperative animation + ANIMANIM.DLE Cooperative animation + ANIMANIM.DLL Cooperative animation + CCINETB.DLE Cooperative animation (other machine) DOS + CCINETB.DLL Cooperative animation (other machine) OS/2 + CCINAMP.DLL Cooperative animation (same machine) OS/2 + CCINAMP2.DLL Cooperative animation (same machine) OS/2 + + + Linking: + + LCOBOL.LIB COBOL link support routines - static linked + COBLIB.LIB COBOL link support routines - shared run-time + COBAPI.LIB COBOL link support routines DOS + CBLBIND.LIB Required for BINDing + CBLBIND.NOT Required for BINDing + + ADIS.OBJ ADIS-ACCEPT/DISPLAY support + ADISINIT.OBJ ADIS-ACCEPT/DISPLAY support + ADISKEY.OBJ ADIS-ACCEPT/DISPLAY support + ADISDYNA.OBJ ADIS-ACCEPT/DISPLAY support + ADIS.DEF LINK definition file to create ADIS.DLL OS/2 + _CLASS.OBJ Support for user defined CLASS + _CODESET.OBJ Support for CODE-SET syntax + EXTERNL.OBJ External data handler + EXTERNL.DEF LINK definition file to create EXTERNL.DLL OS/2 + EXTFH.OBJ Indexed and External file handler + EXTFH.DEF LINK definition file to create EXTFH.DLL OS/2 + SQLINIT.OBJ Database Manager (SQL) initialization support OS/2 + + + Presentation Manager and Windows support + + H2CPY.EXE Converter for C Header files to COBOL + SPLIT78.EXE Splits large files containing level 78s into + smaller files. + + + COBOL Communications Module Support: + + MCSETUP.EXE Communication setup DOS + MCS.OBJ Communications module DOS + COBLIB.DLE Shared run-time DOS + + Mixed Language Facility: + + MFC6INTF.OBJ Microsoft C 6.0 - COBOL interface + C6DOSIF.OBJ Microsoft C 6.0 - C initialization for DOS + C6DOSLB.OBJ Microsoft C 6.0 - C initialization for DOS + C6OS2IF.OBJ Microsoft C 6.0 - C initialization for OS2 + C6OS2LB.OBJ Microsoft C 6.0 - C initialization for OS2 + + MINITC.ASM Microsoft C 5.0 and 4.0 + MINITC.OBJ + MINITF.ASM Microsoft FORTRAN + MINITF.OBJ + MINITP.ASM Microsoft Pascal + MINITP.OBJ + + LINITC31.ASM Lattice(R) C v3.1 + LINITC31.OBJ + LINITC32.ASM Lattice C v3.2 + LINITC32.OBJ + LINITIO.C I/O module required for linking to Lattice C + LINITIO.OBJ + + Indexed file Rebuild utility: + + REBUILD.EXE File Management Utility - recovery and conversion + + Screen/keyboard Configuration tools: + + ADISCTRL (ADISCTRL.@) ADIS configuration file + ADISCF.EXE ADIS configuration utility + ADISCF.LBR ADISCF/KEYBCF run-time support + HELPADCF.LBR ADIS configuration utility - help screens + KEYBCF.EXE Keyboard configuration utility + COBLIB.DLE Shared run-time for DOS + COBLIB.DLL Shared run-time for OS/2 + + Screen Painter: + + SCREENS.EXE Screen Painter + SCREENS.LBR Screen Painter support + NAME.LBR Screen Painter support + HELPNAME.LBR Screen Painter support + COBLIB.DLE Shared run-time for DOS + COBLIB.DLL Shared run-time for OS/2 + + Windows 3.0 Support + + CBLSSEG.DLL Support DLL used by all COBOL Windows programs + CBLWINB.OBJ Startup module for batch programs running under Windows + CBLWINC.OBJ Startup module for QuickWin applications + CBLWING.OBJ Startup module for COBOL GUI applications + CBLWINL.OBJ Startup module for Dynamic Link Libraries + COBAPIDW.LIB Link library for QuickWin applications + COBAPIW.LIB Link library for GUI applications and DLLs + DWSKEL.DEF .DEF file for QuickWin applications + LIBW.LIB Link library for Windows applications + LLIBCEW.LIB Link library for Windows applications + LDLLCEW.LIB Link library for Windows DLLs + LIBENTRY.OBJ Needed for Windows DLLs + WINSTUB.EXE Needed for Windows applications + RC.EXE Windows Resource Compiler + RCPP.EXE + RCPP.ERR + SDKPAINT.EXE Windows Icon, Cursor and Bitmap painter + SDKPAINT.DAT + + SETUP installation utility and on-disk documentation + + PKUNZIP.EXE Unzipping processor (Bound) + SETUP.EXE Installation utility (Bound) + COBOL.INI Script for installation + PACKING.LST List of documents and files included in this package + README.DOC Essential information about this version + CBL-CMPT.DOC Compatibility with earlier releases + + Demonstration programs: + + ADMOUSE.CBL Demonstrates the use of mouse and ADIS + APPC.@EM Demonstrates the use of APPC. Contains files: + APPC.DOC On-disc documentation for using APPC + ACSSVC.CPY + APPC.CPY + ADAPTER.EXE Program to find adapter address for APPC use + APPCBATL.CFG + APPCBATR.CFG + APPCBATT.CFG + APPCDEMO.DOC Read this for details of the demo + BATTAPPC.CBL + BATTLE.CBL + BATTLE.CMD + BATTLE.SS + BATTLE.WKS + BATTLEL.CBL + BATTLER.CBL + ASM.DEM Demonstrates the use of Assembler sub programs + ADD.CBL + ADDEM.ASM + ADDEM.DEF + ADDEM.OBJ + CASE.CBL Converts the case of COBOL source programs + DECLARE.CBL DECLARATIVES + DIOPHANT.CBL Recursion + EXPAND.CBL Clever expanding ACCEPT + EXTFILE.CBL EXTERNAL FILES + FUNCTION.CBL Function keys + LOGOPER.CBL Demonstrates the logical call-by-name routines + MUDEMO.DEM Multi-user file handling + MUDEMO.CBL + STOCKIN.CBL + STOCKIOA.CBL + STOCKIOM.CBL + STOCKOUT.CBL Multi-user file handling + NESTED.CBL Nested programs + PMCALC.@EM Presentation Manager demonstration. Contains files: + PMCALC.CBL + PMCALC.DEF + PMCALC.DLG + PMCALC.EXE + PMCALC.ICO + PMCALC.PTR + PMCALC.RES + PMCALC.RC + PMHELLO.CBL Presentation Manager (low-level) demo + POPUP.CBL Screen handling demo + PRINTESC.CBL Printer escape codes + REPORT.CBL Report Writer + SMPLACCP.CBL ACCEPT + SORTDEMO.@EM Demonstration program using OS/2 API calls + SORTDEMO.CBL + SRTDEM.BAT Demonstration program batch stream DOS + SRTDEM.CMD Demonstration program batch stream OS/2 + SQLDEMO.DEM SQL demonstration + SQLCA.CPY SQL demonstration - support file + SQLDEMO.CBL SQL demonstration + SQLPREP.CBL SQL demonstration - support program + SSCNTRL.CBL Screen Section dynamic attributes using CONTROL + STATUS.CBL File status handling + TICBUG.CBL Other products support material + TICTAC.@EM Demonstration program + TICTAC.CBL + TTDEMO.BAT Demonstration batch stream DOS + TTDEMO.CMD Demonstration batch stream OS/2 + TSTDEBUG.CBL ANSI Debug + WINDOWS.@EM Windows demonstration files. Contains files: + WINCALC.CBL Simple calculator program + WINCALC.DEF + WINCALC.DLG + WINCALC.ICO + WINCALC.PTR + WINCALC.RES + WINCALC.RC + WINHELLO.CBL 'Hello world' program + WINHELLO.DEF + SYSMETS.CBL Displays system metrics + SYSMETS.CPY + WINDOWS.78 Windows header files converted into COBOL + WINDOWS.CPY + + MF Compatibility Tools: + + MFCOMPAT.DOC Document of compatibility with versions of Micro Focus + COBOL prior to Micro Focus COBOL/2 + RTSCALL.OBJ Emulation of .BIN file handling + RTSBIN.ASM Emulation of .BIN file handling + REBUILD.EXE File Management Utility - file conversion + + MS Compatibility Tools: + + REBUILD.EXE File Management Utility - MS file conversion + + RM Compatibility Tools: + + CNVCOMP6.OBJ Subroutine used with RM data file conversion programs + CONVERT3.EXE Generates programs to convert RM/COBOL data files + TABX.EXE Utility to expand tabs in a source file + COBLIB.DLE Shared run-time for DOS + COBLIB.DLL Shared run-time for OS/2 + + DG Compatibility Tools: + + CONVERT5.EXE Generates programs to convert Data General data files + REFORM5.EXE Reformatter for DG Interactive COBOL source programs + COBLIB.DLE Shared run-time for DOS + COBLIB.DLL Shared run-time for OS/2 + + Utilities: + + LINK.EXE Segmented executable Linker Bound + LIB.EXE Library Manager Bound + ILINK.EXE Incremental Linker Bound + ILINKSTB.OVL Overlay for Incremental Linker + IMPLIB.EXE Create Import Libraries Bound + BIND.EXE Creates family mode applications Bound + LRFMERGE.EXE Used by PWB to merge two linker response files Bound + CVPACK.EXE Packs CodeView debugging information Bound + EXEHDR.EXE Display/modify executable file headers Bound + EXP.EXE Remove files from DELETED directory Bound + PWBRMAKE.EXE Bound + HELPMAKE.EXE Creates help files Bound + QH.EXE QuickHelp Bound + RM.EXE Move a file to DELETED directory Bound + UNDEL.EXE Undelete file Bound + NMAKE.EXE (NMAKE.@P) OS/2 + NMAKE.EXE (NMAKE.@R) DOS + NMK.COM DOS + MOUSE.COM DOS + HIMEM.SYS DOS + MOUSE.COM DOS + RAMDRIVE.SYS DOS + SMARTDRV.SYS DOS + + Programmer's WorkBench: + + PWB.EXE Programmer's Workbench OS/2 + PWBCOBOL.PXT (PWBCOBOL.@P) PWB COBOL Options Extension OS/2 + PWBC.PXT (PWBC.@P) PWB C Options Extension OS/2 + This is only installed by SETUP if you have + the version of PWB supplied with Microsoft + C Version 6.0 already installed. + PWBHELP.PXT (PWBHELP.@P) PWB Advisor OS/2 + PWBROWSE.PXT (PWBROWSE.@P) PWB Browser OS/2 + PWBUTILS.PXT (PWBUTILS.@P) PWB Utilities Options Extension) OS/2 + + PWB.COM Programmer's Workbench DOS + PWBED.EXE + PWBCOBOL.MXT (PWBCOBOL.@R) PWB COBOL Options Extension DOS + PWBC.MXT (PWBC.@R) PWB C Options Extension DOS + This is only installed by SETUP if you have + the version of PWB supplied with Microsoft + C Version 6.0 already installed. + PWBHELP.MXT (PWBHELP.@R) PWB Advisor DOS + PWBROWSE.MXT (PWBROWSE.@R) PWB Browser DOS + PWBUTILS.MXT (PWBUTILS.@R) PWB Utilities Options Extension DOS + + SBR-LOAD.GNT Compiler support for browser + + CodeView: + + CVP.EXE CodeView OS/2 + PMCVAID.EXE Support for debugging Presentation Manager OS/2 + programs + COBOS2.DLL COBOL Expression Evaluator OS/2 + CANOS2.DLL C Expression Evaluator OS/2 + + Help Files: + + UTILERR.HLP Help for utilities error messages + UTILS.HLP Help for utilities + LINK.HLP Help for Linker + QH.HLP Help for the QH program + CV.HLP Help for CodeView + PWB.HLP Help for Programmer's WorkBench + COBOL.HLP Help on the COBOL language + + System Libraries: + + OS2.LIB + API.LIB + + System Dynamic-Link Libraries: + + MSHELP.DLL + + Initialisation Files: + + BRIEF.INI + TOOLS.PRE + + + =========================================================================== + Microsoft and CodeView are registered trademarks and Windows is a trademark of Microsoft Corporation. + OS/2 and Operating System/2 are registered trademarks and Presentation Manager is a trademark licensed to Microsoft Corporation. + Micro Focus is a registered trademark of Micro Focus Limited. + Micro Focus COBOL/2 is a trademark of Micro Focus Limited. + IBM is a registered trademark of the International Business Machines + Corporation. + Lattice is a registered trademark of Lattice Incorporated. + Ryan-McFarland and RM/COBOL are registered trademarks of Ryan-McFarland + Corporation. + =========================================================================== diff --git a/Microsoft COBOL v45/DOCS/README.DOC b/Microsoft COBOL v45/DOCS/README.DOC new file mode 100644 index 0000000..e06e27c --- /dev/null +++ b/Microsoft COBOL v45/DOCS/README.DOC @@ -0,0 +1,484 @@ + + README.DOC File + + Release Notes for the Microsoft(R) COBOL + Professional Development System + Version 4.5 + + (C) Copyright Microsoft Corporation, 1991 + + This document contains essential information for version 4.5 of the + Microsoft COBOL Professional Development System for MS-DOS(R) and the + Microsoft Operating System/2 (MS(R) OS/2(R)). The information in this + document is more up to date than that in the manuals. + + Microsoft improves its languages documentation at the time of reprinting, + so some of the information in this file may already be included in your + manuals. + + + NEW FEATURES + + o Support for Windows 3.0 + + The following types of programs are supported under Windows 3.0 : + + - Existing DOS applications can be linked with a new runtime library + (COBAPIDW) to produce an application that runs under Windows. + + - Programs that call the Windows API can now be written in + COBOL. Note that if you do not have the Windows Software + Development Kit (SDK) and plan to create true COBOL Windows + applications by calling the Windows API directly, you may be + interested in using the Dialog Editor from the SDK. The Dialog + Editor is available through PSS by calling 637-7096. + + - Dynamic-link libraries that can be called from programs written + in other programming languages can be written in COBOL. + + o Intrinsic Functions + + The 1989 Addendum to the ANSI 85 COBOL Standard introduced a set of + intrinsic functions. These functions are fully supported in + Microsoft COBOL 4.5. Functions are provided for Trigonometric, + Financial, Statistical and String handling. + + o Floating Point + + COMP-1 (32 bit Real) and COMP-2 (64 bit Real) data types have been + added to this release of COBOL. The syntax support is the same as + defined for IBM OSVS COBOL and IBM VS COBOL II, and an Intel Floating + Point Co-Processor will be used if available. + + o Table Sort + + The SORT verb can now apply to a Data Division table, which will be + sorted in place. + + o EXIT PERFORM + + Control of program flow is enhanced with a new EXIT PERFORM statement. + + o 'IF 78-level DEFINED' syntax for conditional compilation + + o Support for X/Open XPG3 COBOL definition + + o Compilation up to 10% faster + + o General performance improvements in generated code + + o Save and Restore Environment enables you to save the break-points and + monitors from one Animator session and reload them next time. + + o Breakpoint when data value changes. + + o Monitoring a subscripted item will follow a changing subscript. + + o Data compression + + You can supply your own data compression routines, which can be + tuned to the data that will be in the file. + + o OS/2 Database Manager (SQL) enhancements + + Support for: qualified host variables; more than 100 host variables in + one SQL statement; EXEC SQL WHENEVER SQLWARNING. + + o Screens index program + + The Screens program will generate an index program which can be used + for simple data entry applications. + + + NEW DIRECTIVES + + These are the new compiler directives introduced in this product: + + ALIAS Subscripts + BROWSE Create .SBR file + CHECKDIV Allow divide by zero + DEFAULTCALLS CALL convention + DETECTLOCK Detect record locks + DLL DLL or EXE + FLAGAS Show flags as errors etc. + HIDEMESSAGE Set message to hide + INFORETURN Info msg return value + INTLEVEL Portability level + LOCKTYPE Read locked records + MF(7) Micro Focus COBOL syntax + SQLDB2 Mainframe compatibility + SQLFORMAT Define date format + SQLPROT Protect database + WRITETHROUGH Unbuffered writes + XOPEN X/Open + + + THE COBOL SOFTWARE + + Compatibility with Previous Releases + ==================================== + This product is generally compatible with previous releases, However, + there are some differences. These are described in the ASCII text file, + CBL-CMPT.DOC, supplied with this product. Before you use this product with + programs created with earlier versions, we recommend that you read + CBL-CMPT.DOC. + + + Restrictions in the COBOL Software + ================================== + o Cooperative Animation only allows 4 breakpoints to be set. + + o In general, the components in this product support the High + Performance File System complex filenames. However, the directory + facility in some components will not work correctly when complex names + are present. Also, names are restricted to a maximum of 65 characters. + + o NODYNAM currently impacts both CALL literal and CALL identifier. To + get mainframe-type link-edit, use NOLITLINK with DYNAM and LITLINK + with NODYNAM when compiling to OBJ. + + o The ANIMATOR Do command will not work with: + + - the CHAIN verb when parameters are supplied + - CALL procedure-pointer + - CALL .... BY VALUE + - CANCEL of nested program + - EXIT PERFORM/PARAGRAPH/SECTION + - intrinsic functions. + + o The program-id of a called subprogram must be the same as the name + used for the .OBJ file created by the compiler. Otherwise, a new copy + will be loaded whenever the program is called. + + o Under OS/2 you cannot redirect input to the compiler or Animator. + + o On OS/2, any DLL that is to be loaded by the shared run-time that is + not specified with a path must exist on a path given in the COBDIR + environment variable, as well as on the OS/2 LIBPATH. + + o EXTERNAL data items are limited to a maximum of 64K bytes each. + + o The DISPLAY UPON PRINTER syntax does not work on OS/2. + + o Any computation which has an intermediate result greater than 18 + digits may give an incorrect final result. This will affect arithmetic + expressions such as those used in COMPUTE statements. + + o Floating-point data is currently not supported in QuickWin applications. + + o When interfacing with Microsoft C programs, the following C graphics + library routines should not be called as this will corrupt the COBOL + environment: + + - _outtext + - _outmem + - _floodfill + - any routine that uses floodfill where you specify the + _GFILLINTERIOR option (namely _ellipse and _pie) + + o You should not use cross-session animation on a network server since + this can prevent cross-session animation operating on other machines + on the network. + + o You cannot have more than ten files in the USING or GIVING phrase of a + MERGE statement. + + o In VS COBOL II Releases 1 and 2, and OS/VS COBOL, the "PERFORM stack" + is preserved between calls to a program. Thus, on re-entry to the + program, the PERFORM state will be as it was when the program was last + exited. This means that the code to return to the PERFORM statement + which exists at the end of any piece of code that had been performed + but had not exited when the program itself was exited will remain + active, and may cause unexpected program flow when the program is + re-entered. + + This COBOL behaves the same way as VS COBOL II Release 3 and + initializes the PERFORM stack each time a program is called + irrespective of the existence of the VSC2(1), VSC2(2) or OSVS + directives. + + o When interfacing with a C program, floating point items may only be + passed as BY REFERENCE parameters, not as BY VALUE or BY CONTENT + parameters. + + + + Restrictions in Related Software + ================================ + + Novell(R) network + ----------------- + o When sharing files across a Novell network, it is essential that all + the workstations using the network are configured so that they do not + use local buffering (CACHE DATA BUFFERING). Failure to do this may + result in loss of data. + + Novell version 2.0A, and prior to 2.15 are all configured with local + buffering on by default. To disable this buffering, in version 2.0A + you require a patch from Novell. In other versions, insert the line: + + CACHE BUFFERS = 0 + + into the file SHELL.CFG on each workstation. + + o Use of the NETBIOS option on a Novell network can cause loss of data + on files shared across the network. (NETBIOS is activated by entering + the NETBIOS command after connecting to the network. To avoid loss of + data, do not use this command.) + + o When creating multi-user programs to run on a Novell network, it is + necessary to ensure that all disk mapping assignments are beyond E:. + i.e. do not use assignments A: thru E:. + + + + DOCUMENTATION + + On-disk Documentation + ===================== + The disks supplied with this product contain additional documentation. + + The following on-disk documents should be regarded as additional chapters, + or additions to chapters, in your Operating Guide: + + MFCOMPAT.DOC - Compatibility with Micro Focus COBOL + OPTIMIZE.DOC - Creating Optimized Programs + TIMEOUT.DOC - Timeout Support in ACCEPT + + + Omissions and Errors + ==================== + This section contains information that is either incorrect or missing from + your Microsoft COBOL manuals. This information is organized according + to the manual in which it appears. You may want to mark the changes in + your manuals. + + + Language Reference + ------------------ + Page 5-24. There is an optional phrase within the WITH DUPLICATES phrase + of the ALTERNATE RECORD KEY clause of the SELECT statement for an indexed + file. Its syntax is: + + SUPPRESS [WHEN] { ZEROS } + { SPACES } + { [ALL] literal } + + SUPPRESS, ZEROS, SPACES, and ALL are all keywords. + + + Page 5-32. Insert a new General Rule (13a) between rules 13 and 14: + + "If a file is defined as EXTERNAL and the operating system file name is + assigned by means of a file name (for example, by use of either the + DYNAMIC directive or keyword, using data-name-1 in the SELECT/ASSIGN + statement, or using format 2 of the VALUE OF phrase of an FD), then the + following rules should be followed: + + 1) An identifier with the same name should be used to contain the + physical file name in all programs which reference the file. + + 2) Each definition of the identifier which contains the physical file + name should also contain the EXTERNAL attribute. + + Any violation of these rules will not be detected at compile time. + However, if any program in the run-unit violates these rules, the results + at run time are unpredictable. That is, they may or may not execute as + expected." + + + Page 5-83. After General Rule 27, add: + + "28. The I-O phrase permits the opening of a file for both input and + output operations (except for file with ORGANIZATION LINE SEQUENTIAL). If + the file does not exist it will be created and used as an empty file for + input unless NOT OPTIONAL was specified in the SELECT statement. An + attempt to WRITE it will cause an error." + + + Page 5-120. Add a new General Rule 13a: + + "The phrases ADVANCING PAGE and END-OF-PAGE must not both be specified in + a single WRITE statement." + + + Page 10-11, replace the entire second boxed extension with the following: + + "If a file is defined as EXTERNAL and the operating system file name is + assigned by means of a file name (for example, by use of either the + DYNAMIC directive or keyword, using data-name-1 in the SELECT/ASSIGN + statement, or using format 2 of the VALUE OF phrase of an FD), then the + following rules should be followed: + + 1) An identifier with the same name should be used to contain the + physical file name in all programs which reference the file. + + 2) Each definition of the identifier which contains the physical file + name should also contain the EXTERNAL attribute. + + Any violation of these rules will not be detected at compile time. + However, if any program in the run-unit violates these rules, the results + at run time are unpredictable. That is, they may or may not execute as + expected." + + + Page 15-34, General Rule 4 of the FOREGROUND-COLOR clause. In the first + sentence, change "contains a BACKGROUND-COLOR clause" to "contains a + FOREGROUND-COLOR clause". + + + Page 16-43, before the description of the ORD-MAX function insert a + description of the ORD-MIN function. Its description is exactly the same + as that of ORD-MAX, but replacing "ORD-MAX" by "ORD-MIN", "maximum" by + "minimum" and "greatest" by "least" everywhere that they occur. + + + Operating Guide + --------------- + + General + + A number of the executable files are supplied with .PIF files for use + with Microsoft Windows 3.0 or later. Using these .PIF files, the + components of this system can be run as Windows applications, and can + be added to a group for direct execution from Program Manager. From + the DOS command line, these applications can be invoked using the + command + + WIN prog.PIF + + where prog is the name of the relevant component. + + Chapter 9 (Packaging and Shipping Applications): + + There is a module RMSTAT.OBJ, which must be linked into your + application if you want to get RM file statuses. + + Chapter 19 (SQL): + + There is no support for using COMP-1 items with SQL. + + Chapter 34 (Converting C Header Files with H2CPY) + + There is a utility called SPLIT78. It splits the constants file + produced by H2CPY into several files. + + It uses the first set of characters before the first hyphen to name + the files. For example, if OS2.78 contains: + + 78 ABB-COLOR VALUE H"01". + 78 ABB-BACK-COLOR VALUE H"02". + 78 ABB-MIX-MODE VALUE H"04". + 78 ABB-BACK-MIX-MODE VALUE H"08". + 78 ABB-SET VALUE H"10". + 78 ABB-SYMBOL VALUE H"20". + 78 ABB-REF-POINT VALUE H"40". + + 78 AF-CHAR VALUE H"01". + 78 AF-VIRTUALKEY VALUE H"02". + 78 AF-SCANCODE VALUE H"04". + 78 AF-SHIFT VALUE H"08". + 78 AF-CONTROL VALUE H"10". + 78 AF-ALT VALUE H"20". + 78 AF-LONEKEY VALUE H"40". + 78 AF-SYSCOMMAND VALUE H"0100". + 78 AF-HELP VALUE H"0200". + + 78 HWND-DESKTOP VALUE 1. + 78 HWND-OBJECT VALUE 2. + 78 HWND-TOP VALUE 3. + 78 HWND-BOTTOM VALUE 4. + 78 HWND-THREADCAPTURE VALUE 5. + 78 HWND-PARENT VALUE 0. + + then typing the command, "SPLIT78 OS2.78" will create 3 files: + + ABB.78 + AF.78 + and HWND.78 + + The contents of OS2.78 will be unaffected. If any of the output files + already exist they will be extended, so make sure your working + directory contains no ".78" files other than the source file before + you enter the command SPLIT78. + + Appendix B (Compiler Directives): + + The default for the directive CHECKDIV is NOCHECKDIV, not CHECKDIV as + stated in the manuals. + + There is an additional directive FLAGCD. Its syntax is [NO] FLAGCD. + When it is set, selecting flagging for the dialect SAA, ANS85, OSVS or + VSC2 release 2 or 3 will not only flag syntax outside that dialect, + but will also flag any directive settings that cause behavior + incompatible with that dialect. The default is NOFLAGCD. + + There are two additional directives, HOST-NUMCOMPARE and ZWB which + direct the results of comparing a numeric display field with SPACE, + " " and "0". The directives are provided to ensure compatibility with + mainframe COBOL operation. If NOHOST-NUMCOMPARE or ZWB are specified, + the results of comparing are as now. If HOST-NUMCOMPARE and NOZWB are + specified together, the results are the exact opposite. Hence, if + PIC-9 contains spaces, the results of the comparison with SPACES, " " + and "0" are: + PIC-9 = SPACE PIC-9 = " " PIC-9 = "0" + NOZWB and HOST-NUMCOMPARE TRUE TRUE FALSE + ZWB or NOHOST-NUMCOMPARE FALSE FALSE TRUE + + These results are the same independent of the setting of the F + run-time switch. + + There is an additional generator directive SIGNCOMPARE. Its syntax is + [NO] SIGNCOMPARE. When it is set in an EBCDIC program, it changes the + way some numeric comparisons are performed so that, for example, an + unsigned data item containing 1234 is equal to a signed data item + containing +1234. This does, however, cause these comparisons to be much + less efficient. The default is NOSIGNCOMPARE. If you are using an + add-on product, note that the behavior in intermediate code is the + same as you get in generated code with SIGNCOMPARE; thus with the + default setting of this directive, the behavior in intermediate code + and generated code is different. + + There is an error in the example given for STICKY-LINKAGE. The name + of the data item referenced in the Procedure Division code should be + HOURLY-RATE, not RATE. + + There is an additional directive ZEROLENGTHFALSE. Its syntax is + [NO] ZEROLENGTHFALSE. When it is set, all class tests of zero length + group items return false. Otherwise they all return true. The default + is NOZEROLENGTHFALSE. For conformance to ANSI and SAA you must set + ZEROLENGTHFALSE. + + Appendices C and D (COBOL System Library Routines) + + The following passage is relevant to both these appendices: + + The COBOL system library routines generally supply features that + cannot be accessed using COBOL syntax, such as operating system + functions. Under OS/2, many of the features can be accessed directly + by calling the OS/2 API functions. However, this ties the program to + OS/2, with DOS capability available only for those API calls which are + part of the Family API, and only then when the program is bound. + + Parameters to the call-by-name routines can be defined anywhere + provided they do not cross a segment boundary. (See the CHIP "16" and + FLAG-CHIP compiler directives.) Parameters to the call-by-number + routines must not be defined in the Linkage Section or Local-Storage + Section of your program, and must be in the first 64K of the Data + Division. + + + Error Messages + -------------- + + Page 2-2. The reference to the E switch is only appropriate if you have + the Toolset or Workbench add-on products. Consequently, the effect of the + E switch is not documented in the Operating Guide as stated. + + + Pocket Guide + ------------ + + Reserved Words List + + The words SECONDS is shown as a reserved word. This is incorrect. diff --git a/Microsoft COBOL v45/DOCS/TIMEOUT.DOC b/Microsoft COBOL v45/DOCS/TIMEOUT.DOC new file mode 100644 index 0000000..7c43877 --- /dev/null +++ b/Microsoft COBOL v45/DOCS/TIMEOUT.DOC @@ -0,0 +1,177 @@ + + TIMEOUT SUPPORT IN ACCEPT + ========================= + + Definition + ========== + + General Format + + + For both Format 1 and Format 2 of the ACCEPT statement as documented in + the Screen Handling chapter of the Language Reference, the following + additional phrase is provided. + + +------------------------------------------------------------------------+ + | | + | { TIME-OUT } { integer-7 } | + | { -------- } { } | + | { } AFTER { } | + | { } { } | + | { TIMEOUT } { identifier-8 } | + | { ------- } { } | + | | + +------------------------------------------------------------------------+ + + Syntax Rules + + 1. Identifier-8 must be an integer. It may be signed. If unsigned it is + treated as positive. + + 2. Integer-7 must be an integer which may optionally be signed. If + unsigned it is treated as positive. + + + General Rules + + 1. If identifier-8 or integer-7 has a negative value, this represents a + request that no time-out "exception" should occur no matter how long + there is between/before key-strokes. + + 2. If identifier-8 or integer-7 is zero, this indicates that a time-out + should not occur if characters are waiting. However, if no characters + are waiting (when the ACCEPT is processed), then issue a time-out + immediately. + + 3. The ON EXCEPTION clause, if present, will be executed when a Time-Out + occurs and a time-out clause is specified. The NOT ON EXCEPTION + clause, if present, will be executed when a Time-Out clause is specified + but no time-out (or other exception) occurs. + + 4. If a Time-Out exception occurs, then the contents of any ACCEPT + resultant-field will be defined as follows: + + a. Any field which has been partially modified will contain any + information which has already been received. + b. Fields which have "FULL" or "REQUIRED" attributes or any other + attribute which would normally impact partial field input, will NOT + be required to meet those attributes when a partial field entry has + occurred when a TIMEOUT exception occurs. + c. The rules listed above apply whether or not the timeout clock is + reset upon each keystroke. + + 5. If at run-time a positive timeout interval greater than 2,147,483,647 + hundredths of a second is detected the timeout value will be reset to + 2,147,483,647 hundredths of a seconds (which is approximately eight + months). + + 6. The Time-Out value specifies the number of seconds (or tenths of a + second) after the ACCEPT statement begins processes until a time-out + exception occurs. A new ADISCF configuration option controls + whether or not the TIMEOUT clock is "reset" each time a new keyboard + action is detected. An application which wants some ACCEPT statements + to be handled with a RESET and some without, may make specific CALLs + to the ADIS run-time interface before or after the ACCEPT statements + that need changes from the default. For example when ADIS was + configured not to do resets, if a program had: + + ACCEPT INPUT-FIELD RIME-OUT AFTER +10 + + Then a time-out would occur after 10 seconds had elapsed from the + beginning of the ACCEPT, even if some characters were entered after 5 + seconds into the ACCEPT processing. + + If, on the other hand, ADIS were configured to do resets, if a program + had the same code given above, then each time a new character were + entered, the timeout "clock" would be reset to zero. + + 8. If a Time-Out exception occurs and no On Exception phrase is specified, + then the CRT Status keys (if specified) are updated, the application + continues to the logically next phrase, and the contents of the ACCEPT + receiving field are as defined above. (The above is true whether or not + a NOT ON EXCEPTION phrase is specified.) + + 9. All references to (NOT) ON EXCEPTION phrases within this proposal also + apply to (NOT) ON ESCAPE phrases. + + + + Running + ======= + + Configuring the TIMEOUT options using ADISCF + -------------------------------------------- + Two new Accept/Display options are available in ADISCF to allow + configuration of TIMEOUT. They are as follows: + + Option 31 - Selection of the units used when calculating TIMEOUT on + an accept. + + 1 - Units used are seconds + + 2 - Units used are tenths of a second + + + Option 32 - Control of the timer used to calculate accept TIMEOUT. + + 1 - The timer is never reset. Timeout will occur + at the specified length of time after the accept is + initiated + + 2 - Timeout is reset to its original value each time a + character is entered. + + + Changing the TIMEOUT options at run-time + ---------------------------------------- + Two new X"AF" calls are provided to allow the TIMEOUT options shown + above to be altered at run-time. The calls have the following format + + CALL X"AF" USING Set-Bit-Pairs Parameter-Block + + where the parameters are defined as follows: + + 01 Set-Bit-Pairs PIC 9(2) COMP-X VALUE 1. + 01 Parameter-Block. + 03 Bit-Pair-Setting PIC 9(2) COMP-X. + 03 FILLER PIC X VALUE "6". + 03 Bit-Pair-Number PIC 9(2) COMP-X. + 01 FILLER PIC 9(2) COMP-X VALUE 1. + + The values to be set for the fields Bit-Pair-Setting and Bit-Pais-Number + are given in each of the descriptions below. + + With each call, if an error occurs, Set-Bit-Pairs will return the value + 255. + + + Select Timeout units. + --------------------- + Allows selection of the units to be used when calculating TIMEOUT. + + Bit-Pair-Number must be set to 14. + + Bit-Par-Setting should be one of the following values: + + 0 - Units are seconds + + 1 - Units are tenths of a second + + + Control Timeout Reset + --------------------- + Allows control of the timer used to calculate TIMEOUT on an accept. + + Bit-Pair-Number must be set to 15. + + Bit-Par-Setting should be one of the following values: + + 0 - Timer is never reset. Timeout occurs after the specified + time from the start of the accept. + + 1 - The timer is reset each time a character is entered. + + + ========================================================================== + Copyright (C) 1991 Microsoft Corporation + Copyright (C) 1991 Micro Focus Ltd diff --git a/Microsoft COBOL v45/HELP/COBOL.HLP b/Microsoft COBOL v45/HELP/COBOL.HLP new file mode 100644 index 0000000..fda1f5a Binary files /dev/null and b/Microsoft COBOL v45/HELP/COBOL.HLP differ diff --git a/Microsoft COBOL v45/HELP/HYHELP.HNF b/Microsoft COBOL v45/HELP/HYHELP.HNF new file mode 100644 index 0000000..1dfd9a8 Binary files /dev/null and b/Microsoft COBOL v45/HELP/HYHELP.HNF differ diff --git a/Microsoft COBOL v45/HELP/LINK.HLP b/Microsoft COBOL v45/HELP/LINK.HLP new file mode 100644 index 0000000..2229446 Binary files /dev/null and b/Microsoft COBOL v45/HELP/LINK.HLP differ diff --git a/Microsoft COBOL v45/HELP/PWB.HLP b/Microsoft COBOL v45/HELP/PWB.HLP new file mode 100644 index 0000000..ba83851 Binary files /dev/null and b/Microsoft COBOL v45/HELP/PWB.HLP differ diff --git a/Microsoft COBOL v45/HELP/QH.HLP b/Microsoft COBOL v45/HELP/QH.HLP new file mode 100644 index 0000000..2891f75 Binary files /dev/null and b/Microsoft COBOL v45/HELP/QH.HLP differ diff --git a/Microsoft COBOL v45/HELP/UTILERR.HLP b/Microsoft COBOL v45/HELP/UTILERR.HLP new file mode 100644 index 0000000..e1d1c0f Binary files /dev/null and b/Microsoft COBOL v45/HELP/UTILERR.HLP differ diff --git a/Microsoft COBOL v45/HELP/UTILS.HLP b/Microsoft COBOL v45/HELP/UTILS.HLP new file mode 100644 index 0000000..7f92c8b Binary files /dev/null and b/Microsoft COBOL v45/HELP/UTILS.HLP differ diff --git a/Microsoft COBOL v45/INIT/BRIEF.INI b/Microsoft COBOL v45/INIT/BRIEF.INI new file mode 100644 index 0000000..1bf3d0a --- /dev/null +++ b/Microsoft COBOL v45/INIT/BRIEF.INI @@ -0,0 +1,524 @@ +[pwb brief b] +; TOOLS.INI file for BRIEF(tm) configuration + +NotBrief:=arg "No equivalent in the Programmer's WorkBench" message +ToolsIni:=arg "$INIT:tools.ini" setfile + +; +; GLOBAL CONFIGURATION +; +autosave:no +undocount:30 +autostart:=toggle_re +vscroll:1 +nounixre: +rmargin:70 +menukey:f9 + +; +; Backup File Toggle. Toggle through PWB's backup options and let +; the user know that something extra is going on. +; +backup:bak +baknone:=arg "backup:none" assign arg "File backups turned off!" message \ + arg "bakbak:Ctrl+W" assign +bakbak:=arg "backup:bak" assign arg "Single backups enabled" message \ + arg "bakundel:Ctrl+W" assign +bakundel:= arg "backup:undel" assign arg "Multiple backups enabled" message \ + arg "baknone:Ctrl+W" assign +bakundel:Ctrl+W + +; +; Beginning of Line +; +beginning_of_line:=meta begline +beginning_of_line:Home + +; +; Buffer List +; +Information:Alt+B + +; +; Case Sensitivity Toggle +; +case:yes +caseon:=arg "case:" assign arg "Enabled Case Sensitivity" message \ + arg "caseoff:ctrl+f5" assign +caseoff:=arg "nocase:" assign arg "Disabled Case Sensitivity" message \ + arg "caseon:ctrl+f5" assign +caseoff:ctrl+f5 + +; +; Center Line Horizontally +; Center Line in Window. +; +center:= arg "Please load the txtfmt extension" message +center:Ctrl+C + +; +; Change Output File +; +output_file:=arg arg "New Output File Name" prompt ->can setfile => :>can cancel +output_file:Alt+O + +; +; Change Window +; +Window:F2 + +; +; Color. To set colors in the PWB, assign a new value to one of the +; following switches. The value is a two digit hex number where the +; first digit is the background color and the second is the foreground. +; The number to color mapping is the same as in Brief. The color change +; will not take effect until you restart the editor. To see an immediate +; change, mark (select) the color assignment lines and press Alt+=. +; +colour:=ToolsIni begfile arg "colour:=ToolsIni" psearch up up up up up up up +color:text 07 +color:selection 70 +color:highlight 02 +color:info 06 +color:border 07 + +; +; Compile Buffer. Compile command is set with the 'build' switch +; (see documentation). +; +compile_it:=Arg Compile +compile_it:Alt+F10 + +; +; Create Key Assignment +; +assign_to_key:=arg "" setfile + +; +; Create Window. Window handling is very different in the PWB. +; +; To create a new window, move the cursor to the line or column where +; the new border is to be placed and do: +; +; Alt+A F3 - to create a horizontal border +; Alt+A Alt+A F3 - to create a vertical border +; +; To change the current window, press F3. +; +; To delete an existing window, go to that window and press F4. +; +create_edge:=ToolsIni begfile arg "create_edge:=" psearch \ + mpara arg setwindow \ + arg "window:F3" assign +create_edge:F3 + +; +; Cut to Scrap. Doesn't take current line if nothing is selected. +; +delete:num- + +; +; Delete +; +clear:=meta delete +clear:del + +; +; Delete Current Buffer +; +delete_curr_buffer:=arg refresh +delete_curr_buffer:Ctrl+- + +; +; Delete Line. +; +line_delete:=meta ldelete +line_delete:Alt+D + +; +; Delete Macro File +; +NotBrief:Shift+F9 + +; +; Delete Next Word +; +delete_next_word:=Arg Pword Clear + +; +; Delete Previous Word +; +delete_previous_word:=Pword Arg Mword Clear +delete_previous_word:Ctrl+Bksp + +; +; Delete to End of Line +; +delete_to_eol:=arg ldelete +delete_to_eol:Alt+K + +; +; Delete Window +; +delete_edge:=meta window +delete_edge:F4 + +; +; Display File Name +; +display_file_name:=arg curfile message +display_file_name:Alt+F + +; +; Display version ID +; +version:=arg "Microsoft Programmer's WorkBench Version 1.10" message +version:Alt+V + +; +; EditFile +; +EditFile:=arg "Name of File to Edit" prompt ->can setfile => :>can cancel +EditFile:Alt+E + +; +; End of Buffer +; +endfile:Ctrl+Pgdn + +; +; End of Window +; +end_of_window:=meta down +end_of_window:Ctrl+End + +; +; Execute Command. In the PWB, you can enter any series of functions or +; macros, including string literals "in quotes". +; +execute_macro:=arg "Command to Execute" prompt ->can execute => :>can cancel +execute_macro:F10 + +; +; Exit +; +exit:Alt+X + +; +; Go to Line +; +GoTo:=arg "Line to Go To" prompt ->can mark => :>can cancel +GoTo:alt+g + +; +; Go to routine. +; +routines:=arg "Please load the Browser" message +routines:Ctrl+G + +; +; Incremental Search +; +i_search:=NotBrief + +; +; Insert Mode Toggle. Toggle between Insert and Overstrike modes and issue +; a message telling the user what has been done. +; +enterinsmode:yes +insert_mode:=Insertmode +>showins arg "Overstrike Mode" message => \ + :>showins arg "Insert Mode" message +insert_mode:Alt+I + +; +; Left Side of Window +; +left_side:=meta left +left_side:Shift+Home + +; +; Line to Bottom of Window +; +l2b:=meta begline arg setwindow mpage plines meta down +l2b:Ctrl+B + +; +; Line to Top of Window +; +l2t:=meta begline arg setwindow +l2t:Ctrl+T + +; +; Load Macro File +; +; NotBrief:F9 + +; +; Lower Case Block +; +tolower:= arg "Please load the txtfmt extension" message + +; +; Mark. Known in the PWB as selecting text. In the PWB, selection is +; done in one of three modes: stream, box and line, which correspond +; to normal and column/line selection in Brief. To select lines, +; start marking in column mode, but move straight down. To change +; between modes in the PWB, a toggle function is provided. +; +; Arg:Alt+A ; PWB selection (default assignment) + +SelMode:Ctrl+B ; PWB mode toggle +ToStream:=:>top SelMode ->top ; Change to stream mode +ToBox:=ToStream SelMode ; Change to box mode +ToLine:=ToBox SelMode ; Change to line mode + +mark2:=ToBox Arg +mark2:Alt+C +mark2:Alt+L + +mark1:=ToStream Arg +mark1:Alt+M + +; +; Next Buffer +; +setfile:Alt+N + +; +; Next Character +; +next_char:= arg arg "[~ ]" psearch + +; +; Next Error +; +NextMsg:Ctrl+N + +; +; Open New Line +; +open_line:=down linsert meta begline +open_line:Ctrl+Enter + +; +; Paste From Scrap +; +paste:ins + +; +; Pause Recording Toggle +; +NotBrief:Shift+F7 + +; +; Pause On Error +; +pause_on_error:=NotBrief + +; +; PlayBack +; +recordvalue:=arg "No recording has been made" message +recordvalue:F8 + +; +; Pop-up Errors. In the PWB, this switches you to the compile file. You +; can go to any message with Alt+A Alt+A NextMsg. +; +next_error1:=arg "" setfile +next_error1:Ctrl+P + +; +; Previous Buffer. There are no "next" and "previous" buffers in the PWB, +; so this is the same as "Next Buffer". +; +setfile:Alt+- + +; +; Previous Character +; +prev_char:= arg arg "[~ ]" msearch + +; +; Print Block +; +print:Alt+P + +; +; Quote +; +quote:Alt+Q + +; +; Read File into Buffer +; +read_file:=arg arg "Name of File Read" prompt ->can paste => :>can cancel + +; +; Reformat Paragraph +; +reform:= arg "Please load the txtfmt extension" message + +; +; Regular Expression Toggle. In the PWB, regular expression recognition +; is controlled by modifying the search and search/replace functions +; (Arg Arg forces regular expression search). +; +toggle_re:=togRE arg "togRE:=" srchname assign +toggle_re:Ctrl+F6 +togRE:=REon + +REoff:=arg "psrch:=arg \"String to Search for\" prompt ->can psearch => :>can cancel" assign \ + arg "msrch:=arg \"String to Search for\" prompt ->can msearch => :>can cancel" assign \ + arg "qrepl:=qreplace" assign \ + arg "srchname:=\"REon\"" assign \ + arg "Disabled Regular Expressions" message +REon:=arg "psrch:=arg arg \"String to Search for\" prompt ->can psearch => :>can cancel" assign \ + arg "msrch:=arg arg \"String to Search for\" prompt ->can msearch => :>can cancel" assign \ + arg "qrepl:=arg arg qreplace" assign \ + arg "srchname:=\"REoff\"" assign \ + arg "Enabled Regular Expressions" message + +; +; Remember. Use Arg Arg Record to append to existing macro. +; +record:F7 + +; +; Repeat +; +repeat:Ctrl+R + +; +; Right Side of Window +; +right_side:=meta right +right_side:Shift+End + +; +; Scroll Buffer Down in Window +; +mlines:Ctrl+D + +; +; Scroll Buffer Up in Window +; +plines:Ctrl+U + +; +; Search Again +; +search_again:=psearch +search_again:Shift+F5 + +; +; Search Backward +; +search_back:=msrch arg "search_again:=msearch" assign +search_back:Alt+F5 + +; +; Search Forward +; +search_fwd:=psrch arg "search_again:=psearch" assign +search_fwd:F5 +search_fwd:Alt+S + +; +; Suspend Editor +; +shell:Alt+Z + +; +; Tab. Please read the documentation for a full description of tabs. +; +graphic:tab +realtabs:yes +entab:0 +tabstops:8 + +; +; Tab Stops +; +tabs:= arg "Please load the txtfmt extension" message + +; +; Top of Buffer +; +begfile:Ctrl+PgUp + +; +; Top of Window +; +top_of_window:=meta up +top_of_window:Ctrl+Home + +; +; Translate Again +; +translate_again:=qrepl +translate_again:Shift+F6 + +; +; Translate Backward +; +translate_back:=arg "You can only translate forwards" message +translate_back:Alt+F6 + +; +; Translate Forward +; +translate:=qrepl +translate:F6 +translate:Alt+T + +; +; Undo +; +undo:Alt+U +undo:num* + +; +; Use Tab Characters +; +use_tab_char:=arg "entab:1" assign + +; +; Window Border Toggle. In the PWB, this cycles through the five +; possible border states. +; +winstyle:Alt+F1 + +; +; +; Write +; +write_it:=arg arg setfile +write_it:Alt+W + +; +; BRIEF is a trademark of UnderWare, INC. + + +[pwb-pwbhelp brief-pwbhelp b-pwbhelp] + +; +; Help. Attach context-sensitive help to Alt+H. +; +_pwbhelp_context:Alt+H + + +[pwb-pwbrowse brief-pwbrowse b-pwbrowse] + +; +; Browser. +; + +routines:= pwbrowse1stdef + +[pwb-txtfmt brief-txtfmt b-txtfmt] + +center:= CenterLine +tolower:= lcase +reform:= justify +tabs:= ptab diff --git a/Microsoft COBOL v45/INIT/TOOLS.INI b/Microsoft COBOL v45/INIT/TOOLS.INI new file mode 100644 index 0000000..5bf6c89 --- /dev/null +++ b/Microsoft COBOL v45/INIT/TOOLS.INI @@ -0,0 +1,4 @@ +[cvp] + +eval: C:\COBOL\BINP\COBOS2.DLL .CBL.COB.CPY +eval: C:\COBOL\BINP\CANOS2.DLL .C.H.ASM.INC diff --git a/Microsoft COBOL v45/INIT/TOOLS.PRE b/Microsoft COBOL v45/INIT/TOOLS.PRE new file mode 100644 index 0000000..541000c --- /dev/null +++ b/Microsoft COBOL v45/INIT/TOOLS.PRE @@ -0,0 +1,138 @@ +[pwb] +; +; Predefined and example Programmer's Work Bench Macros +; +; assignments +; Displays the current assignments pseudo-file. (Formerly called "help"). +; +assignments:=arg "?" assign < +assignments:f10 +; +; rawoutput +; Switches the current window to the compile log to view the raw compile +; output. +; +rawoutput:=arg "" setfile +rawoutput:alt+F3 +; +; spell +; Invokes the Microsoft Word 4.0 spelling checker on the current file. (Only +; available under DOS). +; +spell:=arg "spell-am " curfile shell +spell:ctrl+f7 +; +; undotoggle +; Toggling undo. Repeatedly executing this macro undoes and redoes the most +; recent editing change. +; +undotoggle:=meta undo +> undo +undotoggle:ctrl+bksp +; +; +; build switch examples +; +; The following are examples of error strings. If messages output to the +; compile window match these strings they will be counted and found by +; nextmsg (Search.Next Error, etc.). The compiler and utility messages +; will be added by the extensions. If you do not load the extensions, +; but want to match these messages in the compile window, add these to +; your tools.ini. +; +; +; pwbrmake +build: message "^pwbrmake: [^U]+U[124]" +; bind +build: message "^BIND : [^U]+U[124]" +; C +build: message "^\\(\\:p\\)(\\(\\:z\\)) : [^C]+C[124]" file line +build: message "^[^C]+C[124][0-9]+: " +; C or FORTRAN +build: message "^[^D]+D[124][0-9]+ : " +; FORTRAN +build: message "^\\(\\:p\\)(\\(\\:z\\)) : [^F]+F[124]" file line +build: message "^[^F]+F[1234][0-9]+: " +; COBOL +build: message "^\\(\\:p\\)\\:b\\([0-9]+\\) \\([0-9]+\\): \\*[ 0-9][ 0-9][ 0-9]" file line col +; BASIC +build: message "^\\(\\:p\\)([ \t]*\\(\\:z\\),[ \t]*\\(\\:z\\)) : " file line col +; MASM +build: message "^\\(\\:p\\)(\\([0-9]+\\))[ \t]*:[ \t]*[^A]+A[12456]" file line +; H2INC +build: message "^\\(\\:p\\)(\\(\\:z\\)) : [^H]+HI[124]" file line +build: message "^[^H]+HI[124][0-9]+: " +; general +build: message "^fatal error" +; generic OS/2 system messages (SYS and NET are already in defaults) +build: message "^[A-Z][A-Z][A-Z]\\:d\\:d\\:d\\:d:\\:b" +; +; +; Default colors. +; +; The following are the color settings that the PWB uses by default. On +; some hardware configurations, the PWB may incorrectly identify your +; monochrome video as color (or vice-versa). If the PWB screen looks +; wrong, try using the color set appropriate for your hardware +; +; Colors for a Color system +; +; color: background 07 +; color: hilitectrl 07 +; color: greyed 78 +; color: enabled 70 +; color: disabled 78 +; color: alert 70 +; color: dialogbox 70 +; color: pushbutton 70 +; color: buttondown 07 +; color: listbox 70 +; color: scrollbar 70 +; color: elevator 07 +; color: menubox 70 +; color: menu 70 +; color: menuselected 07 +; color: menuhilite 7f +; color: menuhilitesel 0f +; color: itemhilitesel 0f +; color: dialogaccel 7f +; color: dialogaccelbor 7f +; color: shadow 08 +; color: text 17 +; color: highlight 1f +; color: info 3f +; color: selection 71 +; color: border 07 +; color: status 70 +; color: scratch 07 +; +; +; Colors for a Monochrome system +; +; color: background 07 +; color: hilitectrl 07 +; color: greyed 70 +; color: enabled 70 +; color: disabled 70 +; color: alert 70 +; color: dialogbox 70 +; color: pushbutton 70 +; color: buttondown 07 +; color: listbox 70 +; color: scrollbar 70 +; color: elevator 07 +; color: menubox 70 +; color: menu 70 +; color: menuselected 07 +; color: menuhilite 7f +; color: menuhilitesel 0f +; color: itemhilitesel 0f +; color: dialogaccel 7f +; color: dialogaccelbor 7f +; color: shadow 07 +; color: text 07 +; color: highlight 0f +; color: info 70 +; color: selection 70 +; color: border 07 +; color: status 70 +; color: scratch 07 diff --git a/Microsoft COBOL v45/LIB/ADIS.OBJ b/Microsoft COBOL v45/LIB/ADIS.OBJ new file mode 100644 index 0000000..7943db3 Binary files /dev/null and b/Microsoft COBOL v45/LIB/ADIS.OBJ differ diff --git a/Microsoft COBOL v45/LIB/ADISDYNA.OBJ b/Microsoft COBOL v45/LIB/ADISDYNA.OBJ new file mode 100644 index 0000000..17dc6f1 Binary files /dev/null and b/Microsoft COBOL v45/LIB/ADISDYNA.OBJ differ diff --git a/Microsoft COBOL v45/LIB/ADISINIT.OBJ b/Microsoft COBOL v45/LIB/ADISINIT.OBJ new file mode 100644 index 0000000..e1d6b17 Binary files /dev/null and b/Microsoft COBOL v45/LIB/ADISINIT.OBJ differ diff --git a/Microsoft COBOL v45/LIB/ADISKEY.OBJ b/Microsoft COBOL v45/LIB/ADISKEY.OBJ new file mode 100644 index 0000000..b717487 Binary files /dev/null and b/Microsoft COBOL v45/LIB/ADISKEY.OBJ differ diff --git a/Microsoft COBOL v45/LIB/CBLBIND.LIB b/Microsoft COBOL v45/LIB/CBLBIND.LIB new file mode 100644 index 0000000..145d815 Binary files /dev/null and b/Microsoft COBOL v45/LIB/CBLBIND.LIB differ diff --git a/Microsoft COBOL v45/LIB/CBLBIND.NOT b/Microsoft COBOL v45/LIB/CBLBIND.NOT new file mode 100644 index 0000000..a32b9af --- /dev/null +++ b/Microsoft COBOL v45/LIB/CBLBIND.NOT @@ -0,0 +1,6 @@ +DOSGETMODHANDLE +DOSGETPROCADDR +DOSSETMAXFH +DOSLOADMODULE +DOSFREEMODULE +DOSERROR diff --git a/Microsoft COBOL v45/LIB/CBLDC001.OBJ b/Microsoft COBOL v45/LIB/CBLDC001.OBJ new file mode 100644 index 0000000..f3007b1 Binary files /dev/null and b/Microsoft COBOL v45/LIB/CBLDC001.OBJ differ diff --git a/Microsoft COBOL v45/LIB/CCIAPPC.LIB b/Microsoft COBOL v45/LIB/CCIAPPC.LIB new file mode 100644 index 0000000..e9cc3ac Binary files /dev/null and b/Microsoft COBOL v45/LIB/CCIAPPC.LIB differ diff --git a/Microsoft COBOL v45/LIB/CCIIPX.OBJ b/Microsoft COBOL v45/LIB/CCIIPX.OBJ new file mode 100644 index 0000000..bde5fad Binary files /dev/null and b/Microsoft COBOL v45/LIB/CCIIPX.OBJ differ diff --git a/Microsoft COBOL v45/LIB/CCINAMP.LIB b/Microsoft COBOL v45/LIB/CCINAMP.LIB new file mode 100644 index 0000000..d3459fa Binary files /dev/null and b/Microsoft COBOL v45/LIB/CCINAMP.LIB differ diff --git a/Microsoft COBOL v45/LIB/CCINETB.LIB b/Microsoft COBOL v45/LIB/CCINETB.LIB new file mode 100644 index 0000000..3833065 Binary files /dev/null and b/Microsoft COBOL v45/LIB/CCINETB.LIB differ diff --git a/Microsoft COBOL v45/LIB/CCINETB.OBJ b/Microsoft COBOL v45/LIB/CCINETB.OBJ new file mode 100644 index 0000000..e3e62f7 Binary files /dev/null and b/Microsoft COBOL v45/LIB/CCINETB.OBJ differ diff --git a/Microsoft COBOL v45/LIB/COBAPI.LIB b/Microsoft COBOL v45/LIB/COBAPI.LIB new file mode 100644 index 0000000..9f1a202 Binary files /dev/null and b/Microsoft COBOL v45/LIB/COBAPI.LIB differ diff --git a/Microsoft COBOL v45/LIB/COBFP87D.LIB b/Microsoft COBOL v45/LIB/COBFP87D.LIB new file mode 100644 index 0000000..825c5d5 Binary files /dev/null and b/Microsoft COBOL v45/LIB/COBFP87D.LIB differ diff --git a/Microsoft COBOL v45/LIB/COBINTFN.OBJ b/Microsoft COBOL v45/LIB/COBINTFN.OBJ new file mode 100644 index 0000000..1ebb76d Binary files /dev/null and b/Microsoft COBOL v45/LIB/COBINTFN.OBJ differ diff --git a/Microsoft COBOL v45/LIB/COBLIB.LIB b/Microsoft COBOL v45/LIB/COBLIB.LIB new file mode 100644 index 0000000..25715e5 Binary files /dev/null and b/Microsoft COBOL v45/LIB/COBLIB.LIB differ diff --git a/Microsoft COBOL v45/LIB/EXTERNL.OBJ b/Microsoft COBOL v45/LIB/EXTERNL.OBJ new file mode 100644 index 0000000..74b7c3d Binary files /dev/null and b/Microsoft COBOL v45/LIB/EXTERNL.OBJ differ diff --git a/Microsoft COBOL v45/LIB/EXTFH.OBJ b/Microsoft COBOL v45/LIB/EXTFH.OBJ new file mode 100644 index 0000000..8cb7699 Binary files /dev/null and b/Microsoft COBOL v45/LIB/EXTFH.OBJ differ diff --git a/Microsoft COBOL v45/LIB/LCOBOL.LIB b/Microsoft COBOL v45/LIB/LCOBOL.LIB new file mode 100644 index 0000000..cdc9825 Binary files /dev/null and b/Microsoft COBOL v45/LIB/LCOBOL.LIB differ diff --git a/Microsoft COBOL v45/LIB/MFNETDOS.OBJ b/Microsoft COBOL v45/LIB/MFNETDOS.OBJ new file mode 100644 index 0000000..3e3512f Binary files /dev/null and b/Microsoft COBOL v45/LIB/MFNETDOS.OBJ differ diff --git a/Microsoft COBOL v45/LIB/RMSTAT.OBJ b/Microsoft COBOL v45/LIB/RMSTAT.OBJ new file mode 100644 index 0000000..bdc3014 Binary files /dev/null and b/Microsoft COBOL v45/LIB/RMSTAT.OBJ differ diff --git a/Microsoft COBOL v45/LIB/_CLASS.OBJ b/Microsoft COBOL v45/LIB/_CLASS.OBJ new file mode 100644 index 0000000..2f892ab Binary files /dev/null and b/Microsoft COBOL v45/LIB/_CLASS.OBJ differ diff --git a/Microsoft COBOL v45/LIB/_CODESET.OBJ b/Microsoft COBOL v45/LIB/_CODESET.OBJ new file mode 100644 index 0000000..f5bd929 Binary files /dev/null and b/Microsoft COBOL v45/LIB/_CODESET.OBJ differ diff --git a/Microsoft COBOL v45/SOURCE/SQLCA.CPY b/Microsoft COBOL v45/SOURCE/SQLCA.CPY new file mode 100644 index 0000000..36943d9 --- /dev/null +++ b/Microsoft COBOL v45/SOURCE/SQLCA.CPY @@ -0,0 +1,20 @@ + 01 SQLCA. + 05 SQLCAID PIC X(8). + 05 SQLCABC PIC S9(9) COMP-5. + 05 SQLCODE PIC S9(9) COMP-5. + 05 SQLERRM. + 49 SQLERRML PIC S9(4) COMP-5. + 49 SQLERRMC PIC X(70). + 05 SQLERRP PIC X(8). + 05 SQLERRD PIC S9(9) COMP-5 OCCURS 6. + 05 SQLWARN. + 10 SQLWARN0 PIC X. + 10 SQLWARN1 PIC X. + 10 SQLWARN2 PIC X. + 10 SQLWARN3 PIC X. + 10 SQLWARN4 PIC X. + 10 SQLWARN5 PIC X. + 10 SQLWARN6 PIC X. + 10 SQLWARN7 PIC X. + 05 SQLEXT PIC X(8). +