Return to float.fs CVS log

Up to [gforth] / gforth

added ARM disassembler (contributed by Andreas Bolka)
some fixes in the ARM assembler (contributed by Andreas Bolka)
ARM assembler and disassembler are now distributed
FCOPYSIGN now works with the strangely ordered floats on ARM

    1: \ High level floating point                            14jan94py
    2: 
    3: \ Copyright (C) 1995,1997,2003,2004,2005,2006,2007,2009 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation, either version 3
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program. If not, see http://www.gnu.org/licenses/.
   19: 
   20: \ 1 cells 4 = [IF]
   21: \ ' cells   Alias sfloats
   22: \ ' cell+   Alias sfloat+
   23: \ ' align   Alias sfalign
   24: \ ' aligned Alias sfaligned
   25: \ [ELSE]
   26: \ : sfloats  2* 2* ;
   27: \ : sfloat+  4 + ;
   28: \ : sfaligned ( addr -- addr' )  3 + -4 and ;
   29: \ : sfalign ( -- )  here dup sfaligned swap ?DO  bl c,  LOOP ;
   30: \ [THEN]
   31: 
   32: \ 1 floats 8 = [IF]
   33: \ ' floats   Alias dfloats
   34: \ ' float+   Alias dfloat+
   35: \ ' falign   Alias dfalign
   36: \ ' faligned Alias dfaligned
   37: \ [ELSE]
   38: \ : dfloats  2* 2* 2* ;
   39: \ : dfloat+  8 + ;
   40: \ : dfaligned ( addr -- addr' )  7 + -8 and ;
   41: \ : dfalign ( -- )  here dup dfaligned swap ?DO  bl c,  LOOP ;
   42: \ [THEN]
   43: 
   44: : sfalign ( -- ) \ float-ext s-f-align
   45:     \G If the data-space pointer is not single-float-aligned, reserve
   46:     \G enough space to align it.
   47:     here dup sfaligned swap ?DO  bl c,  LOOP ;
   48: : dfalign ( -- ) \ float-ext d-f-align
   49:     \G If the data-space pointer is not double-float-aligned, reserve
   50:     \G enough space to align it.
   51:     here dup dfaligned swap ?DO  bl c,  LOOP ;
   52: 
   53: (Field) sfloat+ ( sf-addr1 -- sf-addr2 ) \ float-ext s-float-plus
   54: \G @code{1 sfloats +}.
   55:     1 sfloats ,
   56: 
   57: (Field) dfloat+ ( df-addr1 -- df-addr2 ) \ float-ext d-float-plus
   58: \G @code{1 dfloats +}.
   59:     1 dfloats ,
   60:     
   61: : f, ( f -- ) \ gforth
   62:     \G Reserve data space for one floating-point number and store
   63:     \G @i{f} in the space.
   64:     here 1 floats allot f! ;
   65: 
   66: : fconstant  ( r "name" -- ) \ float f-constant
   67:     Create f,
   68: DOES> ( -- r )
   69:     f@ ;
   70: 
   71: : fdepth ( -- +n ) \ float f-depth
   72:     \G @i{+n} is the current number of (floating-point) values on the
   73:     \G floating-point stack.
   74:     fp0 @ fp@ - [ 1 floats ] Literal / ;
   75: 
   76: : FLiteral ( compilation r -- ; run-time -- r ) \ float f-literal
   77:     \G Compile appropriate code such that, at run-time, @i{r} is placed
   78:     \G on the (floating-point) stack. Interpretation semantics are undefined.
   79:     BEGIN  here cell+ cell+ dup faligned <>  WHILE  postpone noop  REPEAT
   80:     postpone ahead here >r f, postpone then
   81:     r> postpone literal postpone f@ ;  immediate
   82: 
   83: &15 Value precision ( -- u ) \ float-ext
   84: \G @i{u} is the number of significant digits currently used by
   85: \G @code{F.} @code{FE.} and @code{FS.} 
   86: : set-precision ( u -- ) \ float-ext
   87:     \G Set the number of significant digits currently used by
   88:     \G @code{F.} @code{FE.} and @code{FS.} to @i{u}.
   89:     to precision ;
   90: 
   91: : scratch ( r -- addr len )
   92:   pad precision - precision ;
   93: 
   94: : zeros ( n -- )   0 max 0 ?DO  '0 emit  LOOP ;
   95: 
   96: : -zeros ( addr u -- addr' u' )
   97:   BEGIN  dup  WHILE  1- 2dup + c@ '0 <>  UNTIL  1+  THEN ;
   98: 
   99: : f$ ( f -- n )  scratch represent 0=
  100:   IF  2drop  scratch 3 min type  rdrop  EXIT  THEN
  101:   IF  '- emit  THEN ;
  102: 
  103: : f.  ( r -- ) \ float-ext f-dot
  104: \G Display (the floating-point number) @i{r} without exponent,
  105: \G followed by a space.
  106:   f$ dup >r 0<=
  107:   IF    '0 emit
  108:   ELSE  scratch r@ min type  r@ precision - zeros  THEN
  109:   '. emit r@ negate zeros
  110:   scratch r> 0 max /string 0 max -zeros type space ;
  111: \ I'm afraid this does not really implement ansi semantics wrt precision.
  112: \ Shouldn't precision indicate the number of places shown after the point?
  113: 
  114: \ Why do you think so? ANS Forth appears ambiguous on this point. -anton.
  115: 
  116: : fe. ( r -- ) \ float-ext f-e-dot
  117: \G Display @i{r} using engineering notation (with exponent dividable
  118: \G by 3), followed by a space.
  119:   f$ 1- s>d 3 fm/mod 3 * >r 1+ >r
  120:   scratch r@ tuck min tuck - >r type r> zeros
  121:   '. emit scratch r> /string type
  122:   'E emit r> . ;
  123: 
  124: : fs. ( r -- ) \ float-ext f-s-dot
  125: \G Display @i{r} using scientific notation (with exponent), followed
  126: \G by a space.
  127:   f$ 1-
  128:   scratch over c@ emit '. emit 1 /string type
  129:   'E emit . ;
  130: 
  131: : sfnumber ( c-addr u -- r true | false )
  132:     2dup [CHAR] e scan ( c-addr u c-addr2 u2 )
  133:     dup 0=
  134:     IF
  135: 	2drop 2dup [CHAR] E scan ( c-addr u c-addr3 u3 )
  136:     THEN
  137:     nip
  138:     IF
  139: 	>float
  140:     ELSE
  141: 	2drop false
  142:     THEN ;
  143: 
  144: [ifundef] compiler-notfound1
  145: defer compiler-notfound1
  146: ' no.extensions IS compiler-notfound1
  147: 
  148: :noname compiler-notfound1 execute ; is compiler-notfound
  149: 
  150: defer interpreter-notfound1
  151: ' no.extensions IS interpreter-notfound1
  152: 
  153: :noname interpreter-notfound1 execute ; is interpreter-notfound
  154: [then]
  155: 
  156: :noname ( c-addr u -- ... xt )
  157:     2dup sfnumber
  158:     IF
  159: 	2drop [comp'] FLiteral
  160:     ELSE
  161: 	defers compiler-notfound1
  162:     ENDIF ;
  163: IS compiler-notfound1
  164: 
  165: :noname ( c-addr u -- ... xt )
  166:     2dup sfnumber
  167:     IF
  168: 	2drop ['] noop
  169:     ELSE
  170: 	defers interpreter-notfound1
  171:     ENDIF ;
  172: IS interpreter-notfound1
  173: 
  174: : fvariable ( "name" -- ) \ float f-variable
  175:     Create 0.0E0 f, ;
  176:     \ does> ( -- f-addr )
  177: 
  178: 1.0e0 fasin 2.0e0 f* fconstant pi ( -- r ) \ gforth
  179: \G @code{Fconstant} -- @i{r} is the value pi; the ratio of a circle's area
  180: \G to its diameter.
  181: 
  182: : f2* ( r1 -- r2 ) \ gforth
  183:     \G Multiply @i{r1} by 2.0e0
  184:     2.0e0 f* ;
  185: 
  186: : f2/ ( r1 -- r2 ) \ gforth
  187:     \G Multiply @i{r1} by 0.5e0
  188:     0.5e0 f* ;
  189: 
  190: : 1/f ( r1 -- r2 ) \ gforth
  191:     \G Divide 1.0e0 by @i{r1}.
  192:     1.0e0 fswap f/ ;
  193: 
  194: get-current environment-wordlist set-current
  195: 1.7976931348623157e308 FConstant max-float
  196: set-current
  197: 
  198: \ We now have primitives for these, so we need not define them
  199: 
  200: \ : falog ( f -- 10^f )  [ 10.0e0 fln ] FLiteral f* fexp ;
  201: 
  202: \ : fsinh    fexpm1 fdup fdup 1.0e0 f+ f/ f+ f2/ ;
  203: \ : fcosh    fexp fdup 1/f f+ f2/ ;
  204: \ : ftanh    f2* fexpm1 fdup 2.0e0 f+ f/ ;
  205: 
  206: \ : fatanh   fdup f0< >r fabs 1.0e0 fover f- f/  f2* flnp1 f2/
  207: \            r> IF  fnegate  THEN ;
  208: \ : facosh   fdup fdup f* 1.0e0 f- fsqrt f+ fln ;
  209: \ : fasinh   fdup fdup f* 1.0e0 f+ fsqrt f/ fatanh ;
  210: 
  211: : f~abs ( r1 r2 r3 -- flag ) \ gforth
  212:     \G Approximate equality with absolute error: |r1-r2|<r3.
  213:     frot frot f- fabs fswap f< ;
  214: 
  215: : f~rel ( r1 r2 r3 -- flag ) \ gforth
  216:     \G Approximate equality with relative error: |r1-r2|<r3*|r1+r2|.
  217: 	frot frot fover fabs fover fabs f+ frot frot
  218: 	f- fabs frot frot f* f< ;
  219: 
  220: : f~ ( r1 r2 r3 -- flag ) \ float-ext f-proximate
  221:     \G ANS Forth medley for comparing r1 and r2 for equality: r3>0:
  222:     \G @code{f~abs}; r3=0: bitwise comparison; r3<0: @code{fnegate f~rel}.
  223:     fdup f0=
  224:     IF \ bitwise comparison
  225: 	fp@ float+ 1 floats over float+ over str=
  226: 	fdrop fdrop fdrop
  227: 	EXIT
  228:     THEN
  229:     fdup f0>
  230:     IF
  231: 	f~abs
  232:     ELSE
  233: 	fnegate f~rel
  234:     THEN ;
  235: 
  236: -0e 8 0 [do] fp@ [i] + c@ $80 = [if] [i] constant fsign-offset [then] [loop]
  237: 
  238: : fcopysign ( r1 r2 -- r3 ) \ gforth
  239: \G r3 takes its absolute value from r1 and its sign from r2
  240:     \ !! implementation relies on IEEE DP format
  241:     fp@ fsign-offset + dup c@ $80 and >r ( r1 r2 addr-r1sign )
  242:     float+ dup c@ $7f and r> or swap c!
  243:     fdrop ;
  244: 
  245: \ proposals from Krishna Myeni in <cjsp2d$47l$1@ngspool-d02.news.aol.com>
  246: \ not sure if they are a good idea
  247: 
  248: : ftrunc ( r1 -- r2 ) \ X:ftrunc
  249:     \ round towards 0
  250:     fdup fabs floor fswap fcopysign ;
  251: 
  252: : FMOD ( r1 r2 -- r )
  253:     \ remainder of r1/r2
  254:     FOVER FOVER F/ ftrunc F* F- ;
  255: