Commit fc179124 authored by Kim Nguyễn's avatar Kim Nguyễn

Merge branch 'master' of https://git.cduce.org/cduce

parents bb37c0ca 737730a2
......@@ -28,7 +28,7 @@ let mk_pp = function
let mk_prod l =
List.fold_left (fun acc2 c ->
Tallying.CS.prod (mk_pp c) acc2
Tallying.CS.prod Var.Set.empty (mk_pp c) acc2
) Tallying.CS.sat l
let mk_union l1 l2 =
......
......@@ -5,7 +5,6 @@ type env = {
cu: Compunit.t option; (* None: toplevel *)
vars: var_loc Env.t; (* Id.t to var_loc *)
sigma : sigma; (* symbolic substitutions (Lambda.sigma) *)
gamma : Types.Node.t IdMap.map; (* map of type variables to types *)
xi : Var.Set.t IdMap.map;
stack_size: int;
max_stack: int ref;
......@@ -13,19 +12,17 @@ type env = {
}
let pp_vars ppf vars =
Ident.pp_env Lambda.Print.pp_vloc ppf vars
let pp_gamma ppf gamma =
Ident.pp_idmap Types.Print.pp_node ppf gamma
let pp_item ppf (s,t) = Format.fprintf ppf "%s : %a" s Lambda.Print.pp_vloc t in
Ident.pp_env pp_item ppf vars
let pp_xi ppf xi =
Ident.pp_idmap Var.Set.pp ppf xi
let pp_item ppf (s,t) = Format.fprintf ppf "%s : %a" s Var.Set.pp t in
Ident.pp_idmap pp_item ppf xi
let pp_env ppf env =
Format.fprintf ppf "{vars=%a,sigma=%a,gamma=%a,xi=%a}"
Format.fprintf ppf "{vars=%a,sigma=%a,xi=%a}"
pp_vars env.vars
Lambda.Print.pp_sigma env.sigma
pp_gamma env.gamma
pp_xi env.xi
let global_size env = env.global_size
......@@ -34,7 +31,6 @@ let mk cu = {
cu = cu;
vars = Env.empty;
sigma = Lambda.Identity;
gamma = IdMap.empty;
xi = IdMap.empty;
stack_size = 0;
max_stack = ref 0;
......@@ -126,8 +122,8 @@ let rec comp s1 s2 = match s1, s2 with
(* from intermediate explicitely typed language to Evaluation language (lambda) *)
(* Typed -> Lambda *)
let rec compile env e = compile_aux env e.Typed.exp_descr
and compile_aux env = function
let rec compile env e = compile_aux env e.Typed.exp_typ e.Typed.exp_descr
and compile_aux env te = function
| Typed.Forget (e,_) -> compile env e
| Typed.Check (t0,e,t) ->
let d = Patterns.Compile.make_checker !t0 (Types.descr t) in
......@@ -135,7 +131,7 @@ and compile_aux env = function
| Typed.Var x -> Var (find x env)
| Typed.TVar x ->
let v = find x env in
let ts = Types.all_vars (Types.descr (IdMap.assoc x env.gamma)) in
let ts = Types.all_vars te in
let is_mono x =
if Var.Set.is_empty ts then true else
let from_xi = try IdMap.assoc x env.xi with Not_found -> Var.Set.empty in
......@@ -184,7 +180,7 @@ and compile_aux env = function
| [] -> [] in
Op (op, aux args)
| Typed.NsTable (ns,e) ->
NsTable (ns, compile_aux env e)
NsTable (ns, compile_aux env te e)
and compile_abstr env a =
let fun_env, fun_name =
......@@ -234,7 +230,6 @@ and compile_abstr env a =
let slots = Array.of_list (List.rev slots) in
let env =
{ env with vars = fun_env;
gamma = IdMap.merge (fun _ v2 -> v2) env.gamma fun_name;
stack_size = 0;
max_stack = ref 0 }
in
......@@ -254,9 +249,6 @@ 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);
......@@ -264,14 +256,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 is used here to add elements to env.gamma *)
(* p_i / t_i -> br.Typed.br_pat / br.Typed.br_type *)
and compile_branch env br =
let env = List.fold_left enter_local env (Patterns.fv br.Typed.br_pat) in
let m = Patterns.filter (Types.descr (Patterns.accept br.Typed.br_pat)) br.Typed.br_pat in
let env =
{ env with
gamma = IdMap.merge (fun _ v2 -> v2) env.gamma m;
xi = IdMap.merge (fun _ v2 -> v2) env.xi br.Typed.br_vars_poly
}
in
......@@ -343,28 +332,12 @@ let run_show ~run ~show tenv cenv codes ids =
let let_decl ~run ~show (tenv,cenv,codes) p e =
let (tenv,decl,ids) = Typer.type_let_decl tenv p e in
let (cenv,code) = compile_let_decl cenv decl in
(* XXX I've the impression I'm duplicating information here
* as cenv.gamma == tenv.gamma *)
let cenv = {cenv with gamma =
List.fold_left (fun acc (id,t) ->
(* an old binding is showed by a new one *)
IdMap.add id (Types.cons t) (IdMap.remove id acc)
) cenv.gamma ids;
}
in
run_show ~run ~show tenv cenv code ids;
(tenv,cenv,List.rev_append code codes)
let let_funs ~run ~show (tenv,cenv,codes) funs =
let (tenv,funs,ids) = Typer.type_let_funs tenv funs in
let (cenv,code) = compile_rec_funs cenv funs in
let cenv = {cenv with gamma =
List.fold_left (fun acc (id,t) ->
(* an old binding is showed by a new one *)
IdMap.add id (Types.cons t) (IdMap.remove id acc)
) cenv.gamma ids;
}
in
run_show ~run ~show tenv cenv code ids;
(tenv,cenv,List.rev_append code codes)
......
......@@ -105,7 +105,6 @@ and branches = (ppat * pexpr) list
and ppat = ppat' located
and ppat' =
| TVar of U.t (** polymorphic type variables *)
| PatVar of U.t list
| Cst of pexpr
| NsT of U.t
......
......@@ -25,7 +25,7 @@ module Gram = Camlp4.Struct.Grammar.Static.Make(Ulexer)
let id_dummy = U.mk "$$$"
let ident s =
let ident_aux s =
let b = Buffer.create (String.length s) in
let rec aux i =
if (i = String.length s) then Buffer.contents b
......@@ -35,8 +35,8 @@ let ident s =
in
aux 0
let label s = U.mk (ident s)
let ident s = U.mk (ident s)
let label s = U.mk (ident_aux s)
let ident s = U.mk (ident_aux s)
let prog = Gram.Entry.mk "prog"
let top_phrases = Gram.Entry.mk "toplevel phrases"
......@@ -596,17 +596,17 @@ EXTEND Gram
located_ident: [ [ a = ident_or_keyword -> (lop _loc,ident a) ] ];
pat: [
[ x = pat; "where";
b = LIST1 [ (la,a) = located_ident; "="; y = pat ->
(la,a,y) ] SEP "and"
-> mk _loc (Recurs (x,b)) ]
[ x = pat; "where";
b = LIST1 [ (la,a) = located_ident; "="; y = pat -> (la,a,y) ] SEP "and" ->
mk _loc (Recurs (x,b)) ]
| RIGHTA [ x = pat; "->"; y = pat -> mk _loc (Arrow (x,y))
| x = pat; "@"; y = pat -> mk _loc (Concat (x,y))
| x = pat; "+"; y = pat -> mk _loc (Merge (x,y)) ]
| "no_arrow" [ x = pat; "|"; y = pat -> mk _loc (Or (x,y)) ]
| "simple" [ x = pat; "&"; y = pat -> mk _loc (And (x,y))
| x = pat; "\\"; y = pat -> mk _loc (Diff (x,y)) ]
| "var_typ" [ x = PTYPE -> mk _loc (TVar (ident x)) ]
| "var_typ" [ x = PTYPE ->
mk _loc (Internal (Types.var (Var.mk (ident_aux x)))) ]
|
[ "{"; r = record_spec; "}" -> r
| "ref"; p = pat ->
......
......@@ -186,6 +186,8 @@ let regexp qname = (ncname ':')? ncname
(* Should be [^ xml_letter ] *)
let regexp not_xml_letter = [^ 'A'-'Z' 'a'-'z' '0'-'9' '_' ]
let regexp character = _ | '\\' ['\\' '"' '\''] | "\\n" | "\\t" | "\\r"
| '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F']+ ';' | '\\' ['0'-'9']+ ';'
let illegal lexbuf =
error
......@@ -226,7 +228,7 @@ let rec token = lexer
string (L.lexeme_start lexbuf) '"' lexbuf;
let s = get_stored_string () in
return_loc start (L.lexeme_end lexbuf) (STRING s)
| "'" "\\"? _ "'" ->
| "'" character "'" ->
L.rollback lexbuf;
(fun _ -> lexer
| "'" -> let start = L.lexeme_start lexbuf in
......@@ -280,7 +282,7 @@ and token2 = lexer
string (L.lexeme_start lexbuf) '"' lexbuf;
let s = get_stored_string () in
return_loc start (L.lexeme_end lexbuf) (STRING s)
| "'" "\\"? _ "'--'" "\\"? _ "'"
| "'" character "'--'" character "'"
| "'" [^ '\'']+ "'" not_xml_letter ->
L.rollback lexbuf;
(fun _ -> lexer
......@@ -345,7 +347,7 @@ and token2toplevel = lexer
string (L.lexeme_start lexbuf) '"' lexbuf;
let s = get_stored_string () in
return_loc start (L.lexeme_end lexbuf) (STRING s)
| "'" "\\"? _ "'--'" "\\"? _ "'"
| "'" character "'--'" character "'"
| "'" ((";"[^ ";'"]) | [^ ";'"])* ";"? "'" not_xml_letter ->
L.rollback lexbuf;
(fun _ -> lexer
......
......@@ -61,8 +61,8 @@ let mk_union_res l1 l2 =
(* check invariants on the constraints sets *)
let mk_pp = function
|P(V alpha,t) -> Tallying.CS.singleton Var.Set.empty (Tallying.Pos (Var.mk alpha,parse_typ t))
|N(t,V alpha) -> Tallying.CS.singleton Var.Set.empty (Tallying.Neg (parse_typ t,Var.mk alpha))
|P(V alpha,t) -> Tallying.CS.singleton (Tallying.Pos (Var.mk alpha,parse_typ t))
|N(t,V alpha) -> Tallying.CS.singleton (Tallying.Neg (parse_typ t,Var.mk alpha))
let mk_prod l =
List.fold_left (fun acc c ->
......@@ -339,8 +339,9 @@ let test_tallying =
let s_sigma = Tallying.(s $$ sigma) in
let t_sigma = Tallying.(t $$ sigma) in
assert_equal ~pp_diff:(fun fmt _ ->
Format.fprintf fmt "s @ sigma_i = %a\n" Types.Print.pp_type s_sigma;
Format.fprintf fmt "t @ sigma_i = %a\n" Types.Print.pp_type t_sigma
Format.fprintf fmt "sigma_i = %a\n" Types.Tallying.CS.pp_e sigma;
Format.fprintf fmt "s @@ sigma_i = %a\n" Types.Print.pp_type s_sigma;
Format.fprintf fmt "t @@ sigma_i = %a\n" Types.Print.pp_type t_sigma
) (Types.subtype s_sigma t_sigma) true
) sigma
) l
......
(* Typing environment with built-in types *)
val env: Typer.t
(* Typing environment with built-in types *)
val argv: Value.t ref
......@@ -22,9 +22,9 @@ type label = Ns.Label.t
type 'a label_map = 'a LabelMap.map
let pp_env f ppf env =
let f ppf (e,v) = Format.fprintf ppf "%a:%a" print e f v in
let f ppf (e,v) = f ppf ((Id.to_string e),v) in
Utils.pp_list ~delim:("<",">") ~sep:";" f ppf (Env.bindings env)
let pp_idmap f ppf map =
let f ppf (e,v) = Format.fprintf ppf "%a:%a" print e f v in
let f ppf (e,v) = f ppf ((Id.to_string e),v) in
Utils.pp_list ~delim:("<",">") ~sep:";" f ppf (IdMap.get map)
This diff is collapsed.
module V = struct
type t = { id : string; repr : string }
let dump ppf t =
let r = if t.repr = t.id then "" else Format.sprintf ";repr=%s" t.repr in
Format.fprintf ppf "{id=%s;%s}" t.id r
let compare x y = Pervasives.compare x.id y.id
let equal x y = Pervasives.compare x.id y.id = 0
let hash x = Hashtbl.hash x.id
type t = { id : Ident.U.t ; fr : int }
let dump ppf t = Format.fprintf ppf "{%a(%d)}" Ident.U.print t.id t.fr
let compare x y = Pervasives.compare (x.id,x.fr) (y.id,y.fr)
let equal x y = (compare x y) = 0
let hash x = Hashtbl.hash (x.id,x.fr)
let check _ = ()
let id x = x.id
let is_internal x =
let s = x.repr in
String.length s >= 1 && s.[0] == '#'
let make_id ?repr id =
match repr with
|None -> { id = id ; repr = id }
|Some r -> { id = id ; repr = r }
let mk ?repr id = make_id ?repr id
let is_fresh x = x.fr > 0
let fresh v = { v with fr = v.fr + 1 }
let pp ppf x = Format.fprintf ppf "'%s" x.repr
let mk id = { id = Ident.U.mk id; fr = 0 }
let id x = Ident.U.get_str x.id
let fresh : ?pre: string -> unit -> t =
let counter = ref 0 in
fun ?(pre="_fresh_") -> fun _ ->
let id = (Printf.sprintf "%s%d" pre !counter) in
let v = mk id in
incr counter;
v
let pp ppf x = Format.fprintf ppf "'%a" Ident.U.print x.id
end
include V
......
......@@ -3,10 +3,13 @@ include Custom.T
type var = t
val pp : Format.formatter -> t -> unit
val mk : ?repr:string -> string -> t
val fresh : ?pre:string -> unit -> t
val mk : string -> t
val id : t -> string
val fresh : t -> t
(*
val is_fresh : t -> bool
val is_internal : t -> bool
*)
module Set : sig
include Custom.T
......
......@@ -56,17 +56,25 @@ type t = {
}
let pp_env ppf env =
let pp_item ppf = function
|Type t | Val t -> Types.Print.pp_type ppf t
(*
|ECDuce _ -> Format.fprintf ppf "ECDuce"
|ESchema _ -> Format.fprintf ppf "ESchema"
|ENamespace _ -> Format.fprintf ppf "ENamespace"
*)
let pp_item ppf (s,t) = match t with
|Val t -> Format.fprintf ppf "val %s : %a" s Types.Print.pp_type t
|Type t -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_type t
|_ -> ()
in
let t = [
"Empty";"Any";"Int";"Char";"Byte";"Atom";
"Pair";"Arrow";"Record";
"String";"Latin1";
"Bool";"Float";"AnyXml";
"Namespaces";"Caml_int" ]
in
let ids =
Env.filter (fun n _ ->
not(List.mem (Id.to_string n) t)
) env.ids
in
Format.printf "{ids=%a;delta=%a}"
(Ident.pp_env pp_item) env.ids
(Ident.pp_env pp_item) ids
Var.Set.pp env.delta
;;
......@@ -325,7 +333,6 @@ module IType = struct
(* Ast -> symbolic type *)
let rec derecurs env p =
match p.descr with
| TVar s -> mk_type (Types.var (Var.mk (U.to_string s)))
| PatVar ids -> derecurs_var env p.loc ids
| Recurs (p,b) -> derecurs (fst (derecurs_def env b)) p
| Internal t -> mk_type 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