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

Diff of /typing/typer.ml

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

revision 232 by abate, Tue Jul 10 17:17:01 2007 UTC revision 233 by abate, Tue Jul 10 17:17:31 2007 UTC
# Line 13  Line 13 
13  *)  *)
14    
15  exception NonExhaustive of Types.descr  exception NonExhaustive of Types.descr
 exception MultipleLabel of Types.label  
16  exception Constraint of Types.descr * Types.descr * string  exception Constraint of Types.descr * Types.descr * string
17  exception ShouldHave of Types.descr * string  exception ShouldHave of Types.descr * string
18  exception WrongLabel of Types.descr * Types.label  exception WrongLabel of Types.descr * label
19  exception UnboundId of string  exception UnboundId of string
20    
21  let raise_loc loc exn = raise (Location (loc,exn))  let raise_loc loc exn = raise (Location (loc,exn))
# Line 43  Line 42 
42    | IXml of ti * ti    | IXml of ti * ti
43    | IArrow of ti * ti    | IArrow of ti * ti
44    | IOptional of ti    | IOptional of ti
45    | IRecord of bool * (Types.label * ti) list    | IRecord of bool * ti label_map
46    | ICapture of id    | ICapture of id
47    | IConstant of id * Types.const    | IConstant of id * Types.const
48    
# Line 266  Line 265 
265    | XmlT (t1,t2) -> cons loc (IXml (compile env t1, compile env t2))    | XmlT (t1,t2) -> cons loc (IXml (compile env t1, compile env t2))
266    | Arrow (t1,t2) -> cons loc (IArrow (compile env t1, compile env t2))    | Arrow (t1,t2) -> cons loc (IArrow (compile env t1, compile env t2))
267    | Optional t -> cons loc (IOptional (compile env t))    | Optional t -> cons loc (IOptional (compile env t))
268    | Record (o,r) ->    | Record (o,r) ->  cons loc (IRecord (o, LabelMap.map (compile env) r))
       cons loc (IRecord (o, List.map (fun (l,t) -> l,compile env t) r))  
269    | Constant (x,v) -> cons loc (IConstant (x,v))    | Constant (x,v) -> cons loc (IConstant (x,v))
270    | Capture x -> cons loc (ICapture x)    | Capture x -> cons loc (ICapture x)
271    
# Line 301  Line 299 
299             | ITimes (s1,s2) | IXml (s1,s2)             | ITimes (s1,s2) | IXml (s1,s2)
300             | IArrow (s1,s2) -> comp_fv s1; comp_fv s2             | IArrow (s1,s2) -> comp_fv s1; comp_fv s2
301             | IOptional r -> comp_fv r             | IOptional r -> comp_fv r
302             | IRecord (_,r) -> List.iter (fun (l,s) -> comp_fv s) r             | IRecord (_,r) -> LabelMap.iter comp_fv r
303             | IType _ -> ()             | IType _ -> ()
304             | ICapture x             | ICapture x
305             | IConstant (x,_) -> comp_fv_res := IdSet.add x !comp_fv_res             | IConstant (x,_) -> comp_fv_res := IdSet.add x !comp_fv_res
# Line 337  Line 335 
335      | IOptional s -> Types.Record.or_absent (typ seen s)      | IOptional s -> Types.Record.or_absent (typ seen s)
336      | IRecord (o,r) ->      | IRecord (o,r) ->
337          Types.record'          Types.record'
338            (o,List.map (fun (l,s) -> (l,typ_node s)) r)            (o, LabelMap.map typ_node r)
339      | ICapture x | IConstant (x,_) -> assert false      | ICapture x | IConstant (x,_) -> assert false
340    
341  and typ_node s : Types.node =  and typ_node s : Types.node =
# Line 387  Line 385 
385           "Optional field not allowed in record patterns")           "Optional field not allowed in record patterns")
386    | IRecord (o,r) ->    | IRecord (o,r) ->
387        let pats = ref [] in        let pats = ref [] in
388        let aux (l,s) =        let aux l s =
389          if IdSet.is_empty (fv s) then (l,type_node s)          if IdSet.is_empty (fv s) then type_node s
390          else          else
391            (            ( pats := Patterns.record l (pat_node s) :: !pats;
392              pats := Patterns.record l (pat_node s) :: !pats;              Types.any_node )
393              (l,Types.any_node)        in
394            ) in        let constr = Types.record' (o,LabelMap.mapi aux r) in
       let constr = Types.record' (o,List.map aux r) in  
395        List.fold_left Patterns.cap (Patterns.constr constr) !pats        List.fold_left Patterns.cap (Patterns.constr constr) !pats
396  (* TODO: can avoid constr when o=true, and all fields have fv *)  (* TODO: can avoid constr when o=true, and all fields have fv *)
397    | ICapture x ->  Patterns.capture x    | ICapture x ->  Patterns.capture x
# Line 491  Line 488 
488            (fv,  Typed.Dot (e,l))            (fv,  Typed.Dot (e,l))
489        | RecordLitt r ->        | RecordLitt r ->
490            let fv = ref Fv.empty in            let fv = ref Fv.empty in
491            let r  = List.sort (fun (l1,_) (l2,_) -> compare l1 l2) r in            let r = LabelMap.map
492            let r = List.map                      (fun e ->
                     (fun (l,e) ->  
493                         let (fv2,e) = expr loc glb e                         let (fv2,e) = expr loc glb e
494                         in fv := Fv.cup !fv fv2; (l,e))                         in fv := Fv.cup !fv fv2; e)
495                      r in                      r in
           let rec check = function  
             | (l1,_) :: (l2,_) :: _ when l1 = l2 ->  
                 raise_loc loc (MultipleLabel l1)  
             | _ :: rem -> check rem  
             | _ -> () in  
           check r;  
496            (!fv, Typed.RecordLitt r)            (!fv, Typed.RecordLitt r)
497        | Op (op,le) ->        | Op (op,le) ->
498            let (fvs,ltes) = List.split (List.map (expr loc glb) le) in            let (fvs,ltes) = List.split (List.map (expr loc glb) le) in
# Line 636  Line 626 
626                 raise_loc loc                 raise_loc loc
627                   (ShouldHave (constr,(Printf.sprintf                   (ShouldHave (constr,(Printf.sprintf
628                                          "Field %s is not allowed here."                                          "Field %s is not allowed here."
629                                          (Types.LabelPool.value l)                                          (LabelPool.value l)
630                                       )                                       )
631                               ));                               ));
632               let t = type_check env e pi true in               let t = type_check env e pi true in
# Line 794  Line 784 
784        and t2 = compute_type env e2 in        and t2 = compute_type env e2 in
785        Types.times (Types.cons t1) (Types.cons t2)        Types.times (Types.cons t1) (Types.cons t2)
786    | RecordLitt r ->    | RecordLitt r ->
787        let r =        let r = LabelMap.map (fun e -> Types.cons (compute_type env e)) r in
         List.map  
           (fun (l,e) -> (l,Types.cons (compute_type env e)))  
           r in  
788        Types.record' (false,r)        Types.record' (false,r)
789    | _ -> assert false    | _ -> assert false
790    
Legend:
Removed from v.232  
changed lines
  Added in v.233
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5