Return to float.fs CVS log

Up to [gforth] / gforth

added answords.fs and strsignal.c
added checking of documenetation of ANS Forth words
Fixed many documentation errors and added some documentation
signal handling now uses strsignal and can handle signals not present on all machines

    1: \ High level floating point                            14jan94py
    2: 
    3: \ 1 cells 4 = [IF]
    4: \ ' cells   Alias sfloats
    5: \ ' cell+   Alias sfloat+
    6: \ ' align   Alias sfalign
    7: \ ' aligned Alias sfaligned
    8: \ [ELSE]
    9: \ : sfloats  2* 2* ;
   10: \ : sfloat+  4 + ;
   11: \ : sfaligned ( addr -- addr' )  3 + -4 and ;
   12: \ : sfalign ( -- )  here dup sfaligned swap ?DO  bl c,  LOOP ;
   13: \ [THEN]
   14: 
   15: \ 1 floats 8 = [IF]
   16: \ ' floats   Alias dfloats
   17: \ ' float+   Alias dfloat+
   18: \ ' falign   Alias dfalign
   19: \ ' faligned Alias dfaligned
   20: \ [ELSE]
   21: \ : dfloats  2* 2* 2* ;
   22: \ : dfloat+  8 + ;
   23: \ : dfaligned ( addr -- addr' )  7 + -8 and ;
   24: \ : dfalign ( -- )  here dup dfaligned swap ?DO  bl c,  LOOP ;
   25: \ [THEN]
   26: 
   27: : sfalign ( -- ) \ float-ext s-f-align
   28:     here dup sfaligned swap ?DO  bl c,  LOOP ;
   29: : dfalign ( -- ) \ float-ext d-f-align
   30:     here dup dfaligned swap ?DO  bl c,  LOOP ;
   31: 
   32: 1 sfloats constant sfloat+ ( sf-addr1 -- sf-addr2 ) \ float-ext s-float-plus
   33: dofield: lastxt code-address! \ change the constant into a field
   34: 
   35: 1 dfloats constant dfloat+ ( df-addr1 -- df-addr2 ) \ float-ext d-float-plus
   36: dofield: lastxt code-address! \ change the constant into a field
   37: 
   38: : f, ( f -- )  here 1 floats allot f! ;
   39: 
   40: : fconstant  ( r -- ) \ float
   41:     Create f,
   42: DOES> ( -- r )
   43:     f@ ;
   44: 
   45: : fdepth  ( -- n )  f0 @ fp@ - [ 1 floats ] Literal / ;
   46: 
   47: : FLit ( -- r )  r> dup f@ float+ >r ;
   48: : FLiteral ( r -- )
   49:   BEGIN  here cell+ dup faligned <>  WHILE  postpone noop  REPEAT
   50:   postpone FLit  f, ;  immediate
   51: 
   52: &15 Value precision
   53: : set-precision  to precision ;
   54: 
   55: : scratch ( r -- addr len )
   56:   pad precision - precision ;
   57: 
   58: : zeros ( n -- )   0 max 0 ?DO  '0 emit  LOOP ;
   59: 
   60: : -zeros ( addr u -- addr' u' )
   61:   BEGIN  dup  WHILE  1- 2dup + c@ '0 <>  UNTIL  1+  THEN ;
   62: 
   63: : f$ ( f -- n )  scratch represent 0=
   64:   IF  2drop  scratch 3 min type  rdrop  EXIT  THEN
   65:   IF  '- emit  THEN ;
   66: 
   67: : f.  ( r -- )  f$ dup >r 0<
   68:   IF    '0 emit
   69:   ELSE  scratch r@ min type  r@ precision - zeros  THEN
   70:   '. emit r@ negate zeros
   71:   scratch r> 0 max /string 0 max -zeros type space ;
   72: \ I'm afraid this does not really implement ansi semantics wrt precision.
   73: \ Shouldn't precision indicate the number of places shown after the point?
   74: 
   75: : fe. ( r -- )  f$ 1- s>d 3 fm/mod 3 * >r 1+ >r
   76:   scratch r@ min type '. emit  scratch r> /string type
   77:   'E emit r> . ;
   78: 
   79: : fs. ( r -- )  f$ 1-
   80:   scratch over c@ emit '. emit 1 /string type
   81:   'E emit . ;
   82: 
   83: require debugging.fs
   84: 
   85: : sfnumber ( c-addr u -- r / )
   86:     2dup [CHAR] e scan
   87:     dup 0=
   88:     IF
   89: 	2drop 2dup [CHAR] E scan
   90:     THEN
   91:     nip
   92:     IF
   93: 	2dup >float
   94: 	IF
   95: 	    2drop state @
   96: 	    IF
   97: 		POSTPONE FLiteral
   98: 	    THEN
   99: 	    EXIT
  100: 	THEN
  101:     THEN
  102:     defers notfound ;
  103: 
  104: ' sfnumber IS notfound
  105: 
  106: : fvariable ( -- )
  107:     Create 0.0E0 f, ;
  108:     \ does> ( -- f-addr )
  109: 
  110: 1.0e0 fasin 2.0e0 f* fconstant pi
  111: 
  112: : f2*  2.0e0 f* ;
  113: : f2/  0.5e0 f* ;
  114: : 1/f  1.0e0 fswap f/ ;
  115: 
  116: 
  117: \ We now have primitives for these, so we need not define them
  118: 
  119: \ : falog ( f -- 10^f )  [ 10.0e0 fln ] FLiteral f* fexp ;
  120: 
  121: \ : fsinh    fexpm1 fdup fdup 1.0e0 f+ f/ f+ f2/ ;
  122: \ : fcosh    fexp fdup 1/f f+ f2/ ;
  123: \ : ftanh    f2* fexpm1 fdup 2.0e0 f+ f/ ;
  124: 
  125: \ : fatanh   fdup f0< >r fabs 1.0e0 fover f- f/  f2* flnp1 f2/
  126: \            r> IF  fnegate  THEN ;
  127: \ : facosh   fdup fdup f* 1.0e0 f- fsqrt f+ fln ;
  128: \ : fasinh   fdup fdup f* 1.0e0 f+ fsqrt f/ fatanh ;
  129: 
  130: \ !! factor out parts
  131: : f~ ( f1 f2 f3 -- flag ) \ float-ext
  132:     fdup f0=
  133:     IF
  134: 	fdrop f= EXIT
  135:     THEN
  136:     fdup f0>
  137:     IF
  138: 	frot frot f- fabs fswap
  139:     ELSE
  140: 	fnegate frot frot fover fabs fover fabs f+ frot frot
  141: 	f- fabs frot frot f*
  142:     THEN
  143:     f< ;
  144: 
  145: : f.s  ." <" fdepth 0 .r ." > " fdepth 0 max maxdepth-.s @ min dup 0 
  146:   ?DO  dup i - 1- floats fp@ + f@ f.  LOOP  drop ;