home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / dtx9203 / naxos / fthsourc / math.fth < prev    next >
Encoding:
Text File  |  1992-02-08  |  4.0 KB  |  254 lines
  1. ( -------------------------------------------------------- )
  2. (                          MATH.FTH                 )
  3. (         Copyright (C) 1992 K. Peper & DMV-Verlag         )
  4. (                Compiler: Naxos V 1.0                     )
  5. ( -------------------------------------------------------- )                               )
  6.  
  7.  
  8. include kern
  9.  
  10. typ bcd byte 10 ;
  11. typ real byte 8 ;
  12.  
  13. VAR DPLP byte ;
  14. VAR SCALE real ;
  15. VAR FHLD word ;
  16. var LDZ byte ;
  17.  
  18. : F@
  19.   [ $DD $07 ]    ( FLD [bx] )
  20. ;
  21.  
  22.  
  23. : FI@
  24.   [ $DF $07 ]    ( FILD w/[bx] )
  25. ;
  26.  
  27. : FD@
  28.   [ $DB $07 ]    ( FILD d/[bx] ) 
  29. ;
  30.  
  31. : FBCD@
  32.   [ $DF $27 ]    ( FBLD [bx] )
  33. ;
  34.  
  35. : F!
  36.   [ $9B $DD $1F ]  ( FSTP [bx] )
  37. ;
  38.  
  39. : FI!
  40.   [ $9B $DF $1F ]  ( FISTP w/[bx] )
  41. ;
  42.  
  43. : FD!
  44.   [ $9B $DB $1F ]  ( FISTP d/[bx] )
  45. ;
  46.  
  47. : FBCD!
  48.   [ $9B $DF $37 ]  ( FBSTP [bx] )
  49. ;
  50.  
  51. : F>               ( ST --> ax )
  52.   bcd FI! bcd @
  53. ;
  54.  
  55. : >F               ( ax --> ST )
  56.   bcd ! bcd FI@
  57. ;
  58.  
  59. : F>D              ( ST --> dx:ax )
  60.   bcd FD! bcd D@
  61. ;
  62.  
  63. : D>F              ( dx:ax --> ST )
  64.   bcd D! bcd FD@
  65. ;
  66.  
  67. : FIPUSH       ( ST --> sx )
  68.   [ $4E $4E ]  ( dec si dec si )
  69.   [ $DF $1C ]  ( FISTP w/[si] )
  70. ;
  71.  
  72. : FIPOP        ( sx --> ST )
  73.   [ $DF $04 ]  ( FILD w/[si] )
  74.   [ $46 $46 ]  ( inc si inc si )
  75. ;
  76.  
  77. : FDPUSH               ( ST --> sx )
  78.   [ $4E $4E $4E $4E ]  ( 4* dec si )
  79.   [ $DB $1C ]          ( FISTP d/[si] )
  80. ;
  81.  
  82. : FDPOP                ( sx --> ST )
  83.   [ $DB $04 ]          ( FILD d/[si] )
  84.   [ $46 $46 $46 $46 ]  ( 4* inc si )
  85. ;
  86. : F+            ( ST+ST(1) --> ST ) 
  87.   [ $DE $C1 ]   ( FADDP ST(1),ST )
  88. ;
  89.  
  90. : F-            ( st(1)-st --> st ) 
  91.   [ $DE $E9 ]   ( FSUBP ST(1),ST )
  92. ;
  93.  
  94. : F*            ( st(1)*st --> st ) 
  95.   [ $DE $C9 ]   ( FMULP ST(1),ST )
  96. ;
  97.  
  98. : F/            ( st(1)/st --> st )
  99.   [ $DE $F9 ]   ( FDIVP ST(1),ST )
  100. ;
  101.  
  102. : FABS          ( ABS(ST) --> ST )
  103.   [ $D9 $E1 ]   ( FABS )
  104. ;
  105.  
  106. : FMINUS        ( ST* -1 --> ST )
  107.   [ $D9 $E0 ]   ( FCHS )
  108. ;
  109.  
  110. : FSWAP         ( ST <--> ST(1) )
  111.   [ $D9 $C9 ]   ( FXCH )
  112. ;
  113.  
  114. : FDUP
  115.   [ $D9 $C0 ]   ( FLD ST )
  116. ;
  117.  
  118. : FOVER
  119.   [ $D9 $C1 ]   ( FLD ST(1) )
  120. ;
  121.  
  122. : SQRT          ( SQRT(ST) --> ST ) 
  123.   [ $D9 $FA ]   ( FSQRT )
  124. ;
  125.  
  126. : PI            ( PI --> ST )
  127.   [ $D9 $EB ]   ( FLDPI )
  128. ;
  129.  
  130. : F0            ( 0 --> ST )
  131.   [ $D9 $EE ]   ( FLDZ )   
  132. ;
  133.  
  134. : F1            ( 1 --> ST )
  135.   [ $D9 $E8 ]   ( FLD1 )
  136. ;
  137.  
  138. : setdecimals   ( n -- )
  139.   >TX 
  140.   >dx 18 - dplp !
  141.   %1 
  142.   TX> , 1 do 
  143.      %10 F*
  144.   loop
  145.   scale F!
  146.   TX> , 0 .=. IF %1 scale F! ENDIF
  147. ;
  148.  
  149. : getdecimals  ( -- n )
  150.   dplp @ >dx 18 -
  151. ;
  152.  
  153. : finit ( -- )
  154.   [ $9B $DB $E3 ]
  155.   3 setdecimals
  156. ;
  157.  
  158.  
  159. : <F#  ( n -- )
  160.   0 ldz c!
  161.   pad bx+ bx> fhld !
  162. ;
  163.  
  164. : F#  ( n -- )
  165.    { >R , $000F and .0=. pushf ldz c@ .0=. .and. .not. R> }
  166.    IF
  167.      FHLD @>bx c!  
  168.      FHLD INC 
  169.      1 ldz c!
  170.    ENDIF   
  171. ;
  172.  
  173. var start word ;
  174.  
  175. : #F>  ( n -- )
  176.   pad bx+ bx>dx fhld @ - pad c!
  177. ;
  178.  
  179. : bcd>asc
  180.   [ $88 $C4 $80 $E4 $0F $24 $F0 $C0 $E8 $04 $05 $30 $30 ]
  181. ;
  182.  
  183.  
  184. : nbcd
  185.   ( offset ax asc)
  186.   ( bcd base bx -- )
  187.   minus , 18 +
  188.   push , 1 and
  189.   0=IF
  190.      pop u2/ >bx+ c@ bcd>asc  F#
  191.   ELSE
  192.      pop u2/ >bx+ c@ bcd>asc [ $88 $E0 ] F# 
  193.   ENDIF
  194. ;
  195.  
  196.  
  197.  
  198. : bcd>$
  199.   bx>tx
  200.   <F#
  201.   tx>bx
  202.   9 >bx+ c@ 0=IF '-' FHLD @>bx c! FHLD inc endif
  203.   dplp @ , 1 do
  204.      I tx>bx nbcd
  205.   loop 
  206.   ldz c@ , 0 .=. IF 1 ldz c! '0' F# ENDIF
  207.   dplp @ , 18 .=. .not. IF
  208.     '.' F#
  209.     dplp @ 1+ >dx 18 do
  210.       I tx>bx nbcd
  211.     loop  
  212.   ENDIF  
  213.   #F> 
  214.   pad
  215. ;
  216.  
  217. : F>$
  218.   scale F@ F*
  219.   bcd FBCD! bcd bcd>$
  220. ;
  221.  
  222. : F.
  223.   F>$ count type
  224. ;
  225.  
  226.  
  227. dictionary
  228.  
  229. : main
  230.   >default 
  231.   ." NAXOS Floating-point:  Die Zahl π :   " cr cr
  232.   
  233.   FINIT 
  234.   17 , 0 do 
  235.      I setdecimals
  236.      ." Dezimalstellen    : "  getdecimals , 2 .r ."    "    
  237.      PI F. cr
  238.   loop
  239.   cr
  240.   ." Beachten Sie die richtigen Rundungen am Ende der Zahl !"
  241.   cr
  242.   wait
  243.   10 , 0 do cr loop
  244.   cr
  245.   ." Die Quadratwurzeln von 0 .. 16 " cr cr 
  246.   16 setdecimals
  247.   16 , 0 do
  248.     ." √" I push , 2 .r ."  = " FIPOP sqrt FDUP F.
  249.     ."   √² = " fdup f*  f. cr
  250.   loop
  251.   cr
  252.   ." Wenn Sie nur Nullen sehen, laden Sie aus DOS den Emulator EM87 !"
  253.   cr wait
  254. ;