User Tools

Site Tools


cdc:nos2.source:opl.opl871:deck:extract

Deck EXTRACT

1 Modification

Source

Seq #  *Modification Id* Act 
----------------------------+
00001  M01S00001.extract +++|          IDENT  EXTRACT
00002  M01S00002.extract +++|          ENTRY  EXTRACT
00003  M01S00003.extract +++|          ENTRY  INSERT
00004  M01S00004.extract +++|          SYSCOM B1
00005  M01S00005.extract +++|*COMMENT  EXTRACT/INSERT - BIT MANIPULATION ROUTINE.
Line S00006 Modification History
M01 (Added by) extract
M02 (Updated by) 281l803
Seq #  *Modification Id* Act 
----------------------------+
00006  M02S00006.281l803 ---|          COMMENT  COPYRIGHT CONTROL DATA CORPORATION.     1979.
00007  M01S00001.281l803 +++|          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992.
00008  M01S00007.extract +++|          TITLE  EXTRACT/INSERT - BIT MANIPULATION ROUTINE.
00009  M01S00008.extract +++|          SPACE  4
00010  M01S00009.extract +++|*****     EXTRACT/INSERT - BIT MANIPULATION ROUTINE.
00011  M01S00010.extract +++|*
00012  M01S00011.extract +++|*         W. E. MARTIN.      78/10/30.
00013  M01S00012.extract +++| EXTRACT  SPACE  4,45
00014  M01S00013.extract +++|***       EXTRACT/INSERT - BIT MANIPULATION ROUTINE.
00015  M01S00014.extract +++|*
00016  M01S00015.extract +++|*         EXTRACT/INSERT SUPPORTS THE COBOL TASK WRITER FOR THE
00017  M01S00016.extract +++|*         SITUATIONS WHERE BIT-ORIENTED OPERATIONS SUCH AS *TARO* AND
00018  M01S00017.extract +++|*         *TSIM* MONITOR REQUESTS ARE DESIRED.  THE BASIC OPERATION
00019  M01S00018.extract +++|*         PROVIDED IS TO RIGHT-JUSTIFY THE FIELD SPECIFIED IN THE
00020  M01S00019.extract +++|*         ARGUMENTS, SO THAT MORE TRADITIONAL *COBOL* ARITHMETIC CAN
00021  M01S00020.extract +++|*         BE PERFORMED.  ALTHOUGH THIS ROUTINE MAY BE ENTERED FROM
00022  M01S00021.extract +++|*         *FTN*, IT-S USE IS INTENDED TO AID THE *COBOL* PROGRAMMER WHO
00023  M01S00022.extract +++|*         FINDS THAT THE *STRING/UNSTRING* FUNCTIONS DO NOT PERFORM THE
00024  M01S00023.extract +++|*         NECESSARY OPERATIONS SATISFACTORILY, OR THAT HIS DATA DOES
00025  M01S00024.extract +++|*         NOT LEND ITSELF TO COMPUTATIONAL-4 MAPPING.
00026  M01S00025.extract +++|*
00027  M01S00026.extract +++|*         THE VALUE FIELDS OF THE PARAMETER LIST ARE CHECKED FOR
00028  M01S00027.extract +++|*         EXISTENCE AND SIZE.  IF ANY ARGUMENTS ARE MISSING OR LARGER
00029  M01S00028.extract +++|*         THAN THE WORD SIZE, THEN THE TASK IS ABORTED.
00030  M01S00029.extract +++|*
00031  M01S00030.extract +++|*         COBOL CALL -
00032  M01S00031.extract +++|*
00033  M01S00032.extract +++|*         ENTER EXTRACT USING SOURCE, DESTINATION, LOC1, LOC2.
00034  M01S00033.extract +++|*
00035  M01S00034.extract +++|*         FTN CALL -
00036  M01S00035.extract +++|*
00037  M01S00036.extract +++|*         CALL EXTRACT ( SOURCE, DESTINATION, LOC1, LOC2)
00038  M01S00037.extract +++|*
00039  M01S00038.extract +++|*         WHERE - SOURCE = SOURCE FIELD TO HAVE BITS EXTRACTED FROM.
00040  M01S00039.extract +++|*                 MAY BE ANY DATA TYPE, BUT MUST BEGIN ON A WORD
00041  M01S00040.extract +++|*                 BOUNDARY.
00042  M01S00041.extract +++|*
00043  M01S00042.extract +++|*                 THE REMAINING ITEMS MUST BE COMPUTATIONAL-1
00044  M01S00043.extract +++|*                 OR INTEGER.
00045  M01S00044.extract +++|*
00046  M01S00045.extract +++|*                 DESTINATION = DATA-NAME TO RETURN THE EXTRACTED
00047  M01S00046.extract +++|*                 BITS.
00048  M01S00047.extract +++|*
00049  M01S00048.extract +++|*                 LOC1 = BEGINNING BIT POSITION IN THE SOURCE FIELD.
00050  M01S00049.extract +++|*
00051  M01S00050.extract +++|*                 LOC2 = LENGTH OF BIT STRING TO EXTRACT FROM SOURCE.
00052  M01S00051.extract +++|*
00053  M01S00052.extract +++|*         USES   A - 0, 1, 2, 6.
00054  M01S00053.extract +++|*                X - 0, 1, 2, 6, 7.
00055  M01S00054.extract +++|*                B - 1, 4.
00056  M01S00055.extract +++|*
00057  M01S00056.extract +++|*         CALLS  VVA.
00058  M01S00057.extract +++|*
00059  M01S00058.extract +++|*         MACROS ARGERR.
00060  M01S00059.extract +++|          SPACE  4
00061  M01S00060.extract +++|*         COMMON TEXTS.
00062  M01S00061.extract +++|
00063  M01S00062.extract +++|
00064  M01S00063.extract +++|*CALL     COMCMAC
00065  M01S00064.extract +++|*CALL     COMKMAC
00066  M01S00065.extract +++|          SPACE  4
00067  M01S00066.extract +++|          VFD    42/0LEXTRACT,18/EXTRACT
00068  M01S00067.extract +++|
00069  M01S00068.extract +++| EXT2     SA1    EXTA        RESTORE THE (A0)
00070  M01S00069.extract +++|          SA0    X1+
00071  M01S00070.extract +++|
00072  M01S00071.extract +++| EXTRACT  SUBR               ENTRY/EXIT
00073  M01S00072.extract +++|          SX6    A0+         SAVE (A0)
00074  M01S00073.extract +++|          SB1    1
00075  M01S00074.extract +++|          ZR     X1,EXT1     IF NO ARGUMENTS - ABORT TASK
00076  M01S00075.extract +++|          SA6    EXTA
00077  M01S00076.extract +++|          SA2    X1+         READ SOURCE FIELD
00078  M01S00077.extract +++|
00079  M01S00078.extract +++|*         DETERMINE VALIDITY OF ARGUMENTS.
00080  M01S00079.extract +++|
00081  M01S00080.extract +++|          RJ     VVA         VERIFY VALIDITY OF ARGUMENTS
00082  M01S00081.extract +++|          NE     B4,EXT1     IF ERROR IN ARGUMENTS - ABORT TASK
00083  M01S00082.extract +++|
00084  M01S00083.extract +++|*         EXTRACT SPECIFIED FIELD.
00085  M01S00084.extract +++|
00086  M01S00085.extract +++|          SX1    59
00087  M01S00086.extract +++|          SB4    X5-1        ADJUSTED BIT STRING LENGTH
00088  M01S00087.extract +++|          MX7    1
00089  M01S00088.extract +++|          AX7    B4          (X7) = MASK
00090  M01S00089.extract +++|          SB4    X4+1        SHIFT COUNT FOR MASK
00091  M01S00090.extract +++|          LX7    B4          POSITION MASK
00092  M01S00091.extract +++|          BX6    X7*X2
00093  M01S00092.extract +++|          IX1    X1-X4       COMPUTE SHIFT COUNT
00094  M01S00093.extract +++|          IX1    X1+X5
00095  M01S00094.extract +++|          SB4    X1          SHIFT COUNT TO RIGHT JUSTIFY
00096  M01S00095.extract +++|          LX6    B4
00097  M01S00096.extract +++|          SA6    X3
00098  M01S00097.extract +++|          EQ     EXT2        RESTORE (A0) AND RETURN
00099  M01S00098.extract +++|
00100  M01S00099.extract +++|*         PROCESS PARAMETER ERROR.
00101  M01S00100.extract +++|
00102  M01S00101.extract +++| EXT1     SA1    EXTRACT     READ *RJ* ADDRESS
00103  M01S00102.extract +++|          MX0    30
00104  M01S00103.extract +++|          LX1    30
00105  M01S00104.extract +++|          SA1    X1-1
00106  M01S00105.extract +++|          BX6    -X0*X6
00107  M01S00106.extract +++|          SA6    EXTA
00108  M01S00107.extract +++|          ARGERR A6          EXIT TO EXECUTIVE
00109  M01S00108.extract +++|
00110  M01S00109.extract +++| EXTA     CON    0           STORAGE FOR (A0)
00111  M01S00110.extract +++| INSERT   SPACE  4,35
00112  M01S00111.extract +++|***       INSERT - INSERT BITS INTO A WORD.
00113  M01S00112.extract +++|*         INSERT IS INTENDED TO PROVIDE A COMPANION CAPABILITY FOR
00114  M01S00113.extract +++|*         THE EXTRACT ROUTINE, BY MOVING USER-SPECIFIED BIT STRINGS
00115  M01S00114.extract +++|*         TO ARBITRARY POSITIONS WITHIN A GIVEN WORD.  THIS THEN
00116  M01S00115.extract +++|*         ALLOWS THE COBOL PROGRAMMER THE ABILITY TO TEST AND SET
00117  M01S00116.extract +++|*         BITS WHICH OTHERWISE WOULD REQUIRE CUMBERSOME ARITHMETIC
00118  M01S00117.extract +++|*         OPERATIONS.
00119  M01S00118.extract +++|*
00120  M01S00119.extract +++|*         COBOL ENTRY -
00121  M01S00120.extract +++|*
00122  M01S00121.extract +++|*         ENTER INSERT USING SOURCE, DESTINATION, LOC3, LOC4.
00123  M01S00122.extract +++|*
00124  M01S00123.extract +++|*         FTN ENTRY -
00125  M01S00124.extract +++|*
00126  M01S00125.extract +++|*         CALL INSERT ( SOURCE, DESTINATION, LOC3, LOC4)
00127  M01S00126.extract +++|*
00128  M01S00127.extract +++|*         WHERE - SOURCE = SOURCE FIELD TO HAVE BITS EXTRACTED FROM.
00129  M01S00128.extract +++|*                 THIS ITEM MAY BE ANY DATA TYPE, BUT MUST BEGIN ON A
00130  M01S00129.extract +++|*                 WORD BOUNDARY.
00131  M01S00130.extract +++|*
00132  M01S00131.extract +++|*                 THE REMAINING ITEMS MUST BE COMPUTATIONAL-1
00133  M01S00132.extract +++|*                 OR INTEGER.
00134  M01S00133.extract +++|*
00135  M01S00134.extract +++|*                 DESTINATION = DATA-NAME TO RETURN THE EXTRACTED
00136  M01S00135.extract +++|*                 BITS.
00137  M01S00136.extract +++|*
00138  M01S00137.extract +++|*                 LOC3 = BEGINING BIT POSITION IN THE DESTINATION
00139  M01S00138.extract +++|*                        FIELD - MAYBE COMPUTATIONAL-1 OR INTEGER.
00140  M01S00139.extract +++|*
00141  M01S00140.extract +++|*                 LOC4 = LENGTH OF BIT STRING IN SOURCE WORD - MAY BE
00142  M01S00141.extract +++|*                        COMPUTATIONAL-1 OR INTEGER.
00143  M01S00142.extract +++|*
00144  M01S00143.extract +++|*         USES   A - 0, 1, 2, 3, 6.
00145  M01S00144.extract +++|*                X - 1, 2, 3, 6, 7.
00146  M01S00145.extract +++|*                B - 1, 2, 3, 4.
00147  M01S00146.extract +++|*
00148  M01S00147.extract +++|*         CALLS  VVA.
00149  M01S00148.extract +++|*
00150  M01S00149.extract +++|*         MACROS ARGERR.
00151  M01S00150.extract +++|
00152  M01S00151.extract +++|
00153  M01S00152.extract +++|          VFD    42/0LINSERT,18/INSERT
00154  M01S00153.extract +++|
00155  M01S00154.extract +++| INT2     SA1    INTA        RESTORE (A0)
00156  M01S00155.extract +++|          SA0    X1+
00157  M01S00156.extract +++|
00158  M01S00157.extract +++| INSERT   SUBR               ENTRY/EXIT
00159  M01S00158.extract +++|          SX6    A0+         SAVE (A0)
00160  M01S00159.extract +++|          SB1    1
00161  M01S00160.extract +++|          ZR     X1,INT1     IF NO ARGUMENTS - ABORT TASK
00162  M01S00161.extract +++|          SA6    INTA
00163  M01S00162.extract +++|          SA2    X1+         READ SOURCE FIELD
00164  M01S00163.extract +++|
00165  M01S00164.extract +++|*         DETERMINE VALIDITY OF ARGUMENTS.
00166  M01S00165.extract +++|
00167  M01S00166.extract +++|          RJ     VVA         VERIFY VALIDITY OF ARGUMENTS
00168  M01S00167.extract +++|          NE     B4,INT1     IF ERROR IN ARGUMENTS - ABORT TASK
00169  M01S00168.extract +++|          SA3    X3+         READ DESTINATION FIELD
00170  M01S00169.extract +++|
00171  M01S00170.extract +++|*         INSERT SOURCE FIELD INTO DESTINATION FIELD.
00172  M01S00171.extract +++|
00173  M01S00172.extract +++|          SB4    X5-1        (B4) = LENGTH OF MASK
00174  M01S00173.extract +++|          MX7    1
00175  M01S00174.extract +++|          AX7    B4
00176  M01S00175.extract +++|          SB2    B4+B1
00177  M01S00176.extract +++|          LX7    B2          POSITION MASK TO EXTRACT SOURCE FIELD
00178  M01S00177.extract +++|          BX2    X7*X2       EXTRACT VALUE
00179  M01S00178.extract +++|          SB3    X4          (B3) = BEGINNING BIT POSITION
00180  M01S00179.extract +++|          SB3    B3-B4
00181  M01S00180.extract +++|          LX7    B3          POSITION MASK
00182  M01S00181.extract +++|          LX2    B3
00183  M01S00182.extract +++|          BX6    -X7*X3
00184  M01S00183.extract +++|          BX6    X2+X6
00185  M01S00184.extract +++|          SA6    A3
00186  M01S00185.extract +++|          EQ     INT2        RESTORE (A0) AND RETURN
00187  M01S00186.extract +++|
00188  M01S00187.extract +++|*         PROCESS PARAMETER ERROR.
00189  M01S00188.extract +++|
00190  M01S00189.extract +++| INT1     SA1    INSERT      READ *RJ* ADDRESS
00191  M01S00190.extract +++|          MX0    30
00192  M01S00191.extract +++|          LX1    30
00193  M01S00192.extract +++|          SA2    X1-1        READ TRACEBACK WORD
00194  M01S00193.extract +++|          BX6    -X0*X6
00195  M01S00194.extract +++|          SA6    INTA
00196  M01S00195.extract +++|          ARGERR A6          EXIT TO EXECUTIVE
00197  M01S00196.extract +++|
00198  M01S00197.extract +++| INTA     CON    0           STORAGE FOR (A0)
00199  M01S00198.extract +++| VVA      SPACE  4,15
00200  M01S00199.extract +++|**        VVA - VERIFY VALIDITY OF ARGUMENTS.
00201  M01S00200.extract +++|*
00202  M01S00201.extract +++|*         ENTRY  (A1) = FWA OF LIST OF ARGUMENT ADDRESSES.
00203  M01S00202.extract +++|*
00204  M01S00203.extract +++|*         EXIT   (X3) = ADDRESS OF DESTINATION FIELD.
00205  M01S00204.extract +++|*                (X4) = BEGINNING BIT POSITION ARGUMENT.
00206  M01S00205.extract +++|*                (X5) = LENGTH ARGUMENT.
00207  M01S00206.extract +++|*                (B4) = 0, IF NO ERROR.
00208  M01S00207.extract +++|*                     .NE. 0, IF ERROR IN ARGUMENT.
00209  M01S00208.extract +++|*
00210  M01S00209.extract +++|*         USES   X - 1, 3, 4, 5, 6, 7.
00211  M01S00210.extract +++|*                A - 3, 4, 5.
00212  M01S00211.extract +++|*                B - 3, 4.
00213  M01S00212.extract +++|
00214  M01S00213.extract +++|
00215  M01S00214.extract +++| VVA      SUBR               ENTRY/EXIT
00216  M01S00215.extract +++|          SA3    A1+B1       ADDRESS OF DESTINATION FIELD
00217  M01S00216.extract +++|          SA4    A3+B1       ADDRESS OF BEGINNING BIT POSITION FIELD
00218  M01S00217.extract +++|          SA5    A4+B1       ADDRESS OF BIT STRING LENGTH FIELD
00219  M01S00218.extract +++|          SB4    B1          SET ERROR FLAG
00220  M01S00219.extract +++|          ZR     X3,VVAX     IF NO DESTINATION ARGUMENT
00221  M01S00220.extract +++|          ZR     X4,VVAX     IF NO BEGINNING BIT POSTION ARGUMENT
00222  M01S00221.extract +++|          ZR     X5,VVAX     IF NO LENGTH ARGUMENT
00223  M01S00222.extract +++|          SA4    X4          READ BEGINNING BIT POSITION
00224  M01S00223.extract +++|          SA5    X5          READ LENGTH
00225  M01S00224.extract +++|          SX6    B1
00226  M01S00225.extract +++|          IX6    X5-X6
00227  M01S00226.extract +++|          SX1    59
00228  M01S00227.extract +++|          NG     X4,VVAX     IF RANGE ERROR (BIT POSITION .LT. 0)
00229  M01S00228.extract +++|          NG     X6,VVAX     IF RANGE ERROR (LENGTH .LT. 1)
00230  M01S00229.extract +++|          IX7    X1-X5
00231  M01S00230.extract +++|          IX6    X1-X4
00232  M01S00231.extract +++|          NG     X7,VVAX     IF RANGE ERROR (LENGTH .GT. 59)
00233  M01S00232.extract +++|          NG     X6,VVAX     IF RANGE ERROR (BIT POSITION .GT. 59)
00234  M01S00233.extract +++|          IX6    X5-X4
00235  M01S00234.extract +++|          SB3    X6
00236  M01S00235.extract +++|          GT     B3,B1,VVAX  IF RANGE ERROR
00237  M01S00236.extract +++|          SB4    B0+         CLEAR ERROR FLAG
00238  M01S00237.extract +++|          EQ     VVAX        RETURN
00239  M01S00238.extract +++|
00240  M01S00239.extract +++|          SPACE  4
00241  M01S00240.extract +++|          END
cdc/nos2.source/opl.opl871/deck/extract.txt ยท Last modified: by 127.0.0.1