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

Diff of /typing/typer.ml

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

revision 528 by abate, Tue Jul 10 17:41:19 2007 UTC revision 529 by abate, Tue Jul 10 17:42:07 2007 UTC
# Line 18  Line 18 
18  open Ast  open Ast
19  open Ident  open Ident
20    
21  module S = struct type t = string let compare = compare end  module TypeEnv = Map.Make(U)
 module TypeEnv = Map.Make(S)  
22    
23  exception NonExhaustive of Types.descr  exception NonExhaustive of Types.descr
24  exception Constraint of Types.descr * Types.descr  exception Constraint of Types.descr * Types.descr
# Line 79  Line 78 
78    | PStar of derecurs_regexp    | PStar of derecurs_regexp
79    | PWeakStar of derecurs_regexp    | PWeakStar of derecurs_regexp
80    
81    type tenv = {
82      tenv_names : derecurs_slot TypeEnv.t;
83      tenv_nspref: Atoms.Ns.t TypeEnv.t;
84      tenv_loc   : Location.loc
85    }
86    
87  let rec hash_derecurs = function  let rec hash_derecurs = function
88    | PAlias s ->    | PAlias s ->
89        s.pid        s.pid
# Line 180  Line 185 
185    incr counter;    incr counter;
186    { ploop = false; ploc = loc; pid = !counter; pdescr = None }    { ploop = false; ploc = loc; pid = !counter; pdescr = None }
187    
188    let ns_from_prefix env loc ns =
189      try TypeEnv.find ns env.tenv_nspref
190      with Not_found ->
191        raise_loc_generic loc
192          ("Undefined namespace prefix " ^ (U.to_string ns))
193    
194    let const env loc = function
195      | Const_internal c -> c
196      | Const_atom (ns,l) ->
197          let ns = ns_from_prefix env loc ns in
198          Types.Atom (Atoms.mk ns l)
199    
200  let rec derecurs env p = match p.descr with  let rec derecurs env p = match p.descr with
201    | PatVar v ->    | PatVar v ->
202        (try PAlias (TypeEnv.find v env)        (try PAlias (TypeEnv.find v env.tenv_names)
203         with Not_found ->         with Not_found ->
204           raise_loc_generic p.loc ("Undefined type/pattern " ^ v))           raise_loc_generic p.loc ("Undefined type/pattern " ^ (U.to_string v)))
205    | SchemaVar (kind, schema, item) ->    | SchemaVar (kind, schema, item) ->
206        let try_elt () = fst (Hashtbl.find !schema_elements (schema, item)) in        let try_elt () = fst (Hashtbl.find !schema_elements (schema, item)) in
207        let try_typ () = Hashtbl.find !schema_types (schema, item) in        let try_typ () = Hashtbl.find !schema_types (schema, item) in
# Line 217  Line 234 
234                      "No item named '%s' found in schema '%s'" item schema)))))                      "No item named '%s' found in schema '%s'" item schema)))))
235    | Recurs (p,b) -> derecurs (derecurs_def env b) p    | Recurs (p,b) -> derecurs (derecurs_def env b) p
236    | Internal t -> PType t    | Internal t -> PType t
237      | AtomT (ns,a) ->
238          let ns = ns_from_prefix env p.loc ns in
239          let a = match a with
240            | Some a -> Atoms.atom (Atoms.mk ns a)
241            | None -> Atoms.any_in_ns ns in
242          PType (Types.atom a)
243    | Or (p1,p2) -> POr (derecurs env p1, derecurs env p2)    | Or (p1,p2) -> POr (derecurs env p1, derecurs env p2)
244    | And (p1,p2) -> PAnd (derecurs env p1, derecurs env p2)    | And (p1,p2) -> PAnd (derecurs env p1, derecurs env p2)
245    | Diff (p1,p2) -> PDiff (derecurs env p1, derecurs env p2)    | Diff (p1,p2) -> PDiff (derecurs env p1, derecurs env p2)
# Line 226  Line 249 
249    | Optional p -> POptional (derecurs env p)    | Optional p -> POptional (derecurs env p)
250    | Record (o,r) -> PRecord (o, LabelMap.map (derecurs env) r)    | Record (o,r) -> PRecord (o, LabelMap.map (derecurs env) r)
251    | Capture x -> PCapture x    | Capture x -> PCapture x
252    | Constant (x,c) -> PConstant (x,c)    | Constant (x,c) -> PConstant (x,const env p.loc c)
253    | Regexp (r,q) ->    | Regexp (r,q) ->
254        let constant_nil t v =        let constant_nil t v =
255          PAnd (t, PConstant (v, Types.Atom Sequence.nil_atom)) in          PAnd (t, PConstant (v, Types.Atom Sequence.nil_atom)) in
# Line 253  Line 276 
276    
277  and derecurs_def env b =  and derecurs_def env b =
278    let b = List.map (fun (v,p) -> (v,p,mk_slot p.loc)) b in    let b = List.map (fun (v,p) -> (v,p,mk_slot p.loc)) b in
279    let env = List.fold_left (fun env (v,p,s) -> TypeEnv.add v s env) env b in    let n =
280        List.fold_left (fun env (v,p,s) -> TypeEnv.add v s env) env.tenv_names b in
281      let env = { env with tenv_names = n } in
282    List.iter (fun (v,p,s) -> s.pdescr <- Some (derecurs env p)) b;    List.iter (fun (v,p,s) -> s.pdescr <- Some (derecurs env p)) b;
283    env    env
284    
# Line 532  Line 557 
557      Patterns.define x (pat (descr s));      Patterns.define x (pat (descr s));
558      x      x
559    
560  let glb = State.ref "Typer.glb_env" TypeEnv.empty  let register_global_types glb b =
   
 let register_global_types b =  
