[r2005-02-25 14:46:38 by afrisch] float

Original author: afrisch
Date: 2005-02-25 14:46:39+00:00

runtime/print_xml.ml

@@ -16,8 +16,9 @@ let false_literal = U.mk "false"
 
   (* @raise exn_print_xml in case of failure. Rationale: schema printing is
    * the last attempt to print a value, others have already failed *)
-let rec schema_value ?(recurs=true) ~wds v =
-  match v with
+let rec schema_value ?(recurs=true) ~wds v = match v with
+  | Abstract ("float",f) ->
+      wds (U.mk (string_of_float (Obj.magic f : float)))
   | Record _ as v ->
       (try
         wds (Schema_builtin.string_of_time_type (Value.get_fields v))

runtime/value.ml

@@ -265,6 +265,8 @@ let rec print ppf v =
 	(Utf8.get_idx i) (Utf8.get_idx j) (Utf8.get_str s) print q
     | Concat (x,y) ->
 	Format.fprintf ppf "<concat:%a;%a>" print x print y
+    | Abstract ("float",o) ->
+	Format.fprintf ppf "%f" (Obj.magic o : float)
     | Abstract (s,_) ->
 	Format.fprintf ppf "<abstract=%s>" s
     | Absent -> 	
@@ -643,3 +645,6 @@ let print_utf8 v =
   print_string (U.get_str v);
   flush stdout
 
+
+let float n =
+  Abstract (Builtin_defs.float_abs, Obj.repr n)

runtime/value.mli

@@ -80,6 +80,7 @@ val concat : t -> t -> t
 val flatten : t -> t
 val append : t -> t -> t
 
+val float: float -> t
 
 val get_string_latin1 : t -> string
 val get_string_utf8 : t -> U.t * t

schema/schema_builtin.ml

@@ -16,7 +16,7 @@ open Schema_types
 let xsd = Schema_xml.xsd
 let add_xsd_prefix s = (xsd, Utf8.mk s)
 
-let unsupported = [ "decimal"; "float"; "double"; "NOTATION"; "QName" ]
+let unsupported = [ "NOTATION"; "QName" ]
 
 let is_empty s = Utf8.equal s (Utf8.mk "")
 
@@ -138,6 +138,11 @@ let validate_integer s =
     try Value.Integer (Intervals.V.mk s)
     with Failure _ -> simple_type_error "integer"
 
+let validate_decimal s =
+  let s = Utf8.get_str s in
+  try Value.float (float_of_string s)
+  with Failure _ -> simple_type_error "decimal"
+
 let strip_decimal_RE = Pcre.regexp "\\..*$"
 
 let parse_date =
@@ -475,6 +480,13 @@ let _ =
   primitive "gDay" gDay_type validate_gDay
 let _ = 
   primitive "gMonth" gMonth_type validate_gMonth
+let decimal = 
+  primitive "decimal" Builtin_defs.float validate_decimal
+
+let _ =
+  alias "float" decimal;
+  alias "double" decimal
+
 
 let _ = 
   List.iter (fun n -> alias n string) unsupported

types/builtin.ml

@@ -83,6 +83,11 @@ let exn_int_of =
     Value.Pair (
       Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
       Value.string_latin1 "int_of"))
+let exn_float_of = 
+  Value.CDuceExn (
+    Value.Pair (
+      Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
+      Value.string_latin1 "float_of"))
 
 let eval_load_file ~utf8 e =
   Location.protect_op "load_file";
@@ -307,3 +312,12 @@ unary_op_gen "flatten"
 register_fun "raise" any Types.empty
   (fun v -> raise (Value.CDuceExn v));;
 
+
+
+(* Float *)
+
+register_fun "float_of" string float
+  (fun v ->
+     let (s,_) = Value.get_string_utf8 v in
+     try Value.float (float_of_string (U.get_str s))
+     with Failure _ -> raise exn_float_of);;