Commit 038bbed1 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-10-24 09:22:10 by szach] - added:

- inv_const (build the const type corresponding to a const value)

- some infix comparison operators on Value.t

- dump_xml (dump an XML representation of a Value.t type)

- added ValueSet module

Original author: szach
Date: 2003-10-24 09:22:10+00:00
parent 3a379006
......@@ -65,7 +65,25 @@ let rec const = function
| Types.Record x -> Record (LabelMap.map const x)
| Types.String (i,j,s,c) -> String_utf8 (i,j,s, const c)
let rec inv_const = function
| Pair (x, y) -> Types.Pair (inv_const x, inv_const y)
| Xml (x, y, z) ->
Types.Pair (inv_const x, Types.Pair (inv_const y, inv_const z))
| Record x -> Types.Record (LabelMap.map inv_const x)
| Atom a -> Types.Atom a
| Integer i -> Types.Integer i
| Char c -> Types.Char c
| String_latin1 (_, _, s, v) ->
let s = Utf8.mk s in
Types.String (Utf8.start_index s, Utf8.end_index s, s, inv_const v)
| String_utf8 (i, j, s, v) -> Types.String (i, j, s, inv_const v)
| Concat (x, y) as v ->
let rec children = function
| Concat (x, y) -> children x @ children y
| x -> [x]
in
inv_const (sequence (children v))
| _ -> failwith "inv_const"
let normalize_string_latin1 i j s q =
if i = j then q else
......@@ -291,6 +309,59 @@ and print_record ppf = function
and print_field ppf (l,v) =
Format.fprintf ppf "%a=%a" Label.print (LabelPool.value l) print v
let dump_xml ppf v =
let rec aux ppf = function
| Pair (x, y) ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<pair>@,%a@,%a@,</pair>@]" aux x aux y
| Xml (x, y, z) ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<xml>@,%a@,%a@,%a@,</xml>@]" aux x aux y aux z
| Record x ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<record>@,%a@,</record>@]"
(fun ppf x -> print_record ppf (LabelMap.get x)) x
| Atom a ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<record>@,%a@,</record>@]"
(fun ppf x -> Atoms.V.print ppf x) a
| Integer i ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<integer>@,%a@,</integer>@]"
(fun ppf x -> Intervals.V.print ppf x) i
| Char c ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<char>@,%a@,</char>@]"
(fun ppf x -> Chars.V.print ppf x) c
| Abstraction _ ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<abstraction />@]"
| Abstraction2 _ ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<abstraction2 />@]"
| String_latin1 (_, _, s, v) ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<string_latin1>@,%s@,</string_latin1>" s;
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<follow>@,%a@,</follow>@]</string_latin1>@]" aux v
| String_utf8 (_, _, s, v) ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<string_utf8>@,%s@,</string_utf8>" (Utf8.get_str s);
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<follow>@,%a@,</follow>@]</string_utf8>@]" aux v
| Concat (x, y) ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<concat>@,%a@,%a@,</concat>@]" aux x aux y
| Absent ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<absent />@]"
| Delayed _ ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<delayed />@]"
in
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<value>@,%a@,</value>@]" aux v
let rec compare x y =
if (x == y) then 0
else
......@@ -385,6 +456,22 @@ let iter_xml pcdata_callback other_callback =
| _ -> raise (Invalid_argument "Value.iter_xml")
(** set of values *)
type tmp = t
module OrderedValue =
struct
type t = tmp
let compare = compare
end
module ValueSet = Set.Make(OrderedValue)
let ( |<| ) x y = compare x y < 0
let ( |>| ) x y = compare x y > 0
let ( |<=| ) x y = let c = compare x y in c < 0 || c = 0
let ( |>=| ) x y = let c = compare x y in c > 0 || c = 0
let ( |=| ) x y = compare x y = 0
let ( |<>| ) x y = compare x y <> 0
(*
let rec concat l1 l2 = match l1 with
......
......@@ -23,14 +23,18 @@ type t =
(* Only in evaluation environment *)
| Delayed of t ref
module ValueSet: Set.S with type elt = t
exception CDuceExn of t
val print: Format.formatter -> t -> unit
val dump_xml: Format.formatter -> t -> unit
val normalize: t -> t
(* Transform a derived form to its canonical equivalent *)
val const : Types.const -> t
val const : Types.const -> t (* extract the const value from a const type *)
val inv_const : t -> Types.const (* build a const type from a const value *)
val string_latin1 : string -> t
val string_utf8 : U.t -> t
val nil : t
......@@ -60,9 +64,14 @@ val get_int : t -> int
val get_fields : t -> (string * t) list
val compare : t -> t -> int
val ( |<| ): t -> t -> bool
val ( |>| ): t -> t -> bool
val ( |<=| ): t -> t -> bool
val ( |>=| ): t -> t -> bool
val ( |=| ): t -> t -> bool
val ( |<>| ): t -> t -> bool
val set_cdr : t -> t -> unit
val append_cdr : t -> t -> t
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