The RTOS.I include file resides on the Kyan Pascal 2.x Utilities Disk 1.
- PROCEDURE REALTOSTR(VAR NUM:REAL; LEAD,DPT:INTEGER; VAR RESULT:STRING20);
Source Code
PROCEDURE REALTOSTR(VAR NUM:REAL; LEAD,DPT:INTEGER; VAR RESULT:STRING20);
BEGIN
#A
STX _T
LDY #5
LDA (_SP),Y
STA _T+3 ;ADDRESS OF RESULT STRING
INY
LDA (_SP),Y
STA _T+4
LDY #11
LDA (_SP),Y ;ADDRESS OF REAL NUMBER
STA _T+1
INY
LDA (_SP),Y
STA _T+2
LDY #8
LDA (_SP),Y ;DECIMAL FIELD LENGTH MSB
BNE RTS1
DEY
LDA (_SP),Y
CMP #14
BCC RTS2
RTS1 LDA #13
RTS2 STA _T+6
LDY #10 ;LEADING DIGITS MSB
LDA (_SP),Y
BNE RTS3
DEY
LDA (_SP),Y
CMP #21
BCC RTS4
RTS3 LDA #20
RTS4 STA _T+7
;
LDY #0
STY _T+5 ;INDEX INTO STRING SPACE
LDA (_T+1),Y ;FIRST BYTE OF #
AND #$30 ;CLEAR ALL BUT BITS 4&5
ASL
ASL
STA _T+8 ;BIT 7 ON IF # -, BIT6 ON IF EXP -
INY
STY _T+9 ;SIG. DIGIT
;
LDA _T+7
BNE *+5
JMP RTSE ;USE E+/- NOTATION
LDY #7
LDA (_T+1),Y ;EXPONANT IN BCD
CLC
PHA
AND #$F0 ;STRIP LOW NIBBLE
LSR
STA _T+10 ;UPPER*8
LSR
LSR
LSR
PHA
ADC _T+10
STA _T+10
PLA
ADC _T+10
STA _T+10
PLA ;ADD LOWER NIBBLE
AND #15
ADC _T+10
STA _T+10 ;HEX EXPONANT
BIT _T+8
BVC RTS3A ;+ EXP USES NORMAL TEST
BPL RTS4C ;IF SIGN OF # IS + ALWAYS PASSES
INC _T+10 ;MUST INC FOR DEC LATER
LDA _T+7
CMP #1 ;IF LEADING CAME IN AS 1 THEN THERE'S NO
BNE RTS4C ;ROOM FOR THE - SIGN SO GIVE #S
LDY #'#
BNE RTS4D ;ALWAYS
RTS3A BPL RTS4A
INC _T+10 ;YES:COMPENSATE BY EXTRA PLACE TO LEFT OF .
RTS4A EQU *
LDY #'#
LDA _T+10
CMP _T+7 ;EXPONANT >= LEADING?
BCS *+4 ;YES:FILL WITH #
RTS4C LDY #$20 ;BLANKS
RTS4D TYA
LDY #19
RTS5 STA (_T+3),Y ;FILL STRING
DEY
BPL RTS5
CMP #'#
BEQ RTS99 ;EXIT IF OVERFLOW
BIT _T+8
BPL RTS5A
DEC _T+10
RTS5A EQU *
BIT _T+8
BVC RTS6
LDY _T+7 ;IF EXP WAS MINUS, USE LEADING ZERO
BIT _T+8 ;# NEG ALSO?
BPL RTS5B ;NO
DEY
DEY
LDA #'-
STA (_T+3),Y
INY
BNE *+3
RTS5B DEY ;PUT ZERO TO LEFT OF .
LDA #'0
STA (_T+3),Y
INY
BNE RTS10 ;AND WRITE REMAINDER OF NUMBER
RTS6 EQU *
SEC
LDA _T+7
SBC _T+10 ;START @ LEADING - EXPONANT - 1
TAY
DEY
BIT _T+8 ;NEED MINUS SIGN?
BPL RTS7
LDA #'-
DEY
STA (_T+3),Y
INY
RTS7 JSR RTS20 ;PUT SIG# IN _T+9 IN STRING @ Y
INY
CPY _T+7
BNE RTS7 ;WRITE ALL LEADING DIGITS
RTS10 LDA _T+6 ;# OF DEC. PLACES
BEQ RTS99 ;IF NONE WE'RE DONE
LDA #'. ;Y IS ALWAYS = _T+7
STA (_T+3),Y ;WRITE DEC. POINT
BIT _T+8 ;USING NEG EXP?
BVC RTS11 ;NO
LDA #'0
RTS12 EQU *
DEC _T+10
BEQ RTS11
INY ;INSERT LEADING ZEROS
STA (_T+3),Y
DEC _T+6
BEQ RTS99
BNE RTS12
RTS11 INY
JSR RTS20 ;PUT REMAINDER OF # IN
DEC _T+6 ;UNTIL ALL DEC. REQUESTED WRITTEN
BEQ RTS99
CPY #19 ;OR STRING FILLED
BNE RTS11
RTS99 LDX _T
#
END;
#A
RTS20 EQU *
STY _T+5
CLC
LDA _T+9 ;SIG DIGIT # (1-13)
LSR ;/2
TAY
LDA (_T+1),Y
LDY _T+5
BCC RTS21 ;C=0 FOR EVEN SIG#
AND #15 ;STRIP UPPER NIBBLE
ADC #$2F ;2F+1 FOR CARRY = $30
BNE RTS22 ;ALWAYS
RTS21 AND #$F0 ;STRIP LOWER
LSR
LSR
LSR
LSR
CLC
ADC #$30
RTS22 STA (_T+3),Y
INC _T+9
RTS
;
RTSE EQU * ;RETURN NUMBER IN SCI NOTATION
LDY #$20 ;ASSUME SPACE AS LEADING CHAR
BIT _T+8 ;# NEG?
BPL *+4
LDY #'-
TYA
LDY #0
STA (_T+3),Y ;FIRST CHAR EITHER BLANK OR -
INY
JSR RTS20 ;PRINT 1ST DIGIT
LDA _T+6 ;# OF DEC PLACES
BEQ RTSE2
INY
LDA #'.
STA (_T+3),Y ;PUT IN DECPT NEXT
RTSE1 EQU *
INY
JSR RTS20
CPY #15
BEQ RTSE2 ;PRINT E+/- & END
DEC _T+6
BNE RTSE1
RTSE2 EQU * ;PUT IN E AND EXPONANT
INY
LDA #'E
STA (_T+3),Y
LDX #'+
BIT _T+8 ;EXP + OR -?
BVC *+4
LDX #'-
TXA
INY
STA (_T+3),Y
INY
LDA #14 ;PRINT EXP VIA RTS20
STA _T+9
JSR RTS20
INY
JSR RTS20
RTSE4 LDA #$20
RTSE3 INY
CPY #20 ;BUFFER REMAINDER W/BLANKS
BEQ RTS99
STA (_T+3),Y
BNE RTSE3 ;ALWAYS
#
No comments:
Post a Comment