CP/M/CPM_CDROM.iso/cpm/bdsc/bdsc-1/fp.csm

Text File | 1994-07-13 | 10KB | 690 lines

;
; FP and LONG functions for floating point and long packages
;

    INCLUDE "bds.lib"


    FUNCTION    fp

    CALL    arghak
    PUSH    B        ; save BC
     LXI    H,COMMON$EXIT

    PUSH    H        ; save the common exit addr in the stack
    LDA    arg1        ;Get code ptr
    RAL            ;Multiply code by 2
    MOV    E,A
    MVI    D,0        ;Move result to DE
    LXI    H,JMPTAB    ;Get JMPTAB addr
    DAD    D        ;Add offset to it
    XCHG            ;Store result in DE
    LDAX    D
    MOV    L,A
    INX    D
    LDAX    D
    MOV    H,A        ;Move table addr to HL
    PCHL            ;Jump to selected routine
JMPTAB:
    DW    XNORM
    DW    XADD
    DW    XSUB
    DW    XMULT
    DW    XDIV
    DW    XFTOA

COMMON$EXIT:
    POP    B        ; restore BC
    RET            ; return to BDS C

XNORM:
    CALL    LD$OP1
    CALL    FPNORM
EXIT0:
    CALL    ST$ACC
    RET

XADD:
    CALL    LD$OP2
    CALL    FPADD
    JMP    EXIT0
XSUB:
    CALL    LD$OP2
    CALL    FPSUB
    JMP    EXIT0
XMULT:
    CALL    LD$OP2
    CALL    FPMULT
    JMP    EXIT0

XDIV:
    CALL    LD$OP2
    CALL    FPDIV
    JMP    EXIT0

XFTOA:
    CALL    LD$OP1
    CALL    FTOA
    RET

LD$OP1:
    LHLD    arg3
    XCHG
    LXI    H,FPACC-1
    MVI    M,0
    INX    H
    MVI    C,5
    CALL    MOVE
    RET

LD$OP2:
    CALL    LD$OP1
    LHLD    arg4
    XCHG
    LXI    H,FPOP-1
    MVI    M,0
    INX    H
    MVI    C,5
    CALL    MOVE
    RET

ST$ACC:
    LHLD    arg2
    LXI    D,FPACC
    MVI    C,5
    CALL    MOVE
    RET

FPNORM:
    LDA    FPACC+3        ;Get MS byte of FPACC
    STA    SIGN        ;Save SIGN byte of FPACC
    ANA    A        ;If number is positive
    JP    NZERO$TEST    ;.. go test for zero
    LXI    H,FPACC-1    ;Load addr of FPACC (+ xtra byte)
    MVI    C,5        ;Load precision register
    CALL    NEGATE        ;Negate FPACC

NZERO$TEST:
    LXI    H,FPACC-1
    MVI    C,5
    CALL    ZERO$TEST    ;If FPACC not zero
    JNZ    NOTZERO        ;.. go normalize
    STA    FPACCX        ;make sure exponent is zero
    RET

NOTZERO:
    LXI    H,FPACC-1
    MVI    C,5
    CALL    SHIFTL        ;shift FPACC left
    LXI    H,FPACCX
    DCR    M        ;subtract 1 from FPACC exponent
    LDA    FPACC+3        ;get MS byte of FPACC
    ANA    A        ;if high order bit not no
    JP    NOTZERO        ;.. go do again

;compensate for last shift

    LXI    H,FPACCX
    INR    M
    DCX    H
    MVI    C,5
    CALL    SHIFTR
    LDA    SIGN        ;fetch original sign
    RAL            ;shift sign bit into carry
    RNC            ;exit if orig # was positive
    LXI    H,FPACC-1
    MVI    C,5
    CALL    NEGATE        ;2's complement FPACC
    RET            ;Exit FPNORM
FPADD:
    LXI    H,FPACC
    MVI    C,4
    CALL    ZERO$TEST        ;if FPACC not = zero
    JNZ    TEST$FPOP        ;.. go test FPOP for zero
    LXI    H,FPACC
    LXI    D,FPOP
    MVI    C,5
    CALL    MOVE        ;Move FPOP to  FPACC
    RET            ;Exit FPADD
TEST$FPOP:
    LXI    H,FPOP
    MVI    C,4
    CALL    ZERO$TEST    ;if FPOP = 0
    RZ            ;.. exit FPADD
    LDA    FPACCX
    LXI    H,FPOPX
    SUB    M        ;if exponents are equal
    JZ    ADD$SETUP    ;.. go to add setup
    JP    RANGE$TEST    ;if diff of exp >=0,goto range test
    CMA
    INR    A        ;ABS of difference

