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

Diff of /typing/typer.ml

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

revision 541 by abate, Tue Jul 10 17:42:13 2007 UTC revision 542 by abate, Tue Jul 10 17:43:11 2007 UTC
# Line 11  Line 11 
11      Location.html_hilight (loc,`Full)      Location.html_hilight (loc,`Full)
12      msg      msg
13    
14    
15    
16    
17    
18  (* I. Transform the abstract syntax of types and patterns into  (* I. Transform the abstract syntax of types and patterns into
19        the internal form *)        the internal form *)
20    
# Line 80  Line 84 
84    
85  type tenv = {  type tenv = {
86    tenv_names : derecurs_slot TypeEnv.t;    tenv_names : derecurs_slot TypeEnv.t;
87    tenv_nspref: Atoms.Ns.t TypeEnv.t;    tenv_nspref: Ns.table;
88    tenv_loc   : Location.loc    tenv_loc   : Location.loc
89  }  }
90    let get_ns_table tenv = tenv.tenv_nspref
91    
92  let rec hash_derecurs = function  let rec hash_derecurs = function
93    | PAlias s ->    | PAlias s ->
# Line 185  Line 190 
190    incr counter;    incr counter;
191    { ploop = false; ploc = loc; pid = !counter; pdescr = None }    { ploop = false; ploc = loc; pid = !counter; pdescr = None }
192    
193    (*
194  let ns_from_prefix env loc ns =  let ns_from_prefix env loc ns =
195    try TypeEnv.find ns env.tenv_nspref    try TypeEnv.find ns env.tenv_nspref
196    with Not_found ->    with Not_found ->
197      raise_loc_generic loc      raise_loc_generic loc
198        ("Undefined namespace prefix " ^ (U.to_string ns))        ("Undefined namespace prefix " ^ (U.to_string ns))
199    *)
200    
201    let parse_atom env loc t =
202      try
203        let (ns,l) = Ns.map_tag env.tenv_nspref t in
204        Atoms.mk ns l
205      with Ns.UnknownPrefix ns ->
206        raise_loc_generic loc
207        ("Undefined namespace prefix " ^ (U.to_string ns))
208    
209    let parse_ns env loc ns =
210      try Ns.map_prefix env.tenv_nspref ns
211      with Ns.UnknownPrefix ns ->
212        raise_loc_generic loc
213        ("Undefined namespace prefix " ^ (U.to_string ns))
214    
215    
216  let const env loc = function  let const env loc = function
217    | Const_internal c -> c    | Const_internal c -> c
218    | Const_atom (ns,l) ->    | Const_atom t -> Types.Atom (parse_atom env loc t)
       let ns = ns_from_prefix env loc ns in  
       Types.Atom (Atoms.mk ns l)  
219    
220  let rec derecurs env p = match p.descr with  let rec derecurs env p = match p.descr with
221    | PatVar v ->    | PatVar v ->
# Line 234  Line 254 
254                      "No item named '%s' found in schema '%s'" item schema)))))                      "No item named '%s' found in schema '%s'" item schema)))))
255    | Recurs (p,b) -> derecurs (derecurs_def env b) p    | Recurs (p,b) -> derecurs (derecurs_def env b) p
256    | Internal t -> PType t    | Internal t -> PType t
257    | AtomT (ns,a) ->    | AtomT t -> PType (Types.atom (Atoms.atom (parse_atom env p.loc t)))
258        let ns = ns_from_prefix env p.loc ns in    | NsT ns -> PType (Types.atom (Atoms.any_in_ns (parse_ns env p.loc ns)))
       let a = match a with  
         | Some a -> Atoms.atom (Atoms.mk ns a)  
         | None -> Atoms.any_in_ns ns in  
       PType (Types.atom a)  
