Retro1.org codex

          IDENT  EXTRACT 
          ENTRY  EXTRACT
          ENTRY  INSERT
          SYSCOM B1
*COMMENT  EXTRACT/INSERT - BIT MANIPULATION ROUTINE.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992.
          TITLE  EXTRACT/INSERT - BIT MANIPULATION ROUTINE.
          SPACE  4
*****     EXTRACT/INSERT - BIT MANIPULATION ROUTINE.
*
*         W. E. MARTIN.      78/10/30.
 EXTRACT  SPACE  4,45
***       EXTRACT/INSERT - BIT MANIPULATION ROUTINE.
*
*         EXTRACT/INSERT SUPPORTS THE COBOL TASK WRITER FOR THE
*         SITUATIONS WHERE BIT-ORIENTED OPERATIONS SUCH AS *TARO* AND
*         *TSIM* MONITOR REQUESTS ARE DESIRED.  THE BASIC OPERATION
*         PROVIDED IS TO RIGHT-JUSTIFY THE FIELD SPECIFIED IN THE
*         ARGUMENTS, SO THAT MORE TRADITIONAL *COBOL* ARITHMETIC CAN
*         BE PERFORMED.  ALTHOUGH THIS ROUTINE MAY BE ENTERED FROM
*         *FTN*, IT-S USE IS INTENDED TO AID THE *COBOL* PROGRAMMER WHO
*         FINDS THAT THE *STRING/UNSTRING* FUNCTIONS DO NOT PERFORM THE
*         NECESSARY OPERATIONS SATISFACTORILY, OR THAT HIS DATA DOES
*         NOT LEND ITSELF TO COMPUTATIONAL-4 MAPPING.
*
*         THE VALUE FIELDS OF THE PARAMETER LIST ARE CHECKED FOR
*         EXISTENCE AND SIZE.  IF ANY ARGUMENTS ARE MISSING OR LARGER
*         THAN THE WORD SIZE, THEN THE TASK IS ABORTED.
*
*         COBOL CALL -
*
*         ENTER EXTRACT USING SOURCE, DESTINATION, LOC1, LOC2.
*
*         FTN CALL -
*
*         CALL EXTRACT ( SOURCE, DESTINATION, LOC1, LOC2)
*
*         WHERE - SOURCE = SOURCE FIELD TO HAVE BITS EXTRACTED FROM.
*                 MAY BE ANY DATA TYPE, BUT MUST BEGIN ON A WORD
*                 BOUNDARY.
*
*                 THE REMAINING ITEMS MUST BE COMPUTATIONAL-1
*                 OR INTEGER.
*
*                 DESTINATION = DATA-NAME TO RETURN THE EXTRACTED
*                 BITS.
*
*                 LOC1 = BEGINNING BIT POSITION IN THE SOURCE FIELD.
*
*                 LOC2 = LENGTH OF BIT STRING TO EXTRACT FROM SOURCE.
*
*         USES   A - 0, 1, 2, 6.
*                X - 0, 1, 2, 6, 7.
*                B - 1, 4.
*
*         CALLS  VVA.
*
*         MACROS ARGERR.
          SPACE  4
*         COMMON TEXTS.
 
 
*CALL     COMCMAC
*CALL     COMKMAC
          SPACE  4
          VFD    42/0LEXTRACT,18/EXTRACT
 
 EXT2     SA1    EXTA        RESTORE THE (A0)
          SA0    X1+
 
 EXTRACT  SUBR               ENTRY/EXIT
          SX6    A0+         SAVE (A0)
          SB1    1
          ZR     X1,EXT1     IF NO ARGUMENTS - ABORT TASK
          SA6    EXTA
          SA2    X1+         READ SOURCE FIELD
 
*         DETERMINE VALIDITY OF ARGUMENTS.
 
          RJ     VVA         VERIFY VALIDITY OF ARGUMENTS
          NE     B4,EXT1     IF ERROR IN ARGUMENTS - ABORT TASK
 
*         EXTRACT SPECIFIED FIELD.
 
          SX1    59
          SB4    X5-1        ADJUSTED BIT STRING LENGTH
          MX7    1
          AX7    B4          (X7) = MASK
          SB4    X4+1        SHIFT COUNT FOR MASK
          LX7    B4          POSITION MASK
          BX6    X7*X2
          IX1    X1-X4       COMPUTE SHIFT COUNT
          IX1    X1+X5
          SB4    X1          SHIFT COUNT TO RIGHT JUSTIFY
          LX6    B4
          SA6    X3
          EQ     EXT2        RESTORE (A0) AND RETURN
 
*         PROCESS PARAMETER ERROR.
 
 EXT1     SA1    EXTRACT     READ *RJ* ADDRESS
          MX0    30
          LX1    30
          SA1    X1-1
          BX6    -X0*X6
          SA6    EXTA
          ARGERR A6          EXIT TO EXECUTIVE
 
 EXTA     CON    0           STORAGE FOR (A0)
 INSERT   SPACE  4,35