RANGE$TEST:
    CPI    32        ;if diff < 32
    JM    ALGN$OPRNDS    ;.. we can go align the operands
    LXI    H,FPACCX
    LDA    FPOPX
    SUB    M        ;if exp of FPACC > exp of FPOP
    RM            ;.. exit FPADD
    LXI    D,FPOP
    LXI    H,FPACC
    MVI    C,5
    CALL    MOVE        ;move FPOP to FPACC
    RET            ;Exit FPADD

ALGN$OPRNDS:
    LDA    FPACCX
    LXI    H,FPOPX
    SUB    M        ;subt exponents
    MOV    B,A        ;save difference of exponents
    JM    SHFT$FPACC    ;if diff neg, go shift FPACC

ALGN$FPOP:
    LXI    H,FPOPX
    CALL    SHFT$LOOP    ;shift FPOP & increment exponent
    DCR    B        ;Decrement diff register
    JNZ    ALGN$FPOP    ;loop until exponents are equal
    JMP    ADD$SETUP    ;go to add setup

SHFT$FPACC:
    LXI    H,FPACCX
    CALL    SHFT$LOOP    ;shift FPACC & increment exponent
    INR    B        ;increment difference register
    JNZ    SHFT$FPACC    ;loop until exponents are equal

ADD$SETUP:
    XRA    A
    STA    FPACC-1
    STA    FPOP-1
    LXI    H,FPACCX
    CALL    SHFT$LOOP    ;shift FPACC right
    LXI    H,FPOPX
    CALL    SHFT$LOOP    ;shift FPOP right
    LXI    H,FPACC-1
    LXI    D,FPOP-1
    MVI    C,5
    CALL    ADDER        ;add FPOP to FPACC
    CALL    FPNORM        ;normalize result
    RET            ;exit FPADD

SHFT$LOOP:
    INR    M        ;increment exponent
    DCX    H        ;decrement ptr
    MVI    C,4
    MOV    A,M        ;get MS byte
    ANA    A        ;if negative number
    JM    SHFT$MINUS    ;.. goto negative shift
    CALL    SHIFTR        ;shift mantissa
    RET

SHFT$MINUS:
    STC            ;set carry
    CALL    SHFTR        ;shift mantissa progatating sign
    RET            ;exit

FPSUB:
    LXI    H,FPACC
    MVI    C,4
    CALL    NEGATE
    JMP    FPADD

FPMULT:
    CALL    SIGNJOB        ;process the signs
    LXI    H,WORK
    MVI    C,8
    CALL    ZERO$MEMORY    ;WORK := 0 (partial product)
    LXI    H,FPACCX
    LDA    FPOPX
    ADD    M
    INR    A        ;compensate for algolrithm
    MOV    M,A        ;add FPOP exp to FPACC exponent
    LXI    H,FPACC-4
    MVI    C,4
    CALL    ZERO$MEMORY    ;clear multiplicand extra bytes
    LXI    H,BITS
    MVI    M,31

MULT$LOOP:
    LXI    H,FPOP+3
    MVI    C,4
    CALL    SHIFTR        ;shift multiplier right
    CC    ADD$MULTIPLICAND ;add multiplicand if carry
    LXI    H,WORK+7
    MVI    C,8
    CALL    SHIFTR        ;shift partial product right
    LXI    H,BITS
    DCR    M        ;decrement BITS counter
    JNZ    MULT$LOOP    ;if not zero, do again
    LXI    H,WORK+7
    MVI    C,8
    CALL    SHIFTR        ;shift once more for rounding
    LXI    H,WORK+3
    MOV    A,M
    RAL            ;fetch 32th bit
    ANA    A        ;if it is a 1
    CM    ROUND$IT    ;.. round the result
    LXI    D,WORK+3
    LXI    H,FPACC-1
    MVI    C,5
EXMLDV:
    CALL    MOVE
    LDA    SIGN        ;fetch SIGN and save it on the stack
    PUSH    PSW
    CALL    FPNORM
    POP    PSW
    ANA    A
    RP
    LXI    H,FPACC
    MVI    C,4
    CALL    NEGATE
    RET

ADD$MULTIPLICAND:
    LXI    H,WORK
    LXI    D,FPACC-4
    MVI    C,8
    CALL    ADDER
    RET
ROUND$IT:
    MVI    A,40H
    ADD    M
    MVI    C,4
RND$LOOP:
    MOV    M,A
    INX    H
    MVI    A,0
    ADC    M
    DCR    C
    JNZ    RND$LOOP
    MOV    M,A
    RET
FPDIV:
    LXI    H,FPOP
    MVI    C,4
    CALL    ZERO$TEST
    JNZ    DIV$SIGN
    LXI    H,FPACC
    MVI    C,5
    CALL    ZERO$MEMORY
    RET

