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