[camlp4] Merge 3.10 on trunk for camlp4/examples

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@8552 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

camlp4/examples/_tags

@@ -1,8 +1,13 @@
-"apply_operator.ml" or "type_quotation.ml": camlp4rf, use_camlp4
+<{apply_operator,type_quotation,global_handler,expression_closure{,_filter}}.ml> or <free_vars_test.*>: camlp4rf, use_camlp4
 "lambda_quot.ml": camlp4rf, use_camlp4_full
 "lambda_quot_o.ml": camlp4of, use_camlp4_full
-"macros.ml" or "dirac.ml" or "puzzle.ml" or <arith.*>: camlp4of, use_camlp4
+"macros.ml" or <arith.*> or "gen_match_case.ml": camlp4of, use_camlp4
 "test_macros.ml": pp(camlp4of ./macros.cmo)
 "lambda_test.ml": pp(camlp4of ./lambda_quot_o.cmo)
 <parse_files.*>: camlp4of, use_camlp4_full, use_dynlink
-<{free_vars_test,poly_rec}.*>: camlp4rf, use_camlp4
+"test_type_quotation.ml": pp(camlp4of ./type_quotation.cmo)
+"apply_operator_test.ml": pp(camlp4o ./apply_operator.cmo)
+"expression_closure_test.ml": pp(camlp4o ./expression_closure_filter.cmo)
+"gen_type_N.ml": camlp4orf, use_camlp4
+"syb_fold.ml": pp(camlp4o -filter fold), use_camlp4
+"syb_map.ml": pp(camlp4o -filter map), use_camlp4

camlp4/examples/all.itarget

@@ -0,0 +1,11 @@
+apply_operator.cmo
+type_quotation.cmo
+lambda_quot.cmo
+lambda_quot_o.cmo
+macros.cmo
+parse_files.byte
+parse_files.native
+arith.cmo
+expression_closure.cmo
+expression_closure_filter.cmo
+global_handler.cmo

camlp4/examples/apply_operator.ml

@@ -2,5 +2,5 @@ open Camlp4.PreCast;
 AstFilters.register_str_item_filter
   (Ast.map_expr
     (fun
-     [ <:expr@loc< \& $e1$ $e2$ >> -> <:expr@loc< $e1$ $e2$ >>
+     [ <:expr@loc< $e1$ & $e2$ >> -> <:expr@loc< $e1$ $e2$ >>
      | e -> e ]))#str_item;

camlp4/examples/apply_operator_test.ml

@@ -1 +1,3 @@
-f& g& h x
+let ( & ) = ();; (* To force it to be inlined. If not it's not well typed. *)
+
+fun f g h x -> f& g& h x

camlp4/examples/arith.ml

@@ -0,0 +1,49 @@
+(* Please keep me in sync with brion.inria.fr/gallium/index.php/Arithmetic_Example *)
+
+  open Camlp4.PreCast;;
+  module ArithGram = MakeGram(Lexer);;
+  
+  type t = Local of string * t * t
+         | Binop of t * (int -> int -> int) * t
+         | Int   of int
+         | Var   of string;;
+  
+  let expression = ArithGram.Entry.mk "expression";;
+  
+  EXTEND ArithGram
+    GLOBAL: expression;
+  
+    expression: (* A grammar entry for expressions *)
+    [ "top"
+      [ "let"; `LIDENT s; "="; e1 = SELF; "in"; e2 = SELF -> Local(s,e1,e2) ]
+    | "plus"
+      [ e1 = SELF; "+"; e2 = SELF -> Binop(e1, ( + ), e2)
+      | e1 = SELF; "-"; e2 = SELF -> Binop(e1, ( - ), e2) ]
+    | "times"
+      [ e1 = SELF; "*"; e2 = SELF -> Binop(e1, ( * ), e2)
+      | e1 = SELF; "/"; e2 = SELF -> Binop(e1, ( / ), e2) ]
+    | "simple"
+      [ `INT(i, _)  -> Int(i)
+      | `LIDENT s -> Var(s)
+      | "("; e = expression; ")" -> e ]
+    ];
+  
+  END;;
+  
+  let parse_arith s =
+    ArithGram.parse_string expression (Loc.mk "<string>") s;;
+  
+  let rec eval env =
+    function
+    | Local(x, e1, e2) ->
+         let v1 = eval env e1 in
+         eval ((x, v1) :: env) e2
+    | Binop(e1, op, e2) ->
+         op (eval env e1) (eval env e2)
+    | Int(i) -> i
+    | Var(x) -> List.assoc x env;;
+  
+  let calc s =
+    Format.printf "%s ==> %d@." s (eval [] (parse_arith s));;
+  
+  calc "42 * let x = 21 in x + x";;

camlp4/examples/expression_closure_test.ml

@@ -0,0 +1,14 @@
+(* x and y are free *)
+close_expr(x y);;
+
+(* bind x *)
+let x a = a + 42;;
+
+(* y is free *)
+close_expr(x y);;
+
+(* bind y locally so the expr is closed *)
+close_expr(let y = x 2 in x y);;
+
+(* bind y locally but outside, z is free *)
+let y = x 2 in close_expr(x (z y));;

camlp4/examples/free_vars_test.ml

@@ -49,8 +49,8 @@ fv << fun x -> x y >> << y >>;
 fv << fun y -> fun x -> x y >> <<>>;
 fv << let x = 42 and y = 44 in x y z >> << z >>;
 fv << let z = g in let x = 42 and y = 44 in x y z >> << g >>;
-fv << let rec f x = g (x + 1) and g y = f (y - 1) in fun x -> g x * f x >> << \+ \- \* >>;
-fv << let rec f x = g (x + 1) and g y = f (g (y - 1)) in fun x -> g x * f x >> << \+ \- \* >>;
+fv << let rec f x = g (x + 1) and g y = f (y - 1) in fun x -> g x * f x >> << (+) (-) ( * ) >>;
+fv << let rec f x = g (x + 1) and g y = f (g (y - 1)) in fun x -> g x * f x >> << (+) (-) ( * ) >>;
 
 fv << let i = 42 in let module M = struct value f x = y x; end in M.h >> << y >>;
 
@@ -60,9 +60,9 @@ fv << fun [ A x -> x y | _ -> x ] >> << x y >>;
 
 fv << fun [ { x = A z; y = y } as q -> x z y a q ] >> << x a >>;
 
-fv << let module M = struct value a = 42; value b = a + 1; end in () >> <<\+>>;
+fv << let module M = struct value a = 42; value b = a + 1; end in () >> <<(+)>>;
 
-fv << let module M = struct value rec a = 42; value b = a + 1; end in () >> <<\+>>;
+fv << let module M = struct value rec a = 42; value b = a + 1; end in () >> <<(+)>>;
 
 fv << let rec f x = x and g = x in y >> << x y >>;
 fv << let f x = x in x >> << x >>;

camlp4/examples/gen_match_case.ml

@@ -0,0 +1,12 @@
+open Camlp4.PreCast;;
+
+let gen patts exprs =
+  let cases =
+    List.fold_right2 begin fun patt expr acc ->
+      let _loc = Loc.merge (Ast.loc_of_patt patt) (Ast.loc_of_expr expr) in
+      <:match_case< $patt$ -> $expr$ | $acc$ >>
+    end patts exprs <:match_case@here<>>
+  in
+  let _loc = Ast.loc_of_match_case cases in
+  <:expr< function $cases$ >>
+;;

camlp4/examples/gen_type_N.ml

@@ -0,0 +1,33 @@
+open Camlp4.PreCast;;
+
+let data_constructor_arguments _loc n t =
+  let rec self n =
+    if n <= 0 then <:ctyp<>> else <:ctyp< $t$ and $self (n-1)$ >>
+  in self n
+;;
+
+let data_constructor _loc n t =
+  <:ctyp< $uid:"C"^string_of_int n$ of $data_constructor_arguments _loc n t$ >>
+;;
+
+let gen_type _loc n t =
+  let rec self n =
+    if n <= 0 then <:ctyp<>>
+    else <:ctyp< $self (n-1)$ | $data_constructor _loc n t$ >>
+  in <:ctyp< [ $self n$ ] >>
+;;
+
+let filter =
+  function
+  | <:ctyp@_loc< gen_type $lid:x$ >> | <:ctyp@_loc< $lid:x$ gen_type >> ->
+      Scanf.sscanf x "%[^0-9]%d" begin fun _ n ->
+        gen_type _loc n <:ctyp< $lid:x$ >>
+      end
+  | t -> t
+;;
+
+AstFilters.register_str_item_filter (Ast.map_ctyp filter)#str_item;;
+
+IFDEF TEST THEN
+  type t7 = gen_type t7;;
+ENDIF;;

camlp4/examples/global_handler.ml

@@ -4,19 +4,17 @@ value ghost = Loc.ghost;
 
 value global_handler_ref = ref <:expr@ghost<>>;
 
-value find_global_handler = object
-  inherit Ast.map as super;
-  method str_item st = do {
-    match st with
-    [ <:str_item< value global_handler = $f$ >> -> global_handler_ref.val := f
-    | _ -> () ];
-    super#str_item st
-  };
+value find_global_handler =
+  Ast.map_str_item begin
+    fun
+    [ <:str_item@_loc< value global_handler = $f$ >> ->
+        (global_handler_ref.val := f; <:str_item<>>)
+    | st -> st ]
+  end;
+
+AstFilters.register_str_item_filter begin fun st ->
+  let _ = find_global_handler#str_item st in
+  <:str_item@ghost< try let module Main = struct $st$ end in ()
+                    with e -> $global_handler_ref.val$ e >>
 end;
 
-AstFilters.register_str_item_filter
-  (fun st ->
-    let _ = find_global_handler#str_item st in
-    <:str_item@ghost< try let module Main = struct $st$ end in ()
-                      with e -> $global_handler_ref.val$ e >>);
-

camlp4/examples/lambda_quot_o.ml

@@ -0,0 +1,40 @@
+(* Please keep me in sync with brion.inria.fr/gallium/index.php/Lambda_calculus_quotations *)
+
+open Camlp4.PreCast;;
+module CamlSyntax = Camlp4OCamlParser.Make(Camlp4OCamlRevisedParser.Make(Syntax));;
+
+let expr_of_string = CamlSyntax.Gram.parse_string CamlSyntax.expr_eoi;;
+
+module LambdaGram = MakeGram(Lexer);;
+
+let term = LambdaGram.Entry.mk "term";;
+let term_eoi = LambdaGram.Entry.mk "lambda term quotation";;
+
+Camlp4_config.antiquotations := true;;
+
+EXTEND LambdaGram
+  GLOBAL: term term_eoi;
+  term:
+    [ "top"
+      [ "fun"; v = var; "->"; t = term -> <:expr< `Lam($v$, $t$) >> ]
+    | "app"
+      [ t1 = SELF; t2 = SELF           -> <:expr< `App($t1$, $t2$) >> ]
+    | "simple"
+      [ `ANTIQUOT((""|"term"), a)      -> expr_of_string _loc a
+      | v = var                        -> <:expr< `Var($v$) >>
+      | "("; t = term; ")"             -> t ]
+    ];
+  var:
+    [[ v = LIDENT               -> <:expr< $str:v$ >>
+     | `ANTIQUOT((""|"var"), a) -> expr_of_string _loc a
+    ]];
+  term_eoi:
+    [[ t = term; `EOI -> t ]];
+END;;
+
+let expand_lambda_quot_expr loc _loc_name_opt quotation_contents =
+  LambdaGram.parse_string term_eoi loc quotation_contents;;
+
+Syntax.Quotation.add "lam" Syntax.Quotation.DynAst.expr_tag expand_lambda_quot_expr;;
+
+Syntax.Quotation.default := "lam";;

camlp4/examples/lambda_test.ml

@@ -4,7 +4,7 @@ let zero = << fun s -> fun z -> z >>
 let succ = << fun n -> fun s -> fun z -> s n >>
 let one = << $succ$ $zero$ >>
 let iota = << fun x -> z >>
-let rho = << fun m -> fun r -> (s m (m r iota r)) >>
+let rho = << fun m -> fun r -> (s m (m r $iota$ r)) >>
 let rec_nat =
   << fun n -> fun s -> fun z -> n $rho$ $iota$ $rho$ >>
 let plus = << fun n -> fun m -> $rec_nat$ n (fun n -> fun p -> $succ$ p) m >>

camlp4/examples/parse_files.ml

@@ -1,7 +1,5 @@
 open Camlp4.PreCast;;
 
-module CamlGram = MakeGram(Lexer);;
-
 module Caml =
   Camlp4.Printers.OCaml.Make
     (Camlp4OCamlParser.Make

camlp4/examples/syb_fold.ml

@@ -0,0 +1,90 @@
+type variable = string
+ and term =
+  | Var   of variable
+  | Lam   of variable * term
+  | App   of term * term
+  | Const of constant
+ and constant =
+  | CInt    of int
+  | CString of string
+;;
+
+class fold = Camlp4Filters.GenerateFold.generated;;
+(* class fold = Camlp4FoldGenerator.generated;; *)
+
+module VarSet = Set.Make(String);;
+
+(* Compute free variables with the fold class *)
+let free_variables_v1 =
+  let o =
+    object (self)
+      inherit fold as super
+      val fv = VarSet.empty
+      method fv = fv
+      method empty_fv = {< fv = VarSet.empty >}
+      method term t =
+        match t with
+        | Var(v) -> {< fv = VarSet.add v fv >}
+        | Lam(v, t) ->
+            let fv1 = VarSet.remove v (self#empty_fv#term t)#fv in
+            {< fv = VarSet.union fv fv1 >}
+        | _ -> super#term t
+    end
+  in fun t -> VarSet.elements (o#term t)#fv
+;;
+
+(* Let's try to abstract that a little *)
+
+let fold_term f t init =
+  let o =
+    object (self)
+      inherit fold as super
+      val acc = init
+      method get = acc
+      method reset = {< acc = init >}
+      method term t =
+        {< acc = f t acc (fun t -> (self#reset#term t)#get)
+                         (fun t -> (super#term t)#get) >}
+    end
+  in
+  (o#term t)#get
+;;
+
+(* A nicer version of free_variables *)
+let free_variables_v2 t =
+  VarSet.elements begin
+    fold_term begin fun t fv self next ->
+      match t with
+      | Var(v)    -> VarSet.add v fv
+      | Lam(v, t) -> VarSet.union fv (VarSet.remove v (self t))
+      | _         -> next t
+    end t VarSet.empty
+  end
+;;
+
+let term1 =
+  App(
+    App(Var"x1",
+      Lam("x",
+        App(Var"x", App(Var"y", (Lam("y", Lam("z", (App(Var"y", App(Var"x4",Var"z")))))))))),
+    Var"x3")
+
+;;
+
+let fv1 = free_variables_v1 term1;;
+let fv2 = free_variables_v2 term1;;
+
+(* Low cost syntax *)
+let ( ^-> ) v t = Lam(v, t)
+let ( @ ) t1 t2 = App(t1, t2)
+let ( ! ) s = Var s
+
+let term2 =
+  !"x1" @
+  ("x" ^-> !"x" @ !"y" @ ("y" ^-> ("z" ^-> !"y" @ !"x4" @ !"z"))) @
+  !"x3"
+
+;;
+
+let fv1' = free_variables_v1 term2;;
+let fv2' = free_variables_v2 term2;;

camlp4/examples/syb_map.ml

@@ -0,0 +1,51 @@
+type variable = string
+ and term =
+  | Var   of variable
+  | Lam   of variable * term
+  | App   of term * term
+  | Const of constant
+ and constant =
+  | CInt    of int
+  | CString of string
+ and program =
+  | Def of string * term
+  | Seq of program list
+;;
+
+class map = Camlp4Filters.GenerateMap.generated;;
+(* class map = Camlp4MapGenerator.generated;; *)
+
+let map_term f = object
+  inherit map as super
+  method term t = f (super#term t)
+end;;
+
+let map_term' f = object (self)
+  inherit map as super
+  method term t = f t self#term super#term
+end;;
+
+(* Suppress calls to the identity function... *)
+let suppress_id =
+  map_term begin function
+    | App(Lam(v, Var(v')), t) when v = v' -> t
+    | x -> x
+  end;;
+
+(* Substitute blindly all occurences of v by t *)
+let raw_subst v t =
+  map_term' begin fun t' _ next ->
+    match t' with
+    | Var(v') when v = v' -> t
+    | x -> next x
+  end;;
+
+let id = Lam("x", Var"x");;
+let _42 = Const(CInt 42);;
+let prog =
+  Seq[Def("foo", App(id, _42)); Def("bar", App(id, id))];;
+
+let prog2 = suppress_id#program prog;;
+let term3 = suppress_id#term (App(id, _42));;
+
+let term4 = (raw_subst "x" _42)#term (App(Var"succ", Var"x"));;

camlp4/examples/test.itarget

@@ -0,0 +1,8 @@
+test_macros.cmo
+lambda_test.cmo
+free_vars_test.byte
+free_vars_test.native
+global_handler_test.cmo
+apply_operator_test.cmo
+test_type_quotation.cmo
+expression_closure_test.cmo