Commit 46de929d authored by Pietro Abate's avatar Pietro Abate
Browse files

Merge branch 'eval-test' into apply-test

Conflicts:
	compile/compile.ml
	runtime/eval.ml
	types/types.ml
	typing/typed.ml
parents 01c1b4f8 e59ae0d1
......@@ -4,8 +4,8 @@ open Lambda
type env = {
cu: Compunit.t option; (* None: toplevel *)
vars: var_loc Env.t;
sigma : sigma;
gamma : var_loc Env.t;
sigma : sigma; (* symbolic substitutions (Lambda.sigma) *)
gamma : Types.Node.t IdMap.map; (* map of type variables to types *)
stack_size: int;
max_stack: int ref;
global_size: int
......@@ -13,7 +13,15 @@ type env = {
let global_size env = env.global_size
let mk cu = { cu = cu; vars = Env.empty; stack_size = 0; max_stack = ref 0; global_size = 0 }
let mk cu = {
cu = cu;
vars = Env.empty;
sigma = `List [];
gamma = IdMap.empty;
stack_size = 0;
max_stack = ref 0;
global_size = 0
}
let empty_toplevel = mk None
let empty x = mk (Some x)
......@@ -50,6 +58,12 @@ let enter_global_cu cu env x =
vars = Env.add x (Ext (cu,env.global_size)) env.vars;
global_size = env.global_size + 1 }
let rec domain = function
|`List l -> Types.Tallying.domain l
|`Comp (s1,s2) -> Var.Set.union (domain s1) (domain s2)
|`Sel(x,t,s) -> (domain s)
(* from intermediate explicitely typed language to Evaluation language (lambda) *)
let rec compile env e = compile_aux env e.Typed.exp_descr
and compile_aux env = function
| Typed.Forget (e,_) -> compile env e
......@@ -59,9 +73,10 @@ and compile_aux env = function
| Typed.Var x -> Var (find x env)
| Typed.TVar x ->
let v = find x env in
if env.sigma = [[]] && not (find v dom(env.sigma)) then Var (v)
else TVar(x,env.sigma)
| Typed.Subst(e,sl) -> compile { env with sigma = Comp(env.sigma,List sl) } e
let polyvars = Var.Set.inter (domain(env.sigma)) (Types.all_vars(Types.descr (IdMap.assoc x env.gamma))) in
if Var.Set.is_empty polyvars then Var (v)
else TVar(v,env.sigma)
| Typed.Subst(e,sl) -> compile { env with sigma = `Comp(env.sigma,`List sl) } e
| Typed.ExtVar (cu,x,_) -> Var (find_ext cu x)
| Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
| Typed.Abstraction a -> compile_abstr env a
......@@ -103,10 +118,10 @@ and compile_aux env = function
NsTable (ns, compile_aux env e)
and compile_abstr env a =
let fun_env =
let fun_env, fun_name =
match a.Typed.fun_name with
| Some x -> Env.add x (Env 0) Env.empty
| None -> Env.empty in
| Some x -> Env.add x (Env 0) Env.empty, [x, Types.cons a.Typed.fun_typ]
| None -> Env.empty, [] in
let (slots,nb_slots,fun_env) =
List.fold_left
......@@ -126,10 +141,21 @@ and compile_abstr env a =
let slots = Array.of_list (List.rev slots) in
let env = { env with vars = fun_env; stack_size = 0; max_stack = ref 0 } in
let env = { env with vars = fun_env; gamma = (env.gamma @ fun_name);
stack_size = 0; max_stack = ref 0 } in
let body = compile_branches env a.Typed.fun_body in
let sigma = Sel (x,t,env.sigma) in
if equal (inter vars(t) dom(env.sigma)) empty then
let sigma = `Sel(a.Typed.fun_fv,a.Typed.fun_iface,env.sigma) in
let polyvars =
let vs =
List.fold_left (fun acc (t1,t2) ->
let ts1 = Types.all_vars t1 in
let ts2 = Types.all_vars t2 in
(Var.Set.union acc (Var.Set.union ts1 ts2))
) Var.Set.empty a.Typed.fun_iface
in
Var.Set.inter (domain(env.sigma)) vs
in
if Var.Set.is_empty polyvars then
Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack), false, sigma)
else
Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack), true, sigma)
......@@ -138,6 +164,9 @@ and compile_branches env (brs : Typed.branches) =
(* Don't compile unused branches, because they have not been type checked. *)
let used = List.filter (fun br -> br.Typed.br_used) brs.Typed.br_branches in
let b = List.map (compile_branch env) used in
(* here I need to pull type information from each pattern and then
* compute for each variable gamma(x) . I should be able to compute gamma(x)
* using the information computed in (disp,rhs) *)
let (disp,rhs) = Patterns.Compile.make_branches brs.Typed.br_typ b in
{ brs_stack_pos = env.stack_size;
brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
......@@ -145,10 +174,13 @@ and compile_branches env (brs : Typed.branches) =
brs_rhs = rhs
}
(* p_i / t_i br.Typed.br_pat / br.Typed.br_type *)
(* p_i / t_i -> br.Typed.br_pat / br.Typed.br_type
* p_i / t_i is used here to add elements to env.gamma *)
and compile_branch env br =
let env = List.fold_left enter_local env (Patterns.fv br.Typed.br_pat) in
(br.Typed.br_pat, br.Typed.br_type, compile env br.Typed.br_body)
let m = Patterns.filter (Types.descr (Patterns.accept br.Typed.br_pat)) br.Typed.br_pat in
let env = { env with gamma = IdMap.union_disj m env.gamma } in
(br.Typed.br_pat, compile env br.Typed.br_body )
let enter_globals env n = match env.cu with
| None -> List.fold_left enter_global_toplevel env n
......
......@@ -22,10 +22,12 @@ type var_loc =
(* Only for the toplevel *)
| Dummy
type sigma =
| List of Types.Tallying.CS.sl
| Comp of (sigma * sigma)
| Sel of (fv * Types.t * sigma)
(* only TVar (polymorphic type variable) and Abstraction have
* a sigma annotation *)
type sigma = [
| `List of Types.Tallying.CS.sl
| `Comp of (sigma * sigma)
| `Sel of (fv * (Types.t * Types.t) list * sigma) ]
type expr =
| Var of var_loc
......
......@@ -22,10 +22,12 @@ type var_loc =
(* Only for the toplevel *)
| Dummy
type sigma =
| List of Types.Tallying.CS.sl
| Comp of (sigma * sigma)
| Sel of (fv * Types.t * sigma)
(* only TVar (polymorphic type variable) and Abstraction have
* a sigma annotation *)
type sigma = [
| `List of Types.Tallying.CS.sl
| `Comp of (sigma * sigma)
| `Sel of (fv * (Types.t * Types.t) list * sigma) ]
type expr =
| Var of var_loc
......
......@@ -46,7 +46,7 @@ let register_cst op t v =
let register_fun op dom codom eval =
register_cst op
(Types.arrow (Types.cons dom) (Types.cons codom))
(Value.Abstraction (Some [(dom,codom)],eval))
(Value.Abstraction (Some [(dom,codom)],eval, `List([[]])))
let register_fun2 op dom1 dom2 codom eval =
let t2 = Types.arrow (Types.cons dom2) (Types.cons codom) in
......@@ -55,7 +55,7 @@ let register_fun2 op dom1 dom2 codom eval =
(Types.arrow (Types.cons dom1) (Types.cons t2))
(Value.Abstraction (Some [(dom1,t2)],(fun v1 ->
Value.Abstraction (iface2,
eval v1))))
eval v1, `List([[]]))), `List([[]])))
let register_op op ?(expect=Types.any) typ eval =
register_unary op
(fun tf _ _ -> let t = tf expect true in typ t)
......
......@@ -11,7 +11,7 @@ let eval_op = Hashtbl.find ops
(* To write tail-recursive map-like iteration *)
let make_accu () = Value.Pair(nil,Absent)
let make_accu () = Value.Pair(nil,Absent,esigma)
let get_accu a = snd (Obj.magic a)
let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0
......@@ -64,6 +64,15 @@ let eval_var env locals = function
let tag_op_resolved = Obj.tag (Obj.repr (OpResolved ((fun _ -> assert false), [])))
let tag_const = Obj.tag (Obj.repr (Const (Obj.magic 0)))
let apply_sigma sigma = function
|Value.Pair(v1,v2,sigma') -> Value.Pair(v1,v2,`Comp(sigma,sigma'))
|Value.Abstraction(iface,f,sigma') -> Value.Abstraction(iface,f,`Comp(sigma,sigma'))
|Value.Xml(v1,v2,v3,sigma') -> Value.Xml(v1,v2,v3,`Comp(sigma,sigma'))
|Value.XmlNs(v1,v2,v3,ns,sigma') -> Value.XmlNs(v1,v2,v3,ns,`Comp(sigma,sigma'))
|Value.Record(m,sigma') -> Value.Record(m,`Comp(sigma,sigma'))
|v -> v
;;
(* env is an array implementing de bruines indexes *)
let rec eval env locals = function
| Var ((Global _ | Ext _ | External _ | Builtin _) as x) as e ->
......@@ -75,7 +84,8 @@ let rec eval env locals = function
* PEnv and Env belong to the runtime lambda language
* from the parsing ast + typing information *)
| Var x -> eval_var env locals x
| TVar (x,sigma) -> eval_var env locals x
| TVar (x,sigma) -> (* delayed sigma application *)
apply_sigma sigma (eval_var env locals x)
| Apply (e1,e2) ->
let v1 = eval env locals e1 in
let v2 = eval env locals e2 in
......@@ -86,19 +96,19 @@ let rec eval env locals = function
| Pair (e1,e2) ->
let v1 = eval env locals e1 in
let v2 = eval env locals e2 in
Value.Pair (v1,v2)
Value.Pair (v1,v2,Value.esigma)
| Xml (e1,e2,e3) ->
let v1 = eval env locals e1 in
let v2 = eval env locals e2 in
let v3 = eval env locals e3 in
Value.Xml (v1,v2,v3)
Value.Xml (v1,v2,v3,Value.esigma)
| XmlNs (e1,e2,e3,ns) ->
let v1 = eval env locals e1 in
let v2 = eval env locals e2 in
let v3 = eval env locals e3 in
Value.XmlNs (v1,v2,v3,ns)
Value.XmlNs (v1,v2,v3,ns,Value.esigma)
| Record r ->
Value.Record (Imap.map (eval env locals) r)
Value.Record (Imap.map (eval env locals) r, Value.esigma)
| String (i,j,s,q) -> Value.substring_utf8 i j s (eval env locals q)
(* let is encoded as a match *)
| Match (e,brs) -> eval_branches env locals brs (eval env locals e)
......@@ -129,12 +139,12 @@ and eval_abstraction env locals slots iface body lsize =
let f arg =
eval_branches local_env (Array.create lsize Value.Absent) body arg
in
let a = Value.Abstraction (Some iface,f) in
let a = Value.Abstraction (Some iface,f,Value.esigma) in
local_env.(0) <- a;
a
and eval_apply f arg = match f with
| Value.Abstraction (_,f) -> f arg
| Value.Abstraction (_,f,sigma) -> f arg
| _ -> assert false
and eval_branches env locals brs arg =
......@@ -164,9 +174,9 @@ and eval_map env locals brs v =
map (eval_map_aux env locals brs) v
and eval_map_aux env locals brs acc = function
| Value.Pair (x,y) ->
| Value.Pair (x,y,sigma) ->
let x = eval_branches env locals brs x in
let acc' = Value.Pair (x, Absent) in
let acc' = Value.Pair (x, Absent,sigma) in
set_cdr acc acc';
eval_map_aux env locals brs acc' y
| Value.String_latin1 (_,_,_,_) | Value.String_utf8 (_,_,_,_) as v ->
......@@ -180,7 +190,7 @@ and eval_transform env locals brs v =
map (eval_transform_aux env locals brs) v
and eval_transform_aux env locals brs acc = function
| Value.Pair (x,y) ->
| Value.Pair (x,y,sigma) ->
(match eval_branches env locals brs x with
| Value.Absent -> eval_transform_aux env locals brs acc y
| x -> eval_transform_aux env locals brs (append_cdr acc x) y)
......@@ -214,19 +224,19 @@ and eval_xtrans_aux env locals brs acc = function
| Value.Concat (x,y) ->
let acc = eval_xtrans_aux env locals brs acc x in
eval_xtrans_aux env locals brs acc y
| Value.Pair (x,y) ->
| Value.Pair (x,y,sigma) ->
let acc =
match eval_branches env locals brs x with
| Value.Absent ->
let x = match x with
| Value.Xml (tag, attr, child) ->
| Value.Xml (tag, attr, child,sigma) ->
let child = eval_xtrans env locals brs child in
Value.Xml (tag, attr, child)
| Value.XmlNs (tag, attr, child, ns) ->
Value.Xml (tag, attr, child,sigma)
| Value.XmlNs (tag, attr, child, ns,sigma) ->
let child = eval_xtrans env locals brs child in
Value.XmlNs (tag, attr, child, ns)
Value.XmlNs (tag, attr, child, ns,sigma)
| x -> x in
let acc' = Value.Pair (x, Absent) in
let acc' = Value.Pair (x, Absent,sigma) in
set_cdr acc acc';
acc'
| x -> append_cdr acc x
......@@ -235,16 +245,15 @@ and eval_xtrans_aux env locals brs acc = function
| _ -> acc
and eval_dot l = function
| Value.Record r
| Value.Xml (_,Value.Record r,_)
| Value.XmlNs (_,Value.Record r,_,_) -> Imap.find_lower r (Upool.int l)
| Value.Record (r,_)
| Value.Xml (_,Value.Record (r,_),_,_)
| Value.XmlNs (_,Value.Record (r,_),_,_,_) -> Imap.find_lower r (Upool.int l)
| v -> assert false
and eval_remove_field l = function
| Value.Record r -> Value.Record (Imap.remove r (Upool.int l))
| Value.Record (r,sigma) -> Value.Record (Imap.remove r (Upool.int l),sigma)
| _ -> assert false
let expr e lsize = eval [||] (Array.create lsize Value.Absent) e
(* Evaluation in the toplevel *)
......
......@@ -47,18 +47,18 @@ and run_disp pt d v =
run_dispatcher ((v, d.expected_type)::pt) d v
and run_disp_kind pt d actions = function
| Pair (v1,v2) -> run_disp_prod pt d v1 v2 actions.prod
| Xml (v1,v2,v3) | XmlNs (v1,v2,v3,_) -> run_disp_prod pt d v1 (Pair(v2,v3)) actions.xml
| Record r -> run_disp_record pt d 0 r actions.record
| Pair (v1,v2,sigma) -> run_disp_prod pt d v1 v2 actions.prod
| Xml (v1,v2,v3,sigma) | XmlNs (v1,v2,v3,_,sigma) -> run_disp_prod pt d v1 (Pair(v2,v3,sigma)) actions.xml
| Record (r,sigma) -> run_disp_record pt d 0 r actions.record
| Atom q -> make_result pt d (Atoms.get_map q actions.atoms)
| Char c -> make_result pt d (Chars.get_map c actions.chars)
| Integer i ->
run_disp_basic pt d (fun t -> Types.Int.has_int t i) actions.basic
| Abstraction (None,_) ->
| Abstraction (None,_,sigma) ->
run_disp_basic pt d
(fun t -> failwith "Run-time inspection of external abstraction")
actions.basic
| Abstraction (Some iface,_) ->
| Abstraction (Some iface,_,sigma) ->
run_disp_basic pt d (fun t -> Types.Arrow.check_iface iface t)
actions.basic
| Absent ->
......
......@@ -48,9 +48,9 @@ let attrib att =
let elem ns tag att child =
if !keep_ns then
XmlNs (Atom tag, Record (attrib att), child, ns)
XmlNs (Atom tag, Record (attrib att, `List([[]])), child, ns, `List([[]]))
else
Xml (Atom tag, Record (attrib att), child)
Xml (Atom tag, Record (attrib att, `List([[]])), child, `List([[]]))
type stack =
| Element of Value.t * stack
......@@ -64,7 +64,7 @@ let ns_table = ref Ns.empty_table
let rec create_elt accu = function
| String (s,st) -> create_elt (string s accu) st
| Element (x,st) -> create_elt (Pair (x,accu)) st
| Element (x,st) -> create_elt (Pair (x,accu, `List([[]]))) st
| Start (ns,name,att,old_table,st) ->
stack := Element (elem ns name att accu, st);
ns_table := old_table
......@@ -132,7 +132,7 @@ let load_html s =
| Nethtml.Element (tag, att, child) ->
let att = List.map (fun (n,v) -> (Label.mk (Ns.empty, U.mk n), U.mk v)) att in
Pair (elem Ns.empty_table (Atoms.V.mk (Ns.empty,U.mk tag) )
att (val_of_docs child), q)
att (val_of_docs child), q, `List([[]]))
and val_of_docs = function
| [] -> nil
| h::t -> val_of_doc (val_of_docs t) h
......
......@@ -59,7 +59,7 @@ module H = Hashtbl.Make(Ns.Uri)
let exn_print_xml = CDuceExn (Pair (
Atom (Atoms.V.mk_ascii "Invalid_argument"),
string_latin1 "print_xml"))
string_latin1 "print_xml", `List([[]])))
let blank = U.mk " "
let true_literal = U.mk "true"
......@@ -87,9 +87,9 @@ let rec schema_value ?(recurs=true) ~wds ~wcs v = match v with
and schema_values ~wds ~wcs v =
match v with
| Pair (hd, Atom a) when a = Sequence.nil_atom ->
| Pair (hd, Atom a, _) when a = Sequence.nil_atom ->
schema_value ~recurs:false ~wds ~wcs hd
| Pair (hd, tl) ->
| Pair (hd, tl, _) ->
schema_value ~recurs:false ~wds ~wcs hd;
wds blank;
schema_values ~wds ~wcs tl
......@@ -133,8 +133,8 @@ let to_buf ~utf8 buffer ns_table v subst =
in
let rec register_elt = function
| Xml (Atom q, Record attrs, content)
| XmlNs (Atom q, Record attrs, content, _) ->
| Xml (Atom q, Record (attrs, _), content, _)
| XmlNs (Atom q, Record (attrs, _), content, _, _) ->
Imap.iter
(fun n _ -> Ns.Printer.register_qname printer
(Label.value (Label.from_int n)))
......@@ -145,15 +145,15 @@ let to_buf ~utf8 buffer ns_table v subst =
and register_content = function
| String_utf8 (_,_,_,q)
| String_latin1 (_,_,_,q) -> register_content q
| Pair (x, q) -> register_elt x; register_content q
| Pair (x, q, _) -> register_elt x; register_content q
| Concat (x,y) -> register_content x; register_content y
| _ -> ()
in
register_elt v;
let rec print_elt xmlns = function
| Xml (Atom tag, Record attrs, content)
| XmlNs (Atom tag, Record attrs, content, _) ->
| Xml (Atom tag, Record (attrs, _), content, _)
| XmlNs (Atom tag, Record (attrs, _), content, _, _) ->
let attrs = Imap.map_elements
(fun n v ->
if is_str v then begin
......@@ -180,7 +180,7 @@ let to_buf ~utf8 buffer ns_table v subst =
let (s,q) = get_string_utf8 v in
wds s;
match q with
| Pair ((Xml _ | XmlNs _) as x, q) -> print_elt [] x; print_content q
| Pair ((Xml _ | XmlNs _) as x, q, _) -> print_elt [] x; print_content q
| Atom a when a = Sequence.nil_atom -> ()
| v -> schema_value ~wds ~wcs v
in
......
......@@ -56,7 +56,8 @@ let make_result_prod v1 v2 v (code,r,pop) =
| Recompose (i,j) ->
Pair (
(match i with (-1) -> v1 | (-2) -> nil | _ -> buf.(c - i)),
(match j with (-1) -> v2 | (-2) -> nil | _ -> buf.(c - j))
(match j with (-1) -> v2 | (-2) -> nil | _ -> buf.(c - j)),
esigma
)
in
buf.(c + a) <- x
......@@ -124,7 +125,8 @@ let make_result_string_latin1 i j s q (code,r,pop) =
(match m with
| (-1) -> tail_string_latin1 i j s q
| (-2) -> nil
| _ -> buf.(c - m))
| _ -> buf.(c - m)),
esigma
)
in
buf.(c + a) <- x
......@@ -160,7 +162,8 @@ let make_result_string_utf8 i j s q (code,r,pop) =
(match m with
| (-1) -> tail_string_utf8 i j s q
| (-2) -> nil
| _ -> buf.(c - m))
| _ -> buf.(c - m)),
esigma
)
in
buf.(c + a) <- x
......@@ -187,10 +190,10 @@ let rec run_dispatcher d v =
and run_disp_kind actions v =
match v with
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
| Xml (v1,v2,v3)
| XmlNs (v1,v2,v3,_) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
| Record r -> run_disp_record 0 v r actions.record
| Value.Pair (v1,v2,sigma) -> run_disp_prod v v1 v2 actions.prod
| Xml (v1,v2,v3,sigma)
| XmlNs (v1,v2,v3,_,sigma) -> run_disp_prod v v1 (Pair (v2,v3,sigma)) actions.xml (* ??? *)
| Record (r,sigma) -> run_disp_record 0 v r actions.record
| String_latin1 (i,j,s,q) ->
(* run_disp_kind actions (Value.normalize v) *)
run_disp_string_latin1 i j s q actions
......@@ -201,10 +204,10 @@ and run_disp_kind actions v =
| Char c -> make_result_basic v (Chars.get_map c actions.chars)
| Integer i ->
run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
| Abstraction (None,_) ->
| Abstraction (None,_,_) ->
run_disp_basic v (fun t -> failwith "Run-time inspection of external abstraction")
actions.basic
| Abstraction (Some iface,_) ->
| Abstraction (Some iface,_,sigma) ->
run_disp_basic v (fun t -> Types.Arrow.check_iface iface t)
actions.basic
| Abstract (abs,_) ->
......
This diff is collapsed.
open Ident
open Encodings
type sigma = [
| `List of Types.Tallying.CS.sl
| `Comp of (sigma * sigma)
| `Sel of (fv * (Types.t * Types.t) list * sigma) ]
val esigma : sigma
type t =
(* Canonical representation *)
| Pair of t * t
| Xml of t * t * t
| XmlNs of t * t * t * Ns.table
| Record of t Imap.t
| Pair of t * t * sigma
| Xml of t * t * t * sigma
| XmlNs of t * t * t * Ns.table * sigma
| Record of t Imap.t * sigma
| Atom of Atoms.V.t
| Integer of Intervals.V.t
| Char of Chars.V.t
| Abstraction of (Types.descr * Types.descr) list option * (t -> t)
| Abstraction of (Types.descr * Types.descr) list option * (t -> t) * sigma
| Abstract of Types.Abstract.V.t
(* Derived forms *)
| String_latin1 of int * int * string * t
| String_utf8 of U.uindex * U.uindex * U.t * t
| String_utf8 of Utf8.uindex * Utf8.uindex * Utf8.t * t
| Concat of t * t
(* Special value for absent record fields, and failed pattern matching *)
| Absent
module ValueSet: Set.S with type elt = t
......
......@@ -128,11 +128,11 @@ type to_be_visited =
let stream_of_value v =
let stack = ref [Fully v] in
let f _ = (* lazy visit of a tree of CDuce XML values, stack keeps track of
what has still to be visited *)
match !stack with
| (Fully ((Value.Xml (Value.Atom atom, attrs, _))
|(Value.XmlNs (Value.Atom atom, attrs, _, _)) as v)) :: tl ->
(* lazy visit of a tree of CDuce XML values, stack keeps track of
what has still to be visited *)
let f _ = match !stack with
| (Fully ((Value.Xml (Value.Atom atom, attrs, _,sigma))
|(Value.XmlNs (Value.Atom atom, attrs, _, _,sigma)) as v)) :: tl ->
stack := (Half v) :: tl;
let children = ref [] in (* TODO inefficient *)
let push v s = (s := v :: !s) in
......
......@@ -59,7 +59,7 @@ let concat ctx v = ctx.ctx_current <- Value.concat ctx.ctx_current v
let append ctx v = ctx.ctx_current <- Value.append ctx.ctx_current v
let xml qname attrs content =
Value.Xml (Value.Atom qname, attrs, content)
Value.Xml (Value.Atom qname, attrs, content, Value.esigma)
let peek ctx =
......@@ -194,7 +194,7 @@ struct
* and no Concat, but just Pair *)
let length v =
let rec aux acc = function
| Pair (_, rest) -> aux (succ acc) rest
| Pair (_, rest,sigma) -> aux (succ acc) rest
| _ -> 0
in
aux 0 v
......@@ -539,7 +539,7 @@ let validate_type def value =
let attrs = get_attributes ctx in
let (attrs, content) = validate_complex_type ctx attrs ct_def in
expect_end_tag ctx;
Value.Xml (Value.Atom start_tag, attrs, content)
Value.Xml (Value.Atom start_tag, attrs, content,Value.esigma)
(*
let validate_attribute decl value =
......@@ -599,7 +599,7 @@ let validate_model_group { mg_def = mg } value =
if not (Value.is_seq value) then
error
"Only sequence values could be validated against model groups";
let stream = stream_of_value (Value.Xml (foo_atom, empty_record, value)) in
let stream = stream_of_value (Value.Xml (foo_atom, empty_record, value,Value.esigma)) in
Stream.junk stream;
let ctx = ctx stream in
validate_model_group ctx mg;
......
......@@ -46,7 +46,7 @@ let parse_to_lambda expr =
let new_env = mk_env ~parent:(Some env) ~max_size:env.max_size ~map:map
nbrparams (env.global_size + nbrparams) in
let brs = compile_func_body new_env body (nbrparams - 1) in
Abstraction(params, [], brs, nbrparams, true, List [[]])
Abstraction(params, [], brs, nbrparams, true, `List [[]])
| Var(loc, vname) ->