561    List.iter    List.iter
562      (fun (v,p) ->      (fun (v,p) ->
563         if TypeEnv.mem v !glb         if TypeEnv.mem v glb.tenv_names
564         then raise_loc_generic p.loc ("Multiple definition for type " ^ v)         then raise_loc_generic p.loc ("Multiple definition for type " ^ (U.to_string v))
565      ) b;      ) b;
566    let old_glb = !glb in    let glb = derecurs_def glb b in
567    try    let b = List.map (fun (v,p) -> (v,p,compile (derecurs glb p))) b in
     glb := derecurs_def !glb b;  
     let b = List.map (fun (v,p) -> (v,p,compile (derecurs !glb p))) b in  
568      flush_defs ();      flush_defs ();
569      flush_fv ();      flush_fv ();
570      let b =      let b =
# Line 555  Line 576 
576             let t = typ s in             let t = typ s in
577             if (p.loc <> noloc) && (Types.is_empty t) then             if (p.loc <> noloc) && (Types.is_empty t) then
578               warning p.loc               warning p.loc
579                 ("This definition yields an empty type for " ^ v);               ("This definition yields an empty type for " ^ (U.to_string v));
580             (v,t)) b in             (v,t)) b in
581      List.iter (fun (v,t) -> Types.Print.register_global v t) b    List.iter (fun (v,t) -> Types.Print.register_global v t) b;
582    with e ->    glb
     glb := old_glb;  
     raise e  
