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

Diff of /types/patterns.ml

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

revision 171 by abate, Tue Jul 10 17:12:10 2007 UTC revision 172 by abate, Tue Jul 10 17:12:31 2007 UTC
# Line 689  Line 689 
689    type ('a,'b) sm = ('a,'b) SortedMap.t    type ('a,'b) sm = ('a,'b) SortedMap.t
690    
691    type source =    type source =
692        [ `Catch | `Const of Types.const      | SCatch | SConst of Types.const
693        | `Left | `Right | `Recompose      | SLeft | SRight | SRecompose
694        | `Field of Types.label      | SField of Types.label
       ]  
695    type result = (capture, source) sm    type result = (capture, source) sm
696    
697    type nnf = node sl * Types.descr    type nnf = node sl * Types.descr
# Line 718  Line 717 
717    val normal: Types.descr -> node list -> t    val normal: Types.descr -> node list -> t
718  end =  end =
719  struct  struct
720      let any_basic = Types.neg (List.fold_left Types.cup Types.empty
721                                   [Types.Product.any_xml;
722                                    Types.Product.any;
723                                    Types.Record.any])
724    
725    
726    type 'a sl = 'a SortedList.t    type 'a sl = 'a SortedList.t
727    type ('a,'b) sm = ('a,'b) SortedMap.t    type ('a,'b) sm = ('a,'b) SortedMap.t
728    
729    type source =    type source =
730        [ `Catch | `Const of Types.const      | SCatch | SConst of Types.const
731        | `Left | `Right | `Recompose      | SLeft | SRight | SRecompose
732        | `Field of Types.label      | SField of Types.label
       ]  