DIV$SIGN:
    CALL    SIGNJOB
    LXI    H,WORK
    MVI    C,12
    CALL    ZERO$MEMORY
    MVI    A,31
    STA    BITS
    LXI    H,FPACCX
    LDA    FPOPX
    MOV    B,A
    MOV    A,M
    SUB    B
    INR    A
    MOV    M,A
DIVIDE:
    CALL    SETSUB        ;WORK2 := dividend - divisor
    JM    NOGO        ;if minus, go put 0 in quotient
    LXI    H,FPACC
    LXI    D,WORK2
    MVI    C,4
    CALL    MOVE        ;move subt results to dividend
    STC
    JMP    QUOROT

NOGO:
    ANA    A
QUOROT:
    LXI    H,WORK+4
    MVI    C,4
    CALL    SHFTL        ;Insert carry flag into quotient
    LXI    H,FPACC
    MVI    C,4
    CALL    SHFTL        ;shift dividend left
    LXI    H,BITS
    DCR    M        ;decrement BITS counter
    JNZ    DIVIDE        ;loop until BITS = zero
    CALL    SETSUB        ;1 more time for rounding
    JM    DVEXIT        ;if 24th bit = 0, goto exit
    LXI    H,WORK+4
    LXI    D,ONE
    MVI    C,4
    CALL    ADDER
    LXI    H,WORK+7
    MOV    A,M
    ANA    A
    JP    DVEXIT
    MVI    C,4
    CALL    SHIFTR
    LXI    H,FPACCX
    INR    M
DVEXIT:
    LXI    H,FPACC
    LXI    D,WORK+4
    MVI    C,4
    JMP    EXMLDV

SETSUB:
    LXI    D,FPACC
    LXI    H,WORK2
    MVI    C,4
    CALL    MOVE        ;move dividend to work2
    LXI    H,WORK2
    LXI    D,FPOP
    MVI    C,4
    CALL    SUBBER        ;subtract divisor from work2
    LDA    WORK2+3
    ANA    A
    RET

FTOA:
    LHLD    arg2
    SHLD    ASCII$PTR
    MVI    M,' '
    LDA    FPACC+3
    ANA    A
    JP    BYSIGN
    MVI    M,'-'
    LXI    H,FPACC
    MVI    C,4
    CALL    NEGATE
BYSIGN:
    LHLD    ASCII$PTR
    INX    H
    MVI    M,'0'
    INX    H
    MVI    M,'.'
    INX    H
    SHLD    ASCII$PTR
    XRA    A
    STA    EXP
    LXI    H,FPACC
    MVI    C,4
    CALL    ZERO$TEST
    JNZ    SU$FTOA
    MVI    C,7
    LHLD    ASCII$PTR
ZERO$LOOP:
    MVI    M,'0'
    INX    H
    DCR    C
    JNZ    ZERO$LOOP
    SHLD    ASCII$PTR
    JMP    EXPOUT
SU$FTOA:
    LXI    H,FPACCX
    DCR    M
DECEXT:
    JP    DECEXD
    MVI    A,4
    ADD    M
    JP    DECOUT
    CALL    FPX10
DECREP:
    LXI    H,FPACCX
    MOV    A,M
    ANA    A
    JMP    DECEXT

DECEXD:
    CALL    FPD10
    JMP    DECREP

DECOUT:
    LXI    H,FPACC
    LXI    D,ADJ
    MVI    C,4
    CALL    ADDER
    LXI    H,OUTAREA
    LXI    D,FPACC
    MVI    C,4
    CALL    MOVE
    LXI    H,OUTAREA+4
    MVI    M,0
    LXI    H,OUTAREA
    MVI    C,4
    CALL    SHIFTL
    CALL    OUTX10
COMPEN:
    LXI    H,FPACCX
    INR    M
    JZ    OUTDIG
    LXI    H,OUTAREA+4
    MVI    C,5
    CALL    SHIFTR
    JMP    COMPEN
OUTDIG:
    MVI    A,7
    STA    DIGCNT
    LXI    H,OUTAREA+4
    MOV    A,M
    ANA    A
    JZ    ZERODG
OUTDGS:
    LXI    H,OUTAREA+4
    MVI    A,'0'
    ADD    M
    LHLD    ASCII$PTR
    MOV    M,A
    INX    H
    SHLD    ASCII$PTR
DECRDG:
    LXI    H,DIGCNT
    DCR    M
    JZ    EXPOUT
    CALL    OUTX10
    JMP    OUTDGS

ZERODG:
    LXI    H,EXP
    DCR    M
    LXI    H,OUTAREA
    MVI    C,5
    CALL    ZERO$TEST
    JNZ    DECRDG
    XRA    A
    STA    DIGCNT
    JMP    DECRDG

