/[svn]/types/patterns.ml
ViewVC logotype

Diff of /types/patterns.ml

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

revision 147 by abate, Tue Jul 10 17:10:23 2007 UTC revision 148 by abate, Tue Jul 10 17:10:28 2007 UTC
# Line 707  Line 707 
707      record: ((Types.label, node sl) sm) line;      record: ((Types.label, node sl) sm) line;
708    
709    }    }
710      type nnf = Types.descr * node sl
711    type 'a nline = (result *  'a) list    type 'a nline = (result *  'a) list
712    type record =    type record =
713        [ `Success        [ `Success
714        | `Fail        | `Fail
715        | `Dispatch of (nf * record) list        | `Dispatch of (nnf * record) list
716        | `Label of Types.label * (nf * record) list * record ]        | `Label of Types.label * (nnf * record) list * record ]
717    type t = {    type t = {
718      nfv    : fv;      nfv    : fv;
719      ncatchv: fv;      ncatchv: fv;
720      na     : Types.descr;      na     : Types.descr;
721      nbasic : Types.descr nline;      nbasic : Types.descr nline;
722      nprod  : (nf * nf) nline;      nprod  : (nnf * nnf) nline;
723      nxml   : (nf * nf) nline;      nxml   : (nnf * nnf) nline;
724      nrecord: record nline      nrecord: record nline
725    }    }
726    
# Line 870  Line 870 
870        | Constant (x,c) -> constant x c        | Constant (x,c) -> constant x c
871        | Record (l,p) -> record acc l p        | Record (l,p) -> record acc l p
872    
873    let bigcap = List.fold_left (fun a p -> cap a (nf (descr p))) any    let bigcap pl = pl (* List.fold_left (fun a p -> cap a (nf (descr p))) any *)
874    
875    let normal nf =    let normal nf =
876      let basic =      let basic =
# Line 878  Line 878 
878    
879      and prod ?kind l =      and prod ?kind l =
880        let line accu (((res,(pl,ql)),acc)) =        let line accu (((res,(pl,ql)),acc)) =
881          let p = bigcap pl and q = bigcap ql in          let aux accu (t1,t2) = (res,( (t1,pl), (t2,ql) ))::accu in
         let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in  
882          let t = Types.Product.normal ?kind acc in          let t = Types.Product.normal ?kind acc in
883          List.fold_left aux accu t in          List.fold_left aux accu t in
884        List.fold_left line [] l        List.fold_left line [] l
# Line 891  Line 890 
890            | (`Success, []) -> `Success            | (`Success, []) -> `Success
891            | (`Fail,_) -> `Fail            | (`Fail,_) -> `Fail
892            | (`Success, (l2,pl)::fields) ->            | (`Success, (l2,pl)::fields) ->
893                `Label (l2, [bigcap pl, aux nr fields], `Fail)                `Label (l2, [(Types.any,pl), aux nr fields], `Fail)
894            | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->            | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
895                `Label (l2, [bigcap pl, aux nr fields], `Fail)                `Label (l2, [(Types.any,pl), aux nr fields], `Fail)
896            | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->            | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
               let p = bigcap pl in  
