Tek-Tips is the largest IT community on the Internet today!
Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!
-
Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!
Test bit settings?? 3
- Thread starter Red1
- Start date
Hi Crox,
I did something like this to test the COBOL options
contained in a load module and print them. I have the code at work, but here's the hemi-demi-semi-pseudo-code as I re-
member:
Move or redefine the bit string as COMP, redefine the hi-ord byte as X.
code a loop that compares the hi-ord byte to x'79' (if >,
the bit is "on" else "off"
then multiplies the comp field
by 2 until the string is processed. The x2 "advances" the
the string by 1 bit.
Hope this helps. If you want the code let me know.
Regards, Jack.
P.S. This was done in a COBOLII mainframe environment.
I did something like this to test the COBOL options
contained in a load module and print them. I have the code at work, but here's the hemi-demi-semi-pseudo-code as I re-
member:
Move or redefine the bit string as COMP, redefine the hi-ord byte as X.
code a loop that compares the hi-ord byte to x'79' (if >,
the bit is "on" else "off"
then multiplies the comp fieldby 2 until the string is processed. The x2 "advances" the
the string by 1 bit.
Hope this helps. If you want the code let me know.
Regards, Jack.
P.S. This was done in a COBOLII mainframe environment.
- Thread starter
- #6
This is a cobol example using individual bits setting the file mode in DOS. You can see how the variable BIT is calculated.
It is written in CA-REALIA COBOL, probably version 3.1 or so.
000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. FILEMODE.
000300 ENVIRONMENT DIVISION.
000400 CONFIGURATION SECTION.
000500 SOURCE-COMPUTER. IBM-PC.
000600 OBJECT-COMPUTER. IBM-PC.
000700 INPUT-OUTPUT SECTION.
000800 FILE-CONTROL.
000900 DATA DIVISION.
001000 FILE SECTION.
001100 WORKING-STORAGE SECTION.
001200 01 FILE-NAME PIC X(79).
001300 01 FILE-ATTR PIC S9(4) COMP-5.
001400 01 SUB-BIT PIC S9(4) COMP-5.
001500 01 BITJES.
001600 03 BIT OCCURS 8 PIC 9.
001700 01 START-AANSTURING-SCHERM.
001800* 256 * 27 + 91 = ESC + [
001900 03 FILLER PIC 9(4) COMP-4 VALUE 7003.
002000
002100 01 ZET-CURSOR.
002200 03 REGEL PIC 99.
002300 03 FILLER PIC X VALUE ';'.
002400 03 KOLOM PIC 99.
002500 03 FILLER PIC X VALUE 'H'.
002600
002700 01 SCHERMSTUURTEKENS.
002800 03 SET-MODE-START PIC X VALUE '='.
002900 03 SET-SCHERM-TYPE PIC X.
003000******************************************************************
003100* PARAMETERS VOOR HET AANSTUREN VAN DE SCHERM MODE ONDER ANSI.SYS
003200* *
003300* 0 40X25 MONOCHROME TEXT MODE *
003400* 1 40X25 COLOR TEXT MODE *
003500* 2 80X25 MONOCHROME TEXT MODE *
003600* 3 80X25 COLOR TEXT MODE *
003700* 4 320 X 200 COLOR GRAPHICS MODE *
003800* 5 320 X 200 MONOCHROME GRAPHICS MODE *
003900* 6 640 X 200 MONOCHROME GRAPHICS MODE *
004000* 7 AUTOWRAP MODE ON (= DEFAULT: LOOPT DUS OVER REGEL HEEN) *
004100* *
004200******************************************************************
004300 03 SET-MODE-EINDE PIC X VALUE 'h'.
004400
004500 01 ZET-ATTRIBUTES.
004600***SLECHTS 1 VAN ONDERSTAANDE ATTRIBUTES PER KEER SELEKTEREN ! ***
004700***OF CUMULEREN MET BEHULP VAN EEN ; ***
004800* *
004900* 03 ZA-ATTRIBUTES-UIT PIC X VALUE '0'. *
005000* 03 ZA-HIGH-INTENSITY PIC X VALUE '1'. *
005100* 03 ZA-UNDERSCORE PIC X VALUE '4'. *
005200* 03 ZA-BLINK PIC X VALUE '5'. *
005300* 03 ZA-REVERSE-VIDIO PIC X VALUE '7'. *
005400* 03 ZA-CANCELED-ONZICHTBAAR PIC X VALUE '8'. *
005500* 03 ZA-BLACK-FOREGROUND PIC XX VALUE '30'. *
005600* 03 ZA-RED-FOREGROUND PIC XX VALUE '31'. *
005700* 03 ZA-GREEN-FOREGROUND PIC XX VALUE '32'. *
005800* 03 ZA-YELLOW-FOREGROUND PIC XX VALUE '33'. *
005900* 03 ZA-BLUE-FOREGROUND PIC XX VALUE '34'. *
006000* 03 ZA-MAGENTA-FOREGROUND PIC XX VALUE '35'. *
006100* 03 ZA-CYAN-FOREGROUND PIC XX VALUE '36'. *
006200* 03 ZA-WHITE-FOREGROUND PIC XX VALUE '37'. *
006300* 03 ZA-BLACK-BACKGROUND PIC XX VALUE '40'. *
006400* 03 ZA-RED-BACKGROUND PIC XX VALUE '41'. *
006500* 03 ZA-GREEN-BACKGROUND PIC XX VALUE '42'. *
006600* 03 ZA-YELLOW-BACKGROUND PIC XX VALUE '43'. *
006700* 03 ZA-BLUE-BACKGROUND PIC XX VALUE '44'. *
006800* 03 ZA-MAGENTA-BACKGROUND PIC XX VALUE '45'. *
006900* 03 ZA-CYAND-BACKGROUND PIC XX VALUE '46'. *
007000* 03 ZA-WHITE-BACKGROUND PIC XX VALUE '47'. *
007100******************************************************************
007200 03 FILLER PIC X VALUE 'm'.
007300
007400 01 RESET-ALL-ATTRIBUTES PIC XXX VALUE '00m'.
007500 01 MAAK-SCHERM-SCHOON PIC XX VALUE '2J'.
007600 01 MAAK-REGEL-LEEG PIC X VALUE 'K'.
007700 01 ZET-AUTOWRAP-MODE-OFF PIC X(3) VALUE '=7I'.
007800 01 ZET-80-BY-25 PIC X(3) VALUE '=2I'.
007900 01 ZET-AUTOWRAP-MODE-ON PIC X(3) VALUE '=7h'.
008000
008100
008200******************************************************************
008300* ACCEPT CONTROL OPTIES *
008400******************************************************************
008500 01 ACCEPT-PARMS.
008600 03 ACCEPT-AUTO-ENTER PIC X VALUE 'Y'.
008700 03 ACCEPT-TEST-EMPTY PIC X VALUE 'N'.
008800 03 ACCEPT-FILL-REQUIRED PIC X VALUE 'N'.
008900 03 ACCEPT-ENTRY-REQUIRED PIC X VALUE 'N'.
009000 03 ACCEPT-NO-ENTER-ECHO PIC X VALUE 'N'.
009100 03 FILLER PIC X(8) VALUE SPACE.
009200
009300********************* OVERDRACHT DOS IO CONTROL ROUTINE ****************
009400 01 IOCTL-CONTROL.
009500 03 FILE-HANDLE PIC S9(4) COMP-5.
009600 03 IOCTL-FUNCTION PIC S9(4) COMP-5.
009700 03 IOCTL-DRIVE-ID PIC X.
009800 03 IOCTL-DEVICE-INFO PIC 9(16).
009900 03 FILLER REDEFINES IOCTL-DEVICE-INFO.
010000 05 FILLER PIC 9.
010100 05 CTRL PIC 9.
010200 05 FILLER PIC 9(6).
010300 05 ISDEV PIC 9.
010400 05 EOF PIC 9.
010500 05 RAW PIC 9.
010600 05 BIN REDEFINES RAW PIC 9.
010700 05 FILLER PIC 9.
010800 05 ISCLK PIC 9.
010900 05 ISNUL PIC 9.
011000 05 ISCOT PIC 9.
011100 05 ISCIN PIC 9.
011200 03 IOCTL-STATUS PIC S9(4) COMP-5.
011300 03 IOCTL-COUNT PIC S9(4) COMP-5.
011400 03 IOCTL-BUFFER PIC X(001).
011500
011600******************************************************************
011700* HIERNA HET GECREEERDE GEDEELTE VAN DE SCHERM WORKING-STORAGE *
011800* SECTION INCOPIEREN *
011900******************************************************************
012000 01 SC-SCHERMNAAM.
012100 02 SC-01 VALUE
012200 'filemode programma
012300- ' '.
012400 03 FILLER PIC X(80).
012500 02 SC-02 VALUE
012600 '
012700- ' '.
012800 03 FILLER PIC X(80).
012900 02 SC-03 VALUE
013000 '
013100- ' '.
013200 03 FILLER PIC X(80).
013300 02 SC-04 VALUE
013400 '
013500- ' '.
013600 03 FILLER PIC X(80).
013700 02 SC-05 VALUE
013800 'filenaam:
013900- ' '.
014000 03 FILLER PIC X(10).
014100 03 FILENAME PIC X(69).
014200 03 FILLER PIC X(01).
014300 02 SC-06 VALUE
014400 '
014500- ' '.
014600 03 FILLER PIC X(80).
014700 02 SC-07 VALUE
014800 '
014900- ' 1=AKTIEF, 0=NIET AKTIEF '.
015000 03 FILLER PIC X(80).
015100 02 SC-08 VALUE
015200 ' ATTRIBUTEN:
015300- ' '.
015400 03 FILLER PIC X(80).
015500 02 SC-09 VALUE
015600 '
015700- ' '.
015800 03 FILLER PIC X(80).
015900 02 SC-10 VALUE
016000 '
016100- ' '.
016200 03 FILLER PIC X(80).
016300 02 SC-11 VALUE
016400 ' read/only hidden system vo
016500- 'lume label sub directory archief vlag '.
016600 03 FILLER PIC X(80).
016700 02 SC-12 VALUE
016800 '
016900- ' '.
017000 03 FILLER PIC X(80).
017100 02 SC-13 VALUE
017200 ' oud:
017300- ' '.
017400 03 FILLER PIC X(12).
017500 03 READ-ONLY-OLD PIC 9(01).
017600 03 FILLER PIC X(10).
017700 03 HIDDEN-FILE-OLD PIC 9(01).
017800 03 FILLER PIC X(08).
017900 03 SYSTEM-FILE-OLD PIC 9(01).
018000 03 FILLER PIC X(11).
018100 03 VOLUME-LABEL-OLD PIC 9(01).
018200 03 FILLER PIC X(14).
018300 03 SUB-DIRECTORY-OLD PIC 9(01).
018400 03 FILLER PIC X(13).
018500 03 ARCHIVE-FLAG-OLD PIC 9(01).
018600 03 FILLER PIC X(06).
018700 02 SC-14 VALUE
018800 '
018900- ' '.
019000 03 FILLER PIC X(80).
019100 02 SC-15 VALUE
019200 'nieuw:
019300- ' - - '.
019400 03 FILLER PIC X(12).
019500 03 READ-ONLY-NEW PIC 9(01).
019600 03 FILLER PIC X(10).
019700 03 HIDDEN-FILE-NEW PIC 9(01).
019800 03 FILLER PIC X(08).
019900 03 SYSTEM-FILE-NEW PIC 9(01).
020000 03 FILLER PIC X(11).
020100 03 VOLUME-LABEL-NEW PIC 9(01).
020200 03 FILLER PIC X(14).
020300 03 SUB-DIRECTORY-NEW PIC 9(01).
020400 03 FILLER PIC X(13).
020500 03 ARCHIVE-FLAG-NEW PIC 9(01).
020600 03 FILLER PIC X(06).
020700 02 SC-16 VALUE
020800 '
020900- ' '.
021000 03 FILLER PIC X(80).
021100 02 SC-17 VALUE
021200 '
021300- ' '.
021400 03 FILLER PIC X(80).
021500 02 SC-18 VALUE
021600 '
021700- ' '.
021800 03 FILLER PIC X(80).
021900 02 FOUTBOODSCHAP VALUE
022000 '
022100- ' EINDE=<ESC>'.
022200 03 RUBR-14 PIC X(69).
022300 03 FILLER PIC X(11).
022400 PROCEDURE DIVISION.
022500 0001.
022600 CALL 'ACCEPT-CONTROL' USING ACCEPT-PARMS.
022700******************************************************************
022800* *
022900* *
023000* VERHOGING SNELHEID DISPLAY DOOR DEFINITIE VAN *
023100* BINAIR SCHERM. *
023200* *
023300********************************************* MAKE FAST *********
023400 MOVE 1 TO FILE-HANDLE.
023500 MOVE ZERO TO IOCTL-FUNCTION.
023600 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
023700 MOVE 1 TO BIN.
023800 MOVE 1 TO IOCTL-FUNCTION.
023900 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
024000************************************************************************
024100* HIERNA HET GECREEERDE GEDEELTE VAN DE SCHERM PROCEDURE *
024200* DIVISION INCOPIEREN *
024300******************************************************************
024400 DISPLAY START-AANSTURING-SCHERM MAAK-SCHERM-SCHOON
024500 WITH NO ADVANCING.
024600 DISPLAY SC-SCHERMNAAM WITH NO ADVANCING.
024700 RUBRIEK-FILENAME.
024800 MOVE 05 TO REGEL.
024900 MOVE 11 TO KOLOM.
025000 DISPLAY START-AANSTURING-SCHERM
025100 ZET-CURSOR WITH NO ADVANCING.
025200 ACCEPT FILENAME.
025300 MOVE FILENAME TO FILE-NAME.
025400 IF FIELD-TERMINATOR = 27
025500 GO TO 9999.
025600 CALL 'DOS-GET-FILE-MODE' USING FILE-NAME FILE-ATTR.
025700 IF RETURN-CODE NOT = ZERO
025800 IF RETURN-CODE = 3
025900 MOVE 'PATH NOT FOUND' TO FOUTBOODSCHAP
026000 ELSE
026100 IF RETURN-CODE = 5
026200 MOVE 'ACCESS DENIED' TO FOUTBOODSCHAP
026300 ELSE
026400 MOVE 'UNDOCUMENTED ERROR' TO FOUTBOODSCHAP
026500 END-IF
026600 MOVE 19 TO REGEL
026700 MOVE 01 TO KOLOM
026800 DISPLAY START-AANSTURING-SCHERM
026900 ZET-CURSOR WITH NO ADVANCING
027000 DISPLAY FOUTBOODSCHAP WITH NO ADVANCING
027100 GO TO RUBRIEK-FILENAME.
027200 MOVE SPACE TO FOUTBOODSCHAP.
027300 MOVE 19 TO REGEL.
027400 MOVE 01 TO KOLOM.
027500 DISPLAY START-AANSTURING-SCHERM
027600 ZET-CURSOR WITH NO ADVANCING.
027700 DISPLAY FOUTBOODSCHAP WITH NO ADVANCING.
027800 RUBRIEK-FILEATTRIBUTES-OLD.
027900 PERFORM VARYING SUB-BIT FROM 1 BY 1 UNTIL SUB-BIT > 8
028000 DIVIDE FILE-ATTR BY 2 GIVING FILE-ATTR REMAINDER
028100 BIT (SUB-BIT)
028200 END-PERFORM
028300 MOVE 13 TO REGEL.
028400 MOVE 13 TO KOLOM.
028500 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
028600 MOVE BIT (1) TO READ-ONLY-OLD READ-ONLY-NEW.
028700 DISPLAY READ-ONLY-OLD WITH NO ADVANCING.
028800
028900 MOVE 13 TO REGEL.
029000 MOVE 24 TO KOLOM.
029100 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
029200 MOVE BIT (2) TO HIDDEN-FILE-OLD HIDDEN-FILE-NEW.
029300 DISPLAY HIDDEN-FILE-OLD WITH NO ADVANCING.
029400
029500 MOVE 13 TO REGEL.
029600 MOVE 33 TO KOLOM.
029700 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
029800 MOVE BIT (3) TO SYSTEM-FILE-OLD SYSTEM-FILE-NEW.
029900 DISPLAY SYSTEM-FILE-OLD WITH NO ADVANCING.
030000
030100 MOVE 13 TO REGEL.
030200 MOVE 45 TO KOLOM.
030300 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
030400 MOVE BIT (4) TO VOLUME-LABEL-OLD.
030500 DISPLAY VOLUME-LABEL-OLD WITH NO ADVANCING.
030600
030700 MOVE 13 TO REGEL.
030800 MOVE 60 TO KOLOM.
030900 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
031000 MOVE BIT (5) TO SUB-DIRECTORY-OLD.
031100 DISPLAY SUB-DIRECTORY-OLD WITH NO ADVANCING.
031200
031300 MOVE 13 TO REGEL.
031400 MOVE 74 TO KOLOM.
031500 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
031600 MOVE BIT (6) TO ARCHIVE-FLAG-OLD ARCHIVE-FLAG-NEW.
031700 DISPLAY ARCHIVE-FLAG-OLD WITH NO ADVANCING.
031800
031900 RUBRIEK-FILEATTRIBUTES-NEW.
032000 MOVE 15 TO REGEL.
032100 MOVE 13 TO KOLOM.
032200 DISPLAY START-AANSTURING-SCHERM
032300 ZET-CURSOR WITH NO ADVANCING.
032400 DISPLAY READ-ONLY-NEW WITH NO ADVANCING.
032500 MOVE 15 TO REGEL.
032600 MOVE 24 TO KOLOM.
032700 DISPLAY START-AANSTURING-SCHERM
032800 ZET-CURSOR WITH NO ADVANCING.
032900 DISPLAY HIDDEN-FILE-NEW WITH NO ADVANCING.
033000 MOVE 15 TO REGEL.
033100 MOVE 33 TO KOLOM.
033200 DISPLAY START-AANSTURING-SCHERM
033300 ZET-CURSOR WITH NO ADVANCING.
033400 DISPLAY SYSTEM-FILE-NEW WITH NO ADVANCING.
033500 MOVE 15 TO REGEL.
033600 MOVE 74 TO KOLOM.
033700 DISPLAY START-AANSTURING-SCHERM
033800 ZET-CURSOR WITH NO ADVANCING.
033900 DISPLAY ARCHIVE-FLAG-NEW WITH NO ADVANCING.
034000
034100
034200 RUB-01.
034300 MOVE 15 TO REGEL.
034400 MOVE 13 TO KOLOM.
034500 DISPLAY START-AANSTURING-SCHERM
034600 ZET-CURSOR WITH NO ADVANCING.
034700 ACCEPT READ-ONLY-NEW.
034800 IF READ-ONLY-NEW NOT = ZERO AND NOT = '1'
034900 GO TO RUB-01.
035000
035100
035200 RUB-02.
035300 MOVE 15 TO REGEL.
035400 MOVE 24 TO KOLOM.
035500 DISPLAY START-AANSTURING-SCHERM
035600 ZET-CURSOR WITH NO ADVANCING.
035700 ACCEPT HIDDEN-FILE-NEW.
035800 IF HIDDEN-FILE-NEW NOT = ZERO AND NOT = '1'
035900 GO TO RUB-02.
036000
036100
036200 RUB-03.
036300 MOVE 15 TO REGEL.
036400 MOVE 33 TO KOLOM.
036500 DISPLAY START-AANSTURING-SCHERM
036600 ZET-CURSOR WITH NO ADVANCING.
036700 ACCEPT SYSTEM-FILE-NEW.
036800 IF SYSTEM-FILE-NEW NOT = ZERO AND NOT = '1'
036900 GO TO RUB-03.
037000
037100
037200 RUB-06.
037300 MOVE 15 TO REGEL.
037400 MOVE 74 TO KOLOM.
037500 DISPLAY START-AANSTURING-SCHERM
037600 ZET-CURSOR WITH NO ADVANCING.
037700 ACCEPT ARCHIVE-FLAG-NEW.
037800 IF ARCHIVE-FLAG-NEW NOT = ZERO AND NOT = '1'
037900 GO TO RUB-06.
038000
038100
038200 MOVE READ-ONLY-NEW TO BIT (1).
038300 MOVE HIDDEN-FILE-NEW TO BIT (2).
038400 MOVE SYSTEM-FILE-NEW TO BIT (3).
038500 MOVE ZERO TO BIT (4) BIT (5).
038600 MOVE ARCHIVE-FLAG-NEW TO BIT (6).
038700 MOVE ZERO TO FILE-ATTR.
038800 PERFORM VARYING SUB-BIT FROM 1 BY 1 UNTIL SUB-BIT > 8
038900 COMPUTE FILE-ATTR = FILE-ATTR +
039000 BIT (SUB-BIT) * 2 ** (SUB-BIT - 1)
039100 END-PERFORM.
039200 CALL 'DOS-SET-FILE-MODE' USING FILE-NAME FILE-ATTR.
039300 IF RETURN-CODE NOT = ZERO
039400 IF RETURN-CODE = 3
039500 MOVE 'PATH NOT FOUND' TO FOUTBOODSCHAP
039600 ELSE
039700 IF RETURN-CODE = 5
039800 MOVE 'ACCESS DENIED' TO FOUTBOODSCHAP
039900 ELSE
040000 MOVE 'UNDOCUMENTED ERROR' TO FOUTBOODSCHAP
040100 END-IF
040200 END-IF
040300 ELSE
040400 MOVE 'FILE MODE SET ' TO FOUTBOODSCHAP.
040500 MOVE 19 TO REGEL.
040600 MOVE 01 TO KOLOM
040700 DISPLAY START-AANSTURING-SCHERM
040800 ZET-CURSOR WITH NO ADVANCING.
040900 DISPLAY FOUTBOODSCHAP WITH NO ADVANCING.
041000 GO TO RUBRIEK-FILENAME.
041100
041200 9999.
041300********************************************* MAKE NORMAL **************
041400 MOVE 1 TO FILE-HANDLE.
041500 MOVE ZERO TO IOCTL-FUNCTION.
041600 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
041700 MOVE 0 TO BIN.
041800 MOVE 1 TO IOCTL-FUNCTION.
041900 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
042000************************************************************************
042100 DISPLAY START-AANSTURING-SCHERM MAAK-SCHERM-SCHOON
042200 WITH NO ADVANCING.
042300 DISPLAY '*** BEDANKT ! ***'.
042400 STOP RUN.
It is written in CA-REALIA COBOL, probably version 3.1 or so.
000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. FILEMODE.
000300 ENVIRONMENT DIVISION.
000400 CONFIGURATION SECTION.
000500 SOURCE-COMPUTER. IBM-PC.
000600 OBJECT-COMPUTER. IBM-PC.
000700 INPUT-OUTPUT SECTION.
000800 FILE-CONTROL.
000900 DATA DIVISION.
001000 FILE SECTION.
001100 WORKING-STORAGE SECTION.
001200 01 FILE-NAME PIC X(79).
001300 01 FILE-ATTR PIC S9(4) COMP-5.
001400 01 SUB-BIT PIC S9(4) COMP-5.
001500 01 BITJES.
001600 03 BIT OCCURS 8 PIC 9.
001700 01 START-AANSTURING-SCHERM.
001800* 256 * 27 + 91 = ESC + [
001900 03 FILLER PIC 9(4) COMP-4 VALUE 7003.
002000
002100 01 ZET-CURSOR.
002200 03 REGEL PIC 99.
002300 03 FILLER PIC X VALUE ';'.
002400 03 KOLOM PIC 99.
002500 03 FILLER PIC X VALUE 'H'.
002600
002700 01 SCHERMSTUURTEKENS.
002800 03 SET-MODE-START PIC X VALUE '='.
002900 03 SET-SCHERM-TYPE PIC X.
003000******************************************************************
003100* PARAMETERS VOOR HET AANSTUREN VAN DE SCHERM MODE ONDER ANSI.SYS
003200* *
003300* 0 40X25 MONOCHROME TEXT MODE *
003400* 1 40X25 COLOR TEXT MODE *
003500* 2 80X25 MONOCHROME TEXT MODE *
003600* 3 80X25 COLOR TEXT MODE *
003700* 4 320 X 200 COLOR GRAPHICS MODE *
003800* 5 320 X 200 MONOCHROME GRAPHICS MODE *
003900* 6 640 X 200 MONOCHROME GRAPHICS MODE *
004000* 7 AUTOWRAP MODE ON (= DEFAULT: LOOPT DUS OVER REGEL HEEN) *
004100* *
004200******************************************************************
004300 03 SET-MODE-EINDE PIC X VALUE 'h'.
004400
004500 01 ZET-ATTRIBUTES.
004600***SLECHTS 1 VAN ONDERSTAANDE ATTRIBUTES PER KEER SELEKTEREN ! ***
004700***OF CUMULEREN MET BEHULP VAN EEN ; ***
004800* *
004900* 03 ZA-ATTRIBUTES-UIT PIC X VALUE '0'. *
005000* 03 ZA-HIGH-INTENSITY PIC X VALUE '1'. *
005100* 03 ZA-UNDERSCORE PIC X VALUE '4'. *
005200* 03 ZA-BLINK PIC X VALUE '5'. *
005300* 03 ZA-REVERSE-VIDIO PIC X VALUE '7'. *
005400* 03 ZA-CANCELED-ONZICHTBAAR PIC X VALUE '8'. *
005500* 03 ZA-BLACK-FOREGROUND PIC XX VALUE '30'. *
005600* 03 ZA-RED-FOREGROUND PIC XX VALUE '31'. *
005700* 03 ZA-GREEN-FOREGROUND PIC XX VALUE '32'. *
005800* 03 ZA-YELLOW-FOREGROUND PIC XX VALUE '33'. *
005900* 03 ZA-BLUE-FOREGROUND PIC XX VALUE '34'. *
006000* 03 ZA-MAGENTA-FOREGROUND PIC XX VALUE '35'. *
006100* 03 ZA-CYAN-FOREGROUND PIC XX VALUE '36'. *
006200* 03 ZA-WHITE-FOREGROUND PIC XX VALUE '37'. *
006300* 03 ZA-BLACK-BACKGROUND PIC XX VALUE '40'. *
006400* 03 ZA-RED-BACKGROUND PIC XX VALUE '41'. *
006500* 03 ZA-GREEN-BACKGROUND PIC XX VALUE '42'. *
006600* 03 ZA-YELLOW-BACKGROUND PIC XX VALUE '43'. *
006700* 03 ZA-BLUE-BACKGROUND PIC XX VALUE '44'. *
006800* 03 ZA-MAGENTA-BACKGROUND PIC XX VALUE '45'. *
006900* 03 ZA-CYAND-BACKGROUND PIC XX VALUE '46'. *
007000* 03 ZA-WHITE-BACKGROUND PIC XX VALUE '47'. *
007100******************************************************************
007200 03 FILLER PIC X VALUE 'm'.
007300
007400 01 RESET-ALL-ATTRIBUTES PIC XXX VALUE '00m'.
007500 01 MAAK-SCHERM-SCHOON PIC XX VALUE '2J'.
007600 01 MAAK-REGEL-LEEG PIC X VALUE 'K'.
007700 01 ZET-AUTOWRAP-MODE-OFF PIC X(3) VALUE '=7I'.
007800 01 ZET-80-BY-25 PIC X(3) VALUE '=2I'.
007900 01 ZET-AUTOWRAP-MODE-ON PIC X(3) VALUE '=7h'.
008000
008100
008200******************************************************************
008300* ACCEPT CONTROL OPTIES *
008400******************************************************************
008500 01 ACCEPT-PARMS.
008600 03 ACCEPT-AUTO-ENTER PIC X VALUE 'Y'.
008700 03 ACCEPT-TEST-EMPTY PIC X VALUE 'N'.
008800 03 ACCEPT-FILL-REQUIRED PIC X VALUE 'N'.
008900 03 ACCEPT-ENTRY-REQUIRED PIC X VALUE 'N'.
009000 03 ACCEPT-NO-ENTER-ECHO PIC X VALUE 'N'.
009100 03 FILLER PIC X(8) VALUE SPACE.
009200
009300********************* OVERDRACHT DOS IO CONTROL ROUTINE ****************
009400 01 IOCTL-CONTROL.
009500 03 FILE-HANDLE PIC S9(4) COMP-5.
009600 03 IOCTL-FUNCTION PIC S9(4) COMP-5.
009700 03 IOCTL-DRIVE-ID PIC X.
009800 03 IOCTL-DEVICE-INFO PIC 9(16).
009900 03 FILLER REDEFINES IOCTL-DEVICE-INFO.
010000 05 FILLER PIC 9.
010100 05 CTRL PIC 9.
010200 05 FILLER PIC 9(6).
010300 05 ISDEV PIC 9.
010400 05 EOF PIC 9.
010500 05 RAW PIC 9.
010600 05 BIN REDEFINES RAW PIC 9.
010700 05 FILLER PIC 9.
010800 05 ISCLK PIC 9.
010900 05 ISNUL PIC 9.
011000 05 ISCOT PIC 9.
011100 05 ISCIN PIC 9.
011200 03 IOCTL-STATUS PIC S9(4) COMP-5.
011300 03 IOCTL-COUNT PIC S9(4) COMP-5.
011400 03 IOCTL-BUFFER PIC X(001).
011500
011600******************************************************************
011700* HIERNA HET GECREEERDE GEDEELTE VAN DE SCHERM WORKING-STORAGE *
011800* SECTION INCOPIEREN *
011900******************************************************************
012000 01 SC-SCHERMNAAM.
012100 02 SC-01 VALUE
012200 'filemode programma
012300- ' '.
012400 03 FILLER PIC X(80).
012500 02 SC-02 VALUE
012600 '
012700- ' '.
012800 03 FILLER PIC X(80).
012900 02 SC-03 VALUE
013000 '
013100- ' '.
013200 03 FILLER PIC X(80).
013300 02 SC-04 VALUE
013400 '
013500- ' '.
013600 03 FILLER PIC X(80).
013700 02 SC-05 VALUE
013800 'filenaam:
013900- ' '.
014000 03 FILLER PIC X(10).
014100 03 FILENAME PIC X(69).
014200 03 FILLER PIC X(01).
014300 02 SC-06 VALUE
014400 '
014500- ' '.
014600 03 FILLER PIC X(80).
014700 02 SC-07 VALUE
014800 '
014900- ' 1=AKTIEF, 0=NIET AKTIEF '.
015000 03 FILLER PIC X(80).
015100 02 SC-08 VALUE
015200 ' ATTRIBUTEN:
015300- ' '.
015400 03 FILLER PIC X(80).
015500 02 SC-09 VALUE
015600 '
015700- ' '.
015800 03 FILLER PIC X(80).
015900 02 SC-10 VALUE
016000 '
016100- ' '.
016200 03 FILLER PIC X(80).
016300 02 SC-11 VALUE
016400 ' read/only hidden system vo
016500- 'lume label sub directory archief vlag '.
016600 03 FILLER PIC X(80).
016700 02 SC-12 VALUE
016800 '
016900- ' '.
017000 03 FILLER PIC X(80).
017100 02 SC-13 VALUE
017200 ' oud:
017300- ' '.
017400 03 FILLER PIC X(12).
017500 03 READ-ONLY-OLD PIC 9(01).
017600 03 FILLER PIC X(10).
017700 03 HIDDEN-FILE-OLD PIC 9(01).
017800 03 FILLER PIC X(08).
017900 03 SYSTEM-FILE-OLD PIC 9(01).
018000 03 FILLER PIC X(11).
018100 03 VOLUME-LABEL-OLD PIC 9(01).
018200 03 FILLER PIC X(14).
018300 03 SUB-DIRECTORY-OLD PIC 9(01).
018400 03 FILLER PIC X(13).
018500 03 ARCHIVE-FLAG-OLD PIC 9(01).
018600 03 FILLER PIC X(06).
018700 02 SC-14 VALUE
018800 '
018900- ' '.
019000 03 FILLER PIC X(80).
019100 02 SC-15 VALUE
019200 'nieuw:
019300- ' - - '.
019400 03 FILLER PIC X(12).
019500 03 READ-ONLY-NEW PIC 9(01).
019600 03 FILLER PIC X(10).
019700 03 HIDDEN-FILE-NEW PIC 9(01).
019800 03 FILLER PIC X(08).
019900 03 SYSTEM-FILE-NEW PIC 9(01).
020000 03 FILLER PIC X(11).
020100 03 VOLUME-LABEL-NEW PIC 9(01).
020200 03 FILLER PIC X(14).
020300 03 SUB-DIRECTORY-NEW PIC 9(01).
020400 03 FILLER PIC X(13).
020500 03 ARCHIVE-FLAG-NEW PIC 9(01).
020600 03 FILLER PIC X(06).
020700 02 SC-16 VALUE
020800 '
020900- ' '.
021000 03 FILLER PIC X(80).
021100 02 SC-17 VALUE
021200 '
021300- ' '.
021400 03 FILLER PIC X(80).
021500 02 SC-18 VALUE
021600 '
021700- ' '.
021800 03 FILLER PIC X(80).
021900 02 FOUTBOODSCHAP VALUE
022000 '
022100- ' EINDE=<ESC>'.
022200 03 RUBR-14 PIC X(69).
022300 03 FILLER PIC X(11).
022400 PROCEDURE DIVISION.
022500 0001.
022600 CALL 'ACCEPT-CONTROL' USING ACCEPT-PARMS.
022700******************************************************************
022800* *
022900* *
023000* VERHOGING SNELHEID DISPLAY DOOR DEFINITIE VAN *
023100* BINAIR SCHERM. *
023200* *
023300********************************************* MAKE FAST *********
023400 MOVE 1 TO FILE-HANDLE.
023500 MOVE ZERO TO IOCTL-FUNCTION.
023600 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
023700 MOVE 1 TO BIN.
023800 MOVE 1 TO IOCTL-FUNCTION.
023900 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
024000************************************************************************
024100* HIERNA HET GECREEERDE GEDEELTE VAN DE SCHERM PROCEDURE *
024200* DIVISION INCOPIEREN *
024300******************************************************************
024400 DISPLAY START-AANSTURING-SCHERM MAAK-SCHERM-SCHOON
024500 WITH NO ADVANCING.
024600 DISPLAY SC-SCHERMNAAM WITH NO ADVANCING.
024700 RUBRIEK-FILENAME.
024800 MOVE 05 TO REGEL.
024900 MOVE 11 TO KOLOM.
025000 DISPLAY START-AANSTURING-SCHERM
025100 ZET-CURSOR WITH NO ADVANCING.
025200 ACCEPT FILENAME.
025300 MOVE FILENAME TO FILE-NAME.
025400 IF FIELD-TERMINATOR = 27
025500 GO TO 9999.
025600 CALL 'DOS-GET-FILE-MODE' USING FILE-NAME FILE-ATTR.
025700 IF RETURN-CODE NOT = ZERO
025800 IF RETURN-CODE = 3
025900 MOVE 'PATH NOT FOUND' TO FOUTBOODSCHAP
026000 ELSE
026100 IF RETURN-CODE = 5
026200 MOVE 'ACCESS DENIED' TO FOUTBOODSCHAP
026300 ELSE
026400 MOVE 'UNDOCUMENTED ERROR' TO FOUTBOODSCHAP
026500 END-IF
026600 MOVE 19 TO REGEL
026700 MOVE 01 TO KOLOM
026800 DISPLAY START-AANSTURING-SCHERM
026900 ZET-CURSOR WITH NO ADVANCING
027000 DISPLAY FOUTBOODSCHAP WITH NO ADVANCING
027100 GO TO RUBRIEK-FILENAME.
027200 MOVE SPACE TO FOUTBOODSCHAP.
027300 MOVE 19 TO REGEL.
027400 MOVE 01 TO KOLOM.
027500 DISPLAY START-AANSTURING-SCHERM
027600 ZET-CURSOR WITH NO ADVANCING.
027700 DISPLAY FOUTBOODSCHAP WITH NO ADVANCING.
027800 RUBRIEK-FILEATTRIBUTES-OLD.
027900 PERFORM VARYING SUB-BIT FROM 1 BY 1 UNTIL SUB-BIT > 8
028000 DIVIDE FILE-ATTR BY 2 GIVING FILE-ATTR REMAINDER
028100 BIT (SUB-BIT)
028200 END-PERFORM
028300 MOVE 13 TO REGEL.
028400 MOVE 13 TO KOLOM.
028500 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
028600 MOVE BIT (1) TO READ-ONLY-OLD READ-ONLY-NEW.
028700 DISPLAY READ-ONLY-OLD WITH NO ADVANCING.
028800
028900 MOVE 13 TO REGEL.
029000 MOVE 24 TO KOLOM.
029100 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
029200 MOVE BIT (2) TO HIDDEN-FILE-OLD HIDDEN-FILE-NEW.
029300 DISPLAY HIDDEN-FILE-OLD WITH NO ADVANCING.
029400
029500 MOVE 13 TO REGEL.
029600 MOVE 33 TO KOLOM.
029700 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
029800 MOVE BIT (3) TO SYSTEM-FILE-OLD SYSTEM-FILE-NEW.
029900 DISPLAY SYSTEM-FILE-OLD WITH NO ADVANCING.
030000
030100 MOVE 13 TO REGEL.
030200 MOVE 45 TO KOLOM.
030300 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
030400 MOVE BIT (4) TO VOLUME-LABEL-OLD.
030500 DISPLAY VOLUME-LABEL-OLD WITH NO ADVANCING.
030600
030700 MOVE 13 TO REGEL.
030800 MOVE 60 TO KOLOM.
030900 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
031000 MOVE BIT (5) TO SUB-DIRECTORY-OLD.
031100 DISPLAY SUB-DIRECTORY-OLD WITH NO ADVANCING.
031200
031300 MOVE 13 TO REGEL.
031400 MOVE 74 TO KOLOM.
031500 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
031600 MOVE BIT (6) TO ARCHIVE-FLAG-OLD ARCHIVE-FLAG-NEW.
031700 DISPLAY ARCHIVE-FLAG-OLD WITH NO ADVANCING.
031800
031900 RUBRIEK-FILEATTRIBUTES-NEW.
032000 MOVE 15 TO REGEL.
032100 MOVE 13 TO KOLOM.
032200 DISPLAY START-AANSTURING-SCHERM
032300 ZET-CURSOR WITH NO ADVANCING.
032400 DISPLAY READ-ONLY-NEW WITH NO ADVANCING.
032500 MOVE 15 TO REGEL.
032600 MOVE 24 TO KOLOM.
032700 DISPLAY START-AANSTURING-SCHERM
032800 ZET-CURSOR WITH NO ADVANCING.
032900 DISPLAY HIDDEN-FILE-NEW WITH NO ADVANCING.
033000 MOVE 15 TO REGEL.
033100 MOVE 33 TO KOLOM.
033200 DISPLAY START-AANSTURING-SCHERM
033300 ZET-CURSOR WITH NO ADVANCING.
033400 DISPLAY SYSTEM-FILE-NEW WITH NO ADVANCING.
033500 MOVE 15 TO REGEL.
033600 MOVE 74 TO KOLOM.
033700 DISPLAY START-AANSTURING-SCHERM
033800 ZET-CURSOR WITH NO ADVANCING.
033900 DISPLAY ARCHIVE-FLAG-NEW WITH NO ADVANCING.
034000
034100
034200 RUB-01.
034300 MOVE 15 TO REGEL.
034400 MOVE 13 TO KOLOM.
034500 DISPLAY START-AANSTURING-SCHERM
034600 ZET-CURSOR WITH NO ADVANCING.
034700 ACCEPT READ-ONLY-NEW.
034800 IF READ-ONLY-NEW NOT = ZERO AND NOT = '1'
034900 GO TO RUB-01.
035000
035100
035200 RUB-02.
035300 MOVE 15 TO REGEL.
035400 MOVE 24 TO KOLOM.
035500 DISPLAY START-AANSTURING-SCHERM
035600 ZET-CURSOR WITH NO ADVANCING.
035700 ACCEPT HIDDEN-FILE-NEW.
035800 IF HIDDEN-FILE-NEW NOT = ZERO AND NOT = '1'
035900 GO TO RUB-02.
036000
036100
036200 RUB-03.
036300 MOVE 15 TO REGEL.
036400 MOVE 33 TO KOLOM.
036500 DISPLAY START-AANSTURING-SCHERM
036600 ZET-CURSOR WITH NO ADVANCING.
036700 ACCEPT SYSTEM-FILE-NEW.
036800 IF SYSTEM-FILE-NEW NOT = ZERO AND NOT = '1'
036900 GO TO RUB-03.
037000
037100
037200 RUB-06.
037300 MOVE 15 TO REGEL.
037400 MOVE 74 TO KOLOM.
037500 DISPLAY START-AANSTURING-SCHERM
037600 ZET-CURSOR WITH NO ADVANCING.
037700 ACCEPT ARCHIVE-FLAG-NEW.
037800 IF ARCHIVE-FLAG-NEW NOT = ZERO AND NOT = '1'
037900 GO TO RUB-06.
038000
038100
038200 MOVE READ-ONLY-NEW TO BIT (1).
038300 MOVE HIDDEN-FILE-NEW TO BIT (2).
038400 MOVE SYSTEM-FILE-NEW TO BIT (3).
038500 MOVE ZERO TO BIT (4) BIT (5).
038600 MOVE ARCHIVE-FLAG-NEW TO BIT (6).
038700 MOVE ZERO TO FILE-ATTR.
038800 PERFORM VARYING SUB-BIT FROM 1 BY 1 UNTIL SUB-BIT > 8
038900 COMPUTE FILE-ATTR = FILE-ATTR +
039000 BIT (SUB-BIT) * 2 ** (SUB-BIT - 1)
039100 END-PERFORM.
039200 CALL 'DOS-SET-FILE-MODE' USING FILE-NAME FILE-ATTR.
039300 IF RETURN-CODE NOT = ZERO
039400 IF RETURN-CODE = 3
039500 MOVE 'PATH NOT FOUND' TO FOUTBOODSCHAP
039600 ELSE
039700 IF RETURN-CODE = 5
039800 MOVE 'ACCESS DENIED' TO FOUTBOODSCHAP
039900 ELSE
040000 MOVE 'UNDOCUMENTED ERROR' TO FOUTBOODSCHAP
040100 END-IF
040200 END-IF
040300 ELSE
040400 MOVE 'FILE MODE SET ' TO FOUTBOODSCHAP.
040500 MOVE 19 TO REGEL.
040600 MOVE 01 TO KOLOM
040700 DISPLAY START-AANSTURING-SCHERM
040800 ZET-CURSOR WITH NO ADVANCING.
040900 DISPLAY FOUTBOODSCHAP WITH NO ADVANCING.
041000 GO TO RUBRIEK-FILENAME.
041100
041200 9999.
041300********************************************* MAKE NORMAL **************
041400 MOVE 1 TO FILE-HANDLE.
041500 MOVE ZERO TO IOCTL-FUNCTION.
041600 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
041700 MOVE 0 TO BIN.
041800 MOVE 1 TO IOCTL-FUNCTION.
041900 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
042000************************************************************************
042100 DISPLAY START-AANSTURING-SCHERM MAAK-SCHERM-SCHOON
042200 WITH NO ADVANCING.
042300 DISPLAY '*** BEDANKT ! ***'.
042400 STOP RUN.
019200 'nieuw:
019300- ' - - '.
019400 03 FILLER PIC X(12).
019500 03 READ-ONLY-NEW PIC 9(01).
019600 03 FILLER PIC X(10).
019700 03 HIDDEN-FILE-NEW PIC 9(01).
019800 03 FILLER PIC X(08).
019900 03 SYSTEM-FILE-NEW PIC 9(01).
020000 03 FILLER PIC X(11).
020100 03 VOLUME-LABEL-NEW PIC 9(01).
020200 03 FILLER PIC X(14).
020300 03 SUB-DIRECTORY-NEW PIC 9(01).
020400 03 FILLER PIC X(13).
020500 03 ARCHIVE-FLAG-NEW PIC 9(01).
020600 03 FILLER PIC X(06).
020700 02 SC-16 VALUE
020800 '
020900- ' '.
021000 03 FILLER PIC X(80).
021100 02 SC-17 VALUE
021200 '
021300- ' '.
021400 03 FILLER PIC X(80).
021500 02 SC-18 VALUE
021600 '
021700- ' '.
021800 03 FILLER PIC X(80).
021900 02 FOUTBOODSCHAP VALUE
022000 '
022100- ' EINDE=<ESC>'.
022200 03 RUBR-14 PIC X(69).
022300 03 FILLER PIC X(11).
022400 PROCEDURE DIVISION.
022500 0001.
022600 CALL 'ACCEPT-CONTROL' USING ACCEPT-PARMS.
022700******************************************************************
022800* *
022900* *
023000* VERHOGING SNELHEID DISPLAY DOOR DEFINITIE VAN *
023100* BINAIR SCHERM. *
023200* *
023300********************************************* MAKE FAST *********
023400 MOVE 1 TO FILE-HANDLE.
023500 MOVE ZERO TO IOCTL-FUNCTION.
023600 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
023700 MOVE 1 TO BIN.
023800 MOVE 1 TO IOCTL-FUNCTION.
023900 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
024000************************************************************************
024100* HIERNA HET GECREEERDE GEDEELTE VAN DE SCHERM PROCEDURE *
024200* DIVISION INCOPIEREN *
024300******************************************************************
024400 DISPLAY START-AANSTURING-SCHERM MAAK-SCHERM-SCHOON
024500 WITH NO ADVANCING.
024600 DISPLAY SC-SCHERMNAAM WITH NO ADVANCING.
024700 RUBRIEK-FILENAME.
024800 MOVE 05 TO REGEL.
024900 MOVE 11 TO KOLOM.
025000 DISPLAY START-AANSTURING-SCHERM
025100 ZET-CURSOR WITH NO ADVANCING.
025200 ACCEPT FILENAME.
025300 MOVE FILENAME TO FILE-NAME.
025400 IF FIELD-TERMINATOR = 27
025500 GO TO 9999.
025600 CALL 'DOS-GET-FILE-MODE' USING FILE-NAME FILE-ATTR.
025700 IF RETURN-CODE NOT = ZERO
025800 IF RETURN-CODE = 3
025900 MOVE 'PATH NOT FOUND' TO FOUTBOODSCHAP
026000 ELSE
026100 IF RETURN-CODE = 5
026200 MOVE 'ACCESS DENIED' TO FOUTBOODSCHAP
026300 ELSE
026400 MOVE 'UNDOCUMENTED ERROR' TO FOUTBOODSCHAP
026500 END-IF
026600 MOVE 19 TO REGEL
026700 MOVE 01 TO KOLOM
026800 DISPLAY START-AANSTURING-SCHERM
026900 ZET-CURSOR WITH NO ADVANCING
027000 DISPLAY FOUTBOODSCHAP WITH NO ADVANCING
027100 GO TO RUBRIEK-FILENAME.
027200 MOVE SPACE TO FOUTBOODSCHAP.
027300 MOVE 19 TO REGEL.
027400 MOVE 01 TO KOLOM.
027500 DISPLAY START-AANSTURING-SCHERM
027600 ZET-CURSOR WITH NO ADVANCING.
027700 DISPLAY FOUTBOODSCHAP WITH NO ADVANCING.
027800 RUBRIEK-FILEATTRIBUTES-OLD.
027900 PERFORM VARYING SUB-BIT FROM 1 BY 1 UNTIL SUB-BIT > 8
028000 DIVIDE FILE-ATTR BY 2 GIVING FILE-ATTR REMAINDER
028100 BIT (SUB-BIT)
028200 END-PERFORM
028300 MOVE 13 TO REGEL.
028400 MOVE 13 TO KOLOM.
028500 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
028600 MOVE BIT (1) TO READ-ONLY-OLD READ-ONLY-NEW.
028700 DISPLAY READ-ONLY-OLD WITH NO ADVANCING.
028800
028900 MOVE 13 TO REGEL.
029000 MOVE 24 TO KOLOM.
029100 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
029200 MOVE BIT (2) TO HIDDEN-FILE-OLD HIDDEN-FILE-NEW.
029300 DISPLAY HIDDEN-FILE-OLD WITH NO ADVANCING.
029400
029500 MOVE 13 TO REGEL.
029600 MOVE 33 TO KOLOM.
029700 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
029800 MOVE BIT (3) TO SYSTEM-FILE-OLD SYSTEM-FILE-NEW.
029900 DISPLAY SYSTEM-FILE-OLD WITH NO ADVANCING.
030000
030100 MOVE 13 TO REGEL.
030200 MOVE 45 TO KOLOM.
030300 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
030400 MOVE BIT (4) TO VOLUME-LABEL-OLD.
030500 DISPLAY VOLUME-LABEL-OLD WITH NO ADVANCING.
030600
030700 MOVE 13 TO REGEL.
030800 MOVE 60 TO KOLOM.
030900 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
031000 MOVE BIT (5) TO SUB-DIRECTORY-OLD.
031100 DISPLAY SUB-DIRECTORY-OLD WITH NO ADVANCING.
031200
031300 MOVE 13 TO REGEL.
031400 MOVE 74 TO KOLOM.
031500 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
031600 MOVE BIT (6) TO ARCHIVE-FLAG-OLD ARCHIVE-FLAG-NEW.
031700 DISPLAY ARCHIVE-FLAG-OLD WITH NO ADVANCING.
031800
031900 RUBRIEK-FILEATTRIBUTES-NEW.
032000 MOVE 15 TO REGEL.
032100 MOVE 13 TO KOLOM.
032200 DISPLAY START-AANSTURING-SCHERM
032300 ZET-CURSOR WITH NO ADVANCING.
032400 DISPLAY READ-ONLY-NEW WITH NO ADVANCING.
032500 MOVE 15 TO REGEL.
032600 MOVE 24 TO KOLOM.
032700 DISPLAY START-AANSTURING-SCHERM
032800 ZET-CURSOR WITH NO ADVANCING.
032900 DISPLAY HIDDEN-FILE-NEW WITH NO ADVANCING.
033000 MOVE 15 TO REGEL.
033100 MOVE 33 TO KOLOM.
033200 DISPLAY START-AANSTURING-SCHERM
033300 ZET-CURSOR WITH NO ADVANCING.
033400 DISPLAY SYSTEM-FILE-NEW WITH NO ADVANCING.
033500 MOVE 15 TO REGEL.
033600 MOVE 74 TO KOLOM.
033700 DISPLAY START-AANSTURING-SCHERM
033800 ZET-CURSOR WITH NO ADVANCING.
033900 DISPLAY ARCHIVE-FLAG-NEW WITH NO ADVANCING.
034000
034100
034200 RUB-01.
034300 MOVE 15 TO REGEL.
034400 MOVE 13 TO KOLOM.
034500 DISPLAY START-AANSTURING-SCHERM
034600 ZET-CURSOR WITH NO ADVANCING.
034700 ACCEPT READ-ONLY-NEW.
034800 IF READ-ONLY-NEW NOT = ZERO AND NOT = '1'
034900 GO TO RUB-01.
035000
035100
035200 RUB-02.
035300 MOVE 15 TO REGEL.
035400 MOVE 24 TO KOLOM.
035500 DISPLAY START-AANSTURING-SCHERM
035600 ZET-CURSOR WITH NO ADVANCING.
035700 ACCEPT HIDDEN-FILE-NEW.
035800 IF HIDDEN-FILE-NEW NOT = ZERO AND NOT = '1'
035900 GO TO RUB-02.
036000
036100
036200 RUB-03.
036300 MOVE 15 TO REGEL.
036400 MOVE 33 TO KOLOM.
036500 DISPLAY START-AANSTURING-SCHERM
036600 ZET-CURSOR WITH NO ADVANCING.
036700 ACCEPT SYSTEM-FILE-NEW.
036800 IF SYSTEM-FILE-NEW NOT = ZERO AND NOT = '1'
036900 GO TO RUB-03.
037000
037100
037200 RUB-06.
037300 MOVE 15 TO REGEL.
037400 MOVE 74 TO KOLOM.
037500 DISPLAY START-AANSTURING-SCHERM
037600 ZET-CURSOR WITH NO ADVANCING.
037700 ACCEPT ARCHIVE-FLAG-NEW.
037800 IF ARCHIVE-FLAG-NEW NOT = ZERO AND NOT = '1'
037900 GO TO RUB-06.
038000
038100
038200 MOVE READ-ONLY-NEW TO BIT (1).
038300 MOVE HIDDEN-FILE-NEW TO BIT (2).
038400 MOVE SYSTEM-FILE-NEW TO BIT (3).
038500 MOVE ZERO TO BIT (4) BIT (5).
038600 MOVE ARCHIVE-FLAG-NEW TO BIT (6).
038700 MOVE ZERO TO FILE-ATTR.
038800 PERFORM VARYING SUB-BIT FROM 1 BY 1 UNTIL SUB-BIT > 8
038900 COMPUTE FILE-ATTR = FILE-ATTR +
039000 BIT (SUB-BIT) * 2 ** (SUB-BIT - 1)
039100 END-PERFORM.
039200 CALL 'DOS-SET-FILE-MODE' USING FILE-NAME FILE-ATTR.
039300 IF RETURN-CODE NOT = ZERO
039400 IF RETURN-CODE = 3
039500 MOVE 'PATH NOT FOUND' TO FOUTBOODSCHAP
039600 ELSE
039700 IF RETURN-CODE = 5
039800 MOVE 'ACCESS DENIED' TO FOUTBOODSCHAP
039900 ELSE
040000 MOVE 'UNDOCUMENTED ERROR' TO FOUTBOODSCHAP
040100 END-IF
040200 END-IF
040300 ELSE
040400 MOVE 'FILE MODE SET ' TO FOUTBOODSCHAP.
040500 MOVE 19 TO REGEL.
040600 MOVE 01 TO KOLOM
040700 DISPLAY START-AANSTURING-SCHERM
040800 ZET-CURSOR WITH NO ADVANCING.
040900 DISPLAY FOUTBOODSCHAP WITH NO ADVANCING.
041000 GO TO RUBRIEK-FILENAME.
041100
041200 9999.
041300********************************************* MAKE NORMAL **************
041400 MOVE 1 TO FILE-HANDLE.
041500 MOVE ZERO TO IOCTL-FUNCTION.
041600 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
041700 MOVE 0 TO BIN.
041800 MOVE 1 TO IOCTL-FUNCTION.
041900 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
042000************************************************************************
042100 DISPLAY START-AANSTURING-SCHERM MAAK-SCHERM-SCHOON
042200 WITH NO ADVANCING.
042300 DISPLAY '*** BEDANKT ! ***'.
042400 STOP RUN.
019300- ' - - '.
019400 03 FILLER PIC X(12).
019500 03 READ-ONLY-NEW PIC 9(01).
019600 03 FILLER PIC X(10).
019700 03 HIDDEN-FILE-NEW PIC 9(01).
019800 03 FILLER PIC X(08).
019900 03 SYSTEM-FILE-NEW PIC 9(01).
020000 03 FILLER PIC X(11).
020100 03 VOLUME-LABEL-NEW PIC 9(01).
020200 03 FILLER PIC X(14).
020300 03 SUB-DIRECTORY-NEW PIC 9(01).
020400 03 FILLER PIC X(13).
020500 03 ARCHIVE-FLAG-NEW PIC 9(01).
020600 03 FILLER PIC X(06).
020700 02 SC-16 VALUE
020800 '
020900- ' '.
021000 03 FILLER PIC X(80).
021100 02 SC-17 VALUE
021200 '
021300- ' '.
021400 03 FILLER PIC X(80).
021500 02 SC-18 VALUE
021600 '
021700- ' '.
021800 03 FILLER PIC X(80).
021900 02 FOUTBOODSCHAP VALUE
022000 '
022100- ' EINDE=<ESC>'.
022200 03 RUBR-14 PIC X(69).
022300 03 FILLER PIC X(11).
022400 PROCEDURE DIVISION.
022500 0001.
022600 CALL 'ACCEPT-CONTROL' USING ACCEPT-PARMS.
022700******************************************************************
022800* *
022900* *
023000* VERHOGING SNELHEID DISPLAY DOOR DEFINITIE VAN *
023100* BINAIR SCHERM. *
023200* *
023300********************************************* MAKE FAST *********
023400 MOVE 1 TO FILE-HANDLE.
023500 MOVE ZERO TO IOCTL-FUNCTION.
023600 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
023700 MOVE 1 TO BIN.
023800 MOVE 1 TO IOCTL-FUNCTION.
023900 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
024000************************************************************************
024100* HIERNA HET GECREEERDE GEDEELTE VAN DE SCHERM PROCEDURE *
024200* DIVISION INCOPIEREN *
024300******************************************************************
024400 DISPLAY START-AANSTURING-SCHERM MAAK-SCHERM-SCHOON
024500 WITH NO ADVANCING.
024600 DISPLAY SC-SCHERMNAAM WITH NO ADVANCING.
024700 RUBRIEK-FILENAME.
024800 MOVE 05 TO REGEL.
024900 MOVE 11 TO KOLOM.
025000 DISPLAY START-AANSTURING-SCHERM
025100 ZET-CURSOR WITH NO ADVANCING.
025200 ACCEPT FILENAME.
025300 MOVE FILENAME TO FILE-NAME.
025400 IF FIELD-TERMINATOR = 27
025500 GO TO 9999.
025600 CALL 'DOS-GET-FILE-MODE' USING FILE-NAME FILE-ATTR.
025700 IF RETURN-CODE NOT = ZERO
025800 IF RETURN-CODE = 3
025900 MOVE 'PATH NOT FOUND' TO FOUTBOODSCHAP
026000 ELSE
026100 IF RETURN-CODE = 5
026200 MOVE 'ACCESS DENIED' TO FOUTBOODSCHAP
026300 ELSE
026400 MOVE 'UNDOCUMENTED ERROR' TO FOUTBOODSCHAP
026500 END-IF
026600 MOVE 19 TO REGEL
026700 MOVE 01 TO KOLOM
026800 DISPLAY START-AANSTURING-SCHERM
026900 ZET-CURSOR WITH NO ADVANCING
027000 DISPLAY FOUTBOODSCHAP WITH NO ADVANCING
027100 GO TO RUBRIEK-FILENAME.
027200 MOVE SPACE TO FOUTBOODSCHAP.
027300 MOVE 19 TO REGEL.
027400 MOVE 01 TO KOLOM.
027500 DISPLAY START-AANSTURING-SCHERM
027600 ZET-CURSOR WITH NO ADVANCING.
027700 DISPLAY FOUTBOODSCHAP WITH NO ADVANCING.
027800 RUBRIEK-FILEATTRIBUTES-OLD.
027900 PERFORM VARYING SUB-BIT FROM 1 BY 1 UNTIL SUB-BIT > 8
028000 DIVIDE FILE-ATTR BY 2 GIVING FILE-ATTR REMAINDER
028100 BIT (SUB-BIT)
028200 END-PERFORM
028300 MOVE 13 TO REGEL.
028400 MOVE 13 TO KOLOM.
028500 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
028600 MOVE BIT (1) TO READ-ONLY-OLD READ-ONLY-NEW.
028700 DISPLAY READ-ONLY-OLD WITH NO ADVANCING.
028800
028900 MOVE 13 TO REGEL.
029000 MOVE 24 TO KOLOM.
029100 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
029200 MOVE BIT (2) TO HIDDEN-FILE-OLD HIDDEN-FILE-NEW.
029300 DISPLAY HIDDEN-FILE-OLD WITH NO ADVANCING.
029400
029500 MOVE 13 TO REGEL.
029600 MOVE 33 TO KOLOM.
029700 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
029800 MOVE BIT (3) TO SYSTEM-FILE-OLD SYSTEM-FILE-NEW.
029900 DISPLAY SYSTEM-FILE-OLD WITH NO ADVANCING.
030000
030100 MOVE 13 TO REGEL.
030200 MOVE 45 TO KOLOM.
030300 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
030400 MOVE BIT (4) TO VOLUME-LABEL-OLD.
030500 DISPLAY VOLUME-LABEL-OLD WITH NO ADVANCING.
030600
030700 MOVE 13 TO REGEL.
030800 MOVE 60 TO KOLOM.
030900 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
031000 MOVE BIT (5) TO SUB-DIRECTORY-OLD.
031100 DISPLAY SUB-DIRECTORY-OLD WITH NO ADVANCING.
031200
031300 MOVE 13 TO REGEL.
031400 MOVE 74 TO KOLOM.
031500 DISPLAY START-AANSTURING-SCHERM ZET-CURSOR WITH NO ADVANCING.
031600 MOVE BIT (6) TO ARCHIVE-FLAG-OLD ARCHIVE-FLAG-NEW.
031700 DISPLAY ARCHIVE-FLAG-OLD WITH NO ADVANCING.
031800
031900 RUBRIEK-FILEATTRIBUTES-NEW.
032000 MOVE 15 TO REGEL.
032100 MOVE 13 TO KOLOM.
032200 DISPLAY START-AANSTURING-SCHERM
032300 ZET-CURSOR WITH NO ADVANCING.
032400 DISPLAY READ-ONLY-NEW WITH NO ADVANCING.
032500 MOVE 15 TO REGEL.
032600 MOVE 24 TO KOLOM.
032700 DISPLAY START-AANSTURING-SCHERM
032800 ZET-CURSOR WITH NO ADVANCING.
032900 DISPLAY HIDDEN-FILE-NEW WITH NO ADVANCING.
033000 MOVE 15 TO REGEL.
033100 MOVE 33 TO KOLOM.
033200 DISPLAY START-AANSTURING-SCHERM
033300 ZET-CURSOR WITH NO ADVANCING.
033400 DISPLAY SYSTEM-FILE-NEW WITH NO ADVANCING.
033500 MOVE 15 TO REGEL.
033600 MOVE 74 TO KOLOM.
033700 DISPLAY START-AANSTURING-SCHERM
033800 ZET-CURSOR WITH NO ADVANCING.
033900 DISPLAY ARCHIVE-FLAG-NEW WITH NO ADVANCING.
034000
034100
034200 RUB-01.
034300 MOVE 15 TO REGEL.
034400 MOVE 13 TO KOLOM.
034500 DISPLAY START-AANSTURING-SCHERM
034600 ZET-CURSOR WITH NO ADVANCING.
034700 ACCEPT READ-ONLY-NEW.
034800 IF READ-ONLY-NEW NOT = ZERO AND NOT = '1'
034900 GO TO RUB-01.
035000
035100
035200 RUB-02.
035300 MOVE 15 TO REGEL.
035400 MOVE 24 TO KOLOM.
035500 DISPLAY START-AANSTURING-SCHERM
035600 ZET-CURSOR WITH NO ADVANCING.
035700 ACCEPT HIDDEN-FILE-NEW.
035800 IF HIDDEN-FILE-NEW NOT = ZERO AND NOT = '1'
035900 GO TO RUB-02.
036000
036100
036200 RUB-03.
036300 MOVE 15 TO REGEL.
036400 MOVE 33 TO KOLOM.
036500 DISPLAY START-AANSTURING-SCHERM
036600 ZET-CURSOR WITH NO ADVANCING.
036700 ACCEPT SYSTEM-FILE-NEW.
036800 IF SYSTEM-FILE-NEW NOT = ZERO AND NOT = '1'
036900 GO TO RUB-03.
037000
037100
037200 RUB-06.
037300 MOVE 15 TO REGEL.
037400 MOVE 74 TO KOLOM.
037500 DISPLAY START-AANSTURING-SCHERM
037600 ZET-CURSOR WITH NO ADVANCING.
037700 ACCEPT ARCHIVE-FLAG-NEW.
037800 IF ARCHIVE-FLAG-NEW NOT = ZERO AND NOT = '1'
037900 GO TO RUB-06.
038000
038100
038200 MOVE READ-ONLY-NEW TO BIT (1).
038300 MOVE HIDDEN-FILE-NEW TO BIT (2).
038400 MOVE SYSTEM-FILE-NEW TO BIT (3).
038500 MOVE ZERO TO BIT (4) BIT (5).
038600 MOVE ARCHIVE-FLAG-NEW TO BIT (6).
038700 MOVE ZERO TO FILE-ATTR.
038800 PERFORM VARYING SUB-BIT FROM 1 BY 1 UNTIL SUB-BIT > 8
038900 COMPUTE FILE-ATTR = FILE-ATTR +
039000 BIT (SUB-BIT) * 2 ** (SUB-BIT - 1)
039100 END-PERFORM.
039200 CALL 'DOS-SET-FILE-MODE' USING FILE-NAME FILE-ATTR.
039300 IF RETURN-CODE NOT = ZERO
039400 IF RETURN-CODE = 3
039500 MOVE 'PATH NOT FOUND' TO FOUTBOODSCHAP
039600 ELSE
039700 IF RETURN-CODE = 5
039800 MOVE 'ACCESS DENIED' TO FOUTBOODSCHAP
039900 ELSE
040000 MOVE 'UNDOCUMENTED ERROR' TO FOUTBOODSCHAP
040100 END-IF
040200 END-IF
040300 ELSE
040400 MOVE 'FILE MODE SET ' TO FOUTBOODSCHAP.
040500 MOVE 19 TO REGEL.
040600 MOVE 01 TO KOLOM
040700 DISPLAY START-AANSTURING-SCHERM
040800 ZET-CURSOR WITH NO ADVANCING.
040900 DISPLAY FOUTBOODSCHAP WITH NO ADVANCING.
041000 GO TO RUBRIEK-FILENAME.
041100
041200 9999.
041300********************************************* MAKE NORMAL **************
041400 MOVE 1 TO FILE-HANDLE.
041500 MOVE ZERO TO IOCTL-FUNCTION.
041600 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
041700 MOVE 0 TO BIN.
041800 MOVE 1 TO IOCTL-FUNCTION.
041900 CALL 'DOS-IOCTL' USING IOCTL-CONTROL.
042000************************************************************************
042100 DISPLAY START-AANSTURING-SCHERM MAAK-SCHERM-SCHOON
042200 WITH NO ADVANCING.
042300 DISPLAY '*** BEDANKT ! ***'.
042400 STOP RUN.
-
1
- #9
If your system is IBM OS/390 and the runtime environment is Language Environment then you can use LE program 'CEESITST' to determine the setting of a bit in a fullword. Here is an example program that determines the setting of a bit and displays the result:
Code:
IDENTIFICATION DIVISION.
PROGRAM-ID. DEMOPGM.
DATE-COMPILED.
****************************************************************
* THIS PROGRAM DEMONSTRATES HOW TO USE LANGUAGE ENVIRONMENT *
* CALLABLE SERVICES TO DETERMINE THE SETTING OF A BIT IN *
* A BINARY FULLWORD. *
****************************************************************
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-370.
OBJECT-COMPUTER. IBM-370.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
DATA DIVISION.
FILE SECTION.
WORKING-STORAGE SECTION.
01 FEEDBACK-CODE.
05 FC-SEVERITY PIC S9(4) BINARY VALUE +0.
05 FC-MESSAGE PIC S9(4) BINARY VALUE +0.
05 FILLER PIC X(08).
01 WS-WORK-FIELDS.
05 INPUT-BINARY-FIELD PIC S9(9) BINARY VALUE +0.
05 BIT-POINTER PIC S9(9) BINARY VALUE +0.
05 RESULT-FIELD PIC S9(9) BINARY VALUE +0.
PROCEDURE DIVISION.
*****************************************************************
* DETERMINE THE VALUE IN A SPECIFIC BIT IN A FULLWORD. *
* *
* - 'BIT-POINTER'. MOVE A VALUE TO THIS FIELD TO INDICATE *
* WHICH BIT YOU WANT TO TEST. BIT '0' IS THE LOW-ORDER *
* BIT AND '31' IS THE HIGH-ORDER. *
* - 'RESULT-FIELD'. CONTAINS A VALUE OF '0' OR '1', INDICATING *
* THE VALUE OF THE BIT TO WHICH BIT-POINTER IS POINTING. *
* *
*****************************************************************
*****************************************************************
* THE FOLLOWING LOGIC DETERMINES THE SETTING OF BIT 24 *
* IN FIELD 'INPUT-BINARY-FIELD'. *
*****************************************************************
MOVE +24 TO BIT-POINTER.
MOVE +0 TO RESULT-FIELD.
CALL 'CEESITST' USING INPUT-BINARY-FIELD,
BIT-POINTER,
FEEDBACK-CODE,
RESULT-FIELD.
IF FC-SEVERITY = +0
DISPLAY 'VALUE OF BIT ' BIT-POINTER ' IS ' RESULT-FIELD
ELSE
DISPLAY 'BAD RETURN FROM CEESITST '
DISPLAY 'FEEDBACK SEVERITY = ' FC-SEVERITY
DISPLAY 'FEEDBACK MESSAGE = ' FC-MESSAGE.
GOBACK.RED1,
I didn't forget about you and I'm not ignoring you. I've beentrying to find a way to E-mail the code to you . So far, no luck. If you want to post your E-addr (not a good idea) I'll send it to you. I don't want to clutter up the board w/code.
Regards, Jack.
I didn't forget about you and I'm not ignoring you. I've beentrying to find a way to E-mail the code to you . So far, no luck. If you want to post your E-addr (not a good idea) I'll send it to you. I don't want to clutter up the board w/code.
Regards, Jack.
- Thread starter
- #11
Slade,
I just joined this forum. Is there not a way to email a reply to a particular member? If not, then if you could just include a clip from working storage showing the field definition and redefines clause? Also, the multiplication and check of the result. I don't need to see the whole program, or even the looping structure. I think I follow your logic, but some specifics would sure make it easier. Thanks!
I just joined this forum. Is there not a way to email a reply to a particular member? If not, then if you could just include a clip from working storage showing the field definition and redefines clause? Also, the multiplication and check of the result. I don't need to see the whole program, or even the looping structure. I think I follow your logic, but some specifics would sure make it easier. Thanks!
-
2
- #12
There is a good example of COBOL Bit Manipulation at the following URL... .. It uses an approach of converting the bit information in a single byte to/from an eight-byte field of COBOL accessible zeroes and ones... The COBOL source code for a demo and a callable COBOL routine are included as ZIPped files for downloading... Good Luck...
Hi red1,
This example shows how to look at the hi-order 37 bits of 6 bytes of data a bit at a time, i.e. determine if a bit is "on" (1) or "off" (0).
Just remember that you have to do "binary" math on the bit
field and that means you're limited to lengths of 2, 4, or 8. If
longer than 8, you have to "loop" thru the field.
Comments:
p1 pads the lo-ord bits w/binary zeros
p2 puts your data in the hi-ord and preserves the lo-ord zeros (1:6)
p3 limits the loop to the desired # of bits
p4 determines "on"/"off" of current bit
p5 is performed when bit is "on"
p7 is performed when bit is "off"
p9 bumps it up to the next bit
This example shows how to look at the hi-order 37 bits of 6 bytes of data a bit at a time, i.e. determine if a bit is "on" (1) or "off" (0).
Just remember that you have to do "binary" math on the bit
field and that means you're limited to lengths of 2, 4, or 8. If
longer than 8, you have to "loop" thru the field.
Code:
05 WRK-COMPOPT-BITS PIC X(08).
05 WRK-COMPOPTS-NUM REDEFINES
WRK-COMPOPT-BITS PIC S9(10) COMP.
05 FILLER REDEFINES
WRK-COMPOPT-BITS.
10 WRK-1ST-OPT-BYTE PIC X(01).
10 FILLER PIC X(07).
.
.
.
.
(p1) MOVE ZEROS TO WRK-COMPOPT-BITS
(p2) MOVE YOUR-6BYTE-FLD TO WRK-COMPOPT-BITS(1:6)
(p3) PERFORM 37 TIMES
(p4) IF WRK-1ST-OPT-BYTE > X'79'
(p5) PERFORM 1000-BIT-IS-ON-STUFF
(p6) ELSE
(p7) PERFORM 2000-BIT-IS-OFF-STUFF
(p8) END-IF
(p9) COMPUTE WRK-COMPOPTS-NUM = WRK-COMPOPTS-NUM * 2
(pa) END-PERFORMComments:
p1 pads the lo-ord bits w/binary zeros
p2 puts your data in the hi-ord and preserves the lo-ord zeros (1:6)
p3 limits the loop to the desired # of bits
p4 determines "on"/"off" of current bit
p5 is performed when bit is "on"
p7 is performed when bit is "off"
p9 bumps it up to the next bit
ShawnStanford
Programmer
If you want the quick and easy way, build a table of expanded bits in WORKING STORAGE and reference the bit you want using your value and reference mod.
For instance:
01 BIT-TABLE-ENTRIES.
05 BIT-TABLE-ENTRY-00 PIC X(08) VALUE '00000000'.
... through ...
05 BIT-TABLE-ENTRY-FF PIC X(08) VALUE '11111111'.
01 BIT-TABLE REDEFINES BIT-TABLE-ENTRIES.
05 BIT-TABLE-ENTRY PIC X(08) OCCURS 256 TIMES.
01 BIT-TABLE-INDEX PIC 9(04) BINARY.
01 BIT-TABLE-DEF REDEFINES BIT-TABLE-INDEX.
05 FILLER PIC X(01).
05 BIT-TABLE-OFFSET PIC X(01).
Now, to use it you move your one-byte field into the index and use that to index the entries and test using reference mod.
MOVE TEST-BYTE TO BIT-TABLE-OFFSET.
ADD 1 TO BIT-TABLE-OFFSET.
IF BIT-TABLE-ENTRY(BIT-TABLE-INDEX)(1:1) = '1' THEN
DISPLAY 'BIT ONE IS TRUE'
ELSE
DISPLAY 'BIT ONE IS FALSE'
END-IF.
This LOOKS like a kludge (and it does leave a mess in WORKING STORAGE), but it is going to be faster than any of the 'calculation' methods for finding this information.
For instance:
01 BIT-TABLE-ENTRIES.
05 BIT-TABLE-ENTRY-00 PIC X(08) VALUE '00000000'.
... through ...
05 BIT-TABLE-ENTRY-FF PIC X(08) VALUE '11111111'.
01 BIT-TABLE REDEFINES BIT-TABLE-ENTRIES.
05 BIT-TABLE-ENTRY PIC X(08) OCCURS 256 TIMES.
01 BIT-TABLE-INDEX PIC 9(04) BINARY.
01 BIT-TABLE-DEF REDEFINES BIT-TABLE-INDEX.
05 FILLER PIC X(01).
05 BIT-TABLE-OFFSET PIC X(01).
Now, to use it you move your one-byte field into the index and use that to index the entries and test using reference mod.
MOVE TEST-BYTE TO BIT-TABLE-OFFSET.
ADD 1 TO BIT-TABLE-OFFSET.
IF BIT-TABLE-ENTRY(BIT-TABLE-INDEX)(1:1) = '1' THEN
DISPLAY 'BIT ONE IS TRUE'
ELSE
DISPLAY 'BIT ONE IS FALSE'
END-IF.
This LOOKS like a kludge (and it does leave a mess in WORKING STORAGE), but it is going to be faster than any of the 'calculation' methods for finding this information.
Crox asked for a code sample. Briefly, here's what you do with Fujitsu.
01 Some-Byte-Area.
03 The-Byte Pic X.
03 The-Byte-Bit redefines The-Byte.
05 The-Bits Pic 1 BIT Occurs 8.
Then The-Bits (subscript) will either be 1 or 0.
It's pretty simple and nice.
01 Some-Byte-Area.
03 The-Byte Pic X.
03 The-Byte-Bit redefines The-Byte.
05 The-Bits Pic 1 BIT Occurs 8.
Then The-Bits (subscript) will either be 1 or 0.
It's pretty simple and nice.
- Status
Similar threads
- Locked
- Question