OUTX10:
    XRA    A
    STA    OUTAREA+4
    LXI    H,WORK
    LXI    D,OUTAREA
    MVI    C,5
    CALL    MOVE
    LXI    H,OUTAREA
    MVI    C,5
    CALL    SHIFTL
    LXI    H,OUTAREA
    MVI    C,5
    CALL    SHIFTL
    LXI    D,WORK
    LXI    H,OUTAREA
    MVI    C,5
    CALL    ADDER
    LXI    H,OUTAREA
    MVI    C,5
    CALL    SHIFTL
    RET
EXPOUT:
    LHLD    ASCII$PTR
    MVI    M,'E'
    INX    H
    LDA    EXP
    ANA    A
    JP    EXPOT
    CMA
    INR    A
    STA    EXP
    MVI    M,'-'
    INX    H
    LDA    EXP
EXPOT:
    MVI    C,0
EXPLOOP:
    SUI    10
    JM    TOMUCH
    STA    EXP
    INR    C
    JMP    EXPLOOP

TOMUCH:
    MVI    A,'0'
    ADD    C
    MOV    M,A
    INX    H
    LDA    EXP
    ADI    '0'
    MOV    M,A
    INX    H
    MVI    M,0
    RET
FPX10:
    LXI    H,FPOP
    LXI    D,TEN
    MVI    C,5
    CALL    MOVE
    CALL    FPMULT
    LXI    H,EXP
    DCR    M
    RET

FPD10:
    LXI    H,FPOP
    LXI    D,ONE$TENTH
    MVI    C,5
    CALL    MOVE
    CALL    FPMULT
    LXI    H,EXP
    INR    M
    RET

NEGATE:
    STC            ;CARRY forces an add of 1
NEGAT$LOOP:
    MOV    A,M        ;fetch byte
    CMA            ;complement it
    ACI    0        ;make it two's complement
    MOV    M,A        ;store the result
    INX    H        ;bump ptr
    DCR    C        ;decrement precision register
    JNZ    NEGAT$LOOP    ;if not done, go do it again
    RET            ;Return to caller

ZERO$TEST:
    XRA    A        ;clear A
    ORA    M        ;'OR' A with next byte
    INX    H        ;bump ptr
    DCR    C        ;decrement precision register
    JNZ    ZERO$TEST+1    ;loop until done
    ANA    A        ;set flags
    RET

SHIFTL:
    ANA    A        ;clear CARRY
SHFTL:
    MOV    A,M        ;get next byte
    RAL            ;shift it left
    MOV    M,A        ;store result
    INX    H        ;bump ptr
    DCR    C        ;decrement precision register
    JNZ    SHFTL        ;loop until done
    RET

SHIFTR:
    ANA    A
SHFTR:
    MOV    A,M
    RAR
    MOV    M,A
    DCX    H
    DCR    C
    JNZ    SHFTR
    RET

ADDER:
    ANA    A
ADD$LOOP:
    LDAX    D
    ADC    M
    MOV    M,A
    INX    D
    INX    H
    DCR    C
    JNZ    ADD$LOOP
    RET

SUBBER:
    ANA    A
    XCHG
SUB$LOOP:
    LDAX    D
    SBB    M
    STAX    D
    INX    D
    INX    H
    DCR    C
    JNZ    SUB$LOOP
    XCHG
    RET

ZERO$MEMORY:
    MVI    M,0
    INX    H
    DCR    C
    JNZ    ZERO$MEMORY
    RET

MOVE:
    LDAX    D
    MOV    M,A
    INX    D
    INX    H
    DCR    C
    JNZ    MOVE
    RET

SIGNJOB:
    LDA    FPACC+3
    STA    SIGN
    ANA    A
    JP    CKFPOP
    LXI    H,FPACC
    MVI    C,4
    CALL    NEGATE
CKFPOP:
    LXI    H,SIGN
    LDA    FPOP+3
    XRA    M
    MOV    M,A
    LDA    FPOP+3
    ANA    A
    RP
    LXI    H,FPOP
    MVI    C,4
    CALL    NEGATE
    RET

    DS    4
FPACC:    DS    4
FPACCX:    DS    1
    DS    4
FPOP:    DS    4
FPOPX:    DS    1
SIGN:    DS    1
WORK:    DS    8
WORK2:    DS    4
BITS:    DS    1
ASCII$PTR:    DS    2
EXP:    DS    1
OUTAREA:    DS    5
DIGCNT:    DS    1
ONE$TENTH:    DB    66H,66H,66H,66H,0FDH
TEN:    DB    0,0,0,50H,4
ADJ:    DB    5,0,0,0
ONE:    DB    80H,0,0,0

    ENDFUNC