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

Diff of /typing/typer.ml

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

revision 142 by abate, Tue Jul 10 17:10:00 2007 UTC revision 159 by abate, Tue Jul 10 17:11:29 2007 UTC
# Line 38  Line 38 
38     | `Times of ti * ti     | `Times of ti * ti
39     | `Xml of ti * ti     | `Xml of ti * ti
40     | `Arrow of ti * ti     | `Arrow of ti * ti
41     | `Record of Types.label * bool * ti     | `Record of bool * (Types.label * bool * ti) list
42     | `Capture of Patterns.capture     | `Capture of Patterns.capture
43     | `Constant of Patterns.capture * Types.const     | `Constant of Patterns.capture * Types.const
44     ]     ]
# Line 261  Line 261 
261    | Prod (t1,t2) -> cons loc (`Times (compile env t1, compile env t2))    | Prod (t1,t2) -> cons loc (`Times (compile env t1, compile env t2))
262    | XmlT (t1,t2) -> cons loc (`Xml (compile env t1, compile env t2))    | XmlT (t1,t2) -> cons loc (`Xml (compile env t1, compile env t2))
263    | Arrow (t1,t2) -> cons loc (`Arrow (compile env t1, compile env t2))    | Arrow (t1,t2) -> cons loc (`Arrow (compile env t1, compile env t2))
264    | Record (l,o,t) -> cons loc (`Record (l,o,compile env t))    | Record (o,r) ->
265          cons loc (`Record (o, List.map (fun (l,o,t) -> l,o,compile env t) r))
266    | Constant (x,v) -> cons loc (`Constant (x,v))    | Constant (x,v) -> cons loc (`Constant (x,v))
267    | Capture x -> cons loc (`Capture x)    | Capture x -> cons loc (`Capture x)
268    
# Line 294  Line 295 
295               | `Diff (s1,s2)               | `Diff (s1,s2)
296               | `Times (s1,s2) | `Xml (s1,s2)               | `Times (s1,s2) | `Xml (s1,s2)
297               | `Arrow (s1,s2) -> comp_fv s1; comp_fv s2               | `Arrow (s1,s2) -> comp_fv s1; comp_fv s2
298               | `Record (l,opt,s) -> comp_fv s               | `Record (_,r) -> List.iter (fun (l,opt,s) -> comp_fv s) r
299               | `Type _ -> ()               | `Type _ -> ()
300               | `Capture x               | `Capture x
301               | `Constant (x,_) -> comp_fv_res := StringSet.add x !comp_fv_res               | `Constant (x,_) -> comp_fv_res := StringSet.add x !comp_fv_res
# Line 327  Line 328 
328      | `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)      | `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
329      | `Xml (s1,s2) ->   Types.xml (typ_node s1) (typ_node s2)      | `Xml (s1,s2) ->   Types.xml (typ_node s1) (typ_node s2)
330      | `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)      | `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
331      | `Record (l,o,s) -> Types.record l o (typ_node s)      | `Record (o,r) ->
332            Types.record'
333              (o,List.map (fun (l,o,s) -> (l,(o,typ_node s))) r)
334      | `Capture x | `Constant (x,_) -> assert false      | `Capture x | `Constant (x,_) -> assert false
335    
336  and typ_node s : Types.node =  and typ_node s : Types.node =
# Line 371  Line 374 
374        raise (Patterns.Error "Difference not allowed in patterns")        raise (Patterns.Error "Difference not allowed in patterns")
375    | `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)    | `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
376    | `Xml (s1,s2) -> Patterns.xml (pat_node s1) (pat_node s2)    | `Xml (s1,s2) -> Patterns.xml (pat_node s1) (pat_node s2)
377    | `Record (l,false,s) -> Patterns.record l (pat_node s)    | `Record (false,_) ->
378    | `Record _ ->        (* TODO: handle this case with a type constraint ... *)
379        raise (Patterns.Error "Optional field not allowed in record patterns")        raise
380          (Patterns.Error "Closed records are not allowed in record patterns");
381      | `Record (true,r) ->
382          let l =
383            List.map
384              (fun (l,o,s) ->
385                 if o then
386                   raise
387                     (Patterns.Error
388                        "Optional field not allowed in record patterns");
389                 Patterns.record l (pat_node s)
390              ) r
391          in
392          (match l with
393             | [] -> Patterns.constr Types.Record.any
394             | h::t -> List.fold_left Patterns.cap h t)
395    | `Capture x ->  Patterns.capture x    | `Capture x ->  Patterns.capture x
396    | `Constant (x,c) -> Patterns.constant x c    | `Constant (x,c) -> Patterns.constant x c
397    | `Arrow _ ->    | `Arrow _ ->
# Line 595  Line 613 
613        type_check_pair loc env e1 e2 constr precise        type_check_pair loc env e1 e2 constr precise
614    | Xml (e1,e2) ->    | Xml (e1,e2) ->
615        type_check_pair ~kind:`XML loc env e1 e2 constr precise        type_check_pair ~kind:`XML loc env e1 e2 constr precise
616    
617    (*
618    | RecordLitt r ->    | RecordLitt r ->
619        let rconstr = Types.Record.get constr in        let rconstr = Types.Record.get constr in
620        if Types.Record.is_empty rconstr then        if Types.Record.is_empty rconstr then
# Line 628  Line 648 
648        in        in
649  (*      check loc res constr ""; *)  (*      check loc res constr ""; *)
650        res        res
651    *)
652    
653    | Map (e,b) ->    | Map (e,b) ->
654        let t = type_check env e (Sequence.star b.br_accept) true in        let t = type_check env e (Sequence.star b.br_accept) true in
# Line 770  Line 791 
791        and t2 = compute_type env e2 in        and t2 = compute_type env e2 in
792        Types.times (Types.cons t1) (Types.cons t2)        Types.times (Types.cons t1) (Types.cons t2)
793    | RecordLitt r ->    | RecordLitt r ->
794        List.fold_left        let r =
795          (fun accu (l,e) ->          List.map
796             let t = compute_type env e in            (fun (l,e) -> (l,(false,Types.cons (compute_type env e))))
797             let t = Types.record l false (Types.cons t) in            r in
798             Types.cap accu t        Types.record' (false,r)
         ) Types.Record.any r  
   
   
799    | _ -> assert false    | _ -> assert false
800    
801  and type_check_branches loc env targ brs constr precise =  and type_check_branches loc env targ brs constr precise =
Legend:
Removed from v.142  
changed lines
  Added in v.159
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5