home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / BDSC / BDSC-1 / FP.CSM < prev    next >
Text File  |  2000-06-30  |  10KB  |  690 lines
  1. ;
  2. ; FP and LONG functions for floating point and long packages
  3. ;
  4.  
  5.     INCLUDE "bds.lib"
  6.  
  7.  
  8.     FUNCTION    fp
  9.  
  10.     CALL    arghak
  11.     PUSH    B        ; save BC
  12.      LXI    H,COMMON$EXIT     
  13.  
  14.     PUSH    H        ; save the common exit addr in the stack
  15.     LDA    arg1        ;Get code ptr
  16.     RAL            ;Multiply code by 2
  17.     MOV    E,A
  18.     MVI    D,0        ;Move result to DE
  19.     LXI    H,JMPTAB    ;Get JMPTAB addr
  20.     DAD    D        ;Add offset to it
  21.     XCHG            ;Store result in DE
  22.     LDAX    D
  23.     MOV    L,A
  24.     INX    D
  25.     LDAX    D
  26.     MOV    H,A        ;Move table addr to HL
  27.     PCHL            ;Jump to selected routine
  28. JMPTAB:
  29.     DW    XNORM
  30.     DW    XADD
  31.     DW    XSUB
  32.     DW    XMULT
  33.     DW    XDIV
  34.     DW    XFTOA
  35.  
  36. COMMON$EXIT:
  37.     POP    B        ; restore BC
  38.     RET            ; return to BDS C
  39.  
  40. XNORM:
  41.     CALL    LD$OP1
  42.     CALL    FPNORM
  43. EXIT0:
  44.     CALL    ST$ACC
  45.     RET
  46.  
  47. XADD:
  48.     CALL    LD$OP2
  49.     CALL    FPADD
  50.     JMP    EXIT0
  51. XSUB:
  52.     CALL    LD$OP2
  53.     CALL    FPSUB
  54.     JMP    EXIT0
  55. XMULT:
  56.     CALL    LD$OP2
  57.     CALL    FPMULT
  58.     JMP    EXIT0
  59.  
  60. XDIV:
  61.     CALL    LD$OP2
  62.     CALL    FPDIV
  63.     JMP    EXIT0
  64.  
  65. XFTOA:
  66.     CALL    LD$OP1
  67.     CALL    FTOA
  68.     RET
  69.  
  70. LD$OP1:
  71.     LHLD    arg3
  72.     XCHG
  73.     LXI    H,FPACC-1
  74.     MVI    M,0
  75.     INX    H
  76.     MVI    C,5
  77.     CALL    MOVE
  78.     RET
  79.  
  80. LD$OP2:
  81.     CALL    LD$OP1
  82.     LHLD    arg4
  83.     XCHG
  84.     LXI    H,FPOP-1
  85.     MVI    M,0
  86.     INX    H
  87.     MVI    C,5
  88.     CALL    MOVE
  89.     RET
  90.  
  91. ST$ACC:
  92.     LHLD    arg2
  93.     LXI    D,FPACC
  94.     MVI    C,5
  95.     CALL    MOVE
  96.     RET
  97.  
  98. FPNORM:
  99.     LDA    FPACC+3        ;Get MS byte of FPACC
  100.     STA    SIGN        ;Save SIGN byte of FPACC
  101.     ANA    A        ;If number is positive
  102.     JP    NZERO$TEST    ;.. go test for zero
  103.     LXI    H,FPACC-1    ;Load addr of FPACC (+ xtra byte)
  104.     MVI    C,5        ;Load precision register
  105.     CALL    NEGATE        ;Negate FPACC
  106.  
  107. NZERO$TEST:
  108.     LXI    H,FPACC-1
  109.     MVI    C,5
  110.     CALL    ZERO$TEST    ;If FPACC not zero
  111.     JNZ    NOTZERO        ;.. go normalize
  112.     STA    FPACCX        ;make sure exponent is zero
  113.     RET
  114.  
  115. NOTZERO:
  116.     LXI    H,FPACC-1
  117.     MVI    C,5
  118.     CALL    SHIFTL        ;shift FPACC left
  119.     LXI    H,FPACCX
  120.     DCR    M        ;subtract 1 from FPACC exponent
  121.     LDA    FPACC+3        ;get MS byte of FPACC
  122.     ANA    A        ;if high order bit not no
  123.     JP    NOTZERO        ;.. go do again
  124.  
  125. ;compensate for last shift
  126.  
  127.     LXI    H,FPACCX
  128.     INR    M
  129.     DCX    H
  130.     MVI    C,5
  131.     CALL    SHIFTR
  132.     LDA    SIGN        ;fetch original sign
  133.     RAL            ;shift sign bit into carry
  134.     RNC            ;exit if orig # was positive
  135.     LXI    H,FPACC-1
  136.     MVI    C,5
  137.     CALL    NEGATE        ;2's complement FPACC
  138.     RET            ;Exit FPNORM
  139. FPADD:
  140.     LXI    H,FPACC
  141.     MVI    C,4
  142.     CALL    ZERO$TEST        ;if FPACC not = zero
  143.     JNZ    TEST$FPOP        ;.. go test FPOP for zero
  144.     LXI    H,FPACC
  145.     LXI    D,FPOP
  146.     MVI    C,5
  147.     CALL    MOVE        ;Move FPOP to  FPACC
  148.     RET            ;Exit FPADD
  149. TEST$FPOP:
  150.     LXI    H,FPOP
  151.     MVI    C,4
  152.     CALL    ZERO$TEST    ;if FPOP = 0
  153.     RZ            ;.. exit FPADD
  154.     LDA    FPACCX
  155.     LXI    H,FPOPX
  156.     SUB    M        ;if exponents are equal
  157.     JZ    ADD$SETUP    ;.. go to add setup
  158.     JP    RANGE$TEST    ;if diff of exp >=0,goto range test
  159.     CMA
  160.     INR    A        ;ABS of difference
  161.  
  162. RANGE$TEST:
  163.     CPI    32        ;if diff < 32
  164.     JM    ALGN$OPRNDS    ;.. we can go align the operands
  165.     LXI    H,FPACCX
  166.     LDA    FPOPX
  167.     SUB    M        ;if exp of FPACC > exp of FPOP
  168.     RM            ;.. exit FPADD
  169.     LXI    D,FPOP
  170.     LXI    H,FPACC
  171.     MVI    C,5
  172.     CALL    MOVE        ;move FPOP to FPACC
  173.     RET            ;Exit FPADD
  174.  
  175. ALGN$OPRNDS:
  176.     LDA    FPACCX
  177.     LXI    H,FPOPX
  178.     SUB    M        ;subt exponents
  179.     MOV    B,A        ;save difference of exponents
  180.     JM    SHFT$FPACC    ;if diff neg, go shift FPACC
  181.  
  182. ALGN$FPOP:
  183.     LXI    H,FPOPX
  184.     CALL    SHFT$LOOP    ;shift FPOP & increment exponent
  185.     DCR    B        ;Decrement diff register
  186.     JNZ    ALGN$FPOP    ;loop until exponents are equal
  187.     JMP    ADD$SETUP    ;go to add setup
  188.  
  189. SHFT$FPACC:
  190.     LXI    H,FPACCX
  191.     CALL    SHFT$LOOP    ;shift FPACC & increment exponent
  192.     INR    B        ;increment difference register
  193.     JNZ    SHFT$FPACC    ;loop until exponents are equal
  194.  
  195. ADD$SETUP:
  196.     XRA    A
  197.     STA    FPACC-1
  198.     STA    FPOP-1
  199.     LXI    H,FPACCX
  200.     CALL    SHFT$LOOP    ;shift FPACC right
  201.     LXI    H,FPOPX
  202.     CALL    SHFT$LOOP    ;shift FPOP right
  203.     LXI    H,FPACC-1
  204.     LXI    D,FPOP-1
  205.     MVI    C,5
  206.     CALL    ADDER        ;add FPOP to FPACC
  207.     CALL    FPNORM        ;normalize result
  208.     RET            ;exit FPADD
  209.  
  210. SHFT$LOOP:
  211.     INR    M        ;increment exponent
  212.     DCX    H        ;decrement ptr
  213.     MVI    C,4
  214.     MOV    A,M        ;get MS byte
  215.     ANA    A        ;if negative number
  216.     JM    SHFT$MINUS    ;.. goto negative shift
  217.     CALL    SHIFTR        ;shift mantissa
  218.     RET
  219.  
  220. SHFT$MINUS:
  221.     STC            ;set carry
  222.     CALL    SHFTR        ;shift mantissa progatating sign
  223.     RET            ;exit
  224.  
  225. FPSUB:
  226.     LXI    H,FPACC
  227.     MVI    C,4
  228.     CALL    NEGATE
  229.     JMP    FPADD
  230.  
  231. FPMULT:
  232.     CALL    SIGNJOB        ;process the signs
  233.     LXI    H,WORK
  234.     MVI    C,8
  235.     CALL    ZERO$MEMORY    ;WORK := 0 (partial product)
  236.     LXI    H,FPACCX
  237.     LDA    FPOPX
  238.     ADD    M
  239.     INR    A        ;compensate for algolrithm
  240.     MOV    M,A        ;add FPOP exp to FPACC exponent
  241.     LXI    H,FPACC-4
  242.     MVI    C,4
  243.     CALL    ZERO$MEMORY    ;clear multiplicand extra bytes
  244.     LXI    H,BITS
  245.     MVI    M,31
  246.  
  247. MULT$LOOP:
  248.     LXI    H,FPOP+3
  249.     MVI    C,4
  250.     CALL    SHIFTR        ;shift multiplier right
  251.     CC    ADD$MULTIPLICAND ;add multiplicand if carry
  252.     LXI    H,WORK+7
  253.     MVI    C,8
  254.     CALL    SHIFTR        ;shift partial product right
  255.     LXI    H,BITS
  256.     DCR    M        ;decrement BITS counter
  257.     JNZ    MULT$LOOP    ;if not zero, do again
  258.     LXI    H,WORK+7
  259.     MVI    C,8
  260.     CALL    SHIFTR        ;shift once more for rounding
  261.     LXI    H,WORK+3
  262.     MOV    A,M
  263.     RAL            ;fetch 32th bit
  264.     ANA    A        ;if it is a 1
  265.     CM    ROUND$IT    ;.. round the result
  266.     LXI    D,WORK+3
  267.     LXI    H,FPACC-1
  268.     MVI    C,5
  269. EXMLDV:
  270.     CALL    MOVE
  271.     LDA    SIGN        ;fetch SIGN and save it on the stack
  272.     PUSH    PSW
  273.     CALL    FPNORM
  274.     POP    PSW
  275.     ANA    A
  276.     RP
  277.     LXI    H,FPACC
  278.     MVI    C,4
  279.     CALL    NEGATE
  280.     RET
  281.  
  282. ADD$MULTIPLICAND:
  283.     LXI    H,WORK
  284.     LXI    D,FPACC-4
  285.     MVI    C,8
  286.     CALL    ADDER
  287.     RET
  288. ROUND$IT:
  289.     MVI    A,40H
  290.     ADD    M
  291.     MVI    C,4
  292. RND$LOOP:
  293.     MOV    M,A
  294.     INX    H
  295.     MVI    A,0
  296.     ADC    M
  297.     DCR    C
  298.     JNZ    RND$LOOP
  299.     MOV    M,A
  300.     RET
  301. FPDIV:
  302.     LXI    H,FPOP
  303.     MVI    C,4
  304.     CALL    ZERO$TEST
  305.     JNZ    DIV$SIGN
  306.     LXI    H,FPACC
  307.     MVI    C,5
  308.     CALL    ZERO$MEMORY
  309.     RET
  310.  
  311. DIV$SIGN:
  312.     CALL    SIGNJOB
  313.     LXI    H,WORK
  314.     MVI    C,12
  315.     CALL    ZERO$MEMORY
  316.     MVI    A,31
  317.     STA    BITS
  318.     LXI    H,FPACCX
  319.     LDA    FPOPX
  320.     MOV    B,A
  321.     MOV    A,M
  322.     SUB    B
  323.     INR    A
  324.     MOV    M,A
  325. DIVIDE:
  326.     CALL    SETSUB        ;WORK2 := dividend - divisor
  327.     JM    NOGO        ;if minus, go put 0 in quotient
  328.     LXI    H,FPACC
  329.     LXI    D,WORK2
  330.     MVI    C,4
  331.     CALL    MOVE        ;move subt results to dividend
  332.     STC
  333.     JMP    QUOROT
  334.  
  335. NOGO:
  336.     ANA    A
  337. QUOROT:
  338.     LXI    H,WORK+4
  339.     MVI    C,4
  340.     CALL    SHFTL        ;Insert carry flag into quotient
  341.     LXI    H,FPACC
  342.     MVI    C,4
  343.     CALL    SHFTL        ;shift dividend left
  344.     LXI    H,BITS
  345.     DCR    M        ;decrement BITS counter
  346.     JNZ    DIVIDE        ;loop until BITS = zero
  347.     CALL    SETSUB        ;1 more time for rounding
  348.     JM    DVEXIT        ;if 24th bit = 0, goto exit
  349.     LXI    H,WORK+4
  350.     LXI    D,ONE
  351.     MVI    C,4
  352.     CALL    ADDER
  353.     LXI    H,WORK+7
  354.     MOV    A,M
  355.     ANA    A
  356.     JP    DVEXIT
  357.     MVI    C,4
  358.     CALL    SHIFTR
  359.     LXI    H,FPACCX
  360.     INR    M
  361. DVEXIT:
  362.     LXI    H,FPACC
  363.     LXI    D,WORK+4
  364.     MVI    C,4
  365.     JMP    EXMLDV
  366.  
  367. SETSUB:
  368.     LXI    D,FPACC
  369.     LXI    H,WORK2
  370.     MVI    C,4
  371.     CALL    MOVE        ;move dividend to work2
  372.     LXI    H,WORK2
  373.     LXI    D,FPOP
  374.     MVI    C,4
  375.     CALL    SUBBER        ;subtract divisor from work2
  376.     LDA    WORK2+3
  377.     ANA    A
  378.     RET
  379.  
  380. FTOA:
  381.     LHLD    arg2
  382.     SHLD    ASCII$PTR
  383.     MVI    M,' '
  384.     LDA    FPACC+3
  385.     ANA    A
  386.     JP    BYSIGN
  387.     MVI    M,'-'
  388.     LXI    H,FPACC
  389.     MVI    C,4
  390.     CALL    NEGATE
  391. BYSIGN:
  392.     LHLD    ASCII$PTR
  393.     INX    H
  394.     MVI    M,'0'
  395.     INX    H
  396.     MVI    M,'.'
  397.     INX    H
  398.     SHLD    ASCII$PTR
  399.     XRA    A
  400.     STA    EXP
  401.     LXI    H,FPACC
  402.     MVI    C,4
  403.     CALL    ZERO$TEST
  404.     JNZ    SU$FTOA
  405.     MVI    C,7
  406.     LHLD    ASCII$PTR
  407. ZERO$LOOP:
  408.     MVI    M,'0'
  409.     INX    H
  410.     DCR    C
  411.     JNZ    ZERO$LOOP
  412.     SHLD    ASCII$PTR
  413.     JMP    EXPOUT
  414. SU$FTOA:
  415.     LXI    H,FPACCX
  416.     DCR    M
  417. DECEXT:
  418.     JP    DECEXD
  419.     MVI    A,4
  420.     ADD    M
  421.     JP    DECOUT
  422.     CALL    FPX10
  423. DECREP:
  424.     LXI    H,FPACCX
  425.     MOV    A,M
  426.     ANA    A
  427.     JMP    DECEXT
  428.  
  429. DECEXD:
  430.     CALL    FPD10
  431.     JMP    DECREP    
  432.  
  433. DECOUT:
  434.     LXI    H,FPACC
  435.     LXI    D,ADJ
  436.     MVI    C,4
  437.     CALL    ADDER
  438.     LXI    H,OUTAREA
  439.     LXI    D,FPACC
  440.     MVI    C,4
  441.     CALL    MOVE
  442.     LXI    H,OUTAREA+4
  443.     MVI    M,0
  444.     LXI    H,OUTAREA
  445.     MVI    C,4
  446.     CALL    SHIFTL
  447.     CALL    OUTX10
  448. COMPEN:
  449.     LXI    H,FPACCX
  450.     INR    M
  451.     JZ    OUTDIG
  452.     LXI    H,OUTAREA+4
  453.     MVI    C,5
  454.     CALL    SHIFTR
  455.     JMP    COMPEN
  456. OUTDIG:
  457.     MVI    A,7
  458.     STA    DIGCNT
  459.     LXI    H,OUTAREA+4
  460.     MOV    A,M
  461.     ANA    A
  462.     JZ    ZERODG
  463. OUTDGS:
  464.     LXI    H,OUTAREA+4
  465.     MVI    A,'0'
  466.     ADD    M
  467.     LHLD    ASCII$PTR
  468.     MOV    M,A
  469.     INX    H
  470.     SHLD    ASCII$PTR
  471. DECRDG:
  472.     LXI    H,DIGCNT
  473.     DCR    M
  474.     JZ    EXPOUT
  475.     CALL    OUTX10
  476.     JMP    OUTDGS
  477.  
  478. ZERODG:
  479.     LXI    H,EXP
  480.     DCR    M
  481.     LXI    H,OUTAREA
  482.     MVI    C,5
  483.     CALL    ZERO$TEST
  484.     JNZ    DECRDG
  485.     XRA    A
  486.     STA    DIGCNT
  487.     JMP    DECRDG
  488.  
  489. OUTX10:
  490.     XRA    A
  491.     STA    OUTAREA+4
  492.     LXI    H,WORK
  493.     LXI    D,OUTAREA
  494.     MVI    C,5
  495.     CALL    MOVE
  496.     LXI    H,OUTAREA
  497.     MVI    C,5
  498.     CALL    SHIFTL
  499.     LXI    H,OUTAREA
  500.     MVI    C,5
  501.     CALL    SHIFTL
  502.     LXI    D,WORK
  503.     LXI    H,OUTAREA
  504.     MVI    C,5
  505.     CALL    ADDER
  506.     LXI    H,OUTAREA
  507.     MVI    C,5
  508.     CALL    SHIFTL
  509.     RET
  510. EXPOUT:
  511.     LHLD    ASCII$PTR
  512.     MVI    M,'E'
  513.     INX    H
  514.     LDA    EXP
  515.     ANA    A
  516.     JP    EXPOT
  517.     CMA
  518.     INR    A
  519.     STA    EXP
  520.     MVI    M,'-'
  521.     INX    H
  522.     LDA    EXP
  523. EXPOT:
  524.     MVI    C,0
  525. EXPLOOP:
  526.     SUI    10
  527.     JM    TOMUCH
  528.     STA    EXP
  529.     INR    C
  530.     JMP    EXPLOOP
  531.  
  532. TOMUCH:
  533.     MVI    A,'0'
  534.     ADD    C
  535.     MOV    M,A
  536.     INX    H
  537.     LDA    EXP
  538.     ADI    '0'
  539.     MOV    M,A
  540.     INX    H
  541.     MVI    M,0
  542.     RET
  543. FPX10:
  544.     LXI    H,FPOP
  545.     LXI    D,TEN
  546.     MVI    C,5
  547.     CALL    MOVE
  548.     CALL    FPMULT
  549.     LXI    H,EXP
  550.     DCR    M
  551.     RET
  552.  
  553. FPD10:
  554.     LXI    H,FPOP
  555.     LXI    D,ONE$TENTH
  556.     MVI    C,5
  557.     CALL    MOVE
  558.     CALL    FPMULT
  559.     LXI    H,EXP
  560.     INR    M
  561.     RET
  562.  
  563. NEGATE:
  564.     STC            ;CARRY forces an add of 1
  565. NEGAT$LOOP:
  566.     MOV    A,M        ;fetch byte
  567.     CMA            ;complement it
  568.     ACI    0        ;make it two's complement
  569.     MOV    M,A        ;store the result
  570.     INX    H        ;bump ptr
  571.     DCR    C        ;decrement precision register
  572.     JNZ    NEGAT$LOOP    ;if not done, go do it again
  573.     RET            ;Return to caller
  574.  
  575. ZERO$TEST:
  576.     XRA    A        ;clear A
  577.     ORA    M        ;'OR' A with next byte
  578.     INX    H        ;bump ptr
  579.     DCR    C        ;decrement precision register
  580.     JNZ    ZERO$TEST+1    ;loop until done
  581.     ANA    A        ;set flags
  582.     RET
  583.  
  584. SHIFTL:
  585.     ANA    A        ;clear CARRY
  586. SHFTL:
  587.     MOV    A,M        ;get next byte
  588.     RAL            ;shift it left
  589.     MOV    M,A        ;store result
  590.     INX    H        ;bump ptr
  591.     DCR    C        ;decrement precision register
  592.     JNZ    SHFTL        ;loop until done
  593.     RET
  594.  
  595. SHIFTR:
  596.     ANA    A
  597. SHFTR:
  598.     MOV    A,M
  599.     RAR
  600.     MOV    M,A
  601.     DCX    H
  602.     DCR    C
  603.     JNZ    SHFTR
  604.     RET
  605.  
  606. ADDER:
  607.     ANA    A
  608. ADD$LOOP:
  609.     LDAX    D
  610.     ADC    M
  611.     MOV    M,A
  612.     INX    D
  613.     INX    H
  614.     DCR    C
  615.     JNZ    ADD$LOOP
  616.     RET
  617.  
  618. SUBBER:
  619.     ANA    A
  620.     XCHG
  621. SUB$LOOP:
  622.     LDAX    D
  623.     SBB    M
  624.     STAX    D
  625.     INX    D
  626.     INX    H
  627.     DCR    C
  628.     JNZ    SUB$LOOP
  629.     XCHG
  630.     RET
  631.  
  632. ZERO$MEMORY:
  633.     MVI    M,0
  634.     INX    H
  635.     DCR    C
  636.     JNZ    ZERO$MEMORY
  637.     RET
  638.  
  639. MOVE:
  640.     LDAX    D
  641.     MOV    M,A
  642.     INX    D
  643.     INX    H
  644.     DCR    C
  645.     JNZ    MOVE
  646.     RET
  647.  
  648. SIGNJOB:
  649.     LDA    FPACC+3
  650.     STA    SIGN
  651.     ANA    A
  652.     JP    CKFPOP
  653.     LXI    H,FPACC
  654.     MVI    C,4
  655.     CALL    NEGATE
  656. CKFPOP:
  657.     LXI    H,SIGN
  658.     LDA    FPOP+3
  659.     XRA    M
  660.     MOV    M,A
  661.     LDA    FPOP+3
  662.     ANA    A
  663.     RP
  664.     LXI    H,FPOP
  665.     MVI    C,4
  666.     CALL    NEGATE
  667.     RET
  668.  
  669.     DS    4
  670. FPACC:    DS    4
  671. FPACCX:    DS    1
  672.     DS    4
  673. FPOP:    DS    4
  674. FPOPX:    DS    1
  675. SIGN:    DS    1
  676. WORK:    DS    8
  677. WORK2:    DS    4
  678. BITS:    DS    1
  679. ASCII$PTR:    DS    2
  680. EXP:    DS    1
  681. OUTAREA:    DS    5
  682. DIGCNT:    DS    1
  683. ONE$TENTH:    DB    66H,66H,66H,66H,0FDH
  684. TEN:    DB    0,0,0,50H,4
  685. ADJ:    DB    5,0,0,0
  686. ONE:    DB    80H,0,0,0
  687.  
  688.     ENDFUNC
  689.  
  690.