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

Diff of /typing/typer.ml

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

revision 8 by abate, Tue Jul 10 16:57:08 2007 UTC revision 9 by abate, Tue Jul 10 16:57:19 2007 UTC
# Line 3  Line 3 
3    
4  open Location  open Location
5  open Ast  open Ast
 exception ParsingPattern of string  
6    
7  let raise_loc loc msg = raise (Location loc (ParsingPattern msg))  exception Pattern of string
8    exception NonExhaustive of Types.descr
9    exception Constraint of Types.descr * Types.descr * string
10    
11    let raise_loc loc exn = raise (Location (loc,exn))
12    
13  (* Internal representation as a graph (desugar recursive types and regexp),  (* Internal representation as a graph (desugar recursive types and regexp),
14     to compute freevars, etc... *)     to compute freevars, etc... *)
# Line 19  Line 22 
22    mutable pat_node: Patterns.node option    mutable pat_node: Patterns.node option
23  }  }
24  and descr =  and descr =
25     [ `Alias of ti     [ `Alias of string * ti
26     | `Type of Types.descr     | `Type of Types.descr
27     | `Or of ti * ti     | `Or of ti * ti
28     | `And of ti * ti     | `And of ti * ti
# Line 41  Line 44 
44    let counter = ref 0 in    let counter = ref 0 in
45    fun () ->    fun () ->
46      incr counter;      incr counter;
47      let rec x = { id = !counter; loc' = noloc; fv = None; descr' = `Alias x;      let rec x = {
48                    type_node = None; pat_node = None } in        id = !counter;
49          loc' = noloc;
50          fv = None;
51          descr' = `Alias ("__dummy__", x);
52          type_node = None;
53          pat_node = None
54        } in
55      x      x
56    
57  let cons loc d =  let cons loc d =
# Line 146  Line 155 
155    match (d : Ast.ppat') with    match (d : Ast.ppat') with
156    | PatVar s ->    | PatVar s ->
157        (try StringMap.find s env        (try StringMap.find s env
158         with Not_found -> raise_loc loc "Undefined variable"         with Not_found ->
159             raise_loc loc (Pattern ("Undefined type variable " ^ s))
160        )        )
161    | Recurs (t, b) ->    | Recurs (t, b) ->
162        let b = List.map (fun (v,t) -> (v,t,mk' ())) b in        let b = List.map (fun (v,t) -> (v,t,mk' ())) b in
163        let env =        let env =
164          List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in          List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in
165        List.iter (fun (v,t,x) -> x.descr' <- `Alias (compile env t)) b;        List.iter
166            (fun (v,t,x) -> x.loc' <- t.loc; x.descr' <- `Alias (v, compile env t))
167            b;
168        compile env t        compile env t
169    | Regexp (r,q) -> compile env (Regexp.compile r q)    | Regexp (r,q) -> compile env (Regexp.compile r q)
170    | Internal t -> cons loc (`Type t)    | Internal t -> cons loc (`Type t)
# Line 171  Line 183 
183      | None ->      | None ->
184          let l =          let l =
185            match s.descr' with            match s.descr' with
186              | `Alias x -> if List.memq s seen then [] else comp_fv (s :: seen) x              | `Alias (_,x) -> if List.memq s seen then [] else comp_fv (s :: seen) x
187              | `Or (s1,s2)              | `Or (s1,s2)
188              | `And (s1,s2)              | `And (s1,s2)
189              | `Diff (s1,s2)              | `Diff (s1,s2)
# Line 190  Line 202 
202    
203  let rec typ seen s : Types.descr =  let rec typ seen s : Types.descr =
204    match s.descr' with    match s.descr' with
205      | `Alias x ->      | `Alias (v,x) ->
206          if List.memq s seen then failwith "Unguarded recursion in this type"          if List.memq s seen then
207              raise_loc s.loc'
208                (Pattern
209                   ("Unguarded recursion on variable " ^ v ^ " in this type"))
210          else typ (s :: seen) x          else typ (s :: seen) x
211      | `Type t -> t      | `Type t -> t
212      | `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)      | `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)
# Line 200  Line 215 
215      | `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)      | `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
216      | `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)      | `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
217      | `Record (l,o,s) -> Types.record l o (typ_node s)      | `Record (l,o,s) -> Types.record l o (typ_node s)
218      | _ -> failwith "This is not a type"      | `Capture _ | `Constant _ -> assert false
219    
220  and typ_node s : Types.node =  and typ_node s : Types.node =
221    match s.type_node with    match s.type_node with
# Line 217  Line 232 
232  let rec pat seen s : Patterns.descr =  let rec pat seen s : Patterns.descr =
233    if fv s = [] then Patterns.constr (type_node s) else    if fv s = [] then Patterns.constr (type_node s) else
234    match s.descr' with    match s.descr' with
235      | `Alias x ->      | `Alias (v,x) ->
236          if List.memq s seen then failwith "Unguarded recursion in this pattern"          if List.memq s seen then
237              raise_loc s.loc'
238                (Pattern
239                   ("Unguarded recursion on variable " ^ v ^ " in this pattern"))
240          else pat (s :: seen) x          else pat (s :: seen) x
241      | `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)      | `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
242      | `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)      | `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
243      | `Diff (s1,s2) when fv s2 = [] ->      | `Diff (s1,s2) when fv s2 = [] ->
244          let s2 = Types.cons (Types.neg (Types.descr (type_node s2)))in          let s2 = Types.cons (Types.neg (Types.descr (type_node s2)))in
245          Patterns.cap (pat seen s1) (Patterns.constr s2)          Patterns.cap (pat seen s1) (Patterns.constr s2)
246        | `Diff _ ->
247            raise_loc s.loc' (Pattern "Difference not allowed in patterns")
248      | `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)      | `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
249      | `Record (l,false,s) -> Patterns.record l (pat_node s)      | `Record (l,false,s) -> Patterns.record l (pat_node s)
250        | `Record _ ->
251            raise_loc s.loc'
252              (Pattern "Optional field not allowed in record patterns")
253      | `Capture x ->  Patterns.capture x      | `Capture x ->  Patterns.capture x
254      | `Constant (x,c) -> Patterns.constant x c      | `Constant (x,c) -> Patterns.constant x c
255      | _ -> failwith "This is not a pattern"      | `Arrow _ ->
256            raise_loc s.loc' (Pattern "Arrow not allowed in patterns")
257        | `Type _ -> assert false
258    
259  and pat_node s : Patterns.node =  and pat_node s : Patterns.node =
260    match s.pat_node with    match s.pat_node with
# Line 243  Line 268 
268    
269  let typ e =  let typ e =
270    let e = compile StringMap.empty e in    let e = compile StringMap.empty e in
271    if fv e = [] then type_node e else failwith "This is not a type"    if fv e = [] then type_node e
272      else (raise_loc e.loc'
273              (Pattern "Capture variables are not allowed in types"))
274    
275  let pat e =  let pat e =
276    let e = compile StringMap.empty e in    let e = compile StringMap.empty e in
# Line 267  Line 294 
294            let t = List.fold_left            let t = List.fold_left
295                      (fun accu (t1,t2) -> Types.cap accu (Types.arrow t1 t2))                      (fun accu (t1,t2) -> Types.cap accu (Types.arrow t1 t2))
296                      Types.any iface in                      Types.any iface in
297              let iface = List.map
298                            (fun (t1,t2) -> (Types.descr t1, Types.descr t2))
299                            iface in
300            let (fv0,body) = branches a.fun_body in            let (fv0,body) = branches a.fun_body in
301            let fv = match a.fun_name with            let fv = match a.fun_name with
302              | None -> fv0              | None -> fv0
# Line 318  Line 348 
348                   let (fv2,e) = expr e in                   let (fv2,e) = expr e in
349                   fv := Fv.union !fv fv2;                   fv := Fv.union !fv fv2;
350                   { Typed.br_used = false;                   { Typed.br_used = false;
                    Typed.br_typ = Types.empty;  
351                     Typed.br_pat = pat p;                     Typed.br_pat = pat p;
352                     Typed.br_body = e }                     Typed.br_body = e }
353                ) b in                ) b in
354      (!fv,b)      (!fv, { Typed.br_typ = Types.empty; Typed.br_branches = b } )
355    
356  module Env = StringMap  module Env = StringMap
357    
# Line 343  Line 372 
372          | None -> env          | None -> env
373          | Some f -> Env.add f a.fun_typ env in          | Some f -> Env.add f a.fun_typ env in
374        List.iter (fun (t1,t2) ->        List.iter (fun (t1,t2) ->
375                     let t = type_branches env (Types.descr t1) a.fun_body in                     let t = type_branches loc env t1 a.fun_body in
376                     if not (Types.subtype t (Types.descr t2)) then                     if not (Types.subtype t t2) then
377                       failwith "Constraint not satisfied"                       raise_loc loc (Constraint (t,t2,"Constraint not satisfied in interface"))
378                  ) a.fun_iface;                  ) a.fun_iface;
379        a.fun_typ        a.fun_typ
380    | Cst c -> Types.constant c    | Cst c -> Types.constant c
# Line 363  Line 392 
392    | Op (op,e) -> assert false    | Op (op,e) -> assert false
393    | Match (e,b) ->    | Match (e,b) ->
394        let t = compute_type env e in        let t = compute_type env e in
395        type_branches env t b        type_branches loc env t b
396    | Map (e,b) -> assert false    | Map (e,b) -> assert false
397    
398  and type_branches env targ branches =  and type_branches loc env targ brs =
399    if Types.is_empty targ then Types.empty    if Types.is_empty targ then Types.empty
400    else branches_aux env targ Types.empty branches    else (
401        brs.br_typ <- Types.cup brs.br_typ targ;
402        branches_aux loc env targ Types.empty brs.br_branches
403      )
404    
405  and branches_aux env targ tres = function  and branches_aux loc env targ tres = function
406    | [] -> failwith "Non-exhaustive pattern matching"    | [] -> raise_loc loc (NonExhaustive targ)
407    | b :: rem ->    | b :: rem ->
408        let p = b.br_pat in        let p = b.br_pat in
409        let acc = Types.descr (Patterns.accept p) in        let acc = Types.descr (Patterns.accept p) in
410    
411        let targ' = Types.cap targ acc in        let targ' = Types.cap targ acc in
412        if Types.is_empty targ'        if Types.is_empty targ'
413        then branches_aux env targ tres rem        then branches_aux loc env targ tres rem
414        else        else
415          ( b.br_used <- true;          ( b.br_used <- true;
416            let res = Patterns.filter targ' p in            let res = Patterns.filter targ' p in
# Line 386  Line 418 
418                         (fun env (x,t) -> Env.add x (Types.descr t) env)                         (fun env (x,t) -> Env.add x (Types.descr t) env)
419                         env res in                         env res in
420            let t = compute_type env' b.br_body in            let t = compute_type env' b.br_body in
421            branches_aux env (Types.diff targ acc) (Types.cup t tres) rem            let tres = Types.cup t tres in
422              let targ'' = Types.diff targ acc in
423              if (Types.non_empty targ'') then
424                branches_aux loc env targ'' (Types.cup t tres) rem
425              else
426                tres
427          )          )
   
   
Legend:
Removed from v.8  
changed lines
  Added in v.9
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5