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

Diff of /types/patterns.ml

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

revision 164 by abate, Tue Jul 10 17:11:46 2007 UTC revision 165 by abate, Tue Jul 10 17:11:58 2007 UTC
# Line 699  Line 699 
699    type 'a nline = (result *  'a) list    type 'a nline = (result *  'a) list
700    type record =    type record =
701        [ `Success        [ `Success
702          | `SomeField
703          | `NoField
704        | `Fail        | `Fail
705        | `Dispatch of (nnf * record) list        | `Dispatch of (nnf * record) list
706        | `Label of Types.label * (nnf * record) list * record ]        | `Label of Types.label * (nnf * record) list * record ]
# Line 742  Line 744 
744    type 'a nline = (result *  'a) sl    type 'a nline = (result *  'a) sl
745    type record =    type record =
746        [ `Success        [ `Success
747          | `SomeField
748          | `NoField
749        | `Fail        | `Fail
750        | `Dispatch of (nnf * record) list        | `Dispatch of (nnf * record) list
751        | `Label of Types.label * (nnf * record) list * record ]        | `Label of Types.label * (nnf * record) list * record ]
# Line 755  Line 759 
759      nrecord: record nline      nrecord: record nline
760    }    }
761    
762      let fus = SortedMap.union_disj
763      let slcup = SortedList.cup
764    (*
765    let nempty = { nfv = []; ncatchv = []; na = Types.empty;    let nempty = { nfv = []; ncatchv = []; na = Types.empty;
766                   nbasic = []; nprod = []; nxml = []; nrecord = [] }                   nbasic = []; nprod = []; nxml = []; nrecord = [] }
767    
# Line 771  Line 778 
778        nrecord = SortedList.cup nf1.nrecord nf2.nrecord;        nrecord = SortedList.cup nf1.nrecord nf2.nrecord;
779      }      }
780    
   let fus = SortedMap.union_disj  
   let slcup = SortedList.cup  
   