897                let pr =                let pr =
898                  List.map (fun (t,x) -> (restrict t p, aux x fields)) pr in                  List.map (fun (t,x) -> ((t,pl), aux x fields)) pr in
899                `Label (l1, pr, `Fail)                `Label (l1, pr, `Fail)
900            | (`Label (l1, pr, ab),_) ->            | (`Label (l1, pr, ab),_) ->
901                let aux_ab = aux ab fields in                let aux_ab = aux ab fields in
902                let pr =                let pr =
903                  List.map (fun (t,x) -> (constr t,                  List.map (fun (t,x) -> ((t,[]),
904  (* Types.Record.normal enforce physical equility  (* Types.Record.normal enforce physical equility
905     in case of a ? field *)     in case of a ? field *)
906                                          if x==ab then aux_ab else                                          if x==ab then aux_ab else
# Line 1197  Line 1195 
1195      let unselect = Array.create (Array.length pl) [] in      let unselect = Array.create (Array.length pl) [] in
1196      let aux i x =      let aux i x =
1197        let yes, no = f x in        let yes, no = f x in
1198        List.iter (fun (p,info) ->        List.iter (fun ( (ty,pl), info) ->
1199                       let p =
1200                         List.fold_left (fun a p -> Normal.cap a
1201                                           (Normal.nf (descr p)))
1202                           (Normal.constr ty) pl in
1203    
1204                     let p = Normal.restrict t p in                     let p = Normal.restrict t p in
1205                     let p = Normal.normal p in                     let p = Normal.normal p in
1206                     accu := (p,[i, info]) :: !accu;                     accu := (p,[i, p.Normal.ncatchv, info]) :: !accu;
1207                  ) yes;                  ) yes;
1208        unselect.(i) <- no @ unselect.(i) in        unselect.(i) <- no @ unselect.(i) in
1209      Array.iteri (fun i -> List.iter (aux i)) pl;      Array.iteri (fun i -> List.iter (aux i)) pl;
# Line 1210  Line 1213 
1213      let disp = dispatcher t (Array.map fst sorted) in      let disp = dispatcher t (Array.map fst sorted) in
1214      let result (t,_,m) =      let result (t,_,m) =
1215        let selected = Array.create (Array.length pl) [] in        let selected = Array.create (Array.length pl) [] in
1216        let add r (i,inf) = selected.(i) <- (r,inf) :: selected.(i) in        let add r (i, ncv, inf) = selected.(i) <- (r,ncv,inf) :: selected.(i) in
1217        List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;        List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
1218        d t selected unselect        d t selected unselect
1219      in      in
# Line 1222  Line 1225 
1225      let (_,brs) =      let (_,brs) =
1226        List.fold_left        List.fold_left
1227          (fun (t,brs) (p,e) ->          (fun (t,brs) (p,e) ->
1228             let p = Normal.restrict t (Normal.nf p) in             let p' = (t,[p]) in
1229             let t = Types.diff t (p.Normal.a) in             let t' = Types.diff t (Types.descr (accept p)) in
1230             (t, (p,(p.Normal.catchv,e)) :: brs)             (t', (p',e) :: brs)
1231          ) (t,[]) brs in          ) (t,[]) brs in
1232    
1233      let pl = Array.map (fun x -> [x]) (Array.of_list brs) in      let pl = Array.map (fun x -> [x]) (Array.of_list brs) in
# Line 1235  Line 1238 
1238        (fun _ pl _ ->        (fun _ pl _ ->
1239           let r = ref None in           let r = ref None in
1240           let aux = function           let aux = function
1241             | [(res,(catchv,e))] -> assert (!r = None);             | [(res,catchv,e)] -> assert (!r = None);
1242                 let catchv = List.map (fun v -> (v,-1)) catchv in                 let catchv = List.map (fun v -> (v,-1)) catchv in
1243                 r := Some (SortedMap.union_disj catchv res,e)                 r := Some (SortedMap.union_disj catchv res,e)
1244             | [] -> () | _ -> assert false in             | [] -> () | _ -> assert false in
# Line 1261  Line 1264 
1264    and dispatch_prod1 disp t t1 pl _ =    and dispatch_prod1 disp t t1 pl _ =
1265      let t = Types.Product.restrict_1 t t1 in      let t = Types.Product.restrict_1 t t1 in
1266      get_tests pl      get_tests pl
1267        (fun (ret1, (res,q)) -> [q, (ret1,res)], [] )        (fun (ret1, ncatchv, (res,q)) -> [q, (ret1,res)], [] )
1268        (Types.Product.pi2 t)        (Types.Product.pi2 t)
1269        (dispatch_prod2 disp t)        (dispatch_prod2 disp t)
1270        (fun x -> detect_right_tail_call (combine x))        (fun x -> detect_right_tail_call (combine x))
1271    and dispatch_prod2 disp t t2 pl _ =    and dispatch_prod2 disp t t2 pl _ =
1272      let aux_final (ret2, (ret1, res)) =      let aux_final (ret2, ncatchv, (ret1, res)) =
1273        List.map (conv_source_prod ret1 ret2) res in        List.map (conv_source_prod ret1 ret2) res in
1274      return disp pl aux_final      return disp pl aux_final
1275    
# Line 1386  Line 1389 
1389            combine_record l present absent            combine_record l present absent
1390    and dispatch_record_field l disp t plabs tfield pl others =    and dispatch_record_field l disp t plabs tfield pl others =
1391      let t = Types.Record.restrict_field t l tfield in      let t = Types.Record.restrict_field t l tfield in
1392      let aux (ret, (res, catch, rem)) =      let aux (ret, ncatchv, (res, catch, rem)) =
1393        let catch = if ret = [] then catch else (l,ret) :: catch in        let catch = if ret = [] then catch else (l,ret) :: catch in
1394        (res, catch, rem) in        (res, catch, rem) in
1395      let pl = Array.map (List.map aux) pl in      let pl = Array.map (List.map aux) pl in
Legend:
Removed from v.147  
changed lines
  Added in v.148
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5