home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / DRI-archive / roche / FUNCTION.ASM < prev    next >
Assembly Source File  |  2009-12-11  |  10KB  |  542 lines
  1. ; FUNCTION.ASM
  2. ; ------------
  3. ;
  4. ; See FALCONER.WS4 as doc.
  5. ;
  6. ; (Retyped by Emmanuel ROCHE.)
  7. ;
  8. ;--------------------------------
  9. ; External routines required, see FLTARITH
  10. ;--------------------------------
  11. ;
  12. ; External arithmetic error trap
  13. ;
  14.     extrn    aerc
  15. ;
  16. ; External floating arithmetic
  17. ;
  18.     extrn    fadd,fdiv,fdivr
  19.     extrn    fint,fixr
  20.     extrn    fmul,frcip,fsubr
  21. ;
  22. ; External format conversion
  23. ;
  24.     extrn    flot,flota,flotd
  25. ;
  26. ; External tests and manipulation
  27. ;
  28.     extrn    fxchg,fcmp
  29. ;
  30. ; External memory access
  31. ;
  32.     extrn    fload,lfbs
  33. ;
  34. ;--------------------------------
  35. ; Entry points allowed
  36. ;
  37. ; Functions
  38. ;
  39.     entry    fract,fmod,poly
  40.     entry    log2,logb,exp2,expx
  41. ;
  42. ; Logical operators
  43. ;
  44.     entry    .or., .and., .xor.
  45. ;
  46. ; Relational operators
  47. ;
  48.     entry    .equ., .ne., .le., .gt.
  49.     entry    .lt., .ge., .gg.
  50. ;
  51. ;--------------------------------
  52. ; Macro definitions
  53. ;--------------------------------
  54. ;
  55. ; Load (and POP) real (reg) from TOS,
  56. ; stored by SFTS macro
  57. ;
  58. lfts    macro    reg
  59. bc.l    equ    b
  60. de.h    equ    d
  61.     pop    reg
  62.     mov    5-reg/2,reg
  63.     pop    reg
  64.     if    reg*(reg-d)
  65.     error    "R"
  66.     endif
  67.     endm
  68. ;
  69. ; Move operation on register pair B, D, or H
  70. ;
  71. movd    macro    r1,r2
  72.     if    ((r1-d)*(r1-h)*r1) OR ((r2-d)*(r2-h)*r2)
  73.     error    "R"
  74.     endif
  75.     mov    r1,r2
  76.     mov    r1+1,r2+1
  77.     endm
  78. ;
  79. ; Move floating operand from reg1 to reg2
  80. ;
  81. movf    macro    r2,r1
  82. bc.l    equ    b
  83. de.h    equ    d
  84.     if    (r1*(r1-d)) or (r2*(r2-d))
  85.     error    "R"
  86.     endif
  87.     mov    r2,r1
  88.     mov    r2+1,r1+1
  89.     mov    5-r2/2,5-r1/2
  90.     endm
  91. ;
  92. ; Reload (BC.L), stored by PUSH B, PUSH H sequence
  93. ;
  94. reload    macro    reg
  95. bc.l    equ    b
  96.     if    reg-b
  97.     error    'R'
  98.     db    0,0,0
  99.     endif
  100.     if    reg-b=0        ; Was IFZ
  101.     pop    b
  102.     mov    l,c
  103.     pop    b
  104.     endif
  105.     endm
  106. ;
  107. ; "Return" and check stack level zero
  108. ;
  109. rtn    macro
  110.     if    .lvl
  111.     error    "0"+.lvl
  112. .lvl    set    0
  113.     endif
  114.     ret
  115.     endm
  116. ;
  117. ; Save (BC.L), to be restored by RELOAD BC.L later
  118. ;
  119. save    macro    reg
  120. bc.l    equ    b
  121.     if    reg-b
  122.     error    "R"
  123.     db    0,0
  124.     endif
  125.     if    reg-b=0        ; Was IFZ
  126.     push    b
  127.     push    h
  128.     endif
  129.     endm
  130. ;
  131. ; Store real value on top of stack;
  132. ;   note SFTS B affects (A)
  133. ;
  134. sfts    macro    r
  135. bc.l    equ    b
  136. de.h    equ    d
  137.     if    r*(r-d)
  138.     error    "R"
  139.     endif
  140.     if    r=0        ; Was IFZ
  141.     mov    a,l
  142.     endif
  143.     push    r
  144.     push    psw-r
  145.     endm
  146. ;
  147. ;--------------------------------
  148. ; Start the code
  149. ;--------------------------------
  150. ;
  151. ; Extract fractional part of (DE.H)
  152. ; A,F,D,E,H
  153. ;
  154. fract:    save    bc.l        ; 
  155.     sfts    d        ; 
  156.     call    fint        ; 
  157.     lfts    b        ; Orig value to (BC.L)
  158.     call    fsubr        ; Remove integer portion
  159.     reload    bc.l        ; 
  160.     rtn            ; 
  161. ;
  162. ; Convert (DE.H) and (BC.L) to rounded integers
  163. ;   in (BC) and (DE) respectively
  164. ; A,F,B,C,D,E,H,L
  165. ;
  166. fixrt:    call    fixr        ; 
  167.     rc            ; Overflow
  168.     call    fxchg        ; 
  169.     jmp    fixr        ; 
  170. ;
  171. ; Modulo arithmetic
  172. ; (DE.H) := (BC.L) modulo (DE.H)
  173. ; System trap for (DE.H) = 0
  174. ; A,F,D,E,H
  175. ;
  176. fmod:    save    bc.l        ; 
  177.     sfts    d        ; 
  178.     mov    a,b        ; 
  179.     xra    d        ; Compare signs
  180.     push    psw        ; Save for exit
  181.     call    fdivr        ; BC.L / DE.H
  182. @01    set    .lvl        ; 
  183.     jc    fmod2        ; Overflow
  184.     call    fint        ; Integer (BC.L / DE.H)
  185.     jc    fmod2        ; Overflow
  186.     pop    psw        ; 
  187.     jp    fmod1        ; Signs same
  188.     lxi    b,8000H        ; 
  189.     mvi    l,81H        ; -1.000
  190.     call    fadd        ; Correct
  191. fmod1:    lfts    b        ; Original DE.H
  192.     call    fmul        ; DE.H * integer (BC.L / DE.H)
  193.     reload    bc.l        ; 
  194.     jnc    fsubr        ; BC.L - DE.H * integer (BC.L / DE.H)
  195.     rtn            ; FMUL overflowed
  196. .lvl    set    @01        ; 
  197. fmod2:    pop    psw        ; 
  198.     lfts    d        ; Overflow occurred,
  199.     stc            ;   restore input condition.
  200.     reload    bc.l        ; 
  201.     rtn            ; 
  202. ;
  203. ; Convert (DE.H) to logarithm, base 2
  204. ; Trap if (DE.H) <= 0 i.e., error
  205. ; Time approx 9 millisec
  206. ; A,F,D,E,H
  207. ;
  208. log2:    mov    a,h        ; 
  209.     ora    a        ; 
  210.     cz    aerc        ; Zero, trap
  211.     rc            ; 
  212.     mov    a,d        ; 
  213.     ral            ; 
  214.     cc    aerc        ; Negative, trap
  215.     rc            ; 
  216.     save    bc.l        ; 
  217.     push    h        ; Save exponent
  218.     movd    b,d        ; X to BC.L
  219.     lxi    d,3502H        ; SQRT(2)
  220.     lxi    h,8181H        ; X range 1 to 2
  221.     call    fadd        ; X + SQRT(2)
  222.     sfts    d        ; and save
  223.     lxi    d,0B502H    ; -SQRT(2)
  224.     mvi    h,81H        ; 
  225.     call    fadd        ; X-SQRT(2)
  226.     lfts    b        ; 
  227.     call    fdiv        ; Form term
  228.     movf    b,d        ; and copy
  229.     call    fmul        ; 
  230.     call    fmul        ; Term^3
  231.     sfts    d        ; 
  232.     lxi    d,38A6H        ; 2.8052
  233.     mvi    h,82H        ; 
  234.     call    fmul        ; 
  235.     lfts    b        ; 
  236.     sfts    d        ; 
  237.     lxi    d,7E08H        ; 0.9935
  238.     mvi    h,80H        ; 
  239.     call    fmul        ; 
  240.     lfts    b        ; 
  241.     call    fadd        ; 
  242.     movf    b,d        ; Partial term of BC.L
  243.     pop    d        ; Get exponent
  244.     mov    a,d        ; 
  245.     sui    81H        ; 
  246.     call    flota        ; Convert
  247.     call    fadd        ; Add characteristic in
  248.     lxi    b,0        ; 
  249.     mvi    l,80H        ; 0.5000
  250.     call    fadd        ; 
  251.     reload    bc.l        ; 
  252.     rtn            ; 
  253. ;
  254. ; Log (DE.H) base (BC.L) => (DE.H)
  255. ; Carry for overflow. Returns max values, or 0.
  256. ; (BC.L) or (DE.H) <= 0 causes trap
  257. ; Time approx 20 millisec
  258. ; A,F,D,E,H
  259. ;
  260. logb:    save    bc.l        ; 
  261.     sfts    d        ; 
  262.     movf    d,b        ; 
  263.     call    log2        ; 
  264.     lfts    b        ; Restore operand
  265.     sfts    d        ; Save log of base
  266.     movf    d,b        ; 
  267.     call    log2        ; 
  268.     lfts    b        ; Restore log base
  269.     call    fdiv        ; 
  270.     reload    bc.l        ; 
  271.     rtn            ; 
  272. ;
  273. ; Evaluate polynomial in (DE.H) = x
  274. ; (DE.H) := A(N)*X^N + A(N-1)*X^(N-1) + ... + A(1)*X + A(0)
  275. ; Carry for arithmetic overflow
  276. ; (BC) specifies address of coefficients
  277. ; First coefficient is order of polynomial (128 max)
  278. ; A,F,D,E,H
  279. ;
  280. poly:    save    bc.l        ; 
  281.     ldax    b        ; Get order
  282.     inx    b        ; Advance coeff pointer
  283.     sfts    d        ; Save argument
  284. @arg    set    .lvl        ; Argument stack address
  285.     mvi    h,0        ; Clear partial value
  286.     push    psw        ; Save order counter
  287. poly1:    push    b        ; Save coeff loc
  288.     sfts    d        ; Save partial value
  289.     call    fload        ; Get coefficient
  290.     lfts    b        ; Recover partial value to (BC.H)
  291.     call    fadd        ; Add in
  292.     pop    b        ; Coeff pointer
  293.     jc    poly2        ; Arith overflow
  294.     pop    psw        ; Order counter
  295.     dcr    a        ; 
  296.     jm    poly3        ; Done
  297.     push    psw        ; Save order counter
  298.     push    b        ; Save coeff pointer
  299.     mvi    a,.lvl-@arg    ; 
  300.     call    lfbs        ; Get argument
  301.     call    fmul        ; Multiply
  302.     pop    b        ; Restore coeff pointer
  303.     inx    b        ; 
  304.     inx    b        ; 
  305.     inx    b        ; Advance to next coeff
  306.     jnc    poly1        ; No arith error
  307. poly2:    pop    b        ; Error exit, purge stack
  308. poly3:    pop    b        ; 
  309.     pop    b        ; Purge argument from stack
  310.     reload    bc.l        ; 
  311.     rtn            ; 
  312. ;
  313. ; Exponential (DE.H) := 2^(DE.H)
  314. ; Carry for overflow
  315. ; A,F,D,E,H
  316. ;
  317. exp2:    mov    a,d        ; 
  318.     ora    a        ; 
  319.     jp    exp21        ; 
  320.     xri    80H        ; Set positive
  321.     mov    d,a        ; 
  322.     call    exp21        ; 
  323.     cnc    frcip        ; Neg exponent
  324.     rnc            ; 
  325.     mvi    h,0        ; Zero for negative overflow
  326.     rtn            ; 
  327. exp21:    save    bc.l        ; 
  328.     movf    b,d        ; Copy argument to B
  329.     call    fixr        ; 
  330.     jc    exp22        ; Too large, overflow
  331.     push    d        ; Save integer portion
  332.     call    flotd        ; 
  333.     call    fsubr        ; Form fractional portion
  334.     lxi    b,ex2c        ; Point to coefficients
  335.     call    poly        ; Form 2^(fract(x))
  336.     movf    b,d        ; 
  337.     call    fmul        ; Form (1+A1*X+...+AN*X^N)^2
  338.     pop    b        ; Get integer portion(x)
  339.     mov    a,b        ; 
  340.     ora    a        ; 
  341.     stc            ; 
  342.     jnz    exp22        ; Too large, overflow
  343.     mov    a,c        ; 
  344.     add    h        ; 
  345.     mov    h,a        ; Exponent overlow causes Carry
  346. exp22:    reload    bc.l        ; 
  347.     rnc            ; 
  348.     lxi    d,7FFFH        ; 
  349.     mov    h,e        ; Set max value
  350.     rtn            ; 
  351. ;
  352. ; Polynomial coefficients for 2^(x)
  353. ;
  354. ex2c:    db    3        ; Polynomial order
  355.     db    7AH,01H,06H    ; 0.0081790
  356.     db    7CH,0DH,73H    ; 0.059340
  357.     db    7FH,81H,31H    ; 0.34669
  358.     db    81H,00H,00H    ; 1.0000
  359. ;
  360. ; Exponential (DE.H) := (BC.L)^(DE.H)
  361. ; (BC.L) < 0 illegal, divertto trap.
  362. ; (BC.L) and (DE.H) = 0 illegal, trap.
  363. ; Carry for over/underflow, returns max, 0.1
  364. ; A,F,D,E,H
  365. ;
  366. expx:    mov    a,l        ; 
  367.     ora    a        ; 
  368.     jnz    expx1        ; (BC.L) <> 0
  369.     ora    h        ; 
  370.     cz    aerc        ; Illegal, trap
  371.     mvi    h,0        ; 0^any = 0
  372.     rtn            ; 
  373. expx1:    mov    a,b        ; 
  374.     ora    a        ; 
  375.     cm    aerc        ; Illegal, trap
  376.     rc            ; 
  377.     mov    a,h        ; 
  378.     ora    a        ; 
  379.     jnz    expx3        ; 
  380. expx2:    lxi    d,0        ; 
  381.     mvi    h,81H        ; Any^0 = 1.000
  382.     rtn            ; 
  383. expx3:    save    bc.l        ; 
  384.     sfts    d        ; 
  385.     movf    d,b        ; 
  386.     call    log2        ; 
  387.     lfts    b        ; Restore argument
  388.     call    fmul        ; 
  389.     reload    bc.l        ; 
  390.     jnc    exp2        ; 
  391.     mov    a,h        ; 
  392.     ora    a        ; 
  393.     stc            ; 
  394.     jz    expx2        ; Underflow, return 1.000
  395.     mov    a,d        ; 
  396.     ora    a        ; 
  397.     stc            ; 
  398.     rp            ; +ve overflow, return max
  399.     mvi    h,0        ; -ve overflow, return 0
  400.     rtn            ; 
  401. ;
  402. ;--------------------------------
  403. ; The logical operators
  404. ;   treat all arguments as signed integers
  405. ;   and return the floating representation of
  406. ;   the bitwise operation specified.
  407. ;   Error: If any argument is outside the
  408. ;   range -32768 to 32767.
  409. ;--------------------------------
  410. ;
  411. ; Logical OR on (BC.L),(DE.H)
  412. ; A,F,D,E,H
  413. ;
  414. .or.:    save    bc.l        ; 
  415.     call    fixrt        ; 
  416.     jc    .or.2        ; 
  417.     mov    a,b        ; 
  418.     ora    d        ; 
  419.     mov    d,a        ; 
  420.     mov    a,c        ; 
  421.     ora    e        ; 
  422. .or.1:    mov    e,a        ; 
  423.     call    flot        ; 
  424. .or.2:    reload    bc.l        ; 
  425.     rtn            ; 
  426. ;
  427. ; Logical AND on (BC.L),(DE.H)
  428. ; A,F,D,E,H
  429. ;
  430. .and.:    save    bc.l        ; 
  431.     call    fixrt        ; 
  432.     jc    .or.2        ; 
  433.     mov    a,b        ; 
  434.     ana    d        ; 
  435.     mov    d,a        ; 
  436.     mov    a,c        ; 
  437.     ana    e        ; 
  438.     jmp    .or.1        ; 
  439. .lvl    set    .lvl-2        ; 
  440. ;
  441. ; Logical XOR on (BC.L),(DE.H)
  442. ; A,F,D,E,H
  443. ;
  444. .xor.:    save    bc.l        ;
  445.     call    fixrt        ; 
  446.     jc    .or.2        ; 
  447.     mov    a,b        ; 
  448.     xra    d        ; 
  449.     mov    d,a        ; 
  450.     mov    a,c        ; 
  451.     xra    e        ; 
  452.     jmp    .or.1        ; 
  453. .lvl    set    .lvl-2        ; 
  454. ;
  455. ;--------------------------------
  456. ; The relational operators
  457. ;   return -1 for true
  458. ;           0 for false.
  459. ;--------------------------------
  460. ;
  461. ; Test (DE.H) = (BC.L)
  462. ; If so, (DE.H) := -1, else 0
  463. ; A,F,D,E,H
  464. ;
  465. .equ.:    call    fcmp        ; 
  466.     jz    .tru        ; True
  467. .mtru:    xra    a        ; 
  468.     mov    h,a        ; (DE.H) := 0
  469.     rtn            ; 
  470. ;
  471. ; Test (DE.H) <> (BC.L)
  472. ; If so, (DE.H) := -1, else 0
  473. ; A,F,D,E,H
  474. ;
  475. .ne.:    call    fcmp        ; 
  476.     jz    .mtru        ; False
  477. .tru:    mvi    h,81H        ; (DE.H) := -1.0
  478.     lxi    d,8000H        ; Use LXI D,0 for true = +1.0, for Pascal etc
  479.     ora    a        ; Clear any Carry
  480.     rtn            ; 
  481. ;
  482. ; Test (DE.H) <= (BC.L)
  483. ; If so, (DE.H) := -1, else 0
  484. ; A,F,D,E,H
  485. ;
  486. .le.:    call    fcmp        ; 
  487. .le.1:    jp    .tru        ; 
  488.     jmp    .mtru        ; 
  489. ;
  490. ; Test (DE.H) > (BC.L)
  491. ; If so, (DE.H) := -1, else 0
  492. ; A,F,D,E,H
  493. ;
  494. .gt.:    call    fcmp        ; 
  495. .gt.1:    jm    .tru        ; 
  496.     jmp    .mtru        ; 
  497. ;
  498. ; Test (DE.H) < (BC.L)
  499. ; If so, (DE.H) := -1, else 0
  500. ; A,F,D,E,H
  501. ;
  502. .lt.:    call    fcmp        ; 
  503.     jz    .mtru        ; 
  504.     jmp    .le.1        ; 
  505. ;
  506. ; Test (DE.H) >= (BC.L)
  507. ; If so, (DE.H) := -1, else 0
  508. ; A,F,D,E,H
  509. ;
  510. .ge.:    call    fcmp        ; 
  511.     jz    .tru        ; 
  512.     jmp    .gt.1        ; 
  513. ;
  514. ; Set (DE.H) := (DE.H) * 2^15 and perform .GT.
  515. ;
  516. ; This can be used to test for a value effectively
  517. ; zero with respect to another. For termination of
  518. ; iteration loops, etc.  The value 2^15 applies to
  519. ; this arithmetic system, and should be customized
  520. ; to the precision of any particular arithmetic
  521. ; system for program portability.
  522. ;
  523. .gg.:    mov    a,h        ; 
  524.     adi    15        ; 
  525.     jnc    .gg.1        ; Dynamic room
  526.     push    h        ; 
  527.     mov    a,l        ; 
  528.     sui    15        ; 
  529.     mov    l,a        ; 
  530.     jnc    .gg.2        ; Dynamic room
  531.     pop    h        ; No room, return false
  532.     jmp    .mtru        ; 
  533. .gg.1:    mov    h,a        ; 
  534.     push    h        ; 
  535. .gg.2:    call    fcmp        ; 
  536.     pop    h        ; 
  537.     jmp    .gt.1        ; 
  538. ;
  539. ;--------------------------------
  540. ;
  541.     end            ; of FUNCTION.ASM
  542.