[hcoop/debian/mlton.git] / lib / stubs / basis-stubs-for-smlnj / real.sml

(* Copyright (C) 2009 Matthew Fluet.
 * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-2000 NEC Research Institute.
 *
 * MLton is released under a BSD-style license.
 * See the file MLton-LICENSE for details.
 *)

(* SML/NJ uses an old version of datatype IEEEReal.float_class. *)
signature REAL =
   sig
      type real

      structure Math: MATH where type real = real

      val != : real * real -> bool
      val * : real * real -> real
      val *+ : real * real * real -> real
      val *- : real * real * real -> real
      val + : real * real -> real
      val - : real * real -> real
      val / : real * real -> real
      val <  : real * real -> bool
      val <= : real * real -> bool
      val == : real * real -> bool
      val >  : real * real -> bool
      val >= : real * real -> bool
      val ?= : real * real -> bool
      val abs: real -> real
      val checkFloat: real -> real
      val class: real -> IEEEReal.float_class
      val compare: real * real -> order
      val compareReal: real * real -> IEEEReal.real_order
      val copySign: real * real -> real
      val fmt: StringCvt.realfmt -> real -> string
      val fromDecimal: IEEEReal.decimal_approx -> real option
      val fromInt: int -> real
      val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real
      val fromLargeInt: LargeInt.int -> real
      val fromManExp: {man: real, exp: int} -> real
      val fromString: string -> real option
      val isFinite: real -> bool
      val isNan: real -> bool
      val isNormal: real -> bool
      val max: real * real -> real
      val maxFinite: real
      val min: real * real -> real
      val minNormalPos: real
      val minPos: real
      val negInf: real
      val nextAfter: real * real -> real
      val posInf: real
      val precision: int
      val radix: int
      val realCeil: real -> real
      val realFloor: real -> real
      val realMod: real -> real
      val realRound: real -> real
      val realTrunc: real -> real
      val rem: real * real -> real
      val round: real -> Int.int
      val sameSign: real * real -> bool
      val scan: (char, 'a) StringCvt.reader -> (real, 'a) StringCvt.reader
      val sign: real -> int
      val signBit: real -> bool
      val split: real -> {whole: real, frac: real}
      val toDecimal: real -> IEEEReal.decimal_approx
      val toInt: IEEEReal.rounding_mode -> real -> int
      val toLarge: real -> LargeReal.real
      val toLargeInt: IEEEReal.rounding_mode -> real -> LargeInt.int
      val toManExp: real -> {man: real, exp: int}
      val toString: real -> string
      val unordered: real * real -> bool
      val ~ : real -> real
      val ceil: real -> Int.int
      val floor: real -> Int.int
      val trunc: real -> Int.int
   end

