Commit c78699d9 authored by Pietro Abate's avatar Pietro Abate

[r2004-06-27 21:11:51 by afrisch] New ocaml interface

Original author: afrisch
Date: 2004-06-27 21:11:54+00:00
parent 2fb71995
......@@ -82,19 +82,14 @@ endif
ifneq ($(ML_INTERFACE), false)
SYNTAX += -symbol ML_INTERFACE=
ML_LIB = oCaml_all.$(EXTENSION_LIB)
ML_INTERFACE_OBJ = \
cdo2cmo/ml_types.cmo \
cdo2cmo/ml_cduce.cmo \
cdo2cmo/ml_ocaml.cmo \
cdo2cmo/ml_checker.cmo \
cdo2cmo/ml_generator.cmo
ML_INTERFACE_OBJ = ocamliface/mltypes.cmo ocamliface/mlstub.cmo
else
ML_INTERFACE_OBJ =
endif
INSTALL := $(shell which install)
all: cduce dtd2cduce validate
all: cduce dtd2cduce validate cdo2ml
ifneq ($(ML_INTERFACE), false)
all: cdml.$(EXTENSION_LIB)
......@@ -103,13 +98,12 @@ endif
install: all
mkdir -p $(BINDIR)
mkdir -p $(MANDIR)/man1
$(INSTALL) -m755 cduce$(EXE) dtd2cduce$(EXE) validate$(EXE) $(BINDIR)/
$(INSTALL) -m755 cduce$(EXE) dtd2cduce$(EXE) \
validate$(EXE) cdo2ml$(EXE) $(BINDIR)/
$(INSTALL) -m644 doc/cduce.1 $(MANDIR)/man1/
$(INSTALL) -m644 doc/dtd2cduce.1 $(MANDIR)/man1/
$(INSTALL) -m644 doc/validate.1 $(MANDIR)/man1/
ifneq ($(ML_INTERFACE), false)
install_cdml:
$(OCAMLFIND) install cduce META \
cdml.$(EXTENSION_LIB) cdo2cmo/cdml.cmi \
cDuce_all.cmi oCaml_all.$(EXTENSION_LIB) \
......@@ -117,8 +111,11 @@ install_cdml:
endif
uninstall:
rm $(BINDIR)/cduce$(EXE) $(BINDIR)/dtd2cduce$(EXE) $(BINDIR)/validate$(EXE)
rm $(MANDIR)/man1/cduce.1 $(MANDIR)/man1/dtd2cduce.1 $(MANDIR)/man1/validate.1
rm -f $(BINDIR)/cduce$(EXE) $(BINDIR)/dtd2cduce$(EXE) \
$(BINDIR)/validate$(EXE) $(BINDIR)/cdo2ml$(EXE)
rm -f $(MANDIR)/man1/cduce.1 $(MANDIR)/man1/dtd2cduce.1 \
$(MANDIR)/man1/validate.1
ocamlfind remove cduce
help:
@echo "GOALS"
......@@ -136,7 +133,7 @@ help:
# Source directories
DIRS = misc parser schema typing types compile runtime driver query cdo2cmo
DIRS = misc parser schema typing types compile runtime driver query cdo2cmo ocamliface
CLEAN_DIRS = $(DIRS) tools tests
# Objects to build
......@@ -193,6 +190,10 @@ ALL_OBJECTS = $(OBJECTS) $(CQL_OBJECTS) \
$(CQL_OBJECTS_RUN)
ALL_INTERFACES = schema/schema_types.mli
ifneq ($(ML_INTERFACE), false)
ALL_INTERFACES += ocamliface/mltypes.mli ocamluface/mlstub.mli
endif
DEPEND = $(ALL_OBJECTS:.cmo=.ml) $(ALL_OBJECTS:.cmo=.mli) $(ALL_INTERFACES)
INCLUDES = $(DIRS:%=-I %)
......@@ -233,6 +234,9 @@ dtd2cduce: $(DTD2CDUCE:.cmo=.$(EXTENSION))
validate: $(VALIDATE_OBJECTS:.cmo=.$(EXTENSION)) tools/validate.$(EXTENSION)
$(LINK) $(INCLUDES) -o $@ $^
cdo2ml: ocamliface/cdo2ml.ml
ocamlc -o $@ -pp camlp4o -I +camlp4 camlp4.cma pr_o.cmo $^
.PHONY: compute_depend
compute_depend: $(DEPEND_OCAMLDEP)
echo $(DEPEND)
......
......@@ -43,6 +43,12 @@ let find x env =
with Not_found ->
failwith ("Compile: cannot find " ^ (Ident.to_string x))
let find_slot x env =
match find x env with
| Lambda.Ext (_,slot) -> slot
| _ -> assert false
let from_comp_unit = ref (fun cu -> assert false)
let find_ext cu x =
......
......@@ -17,7 +17,7 @@ val enter_global : env -> id -> env
val enter_globals : env -> id list -> env
*)
val find : id -> env -> var_loc
val find_slot : id -> env -> int
val compile_expr : env -> Typed.texpr -> Lambda.expr
......
......@@ -73,11 +73,11 @@ compile/lambda.cmo: types/ident.cmo types/patterns.cmi misc/serialize.cmi \
compile/lambda.cmx: types/ident.cmx types/patterns.cmx misc/serialize.cmx \
types/types.cmx
runtime/value.cmo: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/intervals.cmi compile/lambda.cmo types/sequence.cmi \
types/types.cmi runtime/value.cmi
types/ident.cmo types/intervals.cmi compile/lambda.cmo misc/ns.cmi \
types/sequence.cmi types/types.cmi runtime/value.cmi
runtime/value.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/intervals.cmx compile/lambda.cmx types/sequence.cmx \
types/types.cmx runtime/value.cmi
types/ident.cmx types/intervals.cmx compile/lambda.cmx misc/ns.cmx \
types/sequence.cmx types/types.cmx runtime/value.cmi
schema/schema_types.cmo: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi schema/schema_types.cmi
schema/schema_types.cmx: misc/encodings.cmx types/intervals.cmx misc/ns.cmx \
......@@ -220,42 +220,28 @@ driver/librarian.cmx: types/builtin.cmx compile/compile.cmx \
misc/encodings.cmx runtime/eval.cmx types/ident.cmx compile/lambda.cmx \
parser/location.cmx parser/parser.cmx misc/serialize.cmx typing/typer.cmx \
types/types.cmx runtime/value.cmx driver/librarian.cmi
cdo2cmo/ml_types.cmo: types/types.cmi
cdo2cmo/ml_types.cmx: types/types.cmx
cdo2cmo/ml_cduce.cmo: types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
compile/compile.cmi misc/encodings.cmi types/ident.cmo \
types/intervals.cmi compile/lambda.cmo driver/librarian.cmi \
cdo2cmo/ml_types.cmo misc/ns.cmi types/sequence.cmi typing/typer.cmi \
types/types.cmi
cdo2cmo/ml_cduce.cmx: types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
compile/compile.cmx misc/encodings.cmx types/ident.cmx \
types/intervals.cmx compile/lambda.cmx driver/librarian.cmx \
cdo2cmo/ml_types.cmx misc/ns.cmx types/sequence.cmx typing/typer.cmx \
types/types.cmx
cdo2cmo/ml_ocaml.cmo: driver/librarian.cmi cdo2cmo/ml_types.cmo
cdo2cmo/ml_ocaml.cmx: driver/librarian.cmx cdo2cmo/ml_types.cmx
cdo2cmo/ml_checker.cmo: cdo2cmo/ml_cduce.cmo cdo2cmo/ml_ocaml.cmo \
cdo2cmo/ml_types.cmo
cdo2cmo/ml_checker.cmx: cdo2cmo/ml_cduce.cmx cdo2cmo/ml_ocaml.cmx \
cdo2cmo/ml_types.cmx
cdo2cmo/ml_generator.cmo: cdo2cmo/ml_cduce.cmo cdo2cmo/ml_ocaml.cmo \
cdo2cmo/ml_types.cmo
cdo2cmo/ml_generator.cmx: cdo2cmo/ml_cduce.cmx cdo2cmo/ml_ocaml.cmx \
cdo2cmo/ml_types.cmx
ocamliface/mltypes.cmo: cdo2cmo/asttypes.cmo types/ident.cmo types/types.cmi \
ocamliface/mltypes.cmi
ocamliface/mltypes.cmx: cdo2cmo/asttypes.cmx types/ident.cmx types/types.cmx \
ocamliface/mltypes.cmi
ocamliface/mlstub.cmo: types/atoms.cmi types/builtin_defs.cmi \
compile/compile.cmi types/ident.cmo ocamliface/mltypes.cmi misc/ns.cmi \
types/sequence.cmi typing/typer.cmi types/types.cmi ocamliface/mlstub.cmi
ocamliface/mlstub.cmx: types/atoms.cmx types/builtin_defs.cmx \
compile/compile.cmx types/ident.cmx ocamliface/mltypes.cmx misc/ns.cmx \
types/sequence.cmx typing/typer.cmx types/types.cmx ocamliface/mlstub.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmi compile/compile.cmi \
misc/encodings.cmi runtime/eval.cmi runtime/explain.cmi types/ident.cmo \
driver/librarian.cmi parser/location.cmi cdo2cmo/ml_cduce.cmo \
cdo2cmo/ml_checker.cmo cdo2cmo/ml_generator.cmo cdo2cmo/ml_ocaml.cmo \
misc/ns.cmi parser/parser.cmi types/patterns.cmi types/sample.cmi \
schema/schema_common.cmi misc/state.cmi typing/typer.cmi types/types.cmi \
parser/ulexer.cmi runtime/value.cmi driver/cduce.cmi
driver/librarian.cmi parser/location.cmi ocamliface/mlstub.cmi \
ocamliface/mltypes.cmi misc/ns.cmi parser/parser.cmi types/patterns.cmi \
types/sample.cmi schema/schema_common.cmi misc/state.cmi typing/typer.cmi \
types/types.cmi parser/ulexer.cmi runtime/value.cmi driver/cduce.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx compile/compile.cmx \
misc/encodings.cmx runtime/eval.cmx runtime/explain.cmx types/ident.cmx \
driver/librarian.cmx parser/location.cmx cdo2cmo/ml_cduce.cmx \
cdo2cmo/ml_checker.cmx cdo2cmo/ml_generator.cmx cdo2cmo/ml_ocaml.cmx \
misc/ns.cmx parser/parser.cmx types/patterns.cmx types/sample.cmx \
schema/schema_common.cmx misc/state.cmx typing/typer.cmx types/types.cmx \
parser/ulexer.cmx runtime/value.cmx driver/cduce.cmi
driver/librarian.cmx parser/location.cmx ocamliface/mlstub.cmx \
ocamliface/mltypes.cmx misc/ns.cmx parser/parser.cmx types/patterns.cmx \
types/sample.cmx schema/schema_common.cmx misc/state.cmx typing/typer.cmx \
types/types.cmx parser/ulexer.cmx runtime/value.cmx driver/cduce.cmi
query/query.cmo: parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
types/chars.cmi types/ident.cmo types/intervals.cmi parser/location.cmi \
parser/parser.cmi types/types.cmi query/query.cmi
......@@ -331,6 +317,9 @@ compile/operators.cmi: misc/custom.cmo parser/location.cmi misc/serialize.cmi \
typing/typer.cmi types/types.cmi runtime/value.cmi
types/builtin.cmi: typing/typer.cmi runtime/value.cmi
driver/librarian.cmi: types/types.cmi
ocamliface/mltypes.cmi: cdo2cmo/asttypes.cmo types/types.cmi
ocamliface/mlstub.cmi: ocamliface/mltypes.cmi types/types.cmi
query/query.cmi: parser/ast.cmo
schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi
ocamliface/mltypes.cmi: cdo2cmo/asttypes.cmo types/types.cmi
open Location
open Ident
ifdef ML_INTERFACE then module ML = Ml_ocaml;;
exception InvalidInputFilename of string
exception InvalidObjectFilename of string
......@@ -278,52 +276,17 @@ let topinput = run Parser.top_phrases
let script = run Parser.prog
ifdef ML_INTERFACE then
let check_ml cu id out_dir out =
let fnam = String.copy cu in
String.set fnam 0 ( Char.lowercase ( String.get fnam 0 ) );
let cmi_not_found () =
let name = fnam ^ ".mli" in
let has_cmi = List.exists (
fun dir -> Sys.file_exists ( Filename.concat dir name )
) !Librarian.obj_path in
if has_cmi then
Format.eprintf
"Warning: found %s.mli but no %s.cmi: forgotten compilation?@."
fnam fnam;
String.set fnam 0 ( Char.lowercase ( String.get fnam 0 ) );
in
let cmi_found file =
try
let ml_cu = ML.CompUnit.from_bytecode file cu
and cd_cu = Ml_cduce.CompUnit.from_types_cu cu id in
Ml_checker.run ml_cu cd_cu;
let out = open_out ( Filename.concat out_dir (fnam ^ ".ml") ) in
let fmt = Format.formatter_of_out_channel out in
Ml_generator.ML.generate fmt fnam ml_cu cd_cu;
close_out out
with
OCaml_all.Env.Error e ->
OCaml_all.Env.report_error Format.err_formatter e;
exit 1
in
let name = fnam ^ ".cmi" in
let file =
try
let file = List.find (
fun dir -> Sys.file_exists ( Filename.concat dir name )
) !Librarian.obj_path in
if file = "" then None
else Some (Filename.concat file name)
with Not_found -> None
in
match file with
| Some file -> cmi_found file
| None -> cmi_not_found ()
let stub_ml cu id =
try
let name = String.capitalize cu in
let (prolog, values) = Mltypes.read_cmi name in
let stub = Mlstub.stub cu id values in
Some (prolog,stub)
with Not_found ->
Printf.eprintf "Warning: no caml interface\n";
None
else
let check_ml cu id out_dir out = ();;
let stub_ml cu id = None;;
let compile src out_dir =
try
......@@ -337,8 +300,8 @@ let compile src out_dir =
let out = Filename.concat out_dir (cu ^ ".cdo") in
let id = Types.CompUnit.mk (U.mk_latin1 cu) in
Librarian.compile !verbose id src;
Librarian.save id out;
check_ml cu id out_dir out;
let stub = stub_ml cu id in
Librarian.save id out stub;
exit 0
with exn -> catch_exn Format.err_formatter exn; exit 1
......
......@@ -29,7 +29,7 @@ let mk (typing,compile,code) =
status = `Unevaluated;
}
let magic = "CDUCE:compunit:00002"
let magic = "CDUCE:compunit:00003"
let obj_path = ref [ "" ]
......@@ -67,7 +67,7 @@ let find_obj id =
List.find (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path in
Filename.concat p base
let save id out =
let save id out extra =
protect_op "Save compilation unit";
let cu = find id in
C.enter id;
......@@ -92,7 +92,7 @@ let save id out =
let depend = Serialize.Put.run serialize_dep depend in
let digest = Digest.string raw in
let oc = open_out out in
Marshal.to_channel oc (digest,depend,raw) [];
Marshal.to_channel oc (digest,depend,raw,extra) [];
close_out oc
......
......@@ -10,5 +10,5 @@ val compile: bool -> Types.CompUnit.t -> string -> unit
val run: Types.CompUnit.t -> unit
val import: Types.CompUnit.t -> unit
val import_and_run: Types.CompUnit.t -> unit
val save: Types.CompUnit.t -> string -> unit
val save: Types.CompUnit.t -> string -> 'a -> unit
let loc = (-1,-1)
let usage =
"Usage: cdo2ml <module>.cdo
Can also be used as a preprocessor for OCaml:
ocamlc -c -pp cdo2ml -impl <module>.cdo
"
let () =
let fn =
if Array.length Sys.argv != 2 then (prerr_endline usage; exit 1)
else Sys.argv.(1) in
let ic =
try open_in (Sys.argv.(1))
with Sys_error x ->
prerr_endline x;
exit 1 in
let (digest,depend,raw,extra) = input_value ic in
let (prolog,code) =
match extra with
| None ->
Printf.eprintf "Error: no stub found in this cdo file !\n";
exit 1
| Some x -> x in
print_endline "(* Automatically generated by cdo2ml.ml. Do no edit ! *)";
print_endline prolog;
let code = List.map (fun x -> (x,loc)) code in
!Pcaml.print_implem code
This diff is collapsed.
val stub:
string -> Types.CompUnit.t -> (string * Mltypes.t) list ->
MLast.str_item list
(* ocamlc -o mltypes -I .. oCaml_all.cma mltypes.ml *)
open OCaml_all
open Asttypes
open Types
(* Unfolding of OCaml types *)
let ocaml_env = ref Env.initial
type t = { uid : int; mutable recurs : int; mutable def : def }
and def =
| Link of t
| Arrow of t * t
| Tuple of t list
| PVariant of (string * t option) list (* Polymorphic variant *)
| Variant of (string * t list) list * bool
| Record of (string * t) list * bool
| Builtin of string * t list
| Abstract of string
module IntMap =
Map.Make(struct type t = int let compare : t -> t -> int = compare end)
module StringMap =
Map.Make(struct type t = string let compare : t -> t -> int = compare end)
let rec print_sep f sep ppf = function
| [] -> ()
| [x] -> f ppf x
| x::tl -> Format.fprintf ppf "%a%s" f x sep; print_sep f sep ppf tl
let printed = ref IntMap.empty
let rec print_slot ppf slot =
if slot.recurs > 0 then
(
if IntMap.mem slot.uid !printed then
Format.fprintf ppf "X%i" slot.uid
else (
printed := IntMap.add slot.uid () !printed;
Format.fprintf ppf "X%i:=%a" slot.uid print_def slot.def
)
)
else
print_def ppf slot.def
and print_def ppf = function
| Link t -> print_slot ppf t
| Arrow (t,s) -> Format.fprintf ppf "%a -> %a" print_slot t print_slot s
| Tuple tl -> Format.fprintf ppf "(%a)" (print_sep print_slot ",") tl
| PVariant l -> Format.fprintf ppf "[%a]" (print_sep print_palt " | ") l
| Variant (l,_) -> Format.fprintf ppf "[%a]" (print_sep print_alt " | ") l
| Record (l,_) -> Format.fprintf ppf "{%a}" (print_sep print_field " ; ") l
| Builtin (p,tl) -> Format.fprintf ppf "%s(%a)" p (print_sep print_slot ",") tl
| Abstract s -> Format.fprintf ppf "%s" s
and print_palt ppf = function
| lab, None -> Format.fprintf ppf "`%s" lab
| lab, Some t -> Format.fprintf ppf "`%s of %a" lab print_slot t
and print_alt ppf = function
| (lab,[]) ->
Format.fprintf ppf "%s" lab
| (lab,l) ->
Format.fprintf ppf "%s of [%a]" lab (print_sep print_slot ",") l
and print_field ppf (lab,t) =
Format.fprintf ppf "%s:%a" lab print_slot t
let print = print_slot
let counter = ref 0
let new_slot () =
incr counter;
{ uid = !counter; recurs = 0; def = Abstract "DUMMY" }
let builtins =
List.fold_left (fun m x -> StringMap.add x () m) StringMap.empty
["list"]
let rec unfold seen constrs ty =
try
let t = IntMap.find ty.id seen in
t.recurs <- t.recurs + 1;
t
with Not_found ->
let slot = new_slot () in
let seen = IntMap.add ty.id slot seen in
let loop = unfold seen constrs in
slot.def <-
(match ty.desc with
| Tarrow (_,t1,t2,_) -> Arrow (loop t1, loop t2)
| Ttuple tyl -> Tuple (List.map loop tyl)
| Tvariant rd ->
let fields =
List.map
(fun (lab,f) ->
match f with
| Rpresent (Some t) -> (lab, Some (loop t))
| Rpresent None -> (lab, None)
| _ -> assert false)
rd.row_fields in
PVariant fields
| Tvar -> assert false
| Tconstr (p,args,_) ->
let args = List.map loop args in
let pn = Path.name p in
if StringMap.mem pn builtins
then Builtin (pn,args)
else
let decl =
try Env.find_type p !ocaml_env
with Not_found ->
failwith ("Cannot resolve path " ^ pn) in
(try
let (s,args') = StringMap.find pn constrs in
List.iter2
(fun a a' ->
if a.uid != a'.uid then
failwith "Polymorphic recursion forbidden") args args';
s.recurs <- s.recurs + 1;
Link s
with Not_found ->
let seen =
List.fold_left2
(fun seen a v -> a.recurs <- a.recurs - 1; IntMap.add v.id a seen)
seen args decl.type_params in
let constrs = StringMap.add pn (slot,args) constrs in
let loop = unfold seen constrs in
(match decl.type_kind, decl.type_manifest with
| Type_variant (cstrs,pub), _ ->
let cstrs =
List.map (fun (cst,f) -> (cst,List.map loop f)) cstrs in
Variant (cstrs, pub = Public)
| Type_record (f,_,pub), _ ->
let f = List.map (fun (l,_,t) -> (l,loop t)) f in
Record (f, pub = Public)
| Type_abstract, Some t ->
Link (loop t)
| Type_abstract, None ->
(match args with
| [] -> Abstract (Path.name p)
| _ -> failwith "Polymorphic abstract type")))
| _ -> failwith "Unsupported feature"
);
slot
let unfold = unfold IntMap.empty StringMap.empty
(* Reading .cmi *)
open Config
let read_cmi name =
let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
let sg = Env.read_signature name filename in
ocaml_env := Env.add_signature sg Env.initial;
let buf = Buffer.create 1024 in
let ppf = Format.formatter_of_buffer buf in
let values = ref [] in
List.iter
(function
| Tsig_value (id, {val_type=t;val_kind=Val_reg}) ->
values := (Ident.name id, unfold t) :: !values
| Tsig_type (id,t) ->
Format.fprintf ppf "%a@." (Printtyp.type_declaration id) t
| _ -> failwith "Unsupported feature in .cmi"
) sg;
(Buffer.contents buf, !values)
let _ =
Config.load_path := [".";"/home/frisch/godi/lib/ocaml/std-lib"]
(*
let (p,d) = Env.lookup_type (Longident.parse (Sys.argv.(1))) Env.initial in
match d.type_manifest with
| Some ty ->
Format.fprintf Format.std_formatter "%a@." print_slot (unfold ty)
| None -> assert false
*)
open OCaml_all
open Asttypes
open Types
type t = { uid : int; mutable recurs : int; mutable def : def }
and def =
| Link of t
| Arrow of t * t
| Tuple of t list
| PVariant of (string * t option) list (* Polymorphic variant *)
| Variant of (string * t list) list * bool
| Record of (string * t) list * bool
| Builtin of string * t list
| Abstract of string
val read_cmi: string -> string * (string * t) list
val print : Format.formatter -> t -> unit
......@@ -64,6 +64,7 @@ let pop () =
let get_global = ref (fun cu pos -> assert false)
let set_global = ref (fun cu pos -> assert false)
let get_slot cu pos = !get_global cu pos
let eval_var env = function
| Env i -> env.(i)
......
......@@ -8,6 +8,8 @@ val eval_binary_op : (int -> (t -> t -> t)) ref
val get_global: (Types.CompUnit.t -> int -> t) ref
val set_global: (Types.CompUnit.t -> int -> t -> unit) ref
val get_slot : Types.CompUnit.t -> int -> t
val dump: Format.formatter -> unit
val push: Value.t -> unit
val var: var_loc -> t
......
......@@ -53,6 +53,12 @@ let rec sequence = function
| [] -> nil
| h::t -> Pair (h, sequence t)
let rec sequence_rev accu = function
| [] -> accu
| h::t -> sequence_rev (Pair (h,accu)) t
let sequence_rev l = sequence_rev nil l
let concat v1 v2 =
match (v1,v2) with
| (Atom _, v) | (v, Atom _) -> v
......@@ -527,3 +533,44 @@ let failwith' s = raise (CDuceExn (string_latin1 s))
let raise' v = raise (CDuceExn v)
let () = dump_forward := dump_xml
let get_pair v =
match normalize v with
| Pair (x,y) -> (x,y)
| _ -> assert false
(* TODO: tail-rec version of get_sequence *)
let rec get_sequence v =
match normalize v with
| Pair (x,y) -> x :: (get_sequence y)
| _ -> []
let rec get_sequence_rev accu v =
match normalize v with
| Pair (x,y) -> get_sequence_rev (x::accu) y
| _ -> accu
let get_sequence_rev v = get_sequence_rev [] v
let atom_ascii s =
Atom (Atoms.V.mk_ascii s)
let get_variant = function
| Atom a -> Atoms.V.get_ascii a, None
| v -> match normalize v with
| Pair (Atom a,x) -> Atoms.V.get_ascii a, Some x
| _ -> assert false
let label_ascii s =
LabelPool.mk (Ns.empty, U.mk s)
let record l =
Record (LabelMap.from_list_disj l)
let get_field v l =
match v with
| Record fields -> LabelMap.assoc l fields
| _ -> raise Not_found
......@@ -50,6 +50,16 @@ val vbool : bool -> t
val vrecord : (Ns.qname * t) list -> t
val sequence : t list -> t
val sequence_rev : t list -> t
val get_sequence : t -> t list
val get_sequence_rev : t -> t list
val atom_ascii : string -> t
val label_ascii : string -> label
val record : (label * t) list -> t
val get_field : t -> label -> t
val get_variant : t -> string * t option
(* iterator on the content of an Xml value. First callback is invoked on Utf8
character children; second callback is invoked on other children values *)
......@@ -72,6 +82,8 @@ val get_int : t -> int
(** @return an associative list of fields from a Record value *)
val get_fields : t -> (Ns.qname * t) list