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

Diff of /types/patterns.ml

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

revision 165 by abate, Tue Jul 10 17:11:58 2007 UTC revision 166 by abate, Tue Jul 10 17:12:03 2007 UTC
# Line 1046  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        | `Result_other of Types.label list * result * result ]
       | `Absent ]  
1050    
1051    and 'a dispatch =    and 'a dispatch =
1052        [ `Dispatch of dispatcher * 'a array        [ `Dispatch of dispatcher * 'a array
# Line 1135  Line 1134 
1134    let combine_record l present absent =    let combine_record l present absent =
1135      match (present,absent) with      match (present,absent) with
1136        | (`Ignore r1, Some r2) when r1 = r2 -> r1        | (`Ignore r1, Some r2) when r1 = r2 -> r1
       | (`Ignore `Absent, Some r) -> r  
1137        | (`Ignore r, None) -> r        | (`Ignore r, None) -> r
1138          | (`None, Some r) -> r
1139        | _ -> `Label (l, present, absent)        | _ -> `Label (l, present, absent)
1140    
1141    let detect_right_tail_call = function    let detect_right_tail_call = function
# Line 1231  Line 1230 
1230      aux 0 d.interface      aux 0 d.interface
1231    
1232    let create_result pl =    let create_result pl =
1233      Array.of_list (      let aux x accu = match x with Some b -> b @ accu | None -> accu in
1234        Array.fold_right      Array.of_list (Array.fold_right aux pl [])
                      (fun x accu -> match x with  
                         | Some b -> b @ accu  
                         | None -> accu)  
                      pl []  
     )  
1235    
1236    let return disp pl f =    let return disp pl f =
1237      let aux = function [x] -> Some (f x) | [] -> None | _ -> assert false in      let aux = function [x] -> Some (f x) | [] -> None | _ -> assert false in
# Line 1441  Line 1435 
1435      let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in      let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
1436      let pl0 = Array.map prep disp.pl in      let pl0 = Array.map prep disp.pl in
1437      let t = Types.Record.get disp.t in      let t = Types.Record.get disp.t in
1438      let r = dispatch_record_opt disp t pl0 in      let r = dispatch_record_opt disp t pl0 [] in
1439  (*    memo_dispatch_record := []; *)  (*    memo_dispatch_record := []; *)
1440      r      r
1441    and dispatch_record_opt disp t pl =    and dispatch_record_opt disp t pl labs =
1442      if Types.Record.is_empty t then None      if Types.Record.is_empty t then None
1443      else Some (dispatch_record_label disp t pl)      else Some (dispatch_record_label disp t pl labs)
1444  (*  and dispatch_record_label disp t pl =  (*  and dispatch_record_label disp t pl =
1445      try List.assoc (t,pl) !memo_dispatch_record      try List.assoc (t,pl) !memo_dispatch_record
1446      with Not_found ->      with Not_found ->
# Line 1458  Line 1452 
1452        let r = !memo_dr_count, r in        let r = !memo_dr_count, r in
1453        memo_dispatch_record := ((t,pl),r) :: !memo_dispatch_record;        memo_dispatch_record := ((t,pl),r) :: !memo_dispatch_record;
1454        r *)        r *)
1455    and dispatch_record_label disp t pl =    and dispatch_record_label disp t pl labs =
1456      match collect_first_label pl with      match collect_first_label pl with
1457        | None ->        | None ->
1458            let aux_final (res, catch, x) =            let aux_final (res, catch, x) =
# Line 1479  Line 1473 
1473            in            in
1474            (match (somefield,nofield) with            (match (somefield,nofield) with
1475               | Some r1, Some r2 ->               | Some r1, Some r2 ->
1476                   if r1 = r2 then `Result r1 else `Result_other(r1,r2)                   if r1 = r2 then `Result r1 else `Result_other(labs,r1,r2)
1477               | Some r1, None -> `Result r1               | Some r1, None -> `Result r1
1478               | None, Some r2 -> `Result r2               | None, Some r2 -> `Result r2
1479               | _ -> assert false)               | _ -> assert false)
1480        | Some l ->        | Some l ->
1481              let labs = l :: labs in
1482            let (plabs,absent) =            let (plabs,absent) =
1483              let pl = label_not_found l pl in              let pl = label_not_found l pl in
1484              let t = Types.Record.restrict_label_absent t l in              let t = Types.Record.restrict_label_absent t l in
1485              pl, dispatch_record_opt disp t pl              pl, dispatch_record_opt disp t pl labs
1486            in            in
1487            let present =            let present =
1488              let pl = label_found l pl in              let pl = label_found l pl in
1489              let t = Types.Record.restrict_label_present t l in              let t = Types.Record.restrict_label_present t l in
1490              if Types.Record.is_empty t then None else              if Types.Record.is_empty t then `None else
               Some (  
1491                  get_tests pl                  get_tests pl
1492                        (function                        (function
1493                           | (res,catch, `Dispatch d) ->                           | (res,catch, `Dispatch d) ->
1494                               List.map (fun (p, r) -> p, (res, catch, r)) d, []                               List.map (fun (p, r) -> p, (res, catch, r)) d, []
1495                           | x -> [],[x])                           | x -> [],[x])
1496                        (Types.Record.project_field t l)                        (Types.Record.project_field t l)
1497                        (dispatch_record_field l disp t plabs)                  (dispatch_record_field l disp t plabs labs)
1498                        (fun x -> combine x)                        (fun x -> combine x)
               )  
1499            in            in
1500            (match (present,absent) with            combine_record l present absent
1501              | (Some present, absent) -> combine_record l present absent    and dispatch_record_field l disp t plabs labs tfield pl others =
             | (None, Some absent) -> absent  
             | _ -> assert false)  
   and dispatch_record_field l disp t plabs tfield pl others =  
1502      let t = Types.Record.restrict_field t l tfield in      let t = Types.Record.restrict_field t l tfield in
1503      let aux (ret, ncatchv, (res, catch, rem)) =      let aux (ret, ncatchv, (res, catch, rem)) =
1504        let catch = if ret = [] then catch else (l,ret) :: catch in        let catch = if ret = [] then catch else (l,ret) :: catch in
# Line 1526  Line 1516 
1516           Need to investigate ....           Need to investigate ....
1517        *)        *)
1518    
1519      dispatch_record_label disp t pl      dispatch_record_label disp t pl labs
1520    
1521    
1522    let actions disp =    let actions disp =
# Line 1638  Line 1628 
1628            Format.fprintf ppf "     @[%a@]@\n"  print_record r            Format.fprintf ppf "     @[%a@]@\n"  print_record r
1629      and print_record ppf = function      and print_record ppf = function
1630        | `Result r -> Format.fprintf ppf "%a" print_ret r        | `Result r -> Format.fprintf ppf "%a" print_ret r
1631        | `Result_other (r1,r2) -> Format.fprintf ppf "SomeField:%a;NoField:%a"        | `Result_other (_,r1,r2) -> Format.fprintf ppf "SomeField:%a;NoField:%a"
1632                     print_ret r1 print_ret r2                     print_ret r1 print_ret r2
       | `Absent -> Format.fprintf ppf "Jump to Absent"  
1633        | `Label (l, present, absent) ->        | `Label (l, present, absent) ->
1634            let l = Types.LabelPool.value l in            let l = Types.LabelPool.value l in
1635            Format.fprintf ppf "check label %s:@\n" l;            Format.fprintf ppf "check label %s:@\n" l;
Legend:
Removed from v.165  
changed lines
  Added in v.166
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5