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

Diff of /types/patterns.ml

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

revision 44 by abate, Tue Jul 10 17:00:28 2007 UTC revision 45 by abate, Tue Jul 10 17:00:40 2007 UTC
# Line 331  Line 331 
331        [ `Label of Types.label * record dispatch * record option        [ `Label of Types.label * record dispatch * record option
332        | `Result of result ]        | `Result of result ]
333    
334    and 'a dispatch = dispatcher * 'a array    and 'a dispatch =
335    and result = int * source list        [ `Dispatch of dispatcher * 'a array
336          | `TailCall of dispatcher
337          | `Ignore of 'a
338          | `None ]
339    
340      and result = int * source array
341    and source =    and source =
342        [ `Catch | `Const of Types.const        [ `Catch | `Const of Types.const
343        | `Left of int | `Right of int | `Recompose of int * int        | `Left of int | `Right of int | `Recompose of int * int
# Line 357  Line 362 
362      mutable actions : actions option      mutable actions : actions option
363    }    }
364    
365      let array_for_all f a =
366        let rec aux f a i =
367          if i = Array.length a then true
368          else f a.(i) && (aux f a (succ i))
369        in
370        aux f a 0
371    
372      let array_for_all_i f a =
373        let rec aux f a i =
374          if i = Array.length a then true
375          else f i a.(i) && (aux f a (succ i))
376        in
377        aux f a 0
378    
379      let combine disp act =
380        if Array.length act = 0 then `None
381        else
382          if (array_for_all (fun (_,ar,_) -> ar = 0) disp.codes)
383             && (array_for_all ( (=) act.(0) ) act) then
384               `Ignore act.(0)
385          else
386            `Dispatch (disp, act)
387    
388      let combine_record l present absent =
389        match (present,absent) with
390          | (`Ignore r1, Some r2) when r1 = r2 -> r1
391          | (`Ignore r, None) -> r
392          | _ -> `Label (l, present, absent)
393    
394      let detect_right_tail_call = function
395        | `Dispatch (disp,branches)
396            when
397              array_for_all_i
398                (fun i (code,ret) ->
399                   (i = code) &&
400                   (array_for_all_i
401                      (fun pos ->
402                         function `Right j when pos = j -> true | _ -> false)
403                      ret
404                   )
405                ) branches
406              -> `TailCall disp
407        | x -> x
408    
409      let detect_left_tail_call = function
410        | `Dispatch (disp,branches)
411            when
412              array_for_all_i
413                (fun i ->
414                   function
415                     | `Ignore (code,ret) ->
416                         (i = code) &&
417                         (array_for_all_i
418                            (fun pos ->
419                               function `Left j when pos = j -> true | _ -> false)
420                            ret
421                   )
422                     | _ -> false
423                ) branches
424              ->
425             `TailCall disp
426        | x -> x
427    
428    let cur_id = ref 0    let cur_id = ref 0
429    
430    module DispMap = Map.Make(    module DispMap = Map.Make(
# Line 428  Line 496 
496      aux 0 d.interface      aux 0 d.interface
497    
498    let create_result pl =    let create_result pl =
499        Array.of_list (
500      Array.fold_right      Array.fold_right
501        (fun x accu -> match x with        (fun x accu -> match x with
502           | Some b -> b @ accu           | Some b -> b @ accu
503           | None -> accu)           | None -> accu)
504        pl []        pl []
505        )
506    
507    let return disp pl f =    let return disp pl f =
508      let aux = function [x] -> Some (f x) | [] -> None | _ -> assert false in      let aux = function [x] -> Some (f x) | [] -> None | _ -> assert false in
# Line 484  Line 554 
554      !accu      !accu
555    
556    
557    let get_tests pl f t d =    let get_tests pl f t d post =
558      let accu = ref [] in      let accu = ref [] in
559      let unselect = Array.create (Array.length pl) [] in      let unselect = Array.create (Array.length pl) [] in
560      let aux i x =      let aux i x =
# Line 505  Line 575 
575        d t selected unselect        d t selected unselect
576      in      in
577      let res = Array.map result disp.codes in      let res = Array.map result disp.codes in
578      (disp,res)      post (combine disp res)
579    
580    
581    
# Line 516  Line 586 
586        (fun (res,(p,q)) -> [p, (res,q)], [])        (fun (res,(p,q)) -> [p, (res,q)], [])
587        (Types.Product.pi1 t)        (Types.Product.pi1 t)
588        (dispatch_prod1 disp t)        (dispatch_prod1 disp t)
589          detect_left_tail_call
590    and dispatch_prod1 disp t t1 pl _ =    and dispatch_prod1 disp t t1 pl _ =
591      let t = Types.Product.restrict_1 t t1 in      let t = Types.Product.restrict_1 t t1 in
592      get_tests pl      get_tests pl
593        (fun (ret1, (res,q)) -> [q, (ret1,res)], [] )        (fun (ret1, (res,q)) -> [q, (ret1,res)], [] )
594        (Types.Product.pi2 t)        (Types.Product.pi2 t)
595        (dispatch_prod2 disp t)        (dispatch_prod2 disp t)
596          detect_right_tail_call
597    and dispatch_prod2 disp t t2 pl _ =    and dispatch_prod2 disp t t2 pl _ =
598      let aux_final (ret2, (ret1, res)) =      let aux_final (ret2, (ret1, res)) =
599        List.map (conv_source_prod ret1 ret2) res in        List.map (conv_source_prod ret1 ret2) res in
# Line 584  Line 656 
656                   | x -> [],[x])                   | x -> [],[x])
657                (Types.Record.project_field t l)                (Types.Record.project_field t l)
658                (dispatch_record_field l disp t)                (dispatch_record_field l disp t)
659                  (fun x -> x)
660            in            in
661            let absent =            let absent =
662              let pl = label_not_found l pl in              let pl = label_not_found l pl in
663              let t = Types.Record.restrict_label_absent t l in              let t = Types.Record.restrict_label_absent t l in
664              dispatch_record_opt disp t pl              dispatch_record_opt disp t pl
665            in            in
666            `Label (l, present, absent)            combine_record l present absent
667    and dispatch_record_field l disp t tfield pl others =    and dispatch_record_field l disp t tfield pl others =
668      let t = Types.Record.restrict_field t l tfield in      let t = Types.Record.restrict_field t l tfield in
669      let aux (ret, (res, catch, rem)) = (res, (l,ret) :: catch, rem) in      let aux (ret, (res, catch, rem)) = (res, (l,ret) :: catch, rem) in
# Line 629  Line 702 
702        | `Recompose (i,j) -> Format.fprintf ppf "(l%i,r%i)" i j        | `Recompose (i,j) -> Format.fprintf ppf "(l%i,r%i)" i j
703        | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.label_name l) i        | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.label_name l) i
704      in      in
705      let rec print_result ppf = function      let print_result ppf =
706        | [] -> ()        Array.iteri
707        | [s] -> print_source ppf s          (fun i s ->
708        | s :: rem ->             if i > 0 then Format.fprintf ppf ",";
709            Format.fprintf ppf "%a," print_source s;            print_source ppf s;
710            print_result ppf rem          )
711      in      in
712      let print_ret ppf (code,ret) =      let print_ret ppf (code,ret) =
713        Format.fprintf ppf "$%i" code;        Format.fprintf ppf "$%i" code;
714        if ret <> [] then Format.fprintf ppf "(%a)" print_result ret in        if Array.length ret <> 0 then
715            Format.fprintf ppf "(%a)" print_result ret in
716      let print_lhs ppf (code,prefix,d) =      let print_lhs ppf (code,prefix,d) =
717        let arity = match d.codes.(code) with (_,a,_) -> a in        let arity = match d.codes.(code) with (_,a,_) -> a in
718        Format.fprintf ppf "$%i(" code;        Format.fprintf ppf "$%i(" code;
# Line 652  Line 726 
726          Types.Print.print_descr t          Types.Print.print_descr t
727          print_ret ret          print_ret ret
728      in      in
729      let print_prod2 (d,rem) =      let print_prod2 = function
730          | `None -> assert false
731          | `Ignore r ->
732              Format.fprintf ppf "        %a\n"
733                print_ret r
734          | `TailCall d ->
735              queue d;
736              Format.fprintf ppf "        disp_%i v2@\n" d.id
737          | `Dispatch (d, branches) ->
738        queue d;        queue d;
739        Format.fprintf ppf "        match v2 with disp_%i@\n" d.id;        Format.fprintf ppf "        match v2 with disp_%i@\n" d.id;
740        Array.iteri        Array.iteri
# Line 661  Line 743 
743               print_lhs (code, "r", d)               print_lhs (code, "r", d)
744               print_ret r;               print_ret r;
745          )          )
746          rem              branches
747      in      in
748      let print_prod (d,rem) =      let print_prod  = function
749        if Array.length rem > 0 then (        | `None -> ()
750          | `Ignore d2 ->
751              Format.fprintf ppf " | (v1,v2) -> @\n";
752              print_prod2 d2
753          | `TailCall d ->
754              queue d;
755              Format.fprintf ppf " | (v1,v2) -> @\n";
756              Format.fprintf ppf "      disp_%i v1@\n" d.id
757          | `Dispatch (d,branches) ->
758          queue d;          queue d;
759          Format.fprintf ppf " | (v1,v2) -> @\n";          Format.fprintf ppf " | (v1,v2) -> @\n";
760          Format.fprintf ppf "      match v1 with disp_%i@\n" d.id;          Format.fprintf ppf "      match v1 with disp_%i@\n" d.id;
# Line 674  Line 764 
764               print_lhs (code, "l", d);               print_lhs (code, "l", d);
765               print_prod2 d2;               print_prod2 d2;
766            )            )
767            rem              branches
       )  