259    | Or (p1,p2) -> POr (derecurs env p1, derecurs env p2)    | Or (p1,p2) -> POr (derecurs env p1, derecurs env p2)
260    | And (p1,p2) -> PAnd (derecurs env p1, derecurs env p2)    | And (p1,p2) -> PAnd (derecurs env p1, derecurs env p2)
261    | Diff (p1,p2) -> PDiff (derecurs env p1, derecurs env p2)    | Diff (p1,p2) -> PDiff (derecurs env p1, derecurs env p2)
# Line 582  Line 598 
598    glb    glb
599    
600  let register_ns_prefix glb p ns =  let register_ns_prefix glb p ns =
601    { glb with tenv_nspref = TypeEnv.add p ns glb.tenv_nspref }    { glb with tenv_nspref = Ns.add_prefix p ns glb.tenv_nspref }
602    
603  let dump_global_types ppf glb =  let dump_global_types ppf glb =
604    TypeEnv.iter (fun v _ -> Format.fprintf ppf " %a" U.print v) glb.tenv_names    TypeEnv.iter (fun v _ -> Format.fprintf ppf " %a" U.print v) glb.tenv_names
# Line 608  Line 624 
624    
625  (* II. Build skeleton *)  (* II. Build skeleton *)
626    
627    
628    type op = [ `Unary of tenv -> Typed.unary_op | `Binary of tenv -> Typed.binary_op ]
629    let op_table : (string,op) Hashtbl.t = Hashtbl.create 31
630    let register_unary_op s f = Hashtbl.add op_table s (`Unary f)
631    let register_binary_op s f = Hashtbl.add op_table s (`Binary f)
632    let find_op s = Hashtbl.find op_table s
633    
634    
635  module Fv = IdSet  module Fv = IdSet
636    
637  type branch = Branch of Typed.branch * branch list  type branch = Branch of Typed.branch * branch list
# Line 682  Line 706 
706        let (fvs,ltes) = List.split (List.map (expr glb loc) le) in        let (fvs,ltes) = List.split (List.map (expr glb loc) le) in
707        let fv = List.fold_left Fv.cup Fv.empty fvs in        let fv = List.fold_left Fv.cup Fv.empty fvs in
708        (try        (try
709           (match (ltes,Typed.find_op op) with           (match (ltes,find_op op) with
710              | [e], `Unary op -> exp loc fv (Typed.UnaryOp (op, e))              | [e], `Unary op -> exp loc fv (Typed.UnaryOp (op glb, e))
711              | [e1;e2], `Binary op -> exp loc fv (Typed.BinaryOp (op, e1,e2))              | [e1;e2], `Binary op -> exp loc fv (Typed.BinaryOp (op glb, e1,e2))
712              | _ -> assert false)              | _ -> assert false)
713         with Not_found -> assert false)         with Not_found -> assert false)
714    
# Line 759  Line 783 
783    
784  let glb = State.ref "Typer.glb_env"  let glb = State.ref "Typer.glb_env"
785              { tenv_names = TypeEnv.empty;              { tenv_names = TypeEnv.empty;
786                tenv_nspref = TypeEnv.add (U.mk "") Atoms.Ns.empty TypeEnv.empty;                tenv_nspref = Ns.empty_table;
787                tenv_loc = noloc }                tenv_loc = noloc }
788    
789  let pat p = pat !glb p  let pat p = pat !glb p
# Line 974  Line 998 
998           (* could compute (split l e) once... *)           (* could compute (split l e) once... *)
999           let pi = Types.Record.project_opt rconstr l in           let pi = Types.Record.project_opt rconstr l in
1000           if Types.is_empty pi then           if Types.is_empty pi then
1001             (let l = U.to_string (LabelPool.value l) in             (let l = Label.to_string (LabelPool.value l) in
1002              should_have loc constr              should_have loc constr
1003                (Printf.sprintf "Field %s is not allowed here." l));                (Printf.sprintf "Field %s is not allowed here." l));
1004           let t = type_check env e pi true in           let t = type_check env e pi true in
# Line 1171  Line 1195 
1195            (fun (required, (name, st, _), _) ->            (fun (required, (name, st, _), _) ->
1196               let r = cd_type_of_simple_type st in               let r = cd_type_of_simple_type st in
1197               let r = if required then r else POptional r in               let r = if required then r else POptional r in
1198               (LabelPool.mk (U.mk name), r)               (LabelPool.mk (Ns.empty, U.mk name), r)  (* TODO: NS *)
1199            ) attr_uses in            ) attr_uses in
1200        PRecord (false, LabelMap.from_list_disj fields)        PRecord (false, LabelMap.from_list_disj fields)
1201    
1202      and cd_type_of_att_decl (name, st, _) =      and cd_type_of_att_decl (name, st, _) =
1203        let r = cd_type_of_simple_type st in        let r = cd_type_of_simple_type st in
1204        PRecord (false, LabelMap.from_list_disj [(LabelPool.mk (U.mk name), r)])        PRecord (false, LabelMap.from_list_disj [(LabelPool.mk (Ns.empty, U.mk name), r)])
1205            (* TODO: NS *)
1206    
1207      and cd_type_of_elt_decl (name, typ, _) =      and cd_type_of_elt_decl (name, typ, _) =
1208        let atom_type = PType (Types.atom (Atoms.atom (Atoms.mk Atoms.Ns.empty (U.mk name)))) in        let atom_type = PType (Types.atom (Atoms.atom (Atoms.mk Ns.empty (U.mk name)))) in
1209        let content = match !typ with        let content = match !typ with
1210          | S st ->          | S st ->
1211              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.541  
changed lines
  Added in v.542
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5