733    type result = (capture, source) sm    type result = (capture, source) sm
734    
735    type 'a line = (result * 'a, Types.descr) sm    type 'a line = (result * 'a, Types.descr) sm
# Line 759  Line 763 
763      nrecord: record nline      nrecord: record nline
764    }    }
765    
766      let rec print_record ppf = function
767        | `Success -> Format.fprintf ppf "Success"
768        | `SomeField -> Format.fprintf ppf "SomeField"
769        | `NoField -> Format.fprintf ppf "NoField"
770        | `Fail -> Format.fprintf ppf "Fail"
771        | `Dispatch _ -> Format.fprintf ppf "Dispatch"
772        | `Label (l,pr,ab) ->
773            Format.fprintf ppf "Label(%s@[" (Types.LabelPool.value l);
774            List.iter (fun (_,r) -> Format.fprintf ppf ",%a" print_record r) pr;
775            Format.fprintf ppf ",%a@])" print_record ab
776    
777    let fus = SortedMap.union_disj    let fus = SortedMap.union_disj
778    let slcup = SortedList.cup    let slcup = SortedList.cup
779  (*  
780    let nempty = { nfv = []; ncatchv = []; na = Types.empty;    let nempty = { nfv = []; ncatchv = []; na = Types.empty;
781                   nbasic = []; nprod = []; nxml = []; nrecord = [] }                   nbasic = []; nprod = []; nxml = []; nrecord = [] }
782    
# Line 802  Line 817 
817        if Types.is_empty t then accu else        if Types.is_empty t then accu else
818          (fus res1 res2, t) :: accu          (fus res1 res2, t) :: accu
819      in      in
820        let record accu (res1,rec1) (res2,rec2) =
821          let rec aux extra1 rec1 extra2 rec2 =
822            let rec1 =
823              if extra1 then
824                match rec1 with
825                  | `SomeField -> `Success
826                  | `NoField -> `Fail
827                  | x -> x
828              else rec1
829            and rec2 =
830              if extra2 then
831                match rec2 with
832                  | `SomeField -> `Success
833                  | `NoField -> `Fail
834                  | x -> x
835              else rec2
836            in
837            match (rec1,rec2) with
838            | `Success, r | r, `Success -> r
839            | `Fail, _ | _, `Fail -> `Fail
840    
841            | `SomeField, `Label (l, pr, ab) ->
842                (match aux false `SomeField extra2 ab with
843                   | `Fail when pr = [] -> `Fail
844                   | ab -> `Label (l, pr, ab))
845            | `Label (l, pr, ab), `SomeField ->
846                (match aux false `SomeField extra1 ab with
847                   | `Fail when pr = [] -> `Fail
848                   | ab -> `Label (l, pr, ab))
849    
850            | `NoField, `Label (l,pr,ab) ->
851                (match aux false `NoField extra2 ab with
852                   | `Fail -> `Fail
853                   | ab -> `Label (l, [], ab))
854    
855            | `Label (l, pr, ab), `NoField ->
856                (match aux false `NoField extra1 ab with
857                   | `Fail -> `Fail
858                   | ab -> `Label (l, [], ab))
859    
860            | `SomeField, `NoField | `NoField,`SomeField ->
861                `Fail
862            | `NoField, `NoField -> `NoField
863            | `SomeField, `SomeField -> `SomeField
864            | `Label (l1,pr1,ab1), `Label (l2,pr2,ab2) ->
865    (*TODO: eliminate `Fail *)
866                if (l1 < l2) then
867                  `Label (l1,
868                          List.map (fun (d,r) -> (d, aux extra1 r true rec2)) pr1,
869                          aux extra1 ab1 extra2 rec2)
870                else if (l2 < l1) then
871                  `Label (l2,
872                          List.map (fun (d,r) -> (d, aux extra2 r true rec1)) pr2,
873                          aux extra2 ab2 extra1 rec1)
874                else
875                  let pr =
876                    double_fold
877                      (fun accu ((d1,t1),r1) ((d2,t2),r2) ->
878                         let r = aux extra1 r1 extra2 r2 in
879                         match r with
880                           | `Fail -> accu
881                           | x -> ((slcup d1 d2, Types.cap t1 t2),x)::accu)
882                      pr1 pr2 in
883                  `Label (l1, pr, aux extra1 ab1 extra2 ab2)
884            | `Dispatch _, _ | _, `Dispatch _ -> assert false in
885          let res = aux false rec1 false rec2 in
886    (*      Format.fprintf Format.std_formatter
887            "ncap; @\nrecord1=%a; @\nrecord2=%a;@\n result=%a@\n"
888            print_record rec1
889            print_record rec2
890            print_record res; *)
891          match res with
892            | `Fail -> accu
893            | r -> (fus res1 res2, r) :: accu
894        in
895      { nfv = SortedList.cup nf1.nfv nf2.nfv;      { nfv = SortedList.cup nf1.nfv nf2.nfv;
896        ncatchv = SortedList.cup nf1.ncatchv nf2.ncatchv;        ncatchv = SortedList.cup nf1.ncatchv nf2.ncatchv;
897        na = Types.cap nf1.na nf2.na;        na = Types.cap nf1.na nf2.na;
898        nbasic = double_fold basic nf1.nbasic nf2.nbasic;        nbasic = double_fold basic nf1.nbasic nf2.nbasic;
899        nprod = double_fold prod nf1.nprod nf2.nprod;        nprod = double_fold prod nf1.nprod nf2.nprod;
900        nxml = double_fold prod nf1.nxml nf2.nxml;        nxml = double_fold prod nf1.nxml nf2.nxml;
901        nrecord = []; (* TODO ... *)        nrecord = double_fold record nf1.nrecord nf2.nrecord;
902      }      }
903    
904      let nnode p = [p], Types.descr p.accept
905    
906    let ntimes acc p q =    let ntimes acc p q =
907      let src_p = List.map (fun v -> (v,`Left)) p.fv      let src_p = List.map (fun v -> (v,SLeft)) p.fv
908      and src_q = List.map (fun v -> (v,`Right)) q.fv in      and src_q = List.map (fun v -> (v,SRight)) q.fv in
909      let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in      let src = SortedMap.union (fun _ _ -> SRecompose) src_p src_q in
910      let rects = Types.Product.normal acc in  (*    let rects = Types.Product.normal acc in
911      let prod = List.map (fun (t1,t2) -> (src, (([p],t1),([q],t2)))) rects in      let prod = List.map (fun (t1,t2) -> (src, (([p],t1),([q],t2)))) rects in
912    *)
913      { nempty with      { nempty with
914          nfv = SortedList.cup p.fv q.fv;          nfv = SortedList.cup p.fv q.fv;
915          na = acc;          na = acc;
916          nprod = SortedList.from_list prod          nprod = [ (src, (nnode p, nnode q)) ];
917        }
918    
919      let nxml acc p q =
920        let src_p = List.map (fun v -> (v,SLeft)) p.fv
921        and src_q = List.map (fun v -> (v,SRight)) q.fv in
922        let src = SortedMap.union (fun _ _ -> SRecompose) src_p src_q in
923        { nempty with
924            nfv = SortedList.cup p.fv q.fv;
925            na = acc;
926            nxml =  [ (src, (nnode p, nnode q)) ];
927      }      }
 *)  
