Oakland CPM Archive

home *** CD-ROM | disk | FTP | other *** search

/ Oakland CPM Archive / oakcpm.iso / cpm / bdsc-1 / fp.cqm / FP.CSM

Wrap

Text File | 1985-02-10 | 9.9 KB | 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