l4/pkg/ocaml/ocaml/contrib/camlp4/examples/free_vars_test.ml

   1 open Format;
   2 open Camlp4.PreCast;
   3
   4 module FV = Camlp4.Struct.FreeVars.Make Ast;
   5
   6 #default_quotation "expr";
   7
   8 value print_set f s = do {
   9   fprintf f "@[<2>{ ";
  10   FV.S.iter (fprintf f "%s@ ") s;
  11   fprintf f "}@]";
  12 };
  13
  14 module PP = Camlp4.Printers.OCamlr.Make Syntax;
  15 value print_expr = (new PP.printer ())#expr;
  16
  17 value print_status f st = pp_print_string f (if st then "PASS" else "FAIL");
  18
  19 value _loc = Loc.ghost;
  20
  21 value atoms e =
  22   let o = object
  23     inherit Ast.fold as super;
  24     value accu = FV.S.empty;
  25     method accu = accu;
  26     method expr =
  27       fun
  28       [ << $lid:s$ >> -> {< accu = FV.S.add s accu >}
  29       | e -> super#expr e ];
  30   end in (o#expr e)#accu;
  31
  32 value fv e ref =
  33   let s = FV.free_vars FV.S.empty e in
  34   let ref = atoms ref in
  35   let st = FV.S.equal s ref in do {
  36   printf "%a: @[<hv0>fv << %a >> = %a"
  37          print_status st
  38          print_expr e print_set s;
  39   if st then () else printf "@ ref = %a@ diff = %a"
  40     print_set ref print_set (FV.S.diff ref s);
  41   printf "@]@ ";
  42 };
  43
  44 printf "@[<v0>";
  45
  46 fv << x >> << x >>;
  47 fv << x y >> << x y >>;
  48 fv << fun x -> x y >> << y >>;
  49 fv << fun y -> fun x -> x y >> <<>>;
  50 fv << let x = 42 and y = 44 in x y z >> << z >>;
  51 fv << let z = g in let x = 42 and y = 44 in x y z >> << g >>;
  52 fv << let rec f x = g (x + 1) and g y = f (y - 1) in fun x -> g x * f x >> << (+) (-) ( * ) >>;
  53 fv << let rec f x = g (x + 1) and g y = f (g (y - 1)) in fun x -> g x * f x >> << (+) (-) ( * ) >>;
  54
  55 fv << let i = 42 in let module M = struct value f x = y x; end in M.h >> << y >>;
  56
  57 fv << fun [ A x -> x y ] >> << y >>;
  58
  59 fv << fun [ A x -> x y | _ -> x ] >> << x y >>;
  60
  61 fv << fun [ { x = A z; y = y } as q -> x z y a q ] >> << x a >>;
  62
  63 fv << let module M = struct value a = 42; value b = a + 1; end in () >> <<(+)>>;
  64
  65 fv << let module M = struct value rec a = 42; value b = a + 1; end in () >> <<(+)>>;
  66
  67 fv << let rec f x = x and g = x in y >> << x y >>;
  68 fv << let f x = x in x >> << x >>;
  69 fv << let f x = x and g x = x in x >> << x >>;
  70 fv << let (x, y) = (42, 44) in x y z >> << z >>;
  71
  72 printf "@]@.";