/[svn]/typing/typer.ml
ViewVC logotype

Diff of /typing/typer.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 224 by abate, Tue Jul 10 17:15:00 2007 UTC revision 225 by abate, Tue Jul 10 17:16:34 2007 UTC
# Line 3  Line 3 
3    
4  open Location  open Location
5  open Ast  open Ast
6    open Ident
7    
8  module S = struct type t = string let compare = compare end  module S = struct type t = string let compare = compare end
9  module StringMap = Map.Make(S)  module TypeEnv = Map.Make(S)
10    module Env = Map.Make(Ident.Id)
11    (*
12  module StringSet = Set.Make(S)  module StringSet = Set.Make(S)
13    *)
14    
15  exception NonExhaustive of Types.descr  exception NonExhaustive of Types.descr
16  exception MultipleLabel of Types.label  exception MultipleLabel of Types.label
# Line 24  Line 28 
28    id : int;    id : int;
29    mutable seen : bool;    mutable seen : bool;
30    mutable loc' : loc;    mutable loc' : loc;
31    mutable fv : StringSet.t option;    mutable fv : fv option;
32    mutable descr': descr;    mutable descr': descr;
33    mutable type_node: Types.node option;    mutable type_node: Types.node option;
34    mutable pat_node: Patterns.node option    mutable pat_node: Patterns.node option
# Line 39  Line 43 
43    | IXml of ti * ti    | IXml of ti * ti
44    | IArrow of ti * ti    | IArrow of ti * ti
45    | IRecord of bool * (Types.label * bool * ti) list    | IRecord of bool * (Types.label * bool * ti) list
46    | ICapture of Patterns.capture    | ICapture of id
47    | IConstant of Patterns.capture * Types.const    | IConstant of id * Types.const
48    
49    
50  type glb = ti StringMap.t  type glb = ti TypeEnv.t
51    
52  let mk' =  let mk' =
53    let counter = ref 0 in    let counter = ref 0 in
# Line 86  Line 90 
90      | Epsilon | Elem _ -> accu      | Epsilon | Elem _ -> accu
91      | Seq (r1,r2) | Alt (r1,r2) -> seq_vars (seq_vars accu r1) r2      | Seq (r1,r2) | Alt (r1,r2) -> seq_vars (seq_vars accu r1) r2
92      | Star r | WeakStar r -> seq_vars accu r      | Star r | WeakStar r -> seq_vars accu r
93      | SeqCapture (v,r) -> seq_vars (StringSet.add v accu) r      | SeqCapture (v,r) -> seq_vars (IdSet.add v accu) r
94    
95    let uniq_id = let r = ref 0 in fun () -> incr r; !r    let uniq_id = let r = ref 0 in fun () -> incr r; !r
96    
# Line 217  Line 221 
221  *)  *)
222    
223    
224    let constant_nil v t =    let constant_nil t v =
225      mk !re_loc      mk !re_loc
226        (And (t, (mk !re_loc (Constant (v, Types.Atom Sequence.nil_atom)))))        (And (t, (mk !re_loc (Constant (v, Types.Atom Sequence.nil_atom)))))
227    
228    let compile loc regexp queue : ppat =    let compile loc regexp queue : ppat =
229      re_loc := loc;      re_loc := loc;
230      let vars = seq_vars StringSet.empty regexp in      let vars = seq_vars IdSet.empty regexp in
231      let fin = StringSet.fold constant_nil vars queue in      let fin = IdSet.fold constant_nil queue vars in
232      let re = propagate (fun p -> p) regexp in      let re = propagate (fun p -> p) regexp in
233      let n = guard_compile fin [re] in      let n = guard_compile fin [re] in
234      memo := Memo.empty;      memo := Memo.empty;
# Line 247  Line 251 
251  let rec compile env { loc = loc; descr = d } : ti =  let rec compile env { loc = loc; descr = d } : ti =
252    match (d : Ast.ppat') with    match (d : Ast.ppat') with
253    | PatVar s ->    | PatVar s ->
254        (try StringMap.find s env        (try TypeEnv.find s env
255         with Not_found ->         with Not_found ->
256           raise_loc_generic loc ("Undefined type variable " ^ s)           raise_loc_generic loc ("Undefined type variable " ^ s)
257        )        )
# Line 268  Line 272 
272  and compile_many env b =  and compile_many env b =
273    let b = List.map (fun (v,t) -> (v,t,mk' t.loc)) b in    let b = List.map (fun (v,t) -> (v,t,mk' t.loc)) b in
274    let env =    let env =
275      List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in      List.fold_left (fun env (v,t,x) -> TypeEnv.add v x env) env b in
276    List.iter (fun (v,t,x) -> x.descr' <- IAlias (v, compile env t)) b;    List.iter (fun (v,t,x) -> x.descr' <- IAlias (v, compile env t)) b;
277    env    env
278    
# Line 276  Line 280 
280    Set.Make(struct type t = int let compare (x:int) y = compare x y end)    Set.Make(struct type t = int let compare (x:int) y = compare x y end)
281    
282  let comp_fv_seen = ref []  let comp_fv_seen = ref []
283  let comp_fv_res = ref StringSet.empty  let comp_fv_res = ref IdSet.empty
284  let rec comp_fv s =  let rec comp_fv s =
285    match s.fv with    match s.fv with
286      | Some fv -> comp_fv_res := StringSet.union fv !comp_fv_res      | Some fv -> comp_fv_res := IdSet.cup fv !comp_fv_res
287      | None ->      | None ->
288          (match s.descr' with          (match s.descr' with
289             | IAlias (_,x) ->             | IAlias (_,x) ->
# Line 297  Line 301 
301             | IRecord (_,r) -> List.iter (fun (l,opt,s) -> comp_fv s) r             | IRecord (_,r) -> List.iter (fun (l,opt,s) -> comp_fv s) r
302             | IType _ -> ()             | IType _ -> ()
303             | ICapture x             | ICapture x
304             | IConstant (x,_) -> comp_fv_res := StringSet.add x !comp_fv_res             | IConstant (x,_) -> comp_fv_res := IdSet.add x !comp_fv_res
305          )          )
306    
307    
# Line 307  Line 311 
311      | None ->      | None ->
312          comp_fv s;          comp_fv s;
313          let l = !comp_fv_res in          let l = !comp_fv_res in
314          comp_fv_res := StringSet.empty;          comp_fv_res := IdSet.empty;
315          List.iter (fun n -> n.seen <- false) !comp_fv_seen;          List.iter (fun n -> n.seen <- false) !comp_fv_seen;
316          comp_fv_seen := [];          comp_fv_seen := [];
317          s.fv <- Some l;          s.fv <- Some l;
# Line 349  Line 353 
353    s    s
354    
355  let rec pat seen s : Patterns.descr =  let rec pat seen s : Patterns.descr =
356    if StringSet.is_empty (fv s)    if IdSet.is_empty (fv s)
357    then Patterns.constr (Types.descr (type_node s))    then Patterns.constr (Types.descr (type_node s))
358    else    else
359      try pat_aux seen s      try pat_aux seen s
# Line 366  Line 370 
370        pat (IntSet.add s.id seen) x        pat (IntSet.add s.id seen) x
371    | IOr (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)    | IOr (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
372    | IAnd (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)    | IAnd (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
373    | IDiff (s1,s2) when StringSet.is_empty (fv s2) ->    | IDiff (s1,s2) when IdSet.is_empty (fv s2) ->
374        let s2 = Types.neg (Types.descr (type_node s2)) in        let s2 = Types.neg (Types.descr (type_node s2)) in
375        Patterns.cap (pat seen s1) (Patterns.constr s2)        Patterns.cap (pat seen s1) (Patterns.constr s2)
376    | IDiff _ ->    | IDiff _ ->
# Line 376  Line 380 
380    | IRecord (o,r) ->    | IRecord (o,r) ->
381        let pats = ref [] in        let pats = ref [] in
382        let aux (l,o,s) =        let aux (l,o,s) =
383          if StringSet.is_empty (fv s) then (l,(o,type_node s))          if IdSet.is_empty (fv s) then (l,(o,type_node s))
384          else          else
385            if o then            if o then
386              raise              raise
# Line 399  Line 403 
403    match s.pat_node with    match s.pat_node with
404      | Some x -> x      | Some x -> x
405      | None ->      | None ->
406          let fv = SortedList.from_list (StringSet.elements (fv s)) in          let x = Patterns.make (fv s) in
         let x = Patterns.make fv in  
407          s.pat_node <- Some x;          s.pat_node <- Some x;
408          let t = pat IntSet.empty s in          let t = pat IntSet.empty s in
409          Patterns.define x t;          Patterns.define x t;
410          x          x
411    
412  let mk_typ e =  let mk_typ e =
413    if StringSet.is_empty (fv e) then type_node e    if IdSet.is_empty (fv e) then type_node e
414    else raise_loc_generic e.loc' "Capture variables are not allowed in types"    else raise_loc_generic e.loc' "Capture variables are not allowed in types"
415    
416    
# Line 421  Line 424 
424    let env' = compile_many glb b in    let env' = compile_many glb b in
425    List.fold_left    List.fold_left
426      (fun glb (v,{ loc = loc }) ->      (fun glb (v,{ loc = loc }) ->
427         let t = StringMap.find v env' in         let t = TypeEnv.find v env' in
428         let d = Types.descr (mk_typ t) in         let d = Types.descr (mk_typ t) in
429         (*              let d = Types.normalize d in*)         (*              let d = Types.normalize d in*)
430         Types.Print.register_global v d;         Types.Print.register_global v d;
431         if StringMap.mem v glb         if TypeEnv.mem v glb
432         then raise_loc_generic loc ("Multiple definition for type " ^ v);         then raise_loc_generic loc ("Multiple definition for type " ^ v);
433         StringMap.add v t glb         TypeEnv.add v t glb
434      ) glb b      ) glb b
435    
436    
437    
438  (* II. Build skeleton *)  (* II. Build skeleton *)
439    
440  module Fv = StringSet  module Fv = IdSet
441    
442  (* IDEA: introduce a node Loc in the AST to override nolocs  (* IDEA: introduce a node Loc in the AST to override nolocs
443     in sub-expressions *)     in sub-expressions *)
# Line 449  Line 452 
452        | Var s -> (Fv.singleton s, Typed.Var s)        | Var s -> (Fv.singleton s, Typed.Var s)
453        | Apply (e1,e2) ->        | Apply (e1,e2) ->
454            let (fv1,e1) = expr loc glb e1 and (fv2,e2) = expr loc glb e2 in            let (fv1,e1) = expr loc glb e1 and (fv2,e2) = expr loc glb e2 in
455            (Fv.union fv1 fv2, Typed.Apply (e1,e2))            (Fv.cup fv1 fv2, Typed.Apply (e1,e2))
456        | Abstraction a ->        | Abstraction a ->
457            let iface = List.map (fun (t1,t2) -> (typ glb t1, typ glb t2))            let iface = List.map (fun (t1,t2) -> (typ glb t1, typ glb t2))
458                          a.fun_iface in                          a.fun_iface in
# Line 469  Line 472 
472                 Typed.fun_iface = iface;                 Typed.fun_iface = iface;
473                 Typed.fun_body = body;                 Typed.fun_body = body;
474                 Typed.fun_typ = t;                 Typed.fun_typ = t;
475                 Typed.fun_fv = Fv.elements fv                 Typed.fun_fv = fv
476               }               }
477            )            )
478        | Cst c -> (Fv.empty, Typed.Cst c)        | Cst c -> (Fv.empty, Typed.Cst c)
479        | Pair (e1,e2) ->        | Pair (e1,e2) ->
480            let (fv1,e1) = expr loc glb e1 and (fv2,e2) = expr loc glb e2 in            let (fv1,e1) = expr loc glb e1 and (fv2,e2) = expr loc glb e2 in
481            (Fv.union fv1 fv2, Typed.Pair (e1,e2))            (Fv.cup fv1 fv2, Typed.Pair (e1,e2))
482        | Xml (e1,e2) ->        | Xml (e1,e2) ->
483            let (fv1,e1) = expr loc glb e1 and (fv2,e2) = expr loc glb e2 in            let (fv1,e1) = expr loc glb e1 and (fv2,e2) = expr loc glb e2 in
484            (Fv.union fv1 fv2, Typed.Xml (e1,e2))            (Fv.cup fv1 fv2, Typed.Xml (e1,e2))
485        | Dot (e,l) ->        | Dot (e,l) ->
486            let (fv,e) = expr loc glb e in            let (fv,e) = expr loc glb e in
487            (fv,  Typed.Dot (e,l))            (fv,  Typed.Dot (e,l))
# Line 488  Line 491 
491            let r = List.map            let r = List.map
492                      (fun (l,e) ->                      (fun (l,e) ->
493                         let (fv2,e) = expr loc glb e                         let (fv2,e) = expr loc glb e
494                         in fv := Fv.union !fv fv2; (l,e))                         in fv := Fv.cup !fv fv2; (l,e))
495                      r in                      r in
496            let rec check = function            let rec check = function
497              | (l1,_) :: (l2,_) :: _ when l1 = l2 ->              | (l1,_) :: (l2,_) :: _ when l1 = l2 ->
# Line 499  Line 502 
502            (!fv, Typed.RecordLitt r)            (!fv, Typed.RecordLitt r)
503        | Op (op,le) ->        | Op (op,le) ->
504            let (fvs,ltes) = List.split (List.map (expr loc glb) le) in            let (fvs,ltes) = List.split (List.map (expr loc glb) le) in
505            let fv = List.fold_left Fv.union Fv.empty fvs in            let fv = List.fold_left Fv.cup Fv.empty fvs in
506            (fv, Typed.Op (op,ltes))            (fv, Typed.Op (op,ltes))
507        | Match (e,b) ->        | Match (e,b) ->
508            let (fv1,e) = expr loc glb e            let (fv1,e) = expr loc glb e
509            and (fv2,b) = branches loc glb b in            and (fv2,b) = branches loc glb b in
510            (Fv.union fv1 fv2, Typed.Match (e, b))            (Fv.cup fv1 fv2, Typed.Match (e, b))
511        | Map (e,b) ->        | Map (e,b) ->
512            let (fv1,e) = expr loc glb e            let (fv1,e) = expr loc glb e
513            and (fv2,b) = branches loc glb b in            and (fv2,b) = branches loc glb b in
514            (Fv.union fv1 fv2, Typed.Map (e, b))            (Fv.cup fv1 fv2, Typed.Map (e, b))
515        | Try (e,b) ->        | Try (e,b) ->
516            let (fv1,e) = expr loc glb e            let (fv1,e) = expr loc glb e
517            and (fv2,b) = branches loc glb b in            and (fv2,b) = branches loc glb b in
518            (Fv.union fv1 fv2, Typed.Try (e, b))            (Fv.cup fv1 fv2, Typed.Try (e, b))
519    in    in
520    fv,    fv,
521    { Typed.exp_loc = loc;    { Typed.exp_loc = loc;
# Line 527  Line 530 
530                (fun (p,e) ->                (fun (p,e) ->
531                   let (fv2,e) = expr loc glb e in                   let (fv2,e) = expr loc glb e in
532                   let p = pat glb p in                   let p = pat glb p in
533                   let fv2 = List.fold_right Fv.remove (Patterns.fv p) fv2 in                   let fv2 = Fv.diff fv2 (Patterns.fv p) in
534                   fv := Fv.union !fv fv2;                   fv := Fv.cup !fv fv2;
535                   accept := Types.cup !accept (Types.descr (Patterns.accept p));                   accept := Types.cup !accept (Types.descr (Patterns.accept p));
536                   { Typed.br_used = false;                   { Typed.br_used = false;
537                     Typed.br_pat = p;                     Typed.br_pat = p;
# Line 553  Line 556 
556    
557  (* III. Type-checks *)  (* III. Type-checks *)
558    
 module Env = StringMap  
559  type env = Types.descr Env.t  type env = Types.descr Env.t
560    
561  open Typed  open Typed
# Line 765  Line 767 
767  and compute_type' loc env = function  and compute_type' loc env = function
768    | Var s ->    | Var s ->
769        (try Env.find s env        (try Env.find s env
770         with Not_found -> raise_loc loc (UnboundId s)         with Not_found -> raise_loc loc (UnboundId (Id.value s))
771        )        )
772    | Cst c -> Types.constant c    | Cst c -> Types.constant c
773    | Dot (e,l) ->    | Dot (e,l) ->
Legend:
Removed from v.224  
changed lines
  Added in v.225
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5