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

.ocamlinit

@@ -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 =

compile/compile.ml

@@ -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)
   

parser/ast.ml

@@ -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

parser/parser.ml

@@ -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 ->

parser/ulexer.ml

@@ -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

tests/libtest/tallyingTest.ml

@@ -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

types/builtin.mli

+(* Typing environment with built-in types *)
 val env: Typer.t
-  (* Typing environment with built-in types *)
-
-
 val argv: Value.t ref
-

types/ident.ml

@@ -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)

types/var.ml

+
 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

types/var.mli

@@ -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

typing/typer.ml

@@ -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