functor FixReal(PReal: sig include PERVASIVE_REAL val zero : real end) : REAL =
   struct
      open PReal

      local
         datatype z = datatype IEEEReal.float_class
         structure P = Pervasive.IEEEReal
         fun toGoodFC c =
            case c of
               P.NAN _ => NAN
             | P.INF => INF
             | P.ZERO => ZERO
             | P.NORMAL => NORMAL
             | P.SUBNORMAL => SUBNORMAL
         fun toBadFC c =
            case c of
               NAN => P.NAN P.QUIET
             | INF => P.INF
             | ZERO => P.ZERO
             | NORMAL => P.NORMAL
             | SUBNORMAL => P.SUBNORMAL
         fun toGoodDA {digits, exp, kind, sign} =
            {digits = digits, exp = exp, kind = toGoodFC kind, sign = sign}
         fun toBadDA {digits, exp, kind, sign} =
            {digits = digits, exp = exp, kind = toBadFC kind, sign = sign}
      in
         val class = toGoodFC o class
         val fromDecimal = SOME o fromDecimal o toBadDA
         val toDecimal = toGoodDA o toDecimal
      end

      (* SML/NJ doesn't support EXACT
       * and doesn't include a leading "~" for ~0.0.
       *)
      fun fmt f =
         let
            val fmt =
               PReal.fmt
               (let
                   datatype z = datatype StringCvt.realfmt
                in
                   case f of
                      EXACT => StringCvt.GEN NONE
                    | FIX io => StringCvt.FIX io
                    | GEN io => StringCvt.GEN io
                    | SCI io => StringCvt.SCI io
                end)
         in
            fn r =>
            if == (zero, r) andalso signBit r
               then "~" ^ (fmt r)
            else fmt r
         end

      (* SML/NJ doesn't handle "[+~-]?(inf|infinity|nan)"
       * and raises Overflow on large exponents.
       *)
      fun fromString s =
         case s of
            "inf" => SOME posInf
          | "infinity" => SOME posInf
          | "+inf" => SOME posInf
          | "+infinity" => SOME posInf
          | "~inf" => SOME negInf
          | "~infinity" => SOME negInf
          | "-inf" => SOME negInf
          | "-infinity" => SOME negInf
          | "nan" => SOME (negInf + posInf)
          | "+nan" => SOME (negInf + posInf)
          | "~nan" => SOME (negInf + posInf)
          | "-nan" => SOME (negInf + posInf)
          | _ =>
               (case SOME (PReal.fromString s) handle Overflow => NONE of
                   NONE =>
                      let
                         val manexp =
                            String.tokens
                            (fn c => c = #"e" orelse c = #"E")
                            s
                         fun isNeg s =
                            String.sub (s, 0) = #"~"
                            orelse String.sub (s, 0) = #"+"
                         fun isNonzero s =
                            CharVector.exists
                            (fn c => Char.<= (#"1", c) andalso Char.<= (c, #"9"))
                            s
                      in
                         case manexp of
                            [man,exp] =>
                               if isNeg exp
                                  then SOME zero
                               else if isNonzero man
                                  then SOME posInf
                               else SOME zero
                           | _ => NONE
                      end
                 | SOME ro => ro)
   end

structure LargeReal = FixReal(struct open Pervasive.LargeReal val zero : real = 0.0 end)
structure Real = FixReal(struct open Pervasive.Real val zero : real = 0.0 end)
structure Real64 = FixReal(struct open Pervasive.Real64 val zero : real = 0.0 end)
structure Real32 = Real64

(* Dummy implementation that will not be used at run-time. *)
structure PackReal32Big : PACK_REAL where type real = Real32.real = struct
   type real = Real32.real
   val bytesPerElem = 0
   val isBigEndian = false
   fun toBytes _ = raise Fail "PackReal32Big.toBytes"
   fun fromBytes _ = raise Fail "PackReal32Big.fromBytes"
   fun subVec _ = raise Fail "PackReal32Big.subVec"
   fun subArr _ = raise Fail "PackReal32Big.subArr"
   fun update _ = raise Fail "PackReal32Big.update"
end
(* Dummy implementation that will not be used at run-time. *)
structure PackReal32Little : PACK_REAL where type real = Real32.real = struct
   type real = Real32.real
   val bytesPerElem = 0
   val isBigEndian = false
   fun toBytes _ = raise Fail "PackReal32Little.toBytes"
   fun fromBytes _ = raise Fail "PackReal32Little.fromBytes"
   fun subVec _ = raise Fail "PackReal32Little.subVec"
   fun subArr _ = raise Fail "PackReal32Little.subArr"
   fun update _ = raise Fail "PackReal32Little.update"
end

(* Dummy implementation that will not be used at run-time. *)
structure PackReal64Big : PACK_REAL where type real = Real64.real  = struct
   type real = Real64.real
   val bytesPerElem = 0
   val isBigEndian = false
   fun toBytes _ = raise Fail "PackReal64Big.toBytes"
   fun fromBytes _ = raise Fail "PackReal64Big.fromBytes"
   fun subVec _ = raise Fail "PackReal64Big.subVec"
   fun subArr _ = raise Fail "PackReal64Big.subArr"
   fun update _ = raise Fail "PackReal64Big.update"
end
(* Dummy implementation that will not be used at run-time. *)
structure PackReal64Little : PACK_REAL where type real = Real64.real  = struct
   type real = Real64.real
   val bytesPerElem = 0
   val isBigEndian = false
   fun toBytes _ = raise Fail "PackReal64Little.toBytes"
   fun fromBytes _ = raise Fail "PackReal64Little.fromBytes"
   fun subVec _ = raise Fail "PackReal64Little.subVec"
   fun subArr _ = raise Fail "PackReal64Little.subArr"
   fun update _ = raise Fail "PackReal64Little.update"
end
Commit	Line	Data
7f918cf1 CE	1	(* Copyright (C) 2009 Matthew Fluet.
	2	* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
	3	* Jagannathan, and Stephen Weeks.
	4	* Copyright (C) 1997-2000 NEC Research Institute.
	5	*
	6	* MLton is released under a BSD-style license.
	7	* See the file MLton-LICENSE for details.
	8	*)
	9
	10	(* SML/NJ uses an old version of datatype IEEEReal.float_class. *)
	11	signature REAL =
	12	sig
	13	type real
	14
	15	structure Math: MATH where type real = real
	16
	17	val != : real * real -> bool
	18	val * : real * real -> real
	19	val + : real real * real -> real
	20	val - : real real * real -> real
	21	val + : real * real -> real
	22	val - : real * real -> real
	23	val / : real * real -> real
	24	val < : real * real -> bool
	25	val <= : real * real -> bool
	26	val == : real * real -> bool
	27	val > : real * real -> bool
	28	val >= : real * real -> bool
	29	val ?= : real * real -> bool
	30	val abs: real -> real
	31	val checkFloat: real -> real
	32	val class: real -> IEEEReal.float_class
	33	val compare: real * real -> order
	34	val compareReal: real * real -> IEEEReal.real_order
	35	val copySign: real * real -> real
	36	val fmt: StringCvt.realfmt -> real -> string
	37	val fromDecimal: IEEEReal.decimal_approx -> real option
	38	val fromInt: int -> real
	39	val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real
	40	val fromLargeInt: LargeInt.int -> real
	41	val fromManExp: {man: real, exp: int} -> real
	42	val fromString: string -> real option
	43	val isFinite: real -> bool
	44	val isNan: real -> bool
	45	val isNormal: real -> bool
	46	val max: real * real -> real
	47	val maxFinite: real
	48	val min: real * real -> real
	49	val minNormalPos: real
	50	val minPos: real
	51	val negInf: real
	52	val nextAfter: real * real -> real
	53	val posInf: real
	54	val precision: int
	55	val radix: int
	56	val realCeil: real -> real
	57	val realFloor: real -> real
	58	val realMod: real -> real
	59	val realRound: real -> real
	60	val realTrunc: real -> real
	61	val rem: real * real -> real
	62	val round: real -> Int.int
	63	val sameSign: real * real -> bool
	64	val scan: (char, 'a) StringCvt.reader -> (real, 'a) StringCvt.reader
65	val sign: real -> int
66	val signBit: real -> bool
67	val split: real -> {whole: real, frac: real}
68	val toDecimal: real -> IEEEReal.decimal_approx
69	val toInt: IEEEReal.rounding_mode -> real -> int
70	val toLarge: real -> LargeReal.real
71	val toLargeInt: IEEEReal.rounding_mode -> real -> LargeInt.int
72	val toManExp: real -> {man: real, exp: int}
73	val toString: real -> string
74	val unordered: real * real -> bool
75	val ~ : real -> real
76	val ceil: real -> Int.int
77	val floor: real -> Int.int
78	val trunc: real -> Int.int
79	end
80
81	functor FixReal(PReal: sig include PERVASIVE_REAL val zero : real end) : REAL =
82	struct
83	open PReal
84
85	local
86	datatype z = datatype IEEEReal.float_class
87	structure P = Pervasive.IEEEReal
88	fun toGoodFC c =
89	case c of
90	P.NAN _ => NAN
91	\| P.INF => INF
92	\| P.ZERO => ZERO
93	\| P.NORMAL => NORMAL
94	\| P.SUBNORMAL => SUBNORMAL
95	fun toBadFC c =
96	case c of
97	NAN => P.NAN P.QUIET
98	\| INF => P.INF
99	\| ZERO => P.ZERO
100	\| NORMAL => P.NORMAL
101	\| SUBNORMAL => P.SUBNORMAL
102	fun toGoodDA {digits, exp, kind, sign} =
103	{digits = digits, exp = exp, kind = toGoodFC kind, sign = sign}
104	fun toBadDA {digits, exp, kind, sign} =
105	{digits = digits, exp = exp, kind = toBadFC kind, sign = sign}
106	in
107	val class = toGoodFC o class
108	val fromDecimal = SOME o fromDecimal o toBadDA
109	val toDecimal = toGoodDA o toDecimal
110	end
111
112	(* SML/NJ doesn't support EXACT
113	* and doesn't include a leading "~" for ~0.0.
114	*)
115	fun fmt f =
116	let
117	val fmt =
118	PReal.fmt
119	(let
120	datatype z = datatype StringCvt.realfmt
121	in
122	case f of
123	EXACT => StringCvt.GEN NONE
124	\| FIX io => StringCvt.FIX io
125	\| GEN io => StringCvt.GEN io
126	\| SCI io => StringCvt.SCI io
127	end)
128	in
129	fn r =>
130	if == (zero, r) andalso signBit r
131	then "~" ^ (fmt r)
132	else fmt r
133	end
134
135	(* SML/NJ doesn't handle "[+~-]?(inf\|infinity\|nan)"
136	* and raises Overflow on large exponents.
137	*)
138	fun fromString s =
139	case s of
140	"inf" => SOME posInf
141	\| "infinity" => SOME posInf
142	\| "+inf" => SOME posInf
143	\| "+infinity" => SOME posInf
144	\| "~inf" => SOME negInf
145	\| "~infinity" => SOME negInf
146	\| "-inf" => SOME negInf
147	\| "-infinity" => SOME negInf
148	\| "nan" => SOME (negInf + posInf)
149	\| "+nan" => SOME (negInf + posInf)
150	\| "~nan" => SOME (negInf + posInf)
151	\| "-nan" => SOME (negInf + posInf)
152	\| _ =>
153	(case SOME (PReal.fromString s) handle Overflow => NONE of
154	NONE =>
155	let
156	val manexp =
157	String.tokens
158	(fn c => c = #"e" orelse c = #"E")
159	s
160	fun isNeg s =
161	String.sub (s, 0) = #"~"
162	orelse String.sub (s, 0) = #"+"
163	fun isNonzero s =
164	CharVector.exists
165	(fn c => Char.<= (#"1", c) andalso Char.<= (c, #"9"))
166	s
167	in
168	case manexp of
169	[man,exp] =>
170	if isNeg exp
171	then SOME zero
172	else if isNonzero man
173	then SOME posInf
174	else SOME zero
175	\| _ => NONE
176	end
177	\| SOME ro => ro)
178	end
179
180	structure LargeReal = FixReal(struct open Pervasive.LargeReal val zero : real = 0.0 end)
181	structure Real = FixReal(struct open Pervasive.Real val zero : real = 0.0 end)
182	structure Real64 = FixReal(struct open Pervasive.Real64 val zero : real = 0.0 end)
183	structure Real32 = Real64
184
185	(* Dummy implementation that will not be used at run-time. *)
186	structure PackReal32Big : PACK_REAL where type real = Real32.real = struct
187	type real = Real32.real
188	val bytesPerElem = 0
189	val isBigEndian = false
190	fun toBytes _ = raise Fail "PackReal32Big.toBytes"
191	fun fromBytes _ = raise Fail "PackReal32Big.fromBytes"
192	fun subVec _ = raise Fail "PackReal32Big.subVec"
193	fun subArr _ = raise Fail "PackReal32Big.subArr"
194	fun update _ = raise Fail "PackReal32Big.update"
195	end
196	(* Dummy implementation that will not be used at run-time. *)
197	structure PackReal32Little : PACK_REAL where type real = Real32.real = struct
198	type real = Real32.real
199	val bytesPerElem = 0
200	val isBigEndian = false
201	fun toBytes _ = raise Fail "PackReal32Little.toBytes"
202	fun fromBytes _ = raise Fail "PackReal32Little.fromBytes"
203	fun subVec _ = raise Fail "PackReal32Little.subVec"
204	fun subArr _ = raise Fail "PackReal32Little.subArr"
205	fun update _ = raise Fail "PackReal32Little.update"
206	end
207
208	(* Dummy implementation that will not be used at run-time. *)
209	structure PackReal64Big : PACK_REAL where type real = Real64.real = struct
210	type real = Real64.real
211	val bytesPerElem = 0
212	val isBigEndian = false
213	fun toBytes _ = raise Fail "PackReal64Big.toBytes"
214	fun fromBytes _ = raise Fail "PackReal64Big.fromBytes"
215	fun subVec _ = raise Fail "PackReal64Big.subVec"
216	fun subArr _ = raise Fail "PackReal64Big.subArr"
217	fun update _ = raise Fail "PackReal64Big.update"
218	end
219	(* Dummy implementation that will not be used at run-time. *)
220	structure PackReal64Little : PACK_REAL where type real = Real64.real = struct
221	type real = Real64.real
222	val bytesPerElem = 0
223	val isBigEndian = false
224	fun toBytes _ = raise Fail "PackReal64Little.toBytes"
225	fun fromBytes _ = raise Fail "PackReal64Little.fromBytes"
226	fun subVec _ = raise Fail "PackReal64Little.subVec"
227	fun subArr _ = raise Fail "PackReal64Little.subArr"
228	fun update _ = raise Fail "PackReal64Little.update"
229	end