You are invited to browse the list of mainframe-loving sites.
[ Join Now | Ring Hub | Random | << Prev | Next >> ]
© Copyright John Ehrman, 2003. All rights reserved.
This software is free; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either
version 2 of the License,
or (at your option) any later version.
More information is available from
the Free Software Foundation or
the Open Source Initiative.
This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License along with this software; if not, write to either of the following:
|
the Free Software Foundation, Inc. 59 Temple Place, Suite 330 Boston, MA 02111-1307 United States of America |
B.V. Bixoft Rogge 9 7261 JA Ruurlo The Netherlands |
|
email: bixoft@bixoft.nl phone: +31-6-22755401 |
Remark:
This software - and more programs and macros - are available in a format more
suitable for uploading to your mainframe. Please e-mail
B.V. Bixoft with your request
and you will receive a zipped IEBUPDTE job with the program sources.
* 00000100
* This program is free software; you can redistribute it and/or modify 00000200
* it under the terms of the GNU General Public License as published by 00000300
* the Free Software Foundation; either version 2 of the License 00000400
* or (at your option) any later version. 00000500
* The license text is available at the following internet addresses: 00000600
* - http://www.bixoft.com/english/gpl.htm 00000700
* - http://fsf.org 00000800
* - http://opensource.org 00000900
* 00001000
* This program is distributed in the hope that it will be useful, 00001100
* but WITHOUT ANY WARRANTY; without even the implied warranty of 00001200
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00001300
* See the GNU General Public License for more details. 00001400
* 00001500
* You should have received a copy of the GNU General Public License 00001600
* along with this program; if not, write to either of the following: 00001700
* the Free Software Foundation, Inc. B.V. Bixoft 00001800
* 59 Temple Place, Suite 330 Rogge 9 00001900
* Boston, MA 02111-1307 7261 JA Ruurlo 00002000
* United States of America The Netherlands 00002100
* 00002200
* e-mail: bixoft@bixoft.nl 00002300
* phone : +31-6-22755401 00002400
* 00002500
TITLE 'INTEGER*8 Arithmetic: Input' 00010000
* 00020000
* Calling Sequences: 00030000
* 00040000
* CALL I8CVB(s1, l1, n1, m) 00050000
* s1 is a string of decimal EBCDIC characters, with no 00060000
* blanks, optionally preceded by a + or - sign, 00070000
* converted to a 64-bit integer at n1 00080000
* l1 is a 32-bit fullword integer, the length of s1 00090000
* n1 is a 64-bit integer, the result 00100000
* m is a fullword integer (also returned in GR0) 00110000
* m = 0 if no overflow, or other error conditions 00120000
* m = 1 if overflow (answer returned modulo 2**63) 00130000
* m = 2 if invalid leading sign character 00140000
* m = 4 if null digit string 00150000
* bad data gives a data exception interruption; no checks 00160000
* of the numeric characters are made 00170000
* 00180000
I8CVB RSECT , 00190000
SAVE (14,9),,* Save registers 00200000
USING I8CVB,R15 00210000
USING I8CVBSAV,R13 Save area used for work temps 00220000
LM R1,R4,0(R1) Get parameter addresses 00230000
XC 0(4,R4),0(R4) Set m = 0 00240000
XC 0(8,R3),0(R3) Set result n3 to zero 00250000
LR R5,R3 Result address in R5 00260000
L R2,0(,R2) String length l1 in R2 00270000
MVI I8CVBFLG,0 Initialize flag byte 00280000
* 00290000
CLI 0(R1),C'0' Check for leading digit 00300000
BNL I8CVBB Branch if it's a digit 00310000
CLI 0(R1),C'+' Check for + sign 00320000
BE I8CVBA Branch if yes 00330000
CLI 0(R1),C'-' Check for - sign 00340000
BNE I8CVBBS Bad sign character 00350000
OI I8CVBFLG,I8CVB$MS Set flag to indicate - sign 00360000
I8CVBA DS 0H 00370000
AL R1,I8CVBONE Bump scan pointer to step over sign 00380000
BCTR R2,0 Decrement input character count by 1 00390000
I8CVBB DS 0H 00400000
LTR R2,R2 Check character count 00410000
BNP I8CVBND If not positive, no digits there. 00420000
SR R6,R6 Clear working accumulator for answer 00430000
SR R7,R7 Use (R6,R7) 00440000
SRDL R2,3 Shift digit count right by 3 00450000
SRL R3,29 Split into multiples of 8 + leftover 00460000
LTR R3,R3 Is leftover piece null? 00470000
BNP I8CVBC Branch if yes, go do big chunks 00480000
BCTR R3,0 Decrement by 1 for execute 00490000
EX R3,I8CVBPK Pack leftover (high-order) digits 00500000
CVB R7,I8CVBTMP Convert to binary 00510000
LA R1,1(R3,R1) Step over the piece just completed 00520000
I8CVBC DS 0H 00530000
LTR R2,R2 Any more groups of 8 left to do? 00540000
BZ I8CVBI Branch if not 00550000
I8CVBC1 DS 0H Multiply working value by 10**8 00560000
LTR R9,R7 Set up for multiply 00570000
M R8,I8CVB108 Multiply low-order piece 00580000
BNM I8CVBD Branch if no correction required 00590000
AL R8,I8CVB108 Add correction term 00600000
I8CVBD DS 0H 00610000
LR R7,R6 Set up multiply of high-order term 00620000
M R6,I8CVB108 Multiply high-order term by 10**8 00630000
* Note that this product is not strictly correct if there has 00640000
* been any previous overflow, but since the high-order word 00650000
* (which is where the incorrectness lies) will be shifted left 00660000
* by 32 bits, there is no need to do the correction. 00670000
ALR R7,R8 Now, accumulate low-order product 00680000
BC NCY,I8CVBE Branch if no carry 00690000
AL R6,I8CVBONE Add carry bit 00700000
BNO I8CVBE Branch if no overflow 00710000
OI 3(R4),I8CVB$OF Indicate overflow in m 00720000
I8CVBE DS 0H 00730000
LR R0,R7 Save unadulterated R7 (with sign) 00740000
SLDA R6,32 Prepare to accumulate lowest piece 00750000
BNO I8CVBF Branch if no overflow 00760000
LR R6,R0 Restore overflowed piece with sign 00770000
OI 3(R4),I8CVB$OF Indicate overflow in m 00780000
I8CVBF DS 0H Get value of next 8 digits 00790000
LR R7,R9 (Working value)*10**8 now in (R6,R7) 00800000
PACK I8CVBTMP,0(8,R1) Pack 8 digits into working temp 00810000
LA R1,8(,R1) Step over the 8 digits in input 00820000
CVB R0,I8CVBTMP Convert to binary 00830000
ALR R7,R0 Add to working value 00840000
BC NCY,I8CVBH Branch if no carry 00850000
AL R6,I8CVBONE Add the carry bit 00860000
BNO I8CVBH Proceed if no overflow occurred 00870000
* Must now test carefully for maximum negative number: it's OK 00880000
CL R2,I8CVBONE Was this the last set of digits? 00890000
BH I8CVBG If not, have an overflow 00900000
C R6,I8CVBMNN Check if it really is the max neg 00910000
BNE I8CVBG If not, have an overflow 00920000
LTR R7,R7 Low-order piece must be zero also 00930000
BNZ I8CVBG If not, have an overflow 00940000
TM I8CVBFLG,I8CVB$MS Check if user gave a - sign 00950000
BO I8CVBH If yes, the value is O.K. 00960000
I8CVBG DS 0H 00970000
OI 3(R4),I8CVB$OF Indicate overflow 00980000
I8CVBH DS 0H 00990000
* Decrement digit block count by 1, and 01000000
BCT R2,I8CVBC1 Branch if there's more to do 01010000
I8CVBI DS 0H 01020000
TM I8CVBFLG,I8CVB$MS Check for - sign 01030000
BZ I8CVBJ Branch if + 01040000
LCR R6,R6 Complement high-order half 01050000
LCR R7,R7 And low-order half 01060000
BZ I8CVBJ Skip if no spurious carry 01070000
BCTR R6,0 Remove the spurious carry 01080000
I8CVBJ DS 0H 01090000
STM R6,R7,0(R5) Store the answer for the caller 01100000
I8CVBX DS 0H 01110000
L R0,0(,R4) Return m in R0 also 01120000
RETURN (2,9) Restore registers and return 01130000
* 01140000
I8CVBBS DS 0H 01150000
OI 3(R4),I8CVB$BS Indicate bad sign character 01160000
B I8CVBX And exit 01170000
I8CVBND DS 0H 01180000
OI 3(R4),I8CVB$ND Indicate no numeric digits 01190000
B I8CVBX And exit 01200000
* 01210000
I8CVBPK PACK I8CVBTMP,0(*-*,R1) Pack some initial input digits 01220000
I8CVBONE DC F'1' Constant 1 01230000
I8CVB108 DC F'1E8' Constant 10**8 01240000
I8CVBMNN DC X'8000000000000000' Max neg 64-bit number is -2**63 01250000
DROP R15 01260000
I8CVB$MS EQU X'80' Flag: Minus sign for result 01270000
I8CVB$OF EQU 1 Return Code: Overflowed result 01280000
I8CVB$BS EQU 2 Return Code: Bad sign character 01290000
I8CVB$ND EQU 4 Return Code: No numeric digits 01300000
* 01310000
* General Purpose Registers 01320000
* 01330000
R0 EQU 0 01340000
R1 EQU 1 01350000
R2 EQU 2 01360000
R3 EQU 3 01370000
R4 EQU 4 01380000
R5 EQU 5 01390000
R6 EQU 6 01400000
R7 EQU 7 01410000
R8 EQU 8 01420000
R9 EQU 9 01430000
R13 EQU 13 01440000
R15 EQU 15 01450000
* 01460000
* Condition Mask Equates 01470000
* 01480000
NCY EQU 12 No carry following Logical Add 01490000
* 01500000
I8CVBSAV DSect , Save Area Mapping 01510000
DC 15F'0' Reserved (head;chanins;R14-R9) 01520000
I8CVBFLG DC 4X'0' Flag byte and three extra bytes 01530000
I8CVBTMP DC D'0' Work area for CVB instructions 01540000
END 01550000
|
This site is a member of WebRing. You are invited to browse the list of mainframe-loving sites. |
|
Dinos are not dead. They are alive and well and living in data centers all around you. They speak in tongues and work strange magics with computers. Beware the dino! And just in case you're waiting for the final demise of these dino's: remember that dinos ruled the world for 155-million years! |
|
Dinos and other anachronisms [ Join Now | Ring Hub | Random | << Prev | Next >> ] |
||
Below you find the logo of our sponsor and logos of the web-standards that this page adheres to.
|
|
|
|
||