***       INSERT - INSERT BITS INTO A WORD.
*         INSERT IS INTENDED TO PROVIDE A COMPANION CAPABILITY FOR
*         THE EXTRACT ROUTINE, BY MOVING USER-SPECIFIED BIT STRINGS
*         TO ARBITRARY POSITIONS WITHIN A GIVEN WORD.  THIS THEN
*         ALLOWS THE COBOL PROGRAMMER THE ABILITY TO TEST AND SET
*         BITS WHICH OTHERWISE WOULD REQUIRE CUMBERSOME ARITHMETIC
*         OPERATIONS.
*
*         COBOL ENTRY -
*
*         ENTER INSERT USING SOURCE, DESTINATION, LOC3, LOC4.
*
*         FTN ENTRY -
*
*         CALL INSERT ( SOURCE, DESTINATION, LOC3, LOC4)
*
*         WHERE - SOURCE = SOURCE FIELD TO HAVE BITS EXTRACTED FROM.
*                 THIS ITEM MAY BE ANY DATA TYPE, BUT MUST BEGIN ON A
*                 WORD BOUNDARY.
*
*                 THE REMAINING ITEMS MUST BE COMPUTATIONAL-1
*                 OR INTEGER.
*
*                 DESTINATION = DATA-NAME TO RETURN THE EXTRACTED
*                 BITS.
*
*                 LOC3 = BEGINING BIT POSITION IN THE DESTINATION
*                        FIELD - MAYBE COMPUTATIONAL-1 OR INTEGER.
*
*                 LOC4 = LENGTH OF BIT STRING IN SOURCE WORD - MAY BE
*                        COMPUTATIONAL-1 OR INTEGER.
*
*         USES   A - 0, 1, 2, 3, 6.
*                X - 1, 2, 3, 6, 7.
*                B - 1, 2, 3, 4.
*
*         CALLS  VVA.
*
*         MACROS ARGERR.
 
 
          VFD    42/0LINSERT,18/INSERT
 
 INT2     SA1    INTA        RESTORE (A0)
          SA0    X1+
 
 INSERT   SUBR               ENTRY/EXIT
          SX6    A0+         SAVE (A0)
          SB1    1
          ZR     X1,INT1     IF NO ARGUMENTS - ABORT TASK
          SA6    INTA
          SA2    X1+         READ SOURCE FIELD
 
*         DETERMINE VALIDITY OF ARGUMENTS.
 
          RJ     VVA         VERIFY VALIDITY OF ARGUMENTS
          NE     B4,INT1     IF ERROR IN ARGUMENTS - ABORT TASK
          SA3    X3+         READ DESTINATION FIELD
 
*         INSERT SOURCE FIELD INTO DESTINATION FIELD.
 
          SB4    X5-1        (B4) = LENGTH OF MASK
          MX7    1
          AX7    B4
          SB2    B4+B1
          LX7    B2          POSITION MASK TO EXTRACT SOURCE FIELD
          BX2    X7*X2       EXTRACT VALUE
          SB3    X4          (B3) = BEGINNING BIT POSITION
          SB3    B3-B4
          LX7    B3          POSITION MASK
          LX2    B3
          BX6    -X7*X3
          BX6    X2+X6
          SA6    A3
          EQ     INT2        RESTORE (A0) AND RETURN
 
*         PROCESS PARAMETER ERROR.
 
 INT1     SA1    INSERT      READ *RJ* ADDRESS
          MX0    30
          LX1    30
          SA2    X1-1        READ TRACEBACK WORD
          BX6    -X0*X6
          SA6    INTA
          ARGERR A6          EXIT TO EXECUTIVE
 
 INTA     CON    0           STORAGE FOR (A0)
 VVA      SPACE  4,15
**        VVA - VERIFY VALIDITY OF ARGUMENTS.
*
*         ENTRY  (A1) = FWA OF LIST OF ARGUMENT ADDRESSES.
*
*         EXIT   (X3) = ADDRESS OF DESTINATION FIELD.
*                (X4) = BEGINNING BIT POSITION ARGUMENT.
*                (X5) = LENGTH ARGUMENT.
*                (B4) = 0, IF NO ERROR.
*                     .NE. 0, IF ERROR IN ARGUMENT.
*
*         USES   X - 1, 3, 4, 5, 6, 7.
*                A - 3, 4, 5.
*                B - 3, 4.
 
 
 VVA      SUBR               ENTRY/EXIT
          SA3    A1+B1       ADDRESS OF DESTINATION FIELD
          SA4    A3+B1       ADDRESS OF BEGINNING BIT POSITION FIELD
          SA5    A4+B1       ADDRESS OF BIT STRING LENGTH FIELD
          SB4    B1          SET ERROR FLAG
          ZR     X3,VVAX     IF NO DESTINATION ARGUMENT
          ZR     X4,VVAX     IF NO BEGINNING BIT POSTION ARGUMENT
          ZR     X5,VVAX     IF NO LENGTH ARGUMENT
          SA4    X4          READ BEGINNING BIT POSITION
          SA5    X5          READ LENGTH
          SX6    B1
          IX6    X5-X6
          SX1    59
          NG     X4,VVAX     IF RANGE ERROR (BIT POSITION .LT. 0)
          NG     X6,VVAX     IF RANGE ERROR (LENGTH .LT. 1)
          IX7    X1-X5
          IX6    X1-X4
          NG     X7,VVAX     IF RANGE ERROR (LENGTH .GT. 59)
          NG     X6,VVAX     IF RANGE ERROR (BIT POSITION .GT. 59)
          IX6    X5-X4
          SB3    X6
          GT     B3,B1,VVAX  IF RANGE ERROR
          SB4    B0+         CLEAR ERROR FLAG
          EQ     VVAX        RETURN
 
          SPACE  4
          END