781    let double_fold f l1 l2 =    let double_fold f l1 l2 =
782      SortedList.from_list      SortedList.from_list
783        (List.fold_left        (List.fold_left
# Line 818  Line 822 
822          na = acc;          na = acc;
823          nprod = SortedList.from_list prod          nprod = SortedList.from_list prod
824      }      }
825    *)
826    
827    
828    let empty = { v = []; catchv = [];    let empty = { v = []; catchv = [];
# Line 981  Line 985 
985        let rec aux nr fields =        let rec aux nr fields =
986          match (nr,fields) with          match (nr,fields) with
987            | (`Success, []) -> `Success            | (`Success, []) -> `Success
988            | (`Fail,_) -> `Fail            | (`SomeField, []) -> `SomeField
989            | (`Success, (l2,pl)::fields) ->            | (`NoField, []) -> `NoField
990                `Label (l2, [(pl,Types.any), aux nr fields], `Fail)            | (`Fail,_) | (`NoField,_::_) -> `Fail
991              | ((`Success|`SomeField), (l2,pl)::fields) ->
992                  `Label (l2, [(pl,Types.any), aux `Success fields], `Fail)
993            | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->            | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
994                `Label (l2, [(pl,Types.any), aux nr fields], `Fail)                `Label (l2, [(pl,Types.any), aux nr fields], `Fail)
995            | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->            | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
# Line 999  Line 1005 
1005                                          if x==ab then aux_ab else                                          if x==ab then aux_ab else
1006                                          aux x fields)) pr in                                          aux x fields)) pr in
1007                `Label (l1, pr, aux_ab)                `Label (l1, pr, aux_ab)
   
 (* TODO:!!!*)  
           | ((`NoField|`SomeField),_) -> aux `Success fields  
1008        in        in
1009    
1010        let line accu ((res,fields),acc) =        let line accu ((res,fields),acc) =
# Line 1043  Line 1046 
1046    and record =    and record =
1047        [ `Label of Types.label * record dispatch * record option        [ `Label of Types.label * record dispatch * record option
1048        | `Result of result        | `Result of result
1049          | `Result_other of result * result
1050        | `Absent ]        | `Absent ]
1051    
1052    and 'a dispatch =    and 'a dispatch =
# Line 1380  Line 1384 
1384    let map_record f =    let map_record f =
1385      let rec aux = function      let rec aux = function
1386        | [] -> []        | [] -> []
1387        | h::t -> (match f h with (_,_,`Fail) -> aux t | x -> x :: (aux t)) in        | (res,catch,h)::t ->
1388              (match f h with `Fail -> aux t | x -> (res,catch,x) :: (aux t)) in
1389      Array.map aux      Array.map aux
1390    
1391    let label_found l =    let label_found l =
1392      map_record      map_record
1393        (function        (function
1394           | (res, catch, `Label (l1, pr, _)) when l1 = l ->           | `Label (l1, pr, _) when l1 = l -> `Dispatch pr
              (res, catch, `Dispatch pr)  
1395           | x -> x)           | x -> x)
1396    
1397    let label_not_found l =    let label_not_found l =
1398      map_record      map_record
1399        (function        (function
1400           | (res, catch, `Label (l1, _, ab)) when l1 = l -> (res, catch, ab)           | `Label (l1, _, ab) when l1 = l -> ab
1401           | x -> x)           | x -> x)
1402    
1403  (*  (*
# Line 1459  Line 1463 
1463        | None ->        | None ->
1464            let aux_final (res, catch, x) =            let aux_final (res, catch, x) =
1465              assert (x = `Success);              assert (x = `Success);
1466              List.map (conv_source_record catch) res in              List.map (conv_source_record catch) res
1467            `Result (return disp pl aux_final)            in
1468              let somefield =
1469                if Types.Record.somefield_possible t then
1470                  let aux = function `Success | `SomeField -> `Success | _ -> `Fail in
1471                  Some (return disp (map_record aux pl) aux_final)
1472                else None
1473              in
1474              let nofield =
1475                if Types.Record.nofield_possible t then
1476                  let aux = function `Success | `NoField -> `Success | _ -> `Fail in
1477                  Some (return disp (map_record aux pl) aux_final)
1478                else None
1479              in
1480              (match (somefield,nofield) with
1481                 | Some r1, Some r2 ->
1482                     if r1 = r2 then `Result r1 else `Result_other(r1,r2)
1483                 | Some r1, None -> `Result r1
1484                 | None, Some r2 -> `Result r2
1485                 | _ -> assert false)
1486        | Some l ->        | Some l ->
1487            let (plabs,absent) =            let (plabs,absent) =
1488              let pl = label_not_found l pl in              let pl = label_not_found l pl in
# Line 1470  Line 1492 
1492            let present =            let present =
1493              let pl = label_found l pl in              let pl = label_found l pl in
1494              let t = Types.Record.restrict_label_present t l in              let t = Types.Record.restrict_label_present t l in
1495                if Types.Record.is_empty t then None else
1496                  Some (
1497              get_tests pl              get_tests pl
1498                (function                (function
1499                   | (res,catch, `Dispatch d) ->                   | (res,catch, `Dispatch d) ->
# Line 1478  Line 1502 
1502                (Types.Record.project_field t l)                (Types.Record.project_field t l)
1503                (dispatch_record_field l disp t plabs)                (dispatch_record_field l disp t plabs)
1504                (fun x -> combine x)                (fun x -> combine x)
1505                  )
1506            in            in
1507            combine_record l present absent            (match (present,absent) with
1508                | (Some present, absent) -> combine_record l present absent
1509                | (None, Some absent) -> absent
1510                | _ -> assert false)
1511    and dispatch_record_field l disp t plabs tfield pl others =    and dispatch_record_field l disp t plabs tfield pl others =
1512      let t = Types.Record.restrict_field t l tfield in      let t = Types.Record.restrict_field t l tfield in
1513      let aux (ret, ncatchv, (res, catch, rem)) =      let aux (ret, ncatchv, (res, catch, rem)) =
# Line 1609  Line 1637 
1637            Format.fprintf ppf " | Record -> @\n";            Format.fprintf ppf " | Record -> @\n";
1638            Format.fprintf ppf "     @[%a@]@\n"  print_record r            Format.fprintf ppf "     @[%a@]@\n"  print_record r
1639      and print_record ppf = function      and print_record ppf = function
1640        | `Result r -> print_ret ppf r        | `Result r -> Format.fprintf ppf "%a" print_ret r
1641          | `Result_other (r1,r2) -> Format.fprintf ppf "SomeField:%a;NoField:%a"
1642                       print_ret r1 print_ret r2
1643        | `Absent -> Format.fprintf ppf "Jump to Absent"        | `Absent -> Format.fprintf ppf "Jump to Absent"
1644        | `Label (l, present, absent) ->        | `Label (l, present, absent) ->
1645            let l = Types.LabelPool.value l in            let l = Types.LabelPool.value l in
# Line 1621  Line 1651 
1651                     print_record r                     print_record r
1652              | None -> ()              | None -> ()
1653      and print_present l ppf = function      and print_present l ppf = function
1654        | `None -> assert false        | `None ->
1655              Format.fprintf ppf "(cannot happen)"
1656              (* assert false *)
1657        | `TailCall d ->        | `TailCall d ->
1658            queue d;            queue d;
1659            Format.fprintf ppf "disp_%i@\n" d.id            Format.fprintf ppf "disp_%i@\n" d.id
Legend:
Removed from v.164  
changed lines
  Added in v.165
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5