928    
929      let nrecord acc l p =
930        let src = List.map (fun v -> (v, SField l)) p.fv in
931        let r = Types.Record.normal acc in
932        { nempty with
933            nfv = p.fv;
934            na = acc;
935            nrecord = [ src, `Label (l,[nnode p, `Success],`Fail) ] }
936    
937      let nconstr t =
938        let rec aux_record = function
939          | `Success -> `Success
940          | `Fail -> `Fail
941          | `NoField -> `NoField
942          | `SomeField -> `SomeField
943          | `Label (l, pr, ab) ->
944              `Label (l,
945                      List.map (fun (t,r) -> ([],t), aux_record r) pr,
946                      aux_record ab) in
947        { nempty with
948            na = t;
949            nbasic = [ [], Types.cap t any_basic ];
950            nprod =
951              List.map
952                (fun (t1,t2) -> [], (([],t1),([],t2)))
953                (Types.Product.normal t);
954            nxml=
955              List.map
956                (fun (t1,t2) -> [], (([],t1),([],t2)))
957                (Types.Product.normal ~kind:`XML t);
958            nrecord = [ [], aux_record (Types.Record.normal t) ]
959        }
960    
961      let nconstant x c =
962        let l = [x,SConst c] in
963        { nfv = [x];
964          ncatchv = [];
965          na = Types.any;
966          nbasic = [ (l,any_basic) ];
967          nprod  = [ (l,(([], Types.any),([], Types.any))) ];
968          nxml   = [ (l,(([], Types.any),([], Types.any))) ];
969          nrecord = [ (l,`Success) ];
970        }
971    
972      let ncapture x =
973        let l = [x,SCatch] in
974        { nfv = [x];
975          ncatchv = [x];
976          na = Types.any;
977          nbasic = [ (l,any_basic) ];
978          nprod  = [ (l,(([], Types.any),([], Types.any))) ];
979          nxml   = [ (l,(([], Types.any),([], Types.any))) ];
980          nrecord = [ (l,`Success) ];
981        }
982    
983      let rec nnormal (acc,fv,d) =
984        if Types.is_empty acc
985        then nempty
986        else match d with
987          | Constr t -> nconstr t
988          | Cap (p,q) -> ncap (nnormal p) (nnormal q)
989          | Cup ((acc1,_,_) as p,q) ->
990              ncup (nnormal p) (ncap (nnormal q) (nconstr (Types.neg acc1)))
991          | Times (p,q) -> ntimes acc p q
992          | Xml (p,q) -> nxml acc p q
993          | Capture x -> ncapture x
994          | Constant (x,c) -> nconstant x c
995          | Record (l,p) -> nrecord acc l p
996    
997      let remove_catchv n =
998        let ncv = n.ncatchv in
999        let nlines l =
1000          let l = List.map (fun (res,x) -> (SortedMap.diff res ncv,x)) l in
1001    (*       let l = SortedList.from_list l in (* Can get rid of it ? *) *)
1002          l in
1003        { nfv     = SortedList.diff n.nfv ncv;
1004          ncatchv = n.ncatchv;
1005          na      = n.na;
1006          nbasic  = nlines n.nbasic;
1007          nprod   = nlines n.nprod;
1008          nxml    = nlines n.nxml;
1009          nrecord = nlines n.nrecord;
1010        }
1011    
1012      let normal t pl =
1013        remove_catchv
1014          (List.fold_left (fun a p -> ncap a (nnormal (descr p))) (nconstr t) pl)
1015    
1016    (*
1017    let empty = { v = []; catchv = [];    let empty = { v = []; catchv = [];
1018                  a = Types.empty;                  a = Types.empty;
1019                  basic = []; prod = []; xml = []; record = [] }                  basic = []; prod = []; xml = []; record = [] }
   let any_basic = Types.neg (List.fold_left Types.cup Types.empty  
                                [Types.Product.any_xml;  
                                 Types.Product.any;  
                                 Types.Record.any])  
1020    let restrict t nf =    let restrict t nf =
1021      let rec filter = function      let rec filter = function
1022        | (key,acc) :: rem ->        | (key,acc) :: rem ->
# Line 889  Line 1074 
1074      }      }
1075    
1076    let times acc p q =    let times acc p q =
1077      let src_p = List.map (fun v -> (v,`Left)) p.fv      let src_p = List.map (fun v -> (v,SLeft)) p.fv
1078      and src_q = List.map (fun v -> (v,`Right)) q.fv in      and src_q = List.map (fun v -> (v,SRight)) q.fv in
1079      let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in      let src = SortedMap.union (fun _ _ -> SRecompose) src_p src_q in
1080      { empty with      { empty with
1081          v = SortedList.cup p.fv q.fv;          v = SortedList.cup p.fv q.fv;
1082          a = acc;          a = acc;
1083          prod = [ (src, ([p], [q])), acc ] }          prod = [ (src, ([p], [q])), acc ] }
1084    
1085    let xml acc p q =    let xml acc p q =
1086      let src_p = List.map (fun v -> (v,`Left)) p.fv      let src_p = List.map (fun v -> (v,SLeft)) p.fv
1087      and src_q = List.map (fun v -> (v,`Right)) q.fv in      and src_q = List.map (fun v -> (v,SRight)) q.fv in
1088      let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in      let src = SortedMap.union (fun _ _ -> SRecompose) src_p src_q in
1089      { empty with      { empty with
1090          v = SortedList.cup p.fv q.fv;          v = SortedList.cup p.fv q.fv;
1091          a = acc;          a = acc;
1092          xml = [ (src, ([p], [q])), acc ] }          xml = [ (src, ([p], [q])), acc ] }
1093    
1094    let record acc l p =    let record acc l p =
1095      let src = List.map (fun v -> (v, `Field l)) p.fv in      let src = List.map (fun v -> (v, SField l)) p.fv in
1096      { empty with      { empty with
1097          v = p.fv;          v = p.fv;
1098          a = acc;          a = acc;
# Line 924  Line 1109 
1109      }      }
1110    
1111    let capture x =    let capture x =
1112      let l = [x,`Catch] in      let l = [x,SCatch] in
1113      { v = [x];      { v = [x];
1114        catchv = [x];        catchv = [x];
1115        a = Types.any;        a = Types.any;
# Line 935  Line 1120 
1120      }      }
1121    
1122    let constant x c =    let constant x c =
1123      let l = [x,`Const c] in      let l = [x,SConst c] in
1124      { v = [x];      { v = [x];
1125        catchv = [];        catchv = [];
1126        a = Types.any;        a = Types.any;
# Line 991  Line 1176 
1176            | ((`Success|`SomeField), (l2,pl)::fields) ->            | ((`Success|`SomeField), (l2,pl)::fields) ->
1177                `Label (l2, [(pl,Types.any), aux `Success fields], `Fail)                `Label (l2, [(pl,Types.any), aux `Success fields], `Fail)
1178            | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->            | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
1179                  assert false
1180                `Label (l2, [(pl,Types.any), aux nr fields], `Fail)                `Label (l2, [(pl,Types.any), aux nr fields], `Fail)
1181    (* Errr... here, should remember that SomeOtherField has been seen, no ?
1182       Actually, case cannot happen, I guess *)
1183    
1184            | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->            | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
1185                let pr =                let pr =
1186                  List.map (fun (t,x) -> (((pl,t) : nnf), aux x fields)) pr in                  List.map (fun (t,x) -> (((pl,t) : nnf), aux x fields)) pr in
# Line 1016  Line 1205 
1205        List.fold_left line []        List.fold_left line []
1206      in      in
1207      let nlines l =      let nlines l =
1208        List.map (fun (res,x) -> (SortedMap.diff res nf.catchv,x)) l in        let l = List.map (fun (res,x) -> (SortedMap.diff res nf.catchv,x)) l in
1209    (*       let l = SortedList.from_list l in (* Can get rid of it ? *) *)
1210          l in
1211      { nfv     = SortedList.diff nf.v nf.catchv;      { nfv     = SortedList.diff nf.v nf.catchv;
1212        ncatchv = nf.catchv;        ncatchv = nf.catchv;
1213        na      = nf.a;        na      = nf.a;
# Line 1028  Line 1219 
1219    
1220    let normal t pl =    let normal t pl =
1221      normal (List.fold_left (fun a p -> cap a (nf (descr p))) (constr t) pl)      normal (List.fold_left (fun a p -> cap a (nf (descr p))) (constr t) pl)
1222        *)
1223  end  end
1224    
1225    
1226  module Compile =  module Compile =
1227  struct  struct
1228    type actions =    type actions =
1229        [ `Ignore of result      | AIgnore of result
1230        | `Kind of actions_kind ]      | AKind of actions_kind
1231    and actions_kind = {    and actions_kind = {
1232      basic: (Types.descr * result) list;      basic: (Types.descr * result) list;
1233      prod: result dispatch dispatch;      prod: result dispatch dispatch;
# Line 1049  Line 1240 
1240        | `Result_other of Types.label list * result * result ]        | `Result_other of Types.label list * result * result ]
1241    
1242    and 'a dispatch =    and 'a dispatch =
1243        [ `Dispatch of dispatcher * 'a array      | Dispatch of dispatcher * 'a array
1244        | `TailCall of dispatcher      | TailCall of dispatcher
1245        | `Ignore of 'a      | Ignore of 'a
1246        | `None ]      | Impossible
1247    
1248    and result = int * source array    and result = int * source array
1249    and source =    and source =
1250        [ `Catch | `Const of Types.const      | Catch | Const of Types.const
1251        | `Left of int | `Right of int | `Recompose of int * int      | Left of int | Right of int | Recompose of int * int
1252        | `Field of Types.label * int      | Field of Types.label * int
       ]  
1253    
1254    and return_code =    and return_code =
1255        Types.descr * int *   (* accepted type, arity *)        Types.descr * int *   (* accepted type, arity *)
# Line 1101  Line 1291 
1291          | [] -> rs          | [] -> rs
1292          | _ -> raise Exit in          | _ -> raise Exit in
1293        let rs = match prod with        let rs = match prod with
1294          | `None -> rs          | Impossible -> rs
1295          | `Ignore (`Ignore r) -> r :: rs          | Ignore (Ignore r) -> r :: rs
1296          | _ -> raise Exit in          | _ -> raise Exit in
1297        let rs = match xml with        let rs = match xml with
1298          | `None -> rs          | Impossible -> rs
1299          | `Ignore (`Ignore r) -> r :: rs          | Ignore (Ignore r) -> r :: rs
1300          | _ -> raise Exit in          | _ -> raise Exit in
1301        let rs = match record with        let rs = match record with
1302          | None -> rs          | None -> rs
# Line 1116  Line 1306 
1306          | ((_, ret) as r) :: rs when          | ((_, ret) as r) :: rs when
1307              List.for_all ( (=) r ) rs              List.for_all ( (=) r ) rs
1308              && array_for_all              && array_for_all
1309                (function `Catch | `Const _ -> true | _ -> false) ret                (function Catch | Const _ -> true | _ -> false) ret
1310              -> `Ignore r              -> AIgnore r
1311          | _ -> raise Exit          | _ -> raise Exit
1312      )      )
1313      with Exit -> `Kind { basic = basic; prod = prod; xml = xml; record = record }      with Exit -> AKind { basic = basic; prod = prod; xml = xml; record = record }
1314    
1315    let combine (disp,act) =    let combine (disp,act) =
1316      if Array.length act = 0 then `None      if Array.length act = 0 then Impossible
1317      else      else
1318        if (array_for_all (fun (_,ar,_) -> ar = 0) disp.codes)        if (array_for_all (fun (_,ar,_) -> ar = 0) disp.codes)
1319           && (array_for_all ( (=) act.(0) ) act) then           && (array_for_all ( (=) act.(0) ) act) then
1320             `Ignore act.(0)             Ignore act.(0)
1321        else        else
1322          `Dispatch (disp, act)          Dispatch (disp, act)
1323    
1324    let combine_record l present absent =    let combine_record l present absent =
1325      match (present,absent) with      match (present,absent) with
1326        | (`Ignore r1, Some r2) when r1 = r2 -> r1        | (Ignore r1, Some r2) when r1 = r2 -> r1
1327  (*      | (`Ignore r, None) -> r  *)  (*      | (`Ignore r, None) -> r  *)
1328  (* Could allow this when r has no `Result_other ... *)  (* Could allow this when r has no `Result_other ... *)
1329  (* Otherwise:  (* Otherwise:
# Line 1143  Line 1333 
1333   | Record ->   | Record ->
1334       [x ]SomeField:$0;NoField:$1       [x ]SomeField:$0;NoField:$1
1335  *)  *)
1336        | (`None, Some r) -> r        | (Impossible, Some r) -> r
1337        | _ -> `Label (l, present, absent)        | _ -> `Label (l, present, absent)
1338    
1339    let detect_right_tail_call = function    let detect_right_tail_call = function
1340      | `Dispatch (disp,branches)      | Dispatch (disp,branches)
1341          when          when
1342            array_for_all_i            array_for_all_i
1343              (fun i (code,ret) ->              (fun i (code,ret) ->
1344                 (i = code) &&                 (i = code) &&
1345                 (array_for_all_i                 (array_for_all_i
1346                    (fun pos ->                    (fun pos ->
1347                       function `Right j when pos = j -> true | _ -> false)                       function Right j when pos = j -> true | _ -> false)
1348                    ret                    ret
1349                 )                 )
1350              ) branches              ) branches
1351            -> `TailCall disp            -> TailCall disp
1352      | x -> x      | x -> x
1353    
1354    let detect_left_tail_call = function    let detect_left_tail_call = function
1355      | `Dispatch (disp,branches)      | Dispatch (disp,branches)
1356          when          when
1357            array_for_all_i            array_for_all_i
1358              (fun i ->              (fun i ->
1359                 function                 function
1360                   | `Ignore (code,ret) ->                   | Ignore (code,ret) ->
1361                       (i = code) &&                       (i = code) &&
1362                       (array_for_all_i                       (array_for_all_i
1363                          (fun pos ->                          (fun pos ->
1364                             function `Left j when pos = j -> true | _ -> false)                             function Left j when pos = j -> true | _ -> false)
1365                          ret                          ret
1366                 )                 )
1367                   | _ -> false                   | _ -> false
1368              ) branches              ) branches
1369            ->            ->
1370           `TailCall disp           TailCall disp
1371      | x -> x      | x -> x
1372    
1373    let cur_id = State.ref "Patterns.cur_id" 0    let cur_id = State.ref "Patterns.cur_id" 0
# Line 1247  Line 1437 
1437      (find_code disp final, create_result final)      (find_code disp final, create_result final)
1438    
1439    let conv_source_basic (v,s) = match s with    let conv_source_basic (v,s) = match s with
1440      | (`Catch | `Const _) as x -> x      | Normal.SCatch -> Catch
1441        | Normal.SConst c -> Const c
1442      | _ -> assert false      | _ -> assert false
1443    
1444    let assoc v l =    let assoc v l =
1445      try List.assoc v l with Not_found -> -1      try List.assoc v l with Not_found -> -1
1446    
1447    let conv_source_prod left right (v,s) = match s with    let conv_source_prod left right (v,s) = match s with
1448      | (`Catch | `Const _) as x -> x      | Normal.SCatch -> Catch
1449      | `Left -> `Left (assoc v left)      | Normal.SConst c -> Const c
1450      | `Right -> `Right (assoc v right)      | Normal.SLeft -> Left (assoc v left)
1451      | `Recompose -> `Recompose (assoc v left, assoc v right)      | Normal.SRight -> Right (assoc v right)
1452        | Normal.SRecompose -> Recompose (assoc v left, assoc v right)
1453      | _ -> assert false      | _ -> assert false
1454    
1455    let conv_source_record catch (v,s) = match s with    let conv_source_record catch (v,s) = match s with
1456      | (`Catch | `Const _) as x -> x      | Normal.SCatch -> Catch
1457      | `Field l -> `Field (l, try assoc v (List.assoc l catch) with Not_found -> -1)      | Normal.SConst c -> Const c
1458        | Normal.SField l ->
1459            Field (l, try assoc v (List.assoc l catch) with Not_found -> -1)
1460      | _ -> assert false      | _ -> assert false
1461    
1462    
# Line 1378  Line 1572 
1572    let collect_first_label pl =    let collect_first_label pl =
1573      let f = ref true and m = ref dummy_label in      let f = ref true and m = ref dummy_label in
1574      let aux = function      let aux = function
1575        | (res, _, `Label (l, _, _)) -> if (l < !m) then m:= l;        | (_, _, `Label (l, _, _)) -> if (l < !m) then m:= l;
1576        | _ -> () in        | _ -> () in
1577      Array.iter (List.iter aux) pl;      Array.iter (List.iter aux) pl;
1578      if !m = dummy_label then None else Some !m      if !m = dummy_label then None else Some !m
# Line 1495  Line 1689 
1689              let labs = l :: labs in              let labs = l :: labs in
1690              let pl = label_found l pl in              let pl = label_found l pl in
1691              let t = Types.Record.restrict_label_present t l in              let t = Types.Record.restrict_label_present t l in
1692              if Types.Record.is_empty t then `None else              if Types.Record.is_empty t then Impossible else
1693                get_tests pl                get_tests pl
1694                  (function                  (function
1695                     | (res,catch, `Dispatch d) ->                     | (res,catch, `Dispatch d) ->
# Line 1550  Line 1744 
1744      )      )
1745    
1746    let rec print_source ppf = function    let rec print_source ppf = function
1747      | `Catch  -> Format.fprintf ppf "v"      | Catch  -> Format.fprintf ppf "v"
1748      | `Const c -> Types.Print.print_const ppf c      | Const c -> Types.Print.print_const ppf c
1749      | `Left (-1) -> Format.fprintf ppf "v1"      | Left (-1) -> Format.fprintf ppf "v1"
1750      | `Right (-1) -> Format.fprintf ppf "v2"      | Right (-1) -> Format.fprintf ppf "v2"
1751      | `Field (l,-1) -> Format.fprintf ppf "v%s" (Types.LabelPool.value l)      | Field (l,-1) -> Format.fprintf ppf "v%s" (Types.LabelPool.value l)
1752      | `Left i -> Format.fprintf ppf "l%i" i      | Left i -> Format.fprintf ppf "l%i" i
1753      | `Right j -> Format.fprintf ppf "r%i" j      | Right j -> Format.fprintf ppf "r%i" j
1754      | `Recompose (i,j) ->      | Recompose (i,j) ->
1755          Format.fprintf ppf "(%a,%a)"          Format.fprintf ppf "(%a,%a)"
1756            print_source (`Left i)            print_source (Left i)
1757            print_source (`Right j)            print_source (Right j)
1758      | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.LabelPool.value l) i      | Field (l,i) -> Format.fprintf ppf "%s%i" (Types.LabelPool.value l) i
1759    
1760    let print_result ppf =    let print_result ppf =
1761      Array.iteri      Array.iteri
# Line 1590  Line 1784 
1784          print_ret ret          print_ret ret
1785      in      in
1786      let print_prod2 = function      let print_prod2 = function
1787        | `None -> assert false        | Impossible -> assert false
1788        | `Ignore r ->        | Ignore r ->
1789            Format.fprintf ppf "        %a\n"            Format.fprintf ppf "        %a\n"
1790              print_ret r              print_ret r
1791        | `TailCall d ->        | TailCall d ->
1792            queue d;            queue d;
1793            Format.fprintf ppf "        disp_%i v2@\n" d.id            Format.fprintf ppf "        disp_%i v2@\n" d.id
1794        | `Dispatch (d, branches) ->        | Dispatch (d, branches) ->
1795            queue d;            queue d;
1796            Format.fprintf ppf "        match v2 with disp_%i@\n" d.id;            Format.fprintf ppf "        match v2 with disp_%i@\n" d.id;
1797            Array.iteri            Array.iteri
# Line 1609  Line 1803 
1803              branches              branches
1804      in      in
1805      let print_prod prefix = function      let print_prod prefix = function
1806        | `None -> ()        | Impossible -> ()
1807        | `Ignore d2 ->        | Ignore d2 ->
1808            Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;            Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
1809            print_prod2 d2            print_prod2 d2
1810        | `TailCall d ->        | TailCall d ->
1811            queue d;            queue d;
1812            Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;            Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
1813            Format.fprintf ppf "      disp_%i v1@\n" d.id            Format.fprintf ppf "      disp_%i v1@\n" d.id
1814        | `Dispatch (d,branches) ->        | Dispatch (d,branches) ->
1815            queue d;            queue d;
1816            Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;            Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
1817            Format.fprintf ppf "      match v1 with disp_%i@\n" d.id;            Format.fprintf ppf "      match v1 with disp_%i@\n" d.id;
# Line 1654  Line 1848 
1848                     print_record r                     print_record r
1849              | None -> ()              | None -> ()
1850      and print_present l ppf = function      and print_present l ppf = function
1851        | `None ->        | Impossible ->
1852            Format.fprintf ppf "(cannot happen)"            assert false
1853            (* assert false *)        | TailCall d ->
       | `TailCall d ->  
