home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / mosmllib / Real.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  5.2 KB  |  170 lines  |  [TEXT/R*ch]
  1. (* Real.sml -- 1995-05-24, 1996-05-16, 1996-07-02 *)
  2.  
  3. type real = real
  4.  
  5. exception Div = Div
  6. and Overflow = Overflow;
  7.  
  8. val floor = floor;
  9. val ceil  = ceil;
  10. val trunc = trunc;
  11. val round = round;
  12.  
  13. val fromInt = real;
  14.  
  15. (* The following should be replaced by numerically better conversion
  16. functions; see 
  17.  
  18. Steele and White : How to print floating-point numbers accurately,
  19. PLDI'90, pages 112-123, and
  20.  
  21. Clinger: How to read floating-point numbers accurately, PLDI'90, pages
  22. 92-101.
  23.  
  24. D.M. Gay: Correctly rounded binary-decimal and decimal-binary
  25. conversions, AT&T Bell Labs, Numerical Analysis Manuscript 90-10,
  26. November 30, 1990 *)
  27.  
  28. fun fmt spec = 
  29.     let prim_val to_string       : string -> real -> string 
  30.                                = 2 "sml_general_string_of_float";
  31.     prim_val plain_to_string : real -> string = 1 "sml_string_of_float";
  32.     prim_val sub_            : string -> int -> char = 2 "get_nth_char";
  33.     prim_val int_to_string   : int -> string = 1 "sml_string_of_int";
  34.  
  35.     fun mlify s = (* Add ".0" if not "e" or "." in s  *)
  36.         let val stop = size s
  37.         fun loop i =        (* s[0..i-1] contains no "." or "e" *)
  38.             if i = stop then s ^ ".0"
  39.             else if sub_ s i = #"." orelse sub_ s i = #"E" then s
  40.                     else loop (i+1)
  41.         in loop 0 end
  42.  
  43.     open StringCvt
  44.     (* Below we check that the requested number of decimal digits 
  45.      * is reasonable; else sml_general_string_of_float may crash. *)
  46.     val fmtspec = 
  47.     case spec of
  48.         SCI NONE     => to_string "%e"
  49.       | SCI (SOME n) => 
  50.         if n < 0 orelse n > 400 then raise Size 
  51.         else to_string ("%." ^ int_to_string n ^ "e")
  52.       | FIX NONE     => to_string "%f"
  53.       | FIX (SOME n) =>
  54.         if n < 0 orelse n > 400 then raise Size 
  55.         else to_string ("%." ^ int_to_string n ^ "f")
  56.       | GEN NONE     => plain_to_string
  57.       | GEN (SOME n) => 
  58.         if n < 1 orelse n > 400 then raise Size 
  59.         else fn r => mlify (to_string ("%." ^ int_to_string n ^ "g") r)
  60.     in fmtspec end
  61.  
  62. fun toString r = fmt (StringCvt.GEN NONE) r;
  63.  
  64. fun scan getc source = 
  65.     let fun decval c = Char.ord c - 48
  66.     fun pow10 0 = 1.0
  67.       | pow10 n = 
  68.         if n mod 2 = 0 then 
  69.         let val x = pow10 (n div 2) in x * x end
  70.         else 10.0 * pow10 (n-1)
  71.     fun pointsym src = 
  72.         case getc src of
  73.         NONE           => (false, src)
  74.           | SOME (c, rest) => if c = #"." then (true, rest)
  75.                   else (false, src)
  76.     fun esym src = 
  77.         case getc src of
  78.         NONE           => (false, src)
  79.           | SOME (c, rest) => 
  80.             if c = #"e" orelse c = #"E"  then 
  81.             (true, rest)
  82.             else (false, src)
  83.     fun scandigs first next final source =
  84.         let fun digs state src = 
  85.         case getc src of
  86.             NONE          => (SOME (final state), src)
  87.           | SOME(c, rest) => 
  88.             if Char.isDigit c then 
  89.                 digs (next(state, decval c)) rest
  90.             else 
  91.                 (SOME (final state), src)
  92.         in 
  93.         case getc source of
  94.             NONE          => (NONE, source)
  95.           | SOME(c, rest) => 
  96.             if Char.isDigit c then digs (first (decval c)) rest
  97.             else (NONE, source)
  98.         end
  99.  
  100.     fun ident x = x
  101.     val getint  = 
  102.         scandigs real (fn (res, cval) => 10.0 * res + real cval) ident
  103.     val getfrac = 
  104.         scandigs (fn cval => (1, real cval))    
  105.                  (fn ((decs, frac), cval) => (decs+1, 10.0*frac+real cval))
  106.              (fn (decs, frac) => frac / pow10 decs)
  107.     val getexp = scandigs ident (fn (res, cval) => 10 * res + cval) ident
  108.  
  109.     fun sign src =
  110.         case getc src of
  111.         SOME(#"+", rest) => (true,  rest)
  112.           | SOME(#"-", rest) => (false, rest)
  113.           | SOME(#"~", rest) => (false, rest)
  114.           | _                => (true,  src )
  115.  
  116.     val src = StringCvt.dropl Char.isSpace getc source
  117.     val (manpos, src1) = sign src
  118.     val (intg,   src2) = getint src1
  119.     val (decpt,  src3) = pointsym src2
  120.     val (frac,   src4) = getfrac src3 
  121.  
  122.     fun mkres v rest = 
  123.         SOME(if manpos then v else ~v, rest)
  124.  
  125.         fun expopt manval src = 
  126.         let val (esym,   src1) = esym src
  127.         val (exppos, src2) = sign src1
  128.         val (expv,   rest) = getexp src2 
  129.         in 
  130.         case (esym, expv) of
  131.             (_,     NONE)     => mkres manval src
  132.           | (true,  SOME exp) => 
  133.             if exppos then mkres (manval * pow10 exp) rest
  134.             else mkres (manval / pow10 exp) rest
  135.           | _                 => NONE
  136.         end
  137.     in 
  138.     case (intg,     decpt, frac) of
  139.         (NONE,      true,  SOME fval) => expopt fval src4
  140.           | (SOME ival, false, SOME _   ) => NONE
  141.           | (SOME ival, true,  NONE     ) => mkres ival src2
  142.           | (SOME ival, false, NONE     ) => expopt ival src2
  143.           | (SOME ival, _    , SOME fval) => expopt (ival+fval) src4
  144.       | _                             => NONE 
  145.     end;
  146.  
  147. val fromString = StringCvt.scanString scan;
  148.  
  149. val ~       : real -> real        = ~;
  150. val op +    : real * real -> real = op +;
  151. val op -    : real * real -> real = op -;
  152. val op *    : real * real -> real = op *;
  153. val op /    : real * real -> real = op /;
  154. val op >    : real * real -> bool = op >;
  155. val op >=   : real * real -> bool = op >=;
  156. val op <    : real * real -> bool = op <;
  157. val op <=   : real * real -> bool = op <=;
  158. val abs     : real -> real = abs;
  159. fun sign i = if i > 0.0 then 1 else if i < 0.0 then ~1 else 0;
  160. fun compare (x, y: real) = 
  161.     if x<y then LESS else if x>y then GREATER else EQUAL;
  162.  
  163. fun sameSign (i, j) = sign i = sign j;
  164.  
  165. fun min (x, y) = if x < y then x else y : real;
  166. fun max (x, y) = if x < y then y else x : real;
  167.  
  168. fun toDefault   i   = i;
  169. fun fromDefault i   = i;
  170.