583    
584  let dump_global_types ppf =  let register_ns_prefix glb p ns =
585    TypeEnv.iter (fun v _ -> Format.fprintf ppf " %s" v) !glb    { glb with tenv_nspref = TypeEnv.add p ns glb.tenv_nspref }
586    
587    let dump_global_types ppf glb =
588      TypeEnv.iter (fun v _ -> Format.fprintf ppf " %a" U.print v) glb.tenv_names
589    
590  let do_typ loc r =  let do_typ loc r =
591    let s = compile_slot r in    let s = compile_slot r in
# Line 572  Line 594 
594    if IdSet.is_empty (fv_slot s) then typ_node s    if IdSet.is_empty (fv_slot s) then typ_node s
595    else raise_loc_generic loc "Capture variables are not allowed in types"    else raise_loc_generic loc "Capture variables are not allowed in types"
596    
597  let typ p =  let typ glb p =
598    do_typ p.loc (derecurs !glb p)    do_typ p.loc (derecurs glb p)
599    
600  let pat p =  let pat glb p =
601    let s = compile_slot (derecurs !glb p) in    let s = compile_slot (derecurs glb p) in
602    flush_defs ();    flush_defs ();
603    flush_fv ();    flush_fv ();
604    try pat_node s    try pat_node s
# Line 600  Line 622 
622    }    }
623    
624    
625  let rec expr loc = function  let rec expr glb loc = function
626    | LocatedExpr (loc,e) -> expr loc e    | LocatedExpr (loc,e) -> expr glb loc e
627    | Forget (e,t) ->    | Forget (e,t) ->
628        let (fv,e) = expr loc e and t = typ t in        let (fv,e) = expr glb loc e and t = typ glb t in
629        exp loc fv (Typed.Forget (e,t))        exp loc fv (Typed.Forget (e,t))
630    | Var s ->    | Var s ->
631        exp loc (Fv.singleton s) (Typed.Var s)        exp loc (Fv.singleton s) (Typed.Var s)
632    | Apply (e1,e2) ->    | Apply (e1,e2) ->
633        let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in        let (fv1,e1) = expr glb loc e1 and (fv2,e2) = expr glb loc e2 in
634        exp loc (Fv.cup fv1 fv2) (Typed.Apply (e1,e2))        exp loc (Fv.cup fv1 fv2) (Typed.Apply (e1,e2))
635    | Abstraction a ->    | Abstraction a ->
636        let iface = List.map (fun (t1,t2) -> (typ t1, typ t2))        let iface = List.map (fun (t1,t2) -> (typ glb t1, typ glb t2))
637                      a.fun_iface in                      a.fun_iface in
638        let t = List.fold_left        let t = List.fold_left
639                  (fun accu (t1,t2) -> Types.cap accu (Types.arrow t1 t2))                  (fun accu (t1,t2) -> Types.cap accu (Types.arrow t1 t2))
# Line 619  Line 641 
641        let iface = List.map        let iface = List.map
642                      (fun (t1,t2) -> (Types.descr t1, Types.descr t2))                      (fun (t1,t2) -> (Types.descr t1, Types.descr t2))
643                      iface in                      iface in
644        let (fv0,body) = branches a.fun_body in        let (fv0,body) = branches glb a.fun_body in
645        let fv = match a.fun_name with        let fv = match a.fun_name with
646          | None -> fv0          | None -> fv0
647          | Some f -> Fv.remove f fv0 in          | Some f -> Fv.remove f fv0 in
# Line 632  Line 654 
654                  } in                  } in
655        exp loc fv e        exp loc fv e
656    | Cst c ->    | Cst c ->
657        exp loc Fv.empty (Typed.Cst c)        exp loc Fv.empty (Typed.Cst (const glb loc c))
658    | Pair (e1,e2) ->    | Pair (e1,e2) ->
659        let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in        let (fv1,e1) = expr glb loc e1 and (fv2,e2) = expr glb loc e2 in
660        exp loc (Fv.cup fv1 fv2) (Typed.Pair (e1,e2))        exp loc (Fv.cup fv1 fv2) (Typed.Pair (e1,e2))
661    | Xml (e1,e2) ->    | Xml (e1,e2) ->
662        let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in        let (fv1,e1) = expr glb loc e1 and (fv2,e2) = expr glb loc e2 in
663        exp loc (Fv.cup fv1 fv2) (Typed.Xml (e1,e2))        exp loc (Fv.cup fv1 fv2) (Typed.Xml (e1,e2))
664    | Dot (e,l) ->    | Dot (e,l) ->
665        let (fv,e) = expr loc e in        let (fv,e) = expr glb loc e in
666        exp loc fv (Typed.Dot (e,l))        exp loc fv (Typed.Dot (e,l))
667    | RemoveField (e,l) ->    | RemoveField (e,l) ->
668        let (fv,e) = expr loc e in        let (fv,e) = expr glb loc e in
669        exp loc fv (Typed.RemoveField (e,l))        exp loc fv (Typed.RemoveField (e,l))
670    | RecordLitt r ->    | RecordLitt r ->
671        let fv = ref Fv.empty in        let fv = ref Fv.empty in
672        let r = LabelMap.map        let r = LabelMap.map
673                  (fun e ->                  (fun e ->
674                     let (fv2,e) = expr loc e                     let (fv2,e) = expr glb loc e
675                     in fv := Fv.cup !fv fv2; e)                     in fv := Fv.cup !fv fv2; e)
676                  r in                  r in
677        exp loc !fv (Typed.RecordLitt r)        exp loc !fv (Typed.RecordLitt r)
678    | String (i,j,s,e) ->    | String (i,j,s,e) ->
679        let (fv,e) = expr loc e in        let (fv,e) = expr glb loc e in
680        exp loc fv (Typed.String (i,j,s,e))        exp loc fv (Typed.String (i,j,s,e))
681    | Op (op,le) ->    | Op (op,le) ->
682        let (fvs,ltes) = List.split (List.map (expr loc) le) in        let (fvs,ltes) = List.split (List.map (expr glb loc) le) in
683        let fv = List.fold_left Fv.cup Fv.empty fvs in        let fv = List.fold_left Fv.cup Fv.empty fvs in
684        (try        (try
685           (match (ltes,Typed.find_op op) with           (match (ltes,Typed.find_op op) with
# Line 667  Line 689 
689         with Not_found -> assert false)         with Not_found -> assert false)
690    
691    | Match (e,b) ->    | Match (e,b) ->
692        let (fv1,e) = expr loc e        let (fv1,e) = expr glb loc e
693        and (fv2,b) = branches b in        and (fv2,b) = branches glb b in
694        exp loc (Fv.cup fv1 fv2) (Typed.Match (e, b))        exp loc (Fv.cup fv1 fv2) (Typed.Match (e, b))
695    | Map (e,b) ->    | Map (e,b) ->
696        let (fv1,e) = expr loc e        let (fv1,e) = expr glb loc e
697        and (fv2,b) = branches b in        and (fv2,b) = branches glb b in
698        exp loc (Fv.cup fv1 fv2) (Typed.Map (e, b))        exp loc (Fv.cup fv1 fv2) (Typed.Map (e, b))
699    | Transform (e,b) ->    | Transform (e,b) ->
700        let (fv1,e) = expr loc e        let (fv1,e) = expr glb loc e
701        and (fv2,b) = branches b in        and (fv2,b) = branches glb b in
702        exp loc (Fv.cup fv1 fv2) (Typed.Transform (e, b))        exp loc (Fv.cup fv1 fv2) (Typed.Transform (e, b))
703    | Xtrans (e,b) ->    | Xtrans (e,b) ->
704        let (fv1,e) = expr loc e        let (fv1,e) = expr glb loc e
705        and (fv2,b) = branches b in        and (fv2,b) = branches glb b in
706        exp loc (Fv.cup fv1 fv2) (Typed.Xtrans (e, b))        exp loc (Fv.cup fv1 fv2) (Typed.Xtrans (e, b))
707    | Validate (e,schema,elt) ->    | Validate (e,schema,elt) ->
708        let (fv,e) = expr loc e in        let (fv,e) = expr glb loc e in
709        exp loc fv (Typed.Validate (e, schema, elt))        exp loc fv (Typed.Validate (e, schema, elt))
710    | Try (e,b) ->    | Try (e,b) ->
711        let (fv1,e) = expr loc e        let (fv1,e) = expr glb loc e
712        and (fv2,b) = branches b in        and (fv2,b) = branches glb b in
713        exp loc (Fv.cup fv1 fv2) (Typed.Try (e, b))        exp loc (Fv.cup fv1 fv2) (Typed.Try (e, b))
714    
715    
716    and branches b =    and branches glb b =
717      let fv = ref Fv.empty in      let fv = ref Fv.empty in
718      let accept = ref Types.empty in      let accept = ref Types.empty in
719      let branch (p,e) =      let branch (p,e) =
720        let cur_br = !cur_branch in        let cur_br = !cur_branch in
721        cur_branch := [];        cur_branch := [];
722        let (fv2,e) = expr noloc e in        let (fv2,e) = expr glb noloc e in
723        let br_loc = merge_loc p.loc e.Typed.exp_loc in        let br_loc = merge_loc p.loc e.Typed.exp_loc in
724        let p = pat p in        let p = pat glb p in
725        let fv2 = Fv.diff fv2 (Patterns.fv p) in        let fv2 = Fv.diff fv2 (Patterns.fv p) in
726        fv := Fv.cup !fv fv2;        fv := Fv.cup !fv fv2;
727        accept := Types.cup !accept (Types.descr (Patterns.accept p));        accept := Types.cup !accept (Types.descr (Patterns.accept p));
# Line 721  Line 743 
743       }       }
744      )      )
745    
746  let expr = expr noloc  let expr glb = expr glb noloc
747    
748  let let_decl p e =  let let_decl glb p e =
749    let (_,e) = expr e in    let (_,e) = expr glb e in
750    { Typed.let_pat = pat p;    { Typed.let_pat = pat glb p;
751      Typed.let_body = e;      Typed.let_body = e;
752      Typed.let_compiled = None }      Typed.let_compiled = None }
753    
754    
755    (* Hide global "typing/parsing" environment *)
756    
757    let glb = State.ref "Typer.glb_env"
758                { tenv_names = TypeEnv.empty;
759                  tenv_nspref = TypeEnv.add (U.mk "") Atoms.Ns.empty TypeEnv.empty;
760                  tenv_loc = noloc }
761    
762    let pat p = pat !glb p
763    let typ t = typ !glb t
764    let expr e = expr !glb e
765    let let_decl p e = let_decl !glb p e
766    
767    let register_global_types l = glb := register_global_types !glb l
768    let dump_global_types ppf = dump_global_types ppf !glb
769    
770    let register_ns_prefix p ns = glb := register_ns_prefix !glb p ns
771    
772  (* III. Type-checks *)  (* III. Type-checks *)
773    
774  type env = Types.descr Env.t  type env = Types.descr Env.t
# Line 1137  Line 1177 
1177        PRecord (false, LabelMap.from_list_disj [(LabelPool.mk (U.mk name), r)])        PRecord (false, LabelMap.from_list_disj [(LabelPool.mk (U.mk name), r)])
1178    
1179      and cd_type_of_elt_decl (name, typ, _) =      and cd_type_of_elt_decl (name, typ, _) =
1180        let atom_type = PType (Types.atom (Atoms.atom (Atoms.mk (U.mk name)))) in        let atom_type = PType (Types.atom (Atoms.atom (Atoms.mk Atoms.Ns.empty (U.mk name)))) in
1181        let content = match !typ with        let content = match !typ with
1182          | S st ->          | S st ->
1183              PTimes (PType Types.empty_closed_record, cd_type_of_simple_type st)              PTimes (PType Types.empty_closed_record, cd_type_of_simple_type st)
Legend:
Removed from v.528  
changed lines
  Added in v.529
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5