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

Add sigma to Compile.compile (typed -> lambda)

parent bcb7506c
......@@ -137,10 +137,12 @@ 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 body = compile_branches env a.Typed.fun_body in
let sigma = (* `Sel (x,t,env.sigma) *) `List [] 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
(*
if equal (inter (Types.all_vars(Env.find x env.gamma)) dom(env.sigma)) empty 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)
and compile_branches env (brs : Typed.branches) =
......@@ -154,10 +156,11 @@ 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)
(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
......
......@@ -27,7 +27,7 @@ type var_loc =
type sigma = [
| `List of Types.Tallying.CS.sl
| `Comp of (sigma * sigma)
| `Sel of (fv * Types.t * sigma) ]
| `Sel of (fv * (Types.t * Types.t) list * sigma) ]
type expr =
| Var of var_loc
......
......@@ -190,7 +190,7 @@ let rec run_dispatcher d v =
and run_disp_kind actions v =
match v with
| Pair (v1,v2,sigma) -> run_disp_prod v v1 v2 actions.prod
| 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
......
......@@ -4,7 +4,7 @@ open Encodings
type sigma = [
| `List of Types.Tallying.CS.sl
| `Comp of (sigma * sigma)
| `Sel of (fv * Types.t * sigma) ]
| `Sel of (fv * (Types.t * Types.t) list * sigma) ]
type t =
| Pair of t * t * sigma
......
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 *)
......
......@@ -113,15 +113,15 @@ let print_env env = match Ident.Env.is_empty env with
| false -> Ident.Env.iter print_binding env
let rec print_value v = match v with
| Value.Pair(v1, v2) -> printf "("; print_value v1; printf ", ";
| Value.Pair(v1, v2, sigma) -> printf "("; print_value v1; printf ", ";
print_value v2; printf ")"
| Xml(_,_,_) -> printf "Xml"
| XmlNs(_,_,_,_) -> printf "XmlNs"
| Record(_) -> printf "Record"
| Xml(_,_,_,sigma) -> printf "Xml"
| XmlNs(_,_,_,_,sigma) -> printf "XmlNs"
| Record(_,sigma) -> printf "Record"
| Atom(_) -> printf "Atom"
| Integer(i) -> printf "%d" (Big_int.int_of_big_int i)
| Char(i) -> printf "Char()"
| Abstraction(_, _) -> printf "Abstraction()"
| Abstraction(_,_, sigma) -> printf "Abstraction()"
| Abstract((name, _)) -> printf "Abstract(%s)" name
| String_latin1(i1, i2, s, v) -> printf "String_latin1(%d, %d, %s)" i1 i2 s;
print_value v
......@@ -131,15 +131,15 @@ let rec print_value v = match v with
| Absent -> printf "Absent"
let rec value_to_string v = match v with
| Value.Pair(v1, v2) -> "(" ^ (value_to_string v1) ^ ", "
| Value.Pair(v1, v2,sigma) -> "(" ^ (value_to_string v1) ^ ", "
^ (value_to_string v2) ^ ")"
| Xml(_,_,_) -> "Xml"
| XmlNs(_,_,_,_) -> "XmlNs"
| Record(_) -> "Record"
| Xml(_,_,_,sigma) -> "Xml"
| XmlNs(_,_,_,_,sigma) -> "XmlNs"
| Record(_,sigma) -> "Record"
| Atom(_) -> "Atom"
| Integer(i) -> string_of_int (Big_int.int_of_big_int i)
| Char(i) -> "Char()"
| Abstraction(t, _) ->
| Abstraction(t,_,sigma) ->
let t = match t with | Some t -> iface t | None -> "None" in
"Abstraction(" ^ t ^ ")"
| Abstract((name, _)) -> "Abstract(" ^ name ^ ")"
......
......@@ -452,6 +452,7 @@ let var a = {
let is_var t = TLV.is_single t.toplvars
let no_var t = TLV.no_variables t.toplvars
let all_vars t = t.toplvars.f
(* XXX this function could be potentially costly. There should be
* better way to take trace of top level variables in a type *)
......@@ -482,11 +483,13 @@ let update_tlv x y t =
in
List.fold_left Set.inter
(aux BoolChars.get t.chars)
[(aux BoolIntervals.get t.ints);
(aux BoolAtoms.get t.atoms);
(aux BoolPair.get t.arrow);
(aux BoolPair.get t.xml);
(aux BoolRec.get t.record)]
[
(aux BoolIntervals.get t.ints);
(aux BoolAtoms.get t.atoms);
(aux BoolPair.get t.arrow);
(aux BoolPair.get t.xml);
(aux BoolRec.get t.record)
]
in
let s = tlv t in
{ t with toplvars = { s = s ; f = Var.Set.union x.toplvars.f y.toplvars.f ; b = x.toplvars.b && x.toplvars.b } }
......
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