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"
(* @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))
......
......@@ -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)
......@@ -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
......
......@@ -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
......
......@@ -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);;
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