1854            queue d;            queue d;
1855            Format.fprintf ppf "disp_%i@\n" d.id            Format.fprintf ppf "disp_%i@\n" d.id
1856        | `Dispatch (d,branches) ->        | Dispatch (d,branches) ->
1857            queue d;            queue d;
1858            Format.fprintf ppf "match with disp_%i@\n" d.id;            Format.fprintf ppf "match with disp_%i@\n" d.id;
1859            Array.iteri            Array.iteri
# Line 1670  Line 1863 
1863                 Format.fprintf ppf "   @[%a@]@\n"                 Format.fprintf ppf "   @[%a@]@\n"
1864                   print_record r                   print_record r
1865              ) branches              ) branches
1866        | `Ignore r ->        | Ignore r ->
1867            Format.fprintf ppf "@[%a@]@\n"            Format.fprintf ppf "@[%a@]@\n"
1868              print_record r              print_record r
1869      in      in
# Line 1681  Line 1874 
1874      print_record_opt ppf actions.record      print_record_opt ppf actions.record
1875    
1876    let print_actions ppf = function    let print_actions ppf = function
1877      | `Kind k -> print_kind ppf k      | AKind k -> print_kind ppf k
1878      | `Ignore r -> Format.fprintf ppf "v -> %a@\n" print_ret r      | AIgnore r -> Format.fprintf ppf "v -> %a@\n" print_ret r
1879    
1880    let rec print_dispatchers ppf =    let rec print_dispatchers ppf =
1881      match !to_print with      match !to_print with
# Line 1722  Line 1915 
1915      let pl = Array.of_list      let pl = Array.of_list
1916                 (List.map (fun p -> Normal.normal Types.any [p]) pl) in                 (List.map (fun p -> Normal.normal Types.any [p]) pl) in
1917      let t = Types.descr t in      let t = Types.descr t in
1918      show ppf t pl      show ppf t pl;
1919        Format.fprintf ppf "# compiled dispatchers: %i@\n" !cur_id
1920  end  end
1921    
1922    
Legend:
Removed from v.171  
changed lines
  Added in v.172
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5