768      in      in
769      let rec print_record_opt ppf = function      let rec print_record_opt ppf = function
770        | None -> ()        | None -> ()
# Line 684  Line 773 
773            Format.fprintf ppf "     @[%a@]@\n"  print_record r            Format.fprintf ppf "     @[%a@]@\n"  print_record r
774      and print_record ppf = function      and print_record ppf = function
775        | `Result r -> print_ret ppf r        | `Result r -> print_ret ppf r
776        | `Label (l, (d,present), absent) ->        | `Label (l, present, absent) ->
777            let l = Types.label_name l in            let l = Types.label_name l in
           queue d;  
778            Format.fprintf ppf " check label %s:@\n" l;            Format.fprintf ppf " check label %s:@\n" l;
779            Format.fprintf ppf "  Present => match with disp_%i@\n" d.id;            Format.fprintf ppf "Present => @[%a@]@\n" (print_present l) present;
780              match absent with
781                | Some r ->
782                    Format.fprintf ppf "Absent => @[%a@]@\n"
783                       print_record r
784                | None -> ()
785        and print_present l ppf = function
786          | `None -> assert false
787          | `TailCall d ->
788              queue d;
789              Format.fprintf ppf "disp_%i@\n" d.id
790          | `Dispatch (d,branches) ->
791              queue d;
792              Format.fprintf ppf "match with disp_%i@\n" d.id;
793            Array.iteri            Array.iteri
794              (fun code r ->              (fun code r ->
795                 Format.fprintf ppf "    | %a -> @\n"                 Format.fprintf ppf "    | %a -> @\n"
796                   print_lhs (code, l, d);                   print_lhs (code, l, d);
797                 Format.fprintf ppf "       @[%a@]@\n"                 Format.fprintf ppf "       @[%a@]@\n"
798                   print_record r                   print_record r
799              ) present;              ) branches
800            match absent with        | `Ignore r ->
801              | Some r ->            Format.fprintf ppf "@[%a@]@\n"
                 Format.fprintf ppf "  Absent => @[%a@]@\n"  
802                     print_record r                     print_record r
             | None -> ()  
803      in      in
804    
805      List.iter print_basic actions.basic;      List.iter print_basic actions.basic;
# Line 747  Line 846 
846  end  end
847    
848    
 (*  
   let test_filter t p =  
     let t = Syntax.make_type (Syntax.parse t)  
     and p = Syntax.make_pat (Syntax.parse p) in  
     let r = Patterns.filter (Types.descr t) p in  
     List.iter (fun (v,t) ->  
                  let t = Types.normalize t in  
                  Format.fprintf Format.std_formatter "@[%s => %a@]@\n"  
                        v Types.Print.print t) r;;  
 test_filter "[ (1 2 3?)* ]" "[ (x::(1 2) 3?)* ]";;  
 *)  
   
 (*  
 disp " [(`A `B `C?)*] "  [" [ (((x::`A) `B (x::`C))|_)* ] "];;  
 disp " [(`A)*] "  [" [ (x::`A)* ] "];;  
   
 disp "_" ["{x=`A;y=`B}"];;  
 disp "_" [" [((x::1)|(y::2))*] "];;  
   
 disp "_" [ "((x,_),_)"; "((_,x),_)" ];;  
 disp " [ (1 3?)* ]" [ " [(x::1 3?)*] " ];;  
 disp " [ (1 3?)* ]" [ " [(1 (x::3)?)*] " ];;  
 *)  
   
   
   
 (*  
 #install_printer Types.Print.print_descr;;  
 let pat s = Patterns.descr (Typer.pat (Parser.From_string.pat s));;  
 let typ s = Types.descr (Typer.typ (Parser.From_string.pat s));;  
   
 let disp t l =  
   let l = Array.of_list (  
     List.map (fun p -> Patterns.Compile.normal (pat p)) l) in  
   let t = typ t in  
   Patterns.Compile.show Format.std_formatter t l;;  
   
 let () = disp "_" ["(x,y,z)"];;  
   
 disp "_" ["`A"];;  
 disp "_" ["((x,y),z) | ((x := 1) & (y := 2), z)"];;  
 *)  
   
Legend:
Removed from v.44  
changed lines
  Added in v.45
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5