home *** CD-ROM | disk | FTP | other *** search
/ Dream 48 / Amiga_Dream_48.iso / Atari / forth / forst.zoo / forst / lib / fpin.s < prev    next >
Text File  |  1990-12-10  |  2KB  |  92 lines
  1. decimal
  2. : module ;
  3.  
  4. 10 i>f          constant f10.0
  5. 1 i>f f10.0 f/  constant f0.1
  6.  
  7. : fconvert
  8.  { 3 args &pointer &value &range  2 locals pointer char }
  9.  
  10.   &pointer @ 1+ to pointer
  11.  
  12.   begin
  13.     pointer c@ to char
  14.     char 47 > char 58 < and
  15.   while
  16.     &value @ f10.0 f*  char 48 - i>f f+ &value !
  17.     &range @ 0< not
  18.     if 1 &range +! then
  19.     1 addto pointer
  20.   repeat
  21.  
  22.   pointer  &pointer ! ;
  23.  
  24. : expconvert  { 1 arg pointer  3 locals char numb sign }
  25.  
  26.   1 addto pointer  0 to numb  0 to sign
  27.  
  28.   pointer c@ 45 = dup
  29.   if  drop 1 addto pointer  -1 to sign
  30.   else
  31.     43 =
  32.     if  1 addto pointer  then
  33.   then
  34.  
  35.   begin
  36.    pointer c@ to char
  37.    char 47 > char 58 < and
  38.   while
  39.    numb 10 *  char 48 - +  to numb
  40.    1 addto pointer
  41.   repeat
  42.  
  43.   numb  sign if negate then   pointer ;
  44.  
  45. : fnumber  { 1 arg charptr  3 locals sign mantissa dpl }
  46.  
  47.   0 to sign  0 to mantissa  -1 to dpl
  48.  
  49.   charptr 1+ c@ 45 = dup
  50.   if  drop 1 addto charptr  -1 to sign
  51.   else
  52.     43 =
  53.     if  1 addto charptr  then
  54.   then
  55.  
  56.   addr charptr  addr mantissa  addr dpl  fconvert
  57.   charptr c@ 32 =
  58.   if mantissa  sign  if fnegate then  exit then
  59.  
  60.   0 to dpl
  61.   charptr c@ 46 =
  62.   if
  63.     addr charptr  addr mantissa  addr dpl  fconvert
  64.   then
  65.  
  66.   charptr c@ 95 and 69 =
  67.   if
  68.     charptr expconvert
  69.     to charptr  negate addto dpl
  70.   then
  71.  
  72.   charptr c@ 32 - abort" FP conversion error"
  73.   
  74.   mantissa
  75.   dpl if
  76.     dpl 0>
  77.     if
  78.       begin  dpl 0>
  79.       while  f0.1 f*  -1 addto dpl
  80.       repeat
  81.     else
  82.       begin  dpl 0<
  83.       while  f10.0 f*  1 addto dpl
  84.       repeat
  85.     then
  86.   then
  87.   sign  if fnegate then
  88. ;
  89.  
  90. : ffetch  32 word fnumber ;
  91.  
  92.