royf@attctc.Dallas.TX.US (Roy Frederick) (08/15/89)
Here are a couple of routines I cut out of a calculator program I wrote several years ago. The calculator itself runs on a TP monitor used only at Dallas County - but these routines should be usable anywhere (on an IBM mainframe or compatible, of course). AFP converts an EBCDIC string into internal long floating point. Put the address of the first character of the string into SCAN. SCAN should not point to a space. Put the length of the string into SCAN + 4 - trailing spaces are ok. AFP will leave the result in FPR0 if RC = 0. RC = 4 means it found an error. SCAN and SCAN + 4 will be updated to point past the portion of the string converted. CEF converts to external floating format. Input is in FPR0. R1 points to flags that control the result format. Try r1->x'2785' for a first attempt. This should be similar to G15.5 in fortran. Look at the comments at the start of CEF for the details. These routines work only with long floating format - but it is a simple matter to convert to and from short format if desired - at the input of CEF and the output of AFP. It is quite possible that there are easier and/or better ways to do these conversions. These routines are not claimed to be the best of their genre - but they work for me. Note that I did have to modify them slightly to remove some macro calls peculiar to our TP system - Entry and Exit macros dealing with save areas. Hopefully I did not introduce any errors in the process. AFP, CEF, and FAM are free of copyright restrictions. ------------------ Cut Here ----------------------------- .AFP SPACE 2 ** AFP -- ASSEMBLE FLOATING POINT OPERAND * * ENTRY SCAN CONTAINS ADDR OF CHARS TO CONVERT * SCAN + 4 CONTAINS LENGTH OF STRING * * EXIT RC = 0, FPR0 CONTAINS LONG FP RESULT * RC = 4, STRING WAS INVALID NUMBER * * AFP STM 14,12,12(13) SAVE REGS SR 3,3 SET EXPONENT TO ZERO LD 0,=D'1.0' SET MULTIPLIER = 1 MVI AFPF,0 CLEAR FLAG LD 6,=D'0' PRESET ZERO RESULT LM 4,5,SCAN POINT TO INPUT OPERAND * AFP1 CLI 0(4),C'+' SEE IF POSITIVE BE AFP8 CLI 0(4),C'-' SEE IF NEGATIVE BE AFP4 CLI 0(4),C'.' SEE IF DECIMAL POINT BE AFP6 CLI 0(4),C'E' SEE IF EXPONENT BE AFP7 * CLI 0(4),C'0' MUST BE A DECIMAL DIGIT BL AFP10 IF NOT CLI 0(4),C'9' BH AFP10 IF NOT OI AFPF,X'08' SHOW DIGITS FOUND MVN AFPW+7(1),0(4) SET DIGIT VALUE TM AFPF,X'80' SEE IF DIGIT IN EXPONENT BO AFP3 IF SO TM AFPF,X'40' SEE IF FRACTION DIGIT BO AFP2 IF SO MD 6,=D'10.0' SHIFT RESULT 1 DIGIT AD 6,AFPW ADD IN CURRENT DIGIT B AFP9 * AFP2 LD 2,AFPW GET CURRENT DIGIT AD 2,=D'0' NORMALIZE IT DD 0,=D'10.0' SCALE MULTIPLIER MDR 2,0 SHIFT CURRENT DIGIT ADR 6,2 ADD IN CURRENT SHIFTED DIGIT B AFP9 NEXT CHARACTER * AFP3 MH 3,=H'10' SHIFT EXPONENT AH 3,AFPW+6 ADD IN CURRENT DIGIT B AFP9 NEXT CHARACTER * AFP4 TM AFPF,X'68' SEE IF SIGN, DIGITS, OR DECIMAL BNZ AFP10 END OF NUMBER IF SO TM AFPF,X'80' SEE IF EXPONENT SIGN BO AFP5 OI AFPF,X'30' SET NEGATIVE B AFP9 NEXT CHARACTER * AFP5 OI AFPF,X'24' SET NEGATIVE EXPONENT, SIGN CHAR B AFP9 NEXT CHARACTER * AFP6 TM AFPF,X'C0' SEE IF DECIMAL OR E BNZ ERR2 *INVALID FP NUMBER* OI AFPF,X'40' SHOW DECIMAL ENCOUNTERED B AFP9 NEXT CHARACTER * AFP7 TM AFPF,X'80' SEE IF E ALREADY FOUND BO ERR2 TM AFPF,X'08' MUST BE SOME DIGITS BZ ERR2 NI AFPF,255-X'68' NO SIGN, NO DIGITS OI AFPF,X'80' SHOW EXPONENT PRESENT B AFP9 NEXT CHARACTER * AFP8 TM AFPF,X'68' SEE IF SIGN, DIGITS, OR DECIMAL BNZ AFP10 END OF NUMBER IF SO OI AFPF,X'20' SET SIGN FLAG * AFP9 LA 4,1(,4) NEXT INPUT CHARACTER BCT 5,AFP1 LOOP FOR ALL CHARACTERS * AFP10 STM 4,5,SCAN RESET SCAN PTRS TM AFPF,X'80' SEE IF ANY EXPONENT BZ AFP11 IF NOT TM AFPF,X'08' MUST BE SOME DIGITS IF E BZ ERR2 *INVALID FP NUMBER* * AFP11 TM AFPF,X'10' SEE IF NEGATIVE MANTISSA BZ AFP12 IF NOT LNDR 6,6 MAKE IT NEGATIVE * AFP12 LTR 3,3 SEE IF ANY EXPONENT SPECIFIED BNP AFP14 IF NOT LD 0,=D'10.0' ASSUME POSITIVE EXPONENT TM AFPF,X'04' SEE IF NEGATIVE EXPONENT BZ AFP13 IF NOT LD 0,=D'0.10' SET NEGATIVE EXPONENT MULTIPLIER * AFP13 MDR 6,0 SCALE RESULT BCT 3,AFP13 * AFP14 STD 6,AFPR STORE RESULT CLC AFPR+1(7),=XL7'00' SEE IF TRUE ZERO REQUIRED BNE AFPX XC AFPR,AFPR INSURE RESULT IS A TRUE ZERO APFX LD 0,AFPR GET RESULT IN FPR0 LM 14,12,12(13) RESTORE REGS SR 15,15 GIVE GOOD RC BR 14 RETURN TO CALLER * ERR2 XC AFPR,AFPR CLEAR RESULT LD 0,AFPR LM 14,12,12(13) LA 15,4 GIVE BAD RC BR 14 * AFPR DC D'0' RESULT * AFPW DC X'4E00000000000000' WORK AREA * AFPF DC X'00' * ... X'80' 'E' ENCOUNTERED * ... X'40' '.' ENCOUNTERED * ... X'20' SIGN ENCOUNTERED * ... X'10' NEGATIVE MANTISSA * ... X'08' DIGITS ENCOUNTERED * ... X'04' NEGATIVE EXPONENT * SCAN DC A(0) SCAN ADDRESS DC F'0' LENGTH .CEF SPACE 2 ** CEF -- CONVERT TO EXTERNAL FLOATING * * FPR0 - NUMBER TO BE CONVERTED * * R1 -> FFNM * FF = 80, F, FIXED FORMAT * 40, S, SCIENTIFIC FORMAT * 20, G, EITHER OF ABOVE * 10, E, ENGINEERING FORMAT * 08, %, FIXED NOTATION, SCALE BY 100 * * B'00000111' SIGN OPTION * * 00, NO SIGN DISPLAYED * 01, TRAILING - SIGN OPTION * 02, CR SIGN OPTION * 03, DB SIGN OPTION * 04, $, CR * 05, $, DB * 06, + SIGN OPTION * 07, - SIGN OPTION * * N = NUMBER OF FRACTION DIGITS * M = NUMBER OF INTEGER DIGITS * * CEF STM 14,12,12(13) SAVE REGS ST 13,CEFV+4 BACKCHAIN LA 13,CEFV POINT TO SAVE AREA * MVC CEFB,0(1) SAVE FLAG BYTE MVC CEFC,CEFB SET SIGN CONTROL BITS NI CEFC,X'07' SAVE ONLY SIGN BITS MVN CEFI+1(1),1(1) SAVE NUMBER OF INTEGER DIGITS IC 1,1(,1) SAVE NUMBER OF FRACTION DIGITS SRL 1,4 STC 1,CEFF+1 NI CEFF+1,X'0F' ... * TM CEFB,X'08' SEE IF PERCENT NOTATION BZ CEF1 IF NOT MD 0,=D'100.0' SCALE PERCENTAGE * CEF1 LA 1,3 CHECK FOR MIN INTEGER LOCATIONS TM CEFB,X'10' SEE IF ENG NOTATION BO CEF2 LA 1,1 TM CEFB,X'60' SCI OR SCI/FIX BO CEF2 SR 1,1 NO INTEGER PORTION REQUIRED CEF2 CH 1,CEFI CHECK AGAINST LIMIT BNH CEF3 STH 1,CEFI SET MINIMUM * CEF3 MVI CEFS,C'+' ASSUME POSITIVE VALUE LTDR 0,0 TEST INPUT VALUE BNM CEF4 IF NOT NEGATIVE MVI CEFS,C'-' SET NEGATIVE SIGN * CEF4 MVC CEFO,CEFO-1 CLEAR OUTPUT AREA LA 7,CEFO POINT TO OUTPUT AREA CLI CEFC,X'04' SEE IF LEADING SIGN OR CURRENCY BL CEF8 DO NOT ALLOW SPACE FOR IT CLI CEFC,X'06' SEE IF + SIGN OPTION BE CEF6 CLI CEFC,X'07' SEE IF - SIGN OPTION BE CEF5 IF SO MVI 0(7),C'$' SET CURRENCY SIGN B CEF7 CEF5 CLI CEFS,C'+' SEE IF POSITIVE BE CEF7 IF SO CEF6 MVC 0(1,7),CEFS STORE SIGN CEF7 LA 7,1(,7) ADVANCE POINTER * CEF8 SR 6,6 SET ZERO EXPONENT LPDR 0,0 SET POSITIVE SIGN BZ CEF14 IF ZERO ARG * LD 4,=D'1.0' COMPUTE ROUNDING FACTOR LH 2,CEFF GET NUMBER OF FRACTION DIGITS SLL 2,3 INDEX INTO SCALE TABLE DD 4,CEFT00(2) 1.0/SCALE FACTOR HDR 4,4 1.0/(2*SCALE FACTOR) * CEF9 TM CEFB,X'40' SEE IF SCI FORMAT BO CEF10 IF SO LH 1,CEFI GET INTEGER DIGITS REQUIRED SLL 1,3 X LENGTH OF FP NUMBER CD 0,CEFT00(1) SEE IF TOO LARGE FOR F FORMAT BNL CEF10 IF NOT TM CEFB,X'80' SEE IF FIXED POINT BO CEF13 NO SCALING IF SO CD 0,=D'1.0' SEE IF ARG LT 1 BNL CEF13 IF NOT TM CEFB,X'10' SEE IF ENG FORMAT BO CEF10 SCALE ARG IF ENG LH 1,CEFF PREPARE FOR SIGNIFICANCE LOSS TEST SLL 1,3 LD 2,=D'1.0' DD 2,CEFT00(1) SIGNIFICANCE FACTOR CDR 0,2 BH CEF13 IF SOME SIGNIFICANCE RETAINED * CEF10 LD 2,CEFT01 PRESET SCI SCALING FACTOR LA 2,1 SET SCALE = 1 TM CEFB,X'10' SEE IF ENG FORMAT REQUIRED BZ CEF11 IF NOT LD 2,CEFT03 SET ENG SCALING FACTOR LA 2,3 SET SCALE = 3 CEF11 CD 0,=D'1.0' BNL CEF12 IF NEG SCALING NOT REQUIRED MDR 0,2 SCALE IT SR 6,2 ADJUST EXPONENT B CEF11 LOOP FOR ALL NEG SCALING CEF12 CDR 0,2 CHECK FOR POSITIVE SCALING BL CEF13 IF OK DDR 0,2 SCALE IT AR 6,2 ADJUST EXPONENT B CEF12 * CEF13 LTDR 4,4 SEE IF ANY ROUNDING FACTOR BZ CEF14 ADR 0,4 ROUND SCALED RESULT LD 4,=D'0' ZERO OUT ROUNDING FACTOR B CEF9 * CEF14 STD 0,CEFA SAVE ROUNDED ABS OF INPUT VALUE * LH 2,CEFI GET INTEGER POSITIONS BAL 14,FAM FIX AND MOVE INTEGER DIGITS * LH 2,CEFF GET NUMBER OF FRACTION DIGITS SLA 2,3 X LENGTH OF FP NUMBER BZ CEF15 IF NO FRACTION DIGITS REQUIRED MVI 0(7),C'.' STORE DECIMAL POINT LA 7,1(,7) SKIP DECIMAL POINT AD 0,=D'0' GET FRACTION SD 0,CEFA LPDR 0,0 ... MD 0,CEFT00(2) SCALE FRACTION INTO INTEGER LH 2,CEFF GET FRACTION POSITIONS BAL 14,FAM FIX AND MOVE FRACTION DIGITS * CEF15 TM CEFB,X'40' SEE IF SCIENTIFIC BO CEF16 ALWAYS DISPLAY EXPONENT IF SCI LTR 6,6 SEE IF ANY EXPONENT BZ CEF18 IF NOT CEF16 MVC 0(2,7),=C'E+' STORE EXP INDICATOR LTR 6,6 SEE IF NEGATIVE EXPONENT BNM CEF17 MVI 1(7),C'-' SET NEGATIVE EXP CEF17 LPR 6,6 CONVERT EXPONENT CVD 6,DWORK ... OI DWORK+7,X'0F' PRINTABLE SIGN UNPK 2(2,7),DWORK MOVE TO OUTPUT LINE LA 7,4(,7) SKIP EXPONENT * CEF18 CLI CEFS,C'-' SEE IF NEGATIVE BNE CEF21 IF NOT CLI CEFC,X'05' CHECK FOR LEADING SIGN BH CEF21 IF LEADING SIGN CLI CEFC,X'01' BL CEF21 IF NO SIGN DISPLAYED BH CEF19 IF CR OR DB MVI 0(7),C'-' STORE NEG SIGN LA 7,1(,7) SKIP NEG SIGN B CEF21 CEF19 MVC 0(2,7),=C'DB' STORE A DEBIT SYMBOL TM CEFC,X'01' SEE IF DEBIT BO CEF20 IF SO MVC 0(2,7),=C'CR' STORE A CREDIT SYMBOL CEF20 LA 7,2(,7) SKIP CR OR DB * CEF21 TM CEFB,X'08' SEE IF PERCENTAGE OUTPUT BZ CEF22 IF NOT MVI 0(7),C'%' STORE PERCENT SIGN LA 7,1(,7) SKIP PERCENT SIGN * CEF22 LA 1,CEFO-1 ZERO SUPPRESS OUTPUT CEF23 LA 1,1(,1) NEXT DIGIT CLI 1(1),C'0' SEE IF ZERO BNE CEFX IF DONE CLI 2(1),C'0' SEE IF NEXT CHAR IS A DIGIT BL CEFX IF NOT MVC 1(1,1),0(1) MOVE SIGN OR CURRENCY MVI 0(1),C' ' SPACE OUT ORIGINAL LOC B CEF23 LOOP FOR ALL ZEROS TO BE SUPPRESSED * CEFX L 13,4(,13) RESTORE SAVE AREA ADDR LM 14,12,12(13) RESTORE REGS SR 15,15 BR 14 * DC C' ' CEFO DC CL40' ' OUTPUT AREA * CEFT00 DC D'1.0E+00' POWERS OF 10 CEFT01 DC D'1.0E+01' CEFT02 DC D'1.0E+02' CEFT03 DC D'1.0E+03' CEFT04 DC D'1.0E+04' CEFT05 DC D'1.0E+05' CEFT06 DC D'1.0E+06' CEFT07 DC D'1.0E+07' CEFT08 DC D'1.0E+08' CEFT09 DC D'1.0E+09' CEFT10 DC D'1.0E+10' CEFT11 DC D'1.0E+11' CEFT12 DC D'1.0E+12' CEFT13 DC D'1.0E+13' CEFT14 DC D'1.0E+14' CEFT15 DC D'1.0E+15' CEFT16 DC D'1.0E+16' * CEFA DC D'0' HOLD FOR INPUT ARG * CEFB DC X'00' FLAG BYTE CEFC DC X'00' SIGN OPTION * CEFR DC X'0000000000000001' ROUNDING FACTOR * CEFS DC C'+' SIGN * CEFF DC H'0' NUMBER OF FRACTION DIGITS CEFI DC H'0' NUMBER OF INTEGER DIGITS * CEFV DC 18F'0' SAVE AREA .FAM SPACE 2 ** FAM -- FIX AND MOVE * * FAM STM 14,2,12(13) AW 0,FAMF ADD IN FIX CONSTANT STD 0,DWORK SAVE FIXED VALUE CLI DWORK,X'4E' SEE IF OVERFLOW BH ERR1 IF OVERFLOW XC FAMW,FAMW CLEAR WORK AREA SR 0,0 GET UPPER PART OF INTEGER ICM 0,B'0111',DWORK+1 ... L 1,DWORK+4 GET LOWER PART SLDL 0,1 MAKE BOTTOM POSITIVE SRL 1,1 ... CVD 0,FAMW+8 CONVERT UPPER MP FAMW,=P'2147483648' SCALE IT CVD 1,DWORK CONVERT LOWER TO DECIMAL AP FAMW,DWORK ADD IN LOWER PART OI FAMW+15,X'0F' PRINTABLE SIGN BCTR 2,0 LENGTH CODE SLL 2,4 SHIFT INTO POSITION EX 2,FAMX1 MOVE DIGITS TO OUTPUT SRL 2,4 RESTORE LENGTH CODE LA 7,1(2,7) SKIP DIGITS MOVED LM 14,2,12(13) BR 14 * ERR1 L 13,4(,13) RESTORE SAVE AREA ADDR LM 14,12,12(13) RESTORE REGS LA 15,4 GIVE RC = 4, OVERFLOW BR 14 * FAMX1 UNPK 0(0,7),FAMW MOVE DIGITS TO OUTPUT AREA * DS 0D FAMF DC X'4E00000000000000' FIX CONSTANT * FAMW DC XL16'00' WORK AREA * DWORK DC D'0' WORK ------------------ Cut Here ----------------------------- Roy Frederick - royf@attctc Dallas County Data Services 504 Records Building Dallas, TX 75202 (214) 653-6340
royf@TUT.CIS.OHIO-STATE.EDU (Roy Frederick) (08/15/89)
Here are a couple of routines I cut out of a calculator program I
wrote several years ago. The calculator itself runs on a TP monitor
used only at Dallas County - but these routines should be usable
anywhere (on an IBM mainframe or compatible, of course).
AFP converts an EBCDIC string into internal long floating point. Put
the address of the first character of the string into SCAN. SCAN
should not point to a space. Put the length of the string into SCAN
+ 4 - trailing spaces are ok. AFP will leave the result in FPR0 if
RC = 0. RC = 4 means it found an error. SCAN and SCAN + 4 will be
updated to point past the portion of the string converted.
CEF converts to external floating format. Input is in FPR0. R1
points to flags that control the result format. Try r1->x'2785' for
a first attempt. This should be similar to G15.5 in fortran. Look
at the comments at the start of CEF for the details. These routines
work only with long floating format - but it is a simple matter to
convert to and from short format if desired - at the input of CEF and
the output of AFP.
It is quite possible that there are easier and/or better ways to do
these conversions. These routines are not claimed to be the best of
their genre - but they work for me. Note that I did have to modify
them slightly to remove some macro calls peculiar to our TP system -
Entry and Exit macros dealing with save areas. Hopefully I did not
introduce any errors in the process.
AFP, CEF, and FAM are free of copyright restrictions.
------------------ Cut Here -----------------------------
.AFP SPACE 2
** AFP -- ASSEMBLE FLOATING POINT OPERAND
*
* ENTRY SCAN CONTAINS ADDR OF CHARS TO CONVERT
* SCAN + 4 CONTAINS LENGTH OF STRING
*
* EXIT RC = 0, FPR0 CONTAINS LONG FP RESULT
* RC = 4, STRING WAS INVALID NUMBER
*
*
AFP STM 14,12,12(13) SAVE REGS
SR 3,3 SET EXPONENT TO ZERO
LD 0,=D'1.0' SET MULTIPLIER = 1
MVI AFPF,0 CLEAR FLAG
LD 6,=D'0' PRESET ZERO RESULT
LM 4,5,SCAN POINT TO INPUT OPERAND
*
AFP1 CLI 0(4),C'+' SEE IF POSITIVE
BE AFP8
CLI 0(4),C'-' SEE IF NEGATIVE
BE AFP4
CLI 0(4),C'.' SEE IF DECIMAL POINT
BE AFP6
CLI 0(4),C'E' SEE IF EXPONENT
BE AFP7
*
CLI 0(4),C'0' MUST BE A DECIMAL DIGIT
BL AFP10 IF NOT
CLI 0(4),C'9'
BH AFP10 IF NOT
OI AFPF,X'08' SHOW DIGITS FOUND
MVN AFPW+7(1),0(4) SET DIGIT VALUE
TM AFPF,X'80' SEE IF DIGIT IN EXPONENT
BO AFP3 IF SO
TM AFPF,X'40' SEE IF FRACTION DIGIT
BO AFP2 IF SO
MD 6,=D'10.0' SHIFT RESULT 1 DIGIT
AD 6,AFPW ADD IN CURRENT DIGIT
B AFP9
*
AFP2 LD 2,AFPW GET CURRENT DIGIT
AD 2,=D'0' NORMALIZE IT
DD 0,=D'10.0' SCALE MULTIPLIER
MDR 2,0 SHIFT CURRENT DIGIT
ADR 6,2 ADD IN CURRENT SHIFTED DIGIT
B AFP9 NEXT CHARACTER
*
AFP3 MH 3,=H'10' SHIFT EXPONENT
AH 3,AFPW+6 ADD IN CURRENT DIGIT
B AFP9 NEXT CHARACTER
*
AFP4 TM AFPF,X'68' SEE IF SIGN, DIGITS, OR DECIMAL
BNZ AFP10 END OF NUMBER IF SO
TM AFPF,X'80' SEE IF EXPONENT SIGN
BO AFP5
OI AFPF,X'30' SET NEGATIVE
B AFP9 NEXT CHARACTER
*
AFP5 OI AFPF,X'24' SET NEGATIVE EXPONENT, SIGN CHAR
B AFP9 NEXT CHARACTER
*
AFP6 TM AFPF,X'C0' SEE IF DECIMAL OR E
BNZ ERR2 *INVALID FP NUMBER*
OI AFPF,X'40' SHOW DECIMAL ENCOUNTERED
B AFP9 NEXT CHARACTER
*
AFP7 TM AFPF,X'80' SEE IF E ALREADY FOUND
BO ERR2
TM AFPF,X'08' MUST BE SOME DIGITS
BZ ERR2
NI AFPF,255-X'68' NO SIGN, NO DIGITS
OI AFPF,X'80' SHOW EXPONENT PRESENT
B AFP9 NEXT CHARACTER
*
AFP8 TM AFPF,X'68' SEE IF SIGN, DIGITS, OR DECIMAL
BNZ AFP10 END OF NUMBER IF SO
OI AFPF,X'20' SET SIGN FLAG
*
AFP9 LA 4,1(,4) NEXT INPUT CHARACTER
BCT 5,AFP1 LOOP FOR ALL CHARACTERS
*
AFP10 STM 4,5,SCAN RESET SCAN PTRS
TM AFPF,X'80' SEE IF ANY EXPONENT
BZ AFP11 IF NOT
TM AFPF,X'08' MUST BE SOME DIGITS IF E
BZ ERR2 *INVALID FP NUMBER*
*
AFP11 TM AFPF,X'10' SEE IF NEGATIVE MANTISSA
BZ AFP12 IF NOT
LNDR 6,6 MAKE IT NEGATIVE
*
AFP12 LTR 3,3 SEE IF ANY EXPONENT SPECIFIED
BNP AFP14 IF NOT
LD 0,=D'10.0' ASSUME POSITIVE EXPONENT
TM AFPF,X'04' SEE IF NEGATIVE EXPONENT
BZ AFP13 IF NOT
LD 0,=D'0.10' SET NEGATIVE EXPONENT MULTIPLIER
*
AFP13 MDR 6,0 SCALE RESULT
BCT 3,AFP13
*
AFP14 STD 6,AFPR STORE RESULT
CLC AFPR+1(7),=XL7'00' SEE IF TRUE ZERO REQUIRED
BNE AFPX
XC AFPR,AFPR INSURE RESULT IS A TRUE ZERO
APFX LD 0,AFPR GET RESULT IN FPR0
LM 14,12,12(13) RESTORE REGS
SR 15,15 GIVE GOOD RC
BR 14 RETURN TO CALLER
*
ERR2 XC AFPR,AFPR CLEAR RESULT
LD 0,AFPR
LM 14,12,12(13)
LA 15,4 GIVE BAD RC
BR 14
*
AFPR DC D'0' RESULT
*
AFPW DC X'4E00000000000000' WORK AREA
*
AFPF DC X'00'
* ... X'80' 'E' ENCOUNTERED
* ... X'40' '.' ENCOUNTERED
* ... X'20' SIGN ENCOUNTERED
* ... X'10' NEGATIVE MANTISSA
* ... X'08' DIGITS ENCOUNTERED
* ... X'04' NEGATIVE EXPONENT
*
SCAN DC A(0) SCAN ADDRESS
DC F'0' LENGTH
.CEF SPACE 2
** CEF -- CONVERT TO EXTERNAL FLOATING
*
* FPR0 - NUMBER TO BE CONVERTED
*
* R1 -> FFNM
* FF = 80, F, FIXED FORMAT
* 40, S, SCIENTIFIC FORMAT
* 20, G, EITHER OF ABOVE
* 10, E, ENGINEERING FORMAT
* 08, %, FIXED NOTATION, SCALE BY 100
*
* B'00000111' SIGN OPTION
*
* 00, NO SIGN DISPLAYED
* 01, TRAILING - SIGN OPTION
* 02, CR SIGN OPTION
* 03, DB SIGN OPTION
* 04, $, CR
* 05, $, DB
* 06, + SIGN OPTION
* 07, - SIGN OPTION
*
* N = NUMBER OF FRACTION DIGITS
* M = NUMBER OF INTEGER DIGITS
*
*
CEF STM 14,12,12(13) SAVE REGS
ST 13,CEFV+4 BACKCHAIN
LA 13,CEFV POINT TO SAVE AREA
*
MVC CEFB,0(1) SAVE FLAG BYTE
MVC CEFC,CEFB SET SIGN CONTROL BITS
NI CEFC,X'07' SAVE ONLY SIGN BITS
MVN CEFI+1(1),1(1) SAVE NUMBER OF INTEGER DIGITS
IC 1,1(,1) SAVE NUMBER OF FRACTION DIGITS
SRL 1,4
STC 1,CEFF+1
NI CEFF+1,X'0F' ...
*
TM CEFB,X'08' SEE IF PERCENT NOTATION
BZ CEF1 IF NOT
MD 0,=D'100.0' SCALE PERCENTAGE
*
CEF1 LA 1,3 CHECK FOR MIN INTEGER LOCATIONS
TM CEFB,X'10' SEE IF ENG NOTATION
BO CEF2
LA 1,1
TM CEFB,X'60' SCI OR SCI/FIX
BO CEF2
SR 1,1 NO INTEGER PORTION REQUIRED
CEF2 CH 1,CEFI CHECK AGAINST LIMIT
BNH CEF3
STH 1,CEFI SET MINIMUM
*
CEF3 MVI CEFS,C'+' ASSUME POSITIVE VALUE
LTDR 0,0 TEST INPUT VALUE
BNM CEF4 IF NOT NEGATIVE
MVI CEFS,C'-' SET NEGATIVE SIGN
*
CEF4 MVC CEFO,CEFO-1 CLEAR OUTPUT AREA
LA 7,CEFO POINT TO OUTPUT AREA
CLI CEFC,X'04' SEE IF LEADING SIGN OR CURRENCY
BL CEF8 DO NOT ALLOW SPACE FOR IT
CLI CEFC,X'06' SEE IF + SIGN OPTION
BE CEF6
CLI CEFC,X'07' SEE IF - SIGN OPTION
BE CEF5 IF SO
MVI 0(7),C'$' SET CURRENCY SIGN
B CEF7
CEF5 CLI CEFS,C'+' SEE IF POSITIVE
BE CEF7 IF SO
CEF6 MVC 0(1,7),CEFS STORE SIGN
CEF7 LA 7,1(,7) ADVANCE POINTER
*
CEF8 SR 6,6 SET ZERO EXPONENT
LPDR 0,0 SET POSITIVE SIGN
BZ CEF14 IF ZERO ARG
*
LD 4,=D'1.0' COMPUTE ROUNDING FACTOR
LH 2,CEFF GET NUMBER OF FRACTION DIGITS
SLL 2,3 INDEX INTO SCALE TABLE
DD 4,CEFT00(2) 1.0/SCALE FACTOR
HDR 4,4 1.0/(2*SCALE FACTOR)
*
CEF9 TM CEFB,X'40' SEE IF SCI FORMAT
BO CEF10 IF SO
LH 1,CEFI GET INTEGER DIGITS REQUIRED
SLL 1,3 X LENGTH OF FP NUMBER
CD 0,CEFT00(1) SEE IF TOO LARGE FOR F FORMAT
BNL CEF10 IF NOT
TM CEFB,X'80' SEE IF FIXED POINT
BO CEF13 NO SCALING IF SO
CD 0,=D'1.0' SEE IF ARG LT 1
BNL CEF13 IF NOT
TM CEFB,X'10' SEE IF ENG FORMAT
BO CEF10 SCALE ARG IF ENG
LH 1,CEFF PREPARE FOR SIGNIFICANCE LOSS TEST
SLL 1,3
LD 2,=D'1.0'
DD 2,CEFT00(1) SIGNIFICANCE FACTOR
CDR 0,2
BH CEF13 IF SOME SIGNIFICANCE RETAINED
*
CEF10 LD 2,CEFT01 PRESET SCI SCALING FACTOR
LA 2,1 SET SCALE = 1
TM CEFB,X'10' SEE IF ENG FORMAT REQUIRED
BZ CEF11 IF NOT
LD 2,CEFT03 SET ENG SCALING FACTOR
LA 2,3 SET SCALE = 3
CEF11 CD 0,=D'1.0'
BNL CEF12 IF NEG SCALING NOT REQUIRED
MDR 0,2 SCALE IT
SR 6,2 ADJUST EXPONENT
B CEF11 LOOP FOR ALL NEG SCALING
CEF12 CDR 0,2 CHECK FOR POSITIVE SCALING
BL CEF13 IF OK
DDR 0,2 SCALE IT
AR 6,2 ADJUST EXPONENT
B CEF12
*
CEF13 LTDR 4,4 SEE IF ANY ROUNDING FACTOR
BZ CEF14
ADR 0,4 ROUND SCALED RESULT
LD 4,=D'0' ZERO OUT ROUNDING FACTOR
B CEF9
*
CEF14 STD 0,CEFA SAVE ROUNDED ABS OF INPUT VALUE
*
LH 2,CEFI GET INTEGER POSITIONS
BAL 14,FAM FIX AND MOVE INTEGER DIGITS
*
LH 2,CEFF GET NUMBER OF FRACTION DIGITS
SLA 2,3 X LENGTH OF FP NUMBER
BZ CEF15 IF NO FRACTION DIGITS REQUIRED
MVI 0(7),C'.' STORE DECIMAL POINT
LA 7,1(,7) SKIP DECIMAL POINT
AD 0,=D'0' GET FRACTION
SD 0,CEFA
LPDR 0,0 ...
MD 0,CEFT00(2) SCALE FRACTION INTO INTEGER
LH 2,CEFF GET FRACTION POSITIONS
BAL 14,FAM FIX AND MOVE FRACTION DIGITS
*
CEF15 TM CEFB,X'40' SEE IF SCIENTIFIC
BO CEF16 ALWAYS DISPLAY EXPONENT IF SCI
LTR 6,6 SEE IF ANY EXPONENT
BZ CEF18 IF NOT
CEF16 MVC 0(2,7),=C'E+' STORE EXP INDICATOR
LTR 6,6 SEE IF NEGATIVE EXPONENT
BNM CEF17
MVI 1(7),C'-' SET NEGATIVE EXP
CEF17 LPR 6,6 CONVERT EXPONENT
CVD 6,DWORK ...
OI DWORK+7,X'0F' PRINTABLE SIGN
UNPK 2(2,7),DWORK MOVE TO OUTPUT LINE
LA 7,4(,7) SKIP EXPONENT
*
CEF18 CLI CEFS,C'-' SEE IF NEGATIVE
BNE CEF21 IF NOT
CLI CEFC,X'05' CHECK FOR LEADING SIGN
BH CEF21 IF LEADING SIGN
CLI CEFC,X'01'
BL CEF21 IF NO SIGN DISPLAYED
BH CEF19 IF CR OR DB
MVI 0(7),C'-' STORE NEG SIGN
LA 7,1(,7) SKIP NEG SIGN
B CEF21
CEF19 MVC 0(2,7),=C'DB' STORE A DEBIT SYMBOL
TM CEFC,X'01' SEE IF DEBIT
BO CEF20 IF SO
MVC 0(2,7),=C'CR' STORE A CREDIT SYMBOL
CEF20 LA 7,2(,7) SKIP CR OR DB
*
CEF21 TM CEFB,X'08' SEE IF PERCENTAGE OUTPUT
BZ CEF22 IF NOT
MVI 0(7),C'%' STORE PERCENT SIGN
LA 7,1(,7) SKIP PERCENT SIGN
*
CEF22 LA 1,CEFO-1 ZERO SUPPRESS OUTPUT
CEF23 LA 1,1(,1) NEXT DIGIT
CLI 1(1),C'0' SEE IF ZERO
BNE CEFX IF DONE
CLI 2(1),C'0' SEE IF NEXT CHAR IS A DIGIT
BL CEFX IF NOT
MVC 1(1,1),0(1) MOVE SIGN OR CURRENCY
MVI 0(1),C' ' SPACE OUT ORIGINAL LOC
B CEF23 LOOP FOR ALL ZEROS TO BE SUPPRESSED
*
CEFX L 13,4(,13) RESTORE SAVE AREA ADDR
LM 14,12,12(13) RESTORE REGS
SR 15,15
BR 14
*
DC C' '
CEFO DC CL40' ' OUTPUT AREA
*
CEFT00 DC D'1.0E+00' POWERS OF 10
CEFT01 DC D'1.0E+01'
CEFT02 DC D'1.0E+02'
CEFT03 DC D'1.0E+03'
CEFT04 DC D'1.0E+04'
CEFT05 DC D'1.0E+05'
CEFT06 DC D'1.0E+06'
CEFT07 DC D'1.0E+07'
CEFT08 DC D'1.0E+08'
CEFT09 DC D'1.0E+09'
CEFT10 DC D'1.0E+10'
CEFT11 DC D'1.0E+11'
CEFT12 DC D'1.0E+12'
CEFT13 DC D'1.0E+13'
CEFT14 DC D'1.0E+14'
CEFT15 DC D'1.0E+15'
CEFT16 DC D'1.0E+16'
*
CEFA DC D'0' HOLD FOR INPUT ARG
*
CEFB DC X'00' FLAG BYTE
CEFC DC X'00' SIGN OPTION
*
CEFR DC X'0000000000000001' ROUNDING FACTOR
*
CEFS DC C'+' SIGN
*
CEFF DC H'0' NUMBER OF FRACTION DIGITS
CEFI DC H'0' NUMBER OF INTEGER DIGITS
*
CEFV DC 18F'0' SAVE AREA
.FAM SPACE 2
** FAM -- FIX AND MOVE
*
*
FAM STM 14,2,12(13)
AW 0,FAMF ADD IN FIX CONSTANT
STD 0,DWORK SAVE FIXED VALUE
CLI DWORK,X'4E' SEE IF OVERFLOW
BH ERR1 IF OVERFLOW
XC FAMW,FAMW CLEAR WORK AREA
SR 0,0 GET UPPER PART OF INTEGER
ICM 0,B'0111',DWORK+1 ...
L 1,DWORK+4 GET LOWER PART
SLDL 0,1 MAKE BOTTOM POSITIVE
SRL 1,1 ...
CVD 0,FAMW+8 CONVERT UPPER
MP FAMW,=P'2147483648' SCALE IT
CVD 1,DWORK CONVERT LOWER TO DECIMAL
AP FAMW,DWORK ADD IN LOWER PART
OI FAMW+15,X'0F' PRINTABLE SIGN
BCTR 2,0 LENGTH CODE
SLL 2,4 SHIFT INTO POSITION
EX 2,FAMX1 MOVE DIGITS TO OUTPUT
SRL 2,4 RESTORE LENGTH CODE
LA 7,1(2,7) SKIP DIGITS MOVED
LM 14,2,12(13)
BR 14
*
ERR1 L 13,4(,13) RESTORE SAVE AREA ADDR
LM 14,12,12(13) RESTORE REGS
LA 15,4 GIVE RC = 4, OVERFLOW
BR 14
*
FAMX1 UNPK 0(0,7),FAMW MOVE DIGITS TO OUTPUT AREA
*
DS 0D
FAMF DC X'4E00000000000000' FIX CONSTANT
*
FAMW DC XL16'00' WORK AREA
*
DWORK DC D'0' WORK
------------------ Cut Here -----------------------------
Roy Frederick - royf@attctc
Dallas County Data Services
504 Records Building
Dallas, TX 75202
(214) 653-6340