Commit aed31864 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: afrisch
Date: 2005-02-25 14:46:39+00:00
parent 1d31f2a0
...@@ -16,8 +16,9 @@ let false_literal = U.mk "false" ...@@ -16,8 +16,9 @@ let false_literal = U.mk "false"
(* @raise exn_print_xml in case of failure. Rationale: schema printing is (* @raise exn_print_xml in case of failure. Rationale: schema printing is
* the last attempt to print a value, others have already failed *) * the last attempt to print a value, others have already failed *)
let rec schema_value ?(recurs=true) ~wds v = let rec schema_value ?(recurs=true) ~wds v = match v with
match v with | Abstract ("float",f) ->
wds (U.mk (string_of_float (Obj.magic f : float)))
| Record _ as v -> | Record _ as v ->
(try (try
wds (Schema_builtin.string_of_time_type (Value.get_fields v)) wds (Schema_builtin.string_of_time_type (Value.get_fields v))
......
...@@ -265,6 +265,8 @@ let rec print ppf v = ...@@ -265,6 +265,8 @@ let rec print ppf v =
(Utf8.get_idx i) (Utf8.get_idx j) (Utf8.get_str s) print q (Utf8.get_idx i) (Utf8.get_idx j) (Utf8.get_str s) print q
| Concat (x,y) -> | Concat (x,y) ->
Format.fprintf ppf "<concat:%a;%a>" print x print y Format.fprintf ppf "<concat:%a;%a>" print x print y
| Abstract ("float",o) ->
Format.fprintf ppf "%f" (Obj.magic o : float)
| Abstract (s,_) -> | Abstract (s,_) ->
Format.fprintf ppf "<abstract=%s>" s Format.fprintf ppf "<abstract=%s>" s
| Absent -> | Absent ->
...@@ -643,3 +645,6 @@ let print_utf8 v = ...@@ -643,3 +645,6 @@ let print_utf8 v =
print_string (U.get_str v); print_string (U.get_str v);
flush stdout flush stdout
let float n =
Abstract (Builtin_defs.float_abs, Obj.repr n)
...@@ -80,6 +80,7 @@ val concat : t -> t -> t ...@@ -80,6 +80,7 @@ val concat : t -> t -> t
val flatten : t -> t val flatten : t -> t
val append : t -> t -> t val append : t -> t -> t
val float: float -> t
val get_string_latin1 : t -> string val get_string_latin1 : t -> string
val get_string_utf8 : t -> U.t * t val get_string_utf8 : t -> U.t * t
......
...@@ -16,7 +16,7 @@ open Schema_types ...@@ -16,7 +16,7 @@ open Schema_types
let xsd = Schema_xml.xsd let xsd = Schema_xml.xsd
let add_xsd_prefix s = (xsd, Utf8.mk s) 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 "") let is_empty s = Utf8.equal s (Utf8.mk "")
...@@ -138,6 +138,11 @@ let validate_integer s = ...@@ -138,6 +138,11 @@ let validate_integer s =
try Value.Integer (Intervals.V.mk s) try Value.Integer (Intervals.V.mk s)
with Failure _ -> simple_type_error "integer" 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 strip_decimal_RE = Pcre.regexp "\\..*$"
let parse_date = let parse_date =
...@@ -475,6 +480,13 @@ let _ = ...@@ -475,6 +480,13 @@ let _ =
primitive "gDay" gDay_type validate_gDay primitive "gDay" gDay_type validate_gDay
let _ = let _ =
primitive "gMonth" gMonth_type validate_gMonth primitive "gMonth" gMonth_type validate_gMonth
let decimal =
primitive "decimal" Builtin_defs.float validate_decimal
let _ =
alias "float" decimal;
alias "double" decimal
let _ = let _ =
List.iter (fun n -> alias n string) unsupported List.iter (fun n -> alias n string) unsupported
......
...@@ -83,6 +83,11 @@ let exn_int_of = ...@@ -83,6 +83,11 @@ let exn_int_of =
Value.Pair ( Value.Pair (
Value.Atom (Atoms.V.mk_ascii "Invalid_argument"), Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
Value.string_latin1 "int_of")) 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 = let eval_load_file ~utf8 e =
Location.protect_op "load_file"; Location.protect_op "load_file";
...@@ -307,3 +312,12 @@ unary_op_gen "flatten" ...@@ -307,3 +312,12 @@ unary_op_gen "flatten"
register_fun "raise" any Types.empty register_fun "raise" any Types.empty
(fun v -> raise (Value.CDuceExn v));; (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);;
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment