home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / forst / fpout.s < prev    next >
Encoding:
Text File  |  1993-10-23  |  2.0 KB  |  106 lines
  1. decimal
  2. : module ;
  3.  
  4. : normalize { 1 arg fno  1 local decexp }
  5.  
  6.   -1 to decexp
  7.   fno expon 0<
  8.     if  fno fabs
  9.       begin dup f0.1 <
  10.       while f10.0 f*  -1 addto decexp repeat
  11.     else  fno fabs
  12.       begin dup f1.0 < not
  13.       while f0.1 f*  1 addto decexp repeat
  14.     then
  15.   decexp ( normalized mantissa, dec exponent) ;
  16.  
  17. : spill ( fno)
  18.   dup mant  swap expon 8 + lsl
  19.   40000000 um*  swap
  20.   0< if 1+ then 2/ ( decimal mantissa) ;
  21.  
  22. : sigfigs  { 1 arg mantissa  2 locals #digs quotient }
  23.  
  24.   mantissa  7 to #digs
  25.   begin
  26.    dup to quotient
  27.    10 /mod swap  0=  #digs 1 > and
  28.   while
  29.    -1 addto #digs
  30.   repeat  drop
  31.   quotient #digs ( scaled mantissa, #digits) ;
  32.  
  33. : decpt  46 hold ;
  34. : figures  dup 0> if  0 do # loop  else drop then ;
  35. : zeros  dup 0> if  0 do 48 hold loop  else drop then ;
  36.  
  37. : scientific  { 4 args fno value length exponent }
  38.  
  39.   exponent abs
  40.   <#
  41.     #s  exponent sign  69 hold  drop
  42.     value
  43.     length 1 >
  44.     if
  45.       length 1- figures decpt
  46.     then
  47.     #  fno sign
  48.   #>  ( string,length) ;
  49.  
  50. : vsmall  { 4 args fno value length exponent }
  51.  
  52.   value
  53.   <#
  54.     #s
  55.     exponent -1 <
  56.     if exponent abs 1- zeros then
  57.     decpt 1 zeros  fno sign
  58.   #>  ( string,length) ;
  59.  
  60. : small  { 4 args fno value length exponent  1 local diff }
  61.  
  62.   exponent length - to diff
  63.  
  64.   value
  65.   diff 0=
  66.   if
  67.    <# 1 zeros  #s  fno sign  #> exit
  68.   then
  69.  
  70.   diff 0>
  71.   if
  72.     <# diff 1+ zeros  #s  fno sign #>
  73.   else
  74.     diff -1 =
  75.     if
  76.       <# #s fno sign #>
  77.     else
  78.       <# diff abs 1- figures decpt  #s  fno sign #>
  79.     then
  80.   then ( string,length) ;
  81.  
  82. : (f.) { 1 arg fno  3 regs decexp numb numbase }
  83.  
  84.   base @ to numbase  decimal ( force to decimal output)
  85.  
  86.   fno 0=
  87.   if
  88.     0  <# # #>
  89.   else
  90.     fno normalize ( mant,decexp) to decexp
  91.     ( mant) spill to numb
  92.     fno numb sigfigs decexp
  93.     decexp -3 < decexp 5 > or
  94.     if
  95.       scientific
  96.     else
  97.       decexp 0<
  98.       if vsmall else small then
  99.     then
  100.   then ( string,length)
  101.  
  102.   numbase base ! ;
  103.  
  104. : f. (f.)  type space ;
  105.  
  106.