Merge branch 'eval-test' into master-merge

compile/compile.ml

@@ -141,7 +141,7 @@ and compile_abstr env a =
 
 
   let slots = Array.of_list (List.rev slots) in  
-  let env = { env with vars = fun_env; gamma = (env.gamma @ fun_name);
+  let env = { env with vars = fun_env; gamma = IdMap.merge (fun _ v2 -> v2) env.gamma fun_name;
     stack_size = 0; max_stack = ref 0 } in
   let body = compile_branches env a.Typed.fun_body in
   let sigma = `Sel(a.Typed.fun_fv,a.Typed.fun_iface,env.sigma) in
@@ -177,10 +177,18 @@ and compile_branches env (brs : Typed.branches) =
 (* p_i / t_i -> br.Typed.br_pat / br.Typed.br_type 
  * p_i / t_i is used here to add elements to env.gamma *)
 and compile_branch env br =
-  let env = List.fold_left enter_local env (Patterns.fv br.Typed.br_pat) in
-  let m = Patterns.filter (Types.descr (Patterns.accept br.Typed.br_pat)) br.Typed.br_pat in
+  (* We add a fresh variable "pat<nb>:x" for each pattern
+     TODO: Add a fresh variable for cap too. *)
+  let t, _, d = br.Typed.br_pat.Patterns.descr in
+  let fv = match d with
+    | Patterns.Constr(_) | Patterns.Cap(_) -> Patterns.fv br.Typed.br_pat
+    | _ -> incr Patterns.counter; (Patterns.fv br.Typed.br_pat)
+    @ [!Patterns.counter, "pat" ^ (string_of_int !Patterns.counter) ^ ":x"] in
+  let pat = { br.Typed.br_pat with Patterns.descr=(t,fv,d); Patterns.fv=fv } in
+  let env = List.fold_left enter_local env fv in
+  let m = Patterns.filter (Types.descr (Patterns.accept pat)) pat in
   let env = { env with gamma = IdMap.union_disj m env.gamma } in
-  (br.Typed.br_pat, compile env br.Typed.br_body )
+  (pat, compile env br.Typed.br_body )
 
 let enter_globals env n =  match env.cu with
   | None -> List.fold_left enter_global_toplevel env n

tests/lambda/GRAMMAR

 expr = id
 | integer
-| `true
-| `false
-| string
+| "`true"
+| "`false"
+| STRING
 | abstr
+| "let" LIDENT ":" type_id "=" expr "in" expr ":" type_id
+| "if" expr "then" expr
+| "if" expr "then" expr "else" expr
 | expr "." expr
 | expr "," expr
-| expr "{" id "/" type_id sigma "}"
+| expr "=" expr
+| expr "+" expr
+| expr "-" expr
+| expr "*" expr
+| expr "/" expr
+| expr "%" expr
+| expr "@" expr
+| expr "[" sigmalist "]" (* type substitutions *)
 | "(" expr ")"
+| "[" "]" (* nil *)
 | "[" listexpr "]"
 | "match" expr ":" type_id "with" "|" match_value "->" expr branches
+;;
+
+sigmalist = (* empty *)
+| "{" "}" "," sigmalist
+| "{" UIDENT "/" type_id sigma "}" "," sigmalist
+;;
 
 sigma = (* empty *)
-| ";" id "/" type_id
+| ";" UIDENT "/" type_id
+;;
 
-listexpr = (* empty *)
-| expr
+listexpr = expr
 | listexpr ";" listexpr
+;;
 
 abstr = "fun" id id ":" type_id params ":" type_id "->" expr
 | "fun" "_" id ":" type_id params ":" type_id "->" expr
 | "fun" type_id "|" match_value "->" expr branches
+;;
 
 match_value = id ":" type_id
 | integer
-| string
+| STRING
 | match_value "," match_value
 | match_value "::" match_value
 | "(" match_value ")"
+;;
 
 params = (* empty *)
 | id ":" type_id params
+;;
 
 branches = (* empty *)
 | "|" match_value "->" expr branches
+;;
+
+(* Note: The first character of an id is lower case (or '_'), the first
+   character of a type is upper case *)
 
-id = [a-z_][A-Za-z0-9_]*
+id = LIDENT (* [a-z_][A-Za-z0-9_]* *)
+;;
 
-type_id = [A-Z][A-Za-z0-9_]*
-| "'"[A-Z][A-Za-z0-9_]*
-| "'"[A-Z][A-Za-z0-9_]* "{" id "/" type_id sigma "}"
+(* One must precise a set of type substitutions on a type variable, at least a
+   empty one: α = 'A{} *)
+type_id = UIDENT
+| "'" UIDENT "[" sigmalist "]"
 | "[" complex_type_id "]"
 | "(" complex_type_id ")"
+;;
 
-complex_type_id = [A-Z][A-Za-z0-9_]*
-| "'"[A-Z][A-Za-z0-9_]*
-| "'"[A-Z][A-Za-z0-9_]* "{" id "/" type_id sigma "}"
+complex_type_id = UIDENT (* [A-Z][A-Za-z0-9_]* *)
+| "'" UIDENT "[" sigmalist "]"
 | complex_type_id "*" complex_type_id
 | complex_type_id "|" complex_type_id
 | complex_type_id "&" complex_type_id
 | "!" complex_type_id
-| complex_type_id -> complex_type_id
+| complex_type_id "->" complex_type_id
 | "[" complex_type_id "]"
 | "(" complex_type_id ")"
+;;
 
-integer = [0-9]+
+integer = INTEGER (* [0-9]+ *)

tests/lambda/Makefile

@@ -25,7 +25,7 @@ RM		?= rm -f
 OUT		?= main.native
 OUTDEBUG	?= main.byte
 
-.PHONY: clean check test _import
+.PHONY: clean _import tests
 
 all: _import
 	$(COMPILER) -use-ocamlfind $(OUT)
@@ -33,6 +33,9 @@ all: _import
 debug: _import
 	$(COMPILER) -use-ocamlfind -tag debug $(OUTDEBUG)
 
+tests:
+	make -C tests
+
 _import:
 	@echo -n "Copying external files..."
 	@test -d $(EXTDIR) || mkdir $(EXTDIR)
@@ -40,5 +43,6 @@ _import:
 	@echo "done"
 
 clean:
+	make -C tests clean
 	$(COMPILER) -clean
 	test $(EXTDIR) = "src" || test $(EXTDIR) = "." || $(RM) -r $(EXTDIR)

tests/lambda/src/compute.ml

@@ -45,15 +45,24 @@ let rec _to_typed env l expr =
     let _, _, e2 = _to_typed env l e2 in
     let t = Types.times (Types.cons e1.exp_typ) (Types.cons e2.exp_typ) in
     env, l, { exp_loc=loc; exp_typ=t; exp_descr=Pair(e1, e2) }
+  | Op (_, op, e1, e2) ->
+    let _, _, e1 = _to_typed env l e1 in
+    let _, _, e2 = _to_typed env l e2 in
+    env, l, { exp_loc=loc; exp_typ=type_of_string "Int";
+	      exp_descr=Op(op, 0, [e1; e2]) }
   | Var (origloc, vname) ->
+    let line = Loc.start_line origloc in
+    let cbegin = Loc.start_off origloc - Loc.start_bol origloc in
+    let cend = Loc.stop_off origloc - Loc.start_bol origloc in
     if vname = "`nil" then
       let nil_atom = Atoms.V.mk_ascii "nil" in
       env, l, { exp_loc=loc; exp_typ=(Types.atom (Atoms.atom nil_atom));
 		exp_descr=(Cst (Types.Atom nil_atom)) }
+    else if vname = "_" then
+      (Printf.eprintf
+	 "File %s, line %d, characters %d-%d:\nError: Invalid reference to special variable %s\n"
+	 (Loc.file_name origloc) line cbegin cend vname; raise Error)
     else
-      let line = Loc.start_line origloc in
-      let cbegin = Loc.start_off origloc - Loc.start_bol origloc in
-      let cend = Loc.stop_off origloc - Loc.start_bol origloc in
       let index, vtype =
         try Locals.find vname l
         with Not_found -> Printf.eprintf
@@ -90,27 +99,31 @@ let rec _to_typed env l expr =
         raise Error
 
 and make_sigma s =
-  let rec aux acc = function
+  let rec aux2 acc = function
     | (name, ptype) :: rest ->
-      aux ([`Var (Var.make_id name), type_of_ptype ptype] :: acc) rest
-    | [] -> acc
-  in
+      aux2 ((Var.mk name, type_of_ptype ptype) :: acc) rest
+    | [] -> acc in
+  let rec aux acc = function
+    | l :: rest -> aux (acc @ [aux2 [] l]) rest
+    | [] -> acc in
   aux [] s
 
 and type_of_sigma x s =
-  let rec aux x acc = function
+  let rec aux2 x acc = function
     | [] -> acc
     | (id, t2) :: rest when id = x ->
-      aux x (Types.cup acc (type_of_ptype t2)) rest
-    | _ :: rest -> aux x acc rest
-  in
+      aux2 x (Types.cap acc (type_of_ptype t2)) rest
+    | _ :: rest -> aux2 x acc rest in
+  let rec aux x acc = function
+    | [] -> acc
+    | l :: rest -> aux x (Types.cup acc (aux2 x Types.any l)) rest in
   aux x Types.empty s
 
 and type_of_ptype =
   let open Types in function
   | Type(t) -> type_of_string t
   | PType(t, s) ->
-    if s = [] then var (`Var (Var.make_id t)) else type_of_sigma t s
+    if s = [[]] then var (`Var (Var.make_id t)) else type_of_sigma t s
   | TPair(t1, t2) -> times (cons (type_of_ptype t1)) (cons (type_of_ptype t2))
   | TUnion(t1, t2) -> cup (type_of_ptype t1) (type_of_ptype t2)
   | TInter(t1, t2) -> cap (type_of_ptype t1) (type_of_ptype t2)
@@ -212,14 +225,22 @@ and parse_match_value env l list toptype = function
     Patterns.Times (make_patterns t1 list1 d1, make_patterns t2 list2 d2),
     (list1 @ list2), l, b1 && b2;
   | MVar (_, mname, mtype) ->
-    let lsize = Locals.cardinal l in
-    let l = Locals.add mname (lsize, type_of_ptype mtype) l in
-    let list = list @ [lsize, mname] in
-    let d1 = Types.any, list, Patterns.Capture(lsize, mname) in
-    let t2 = type_of_ptype mtype in
-    let d2 = t2, [], Patterns.Constr(t2) in
-    let is_subtype = Types.subtype t2 (type_of_ptype toptype) in
-    (t2, Patterns.Cap(d1, d2), list, l, is_subtype)
+    if mname = "`nil" then
+      let nil_atom = Atoms.V.mk_ascii "nil" in
+      let t = Types.atom (Atoms.atom nil_atom) in
+      (t, Patterns.Constr(t), list, l, true)
+    else if mname = "_" then
+      let t = type_of_ptype mtype in
+      (t, Patterns.Constr(t), list, l, true)
+    else
+      let lsize = Locals.cardinal l in
+      let l = Locals.add mname (lsize, type_of_ptype mtype) l in
+      let list = list @ [lsize, mname] in
+      let d1 = Types.any, list, Patterns.Capture(lsize, mname) in
+      let t2 = type_of_ptype mtype in
+      let d2 = t2, [], Patterns.Constr(t2) in
+      let is_subtype = Types.subtype t2 (type_of_ptype toptype) in
+      (t2, Patterns.Cap(d1, d2), list, l, is_subtype)
   | MInt (_, i) ->
     let t = Types.constant (Types.Integer(Big_int.big_int_of_int i)) in
     let is_subtype = Types.subtype (type_of_string "Int")
@@ -231,7 +252,55 @@ and parse_match_value env l list toptype = function
     let is_subtype = Types.subtype (type_of_string "String")
       (type_of_ptype toptype) in
     (t, Patterns.Constr(t), list, l, is_subtype)
+  | MBool (origloc, b) ->
+    let t = match b with
+      | "true" -> Types.atom (Atoms.atom (Atoms.V.mk_ascii "true"))
+      | "false" -> Types.atom (Atoms.atom (Atoms.V.mk_ascii "false"))
+      | _ ->
+	let line = Loc.start_line origloc in
+	let cbegin = Loc.start_off origloc - Loc.start_bol origloc in
+	let cend = Loc.stop_off origloc - Loc.start_bol origloc in
+	Printf.eprintf
+          "File %s, line %d, characters %d-%d:\nError: Unknown special term %s\n"
+          (Loc.file_name origloc) line cbegin cend b;
+        raise Error in
+    let is_subtype = Types.subtype t (type_of_ptype toptype) in
+    (t, Patterns.Constr(t), list, l, is_subtype)
+
+let arith_op f = function
+  | Value.Integer(x) :: Value.Integer(y) :: [] ->
+    Value.Integer(Big_int.big_int_of_int (f (Big_int.int_of_big_int x)
+					    (Big_int.int_of_big_int y)))
+  | _ -> raise Error
+
+let equal = function
+  | Value.Integer(x) :: Value.Integer(y) :: [] ->
+    let b = if Big_int.int_of_big_int x = Big_int.int_of_big_int y then "true"
+      else "false" in Value.Atom(Atoms.V.mk_ascii b)
+  | _ -> raise Error
+
+let concat =
+  let rec add_to_tail y = function
+    | Value.Pair(x, nil, s) ->
+      if nil = Value.Atom(Atoms.V.mk_ascii "nil")
+      then Value.Pair(x, y, s) else Value.Pair(x, add_to_tail y nil, s)
+    | _ -> raise Error in
+  function
+  | (Value.Pair(_, _, _) as x) :: (Value.Pair(_) as y) :: [] ->
+    add_to_tail y x
+  | x :: y :: [] ->
+    if x = Value.Atom(Atoms.V.mk_ascii "nil") then y
+    else if y = Value.Atom(Atoms.V.mk_ascii "nil") then x
+    else raise Error
+  | _ -> raise Error
 
 let to_typed expr =
+  Eval.register_op "+" (arith_op ( + ));
+  Eval.register_op "-" (arith_op ( - ));
+  Eval.register_op "*" (arith_op ( * ));
+  Eval.register_op "/" (arith_op ( / ));
+  Eval.register_op "%" (arith_op ( mod ));
+  Eval.register_op "=" equal;
+  Eval.register_op "@" concat;
   let env, _, expr = _to_typed Compile.empty_toplevel Locals.empty expr in
   env, expr

tests/lambda/src/parse.ml

@@ -2,11 +2,12 @@ open Printf
 open Camlp4.PreCast
 
 type expr =
-  | Subst of Loc.t * expr * (string * ptype) list
+  | Subst of Loc.t * expr * (string * ptype) list list
   | Apply of Loc.t * expr * expr
   | Abstr of Loc.t * fun_name * ptype * fv * branches
   | Match of Loc.t * expr * ptype * branches
   | Pair of Loc.t * expr * expr
+  | Op of Loc.t * string * expr * expr
   | Var of Loc.t * string
   | Int of Loc.t * int
   | String of Loc.t * string
@@ -19,9 +20,10 @@ and match_value =
   | MVar of Loc.t * string * ptype
   | MInt of Loc.t * int
   | MString of Loc.t * string
+  | MBool of Loc.t * string
 and ptype =
   | Type of string
-  | PType of string * (string * ptype) list
+  | PType of string * (string * ptype) list list
   | TPair of ptype * ptype
   | TUnion of ptype * ptype
   | TInter of ptype * ptype
@@ -52,31 +54,55 @@ module ExprParser = struct
 	    | (loc, pname, ptype) :: rest ->
 	      let t = TArrow(ptype, t) in
 	      let newfv = match fv with | _ :: rest -> rest | [] -> assert false in
-	      aux (Abstr(_loc, x, t, fv, [_loc, MVar(loc, pname, ptype), acc]))
+	      aux (Abstr(_loc, "_", t, fv, [_loc, MVar(loc, pname, ptype), acc]))
 		t newfv rest
 	    | [] -> acc
 	  in
-	  aux e t (make_fv [] 1 p) (List.rev p)
+	  aux e t (make_fv [0, x] 1 p) (List.rev p)
 	  | "fun"; t = type_id; b = LIST1 branch -> Abstr(_loc, "_", t, [], b)
+	  | "let"; x = LIDENT; ":"; t = type_id; "="; v = SELF; "in"; e = SELF;
+	  ":"; te = type_id -> Match(_loc, v, t, [_loc, MVar(_loc, x, t), e])
+	  | "if"; e1 = SELF; "then"; e2 = SELF ->
+	  let b = [(_loc, MBool(_loc, "true"), e2);
+		   (_loc, MBool(_loc, "false"), Var(_loc, "`nil"))] in
+	  Match(_loc, e1, Type("Bool"), b)
+	  | "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF ->
+	  let b = [(_loc, MBool(_loc, "true"), e2);
+		   (_loc, MBool(_loc, "false"), e3)] in
+	  Match(_loc, e1, Type("Bool"), b)
           | "match"; e = SELF; ":"; t = type_id; "with"; b = LIST1 branch ->
 	  Match(_loc, e, t, b) ]
-      | "pair" LEFTA
-          [ e1 = SELF; ","; e2 = SELF -> Pair(_loc, e1, e2)
-          | e1 = SELF ; "."; e2 = SELF -> Apply(_loc, e1, e2) ]
-      | "list" LEFTA [ "["; le = listexpr; "]" -> le ]
+      | "egal" LEFTA
+	  [ e1 = SELF; "="; e2 = SELF -> Op(_loc, "=", e1, e2) ]
+      | "add" LEFTA
+	  [ e1 = SELF; "+"; e2 = SELF -> Op(_loc, "+", e1, e2)
+	  | e1 = SELF; "-"; e2 = SELF -> Op(_loc, "-", e1, e2) ]
+      | "mult" LEFTA
+	  [ e1 = SELF; "*"; e2 = SELF -> Op(_loc, "*", e1, e2)
+	  | e1 = SELF; "/"; e2 = SELF -> Op(_loc, "/", e1, e2)
+	  | e1 = SELF; "%"; e2 = SELF -> Op(_loc, "%", e1, e2) ]
+      | "concat" LEFTA [ e1 = SELF; "@"; e2 = SELF -> Op(_loc, "@", e1, e2) ]
+      | "pair" LEFTA [ e1 = SELF; ","; e2 = SELF -> Pair(_loc, e1, e2) ]
+      | "apply" [ e1 = SELF ; "."; e2 = SELF -> Apply(_loc, e1, e2) ]
+      | "list" LEFTA
+	  [ "["; le = LIST0 SELF SEP ";"; "]" ->
+	  let rec make_seq res = function
+	    | e :: rest -> make_seq (Pair(_loc, e, res)) rest
+	    | [] -> res in
+	  make_seq (Var(_loc, "`nil")) (List.rev le)
+	  ]
       | "paren" [ "("; e = SELF; ")" -> e ]
       | "var" [  x = LIDENT -> Var(_loc, x) ]
       | "int" [ x = INT -> Int(_loc, int_of_string x) ]
       | "string" [ x = STRING -> String(_loc, x) ]
       | "bool" [ "`"; x = LIDENT -> Bool(_loc, x) ]
       |	"subst" NONA
-	  [ e = SELF; "{"; s = LIST1 sigma SEP ";"; "}" -> Subst(_loc, e, s) ]
+	  [ e = SELF; "["; s = LIST0 sigma SEP ","; "]" -> Subst(_loc, e, s) ]
       ];
 
-    sigma: [[ x = UIDENT; "/"; t = type_id -> x, t ]];
+    sigma:[[ "{"; l = LIST0 subst SEP ";"; "}" -> l ]];
 
-    listexpr:[ "rec" RIGHTA [ l1=SELF; ";"; l2=SELF -> Pair(_loc, l1, l2) ]
-	     | [ e=expression -> e]];
+    subst:[[ x = UIDENT; "/"; t = type_id -> x, t ]];
 
     param:[[p = LIDENT; ":"; t = type_id -> _loc, p, t]];
 
@@ -92,18 +118,20 @@ module ExprParser = struct
       | "var" [ x = LIDENT; ":"; t = type_id -> MVar(_loc, x, t) ]
       | "int" [ x = INT -> MInt(_loc, int_of_string x) ]
       | "string" [ x = STRING -> MString(_loc, x) ]
+      | "bool" [ "`"; x = LIDENT -> MBool(_loc, x) ]
+      | "empty" [ "["; "]" -> MVar(_loc, "`nil", Type("Any")) ]
       ];
 
     type_id: [ "atom_type"
       [ t = UIDENT -> Type(t) ]
-      | [ "'"; t1 = UIDENT; "{"; s = LIST0 sigma SEP ";"; "}" -> PType(t1, s) ]
+      | [ "'"; t1 = UIDENT; "["; s = LIST0 sigma SEP ","; "]" -> PType(t1, s) ]
       | [ "("; t = complex_type_id; ")" -> t ]
       | [ "["; t = complex_type_id; "]" -> TSeq(t) ]
     ];
 
     complex_type_id: [ "complex_type" LEFTA
         [ t = UIDENT -> Type(t) | "("; t = SELF; ")" -> t ]
-        | [ "'"; t1 = UIDENT; "{"; s = LIST0 sigma SEP ";"; "}" -> PType(t1, s) ]
+        | [ "'"; t1 = UIDENT; "["; s = LIST0 sigma SEP ","; "]" -> PType(t1, s) ]
         | [ t1 = SELF; "*"; t2 = SELF -> TPair(t1, t2) | t1 = SELF; "->"; t2 = SELF -> TArrow(t1, t2) ]
         | [ t1 = SELF; "|"; t2 = SELF -> TUnion(t1, t2) | t1 = SELF; "&"; t2 = SELF -> TInter(t1, t2) ]
         | [ "!"; t = SELF -> TNot(t) ]
@@ -122,6 +150,7 @@ let get_loc expr = match expr with
   | Abstr (loc, _, _, _, _) -> loc
   | Match (loc, _, _, _) -> loc
   | Pair (loc, _, _) -> loc
+  | Op (loc, _, _, _) -> loc
   | Var (loc, _) -> loc
   | Int (loc, _) -> loc
   | String (loc, _) -> loc

tests/lambda/src/parse.mli

 open Camlp4.PreCast
 
 type expr =
-  | Subst of Loc.t * expr * (string * ptype) list
+  | Subst of Loc.t * expr * (string * ptype) list list
   | Apply of Loc.t * expr * expr
   | Abstr of Loc.t * fun_name * ptype * fv * branches
   | Match of Loc.t * expr * ptype * branches
   | Pair of Loc.t * expr * expr
+  | Op of Loc.t * string * expr * expr
   | Var of Loc.t * string
   | Int of Loc.t * int
   | String of Loc.t * string
@@ -18,9 +19,10 @@ and match_value =
   | MVar of Loc.t * string * ptype
   | MInt of Loc.t * int
   | MString of Loc.t * string
+  | MBool of Loc.t * string
 and ptype =
   | Type of string
-  | PType of string * (string * ptype) list
+  | PType of string * (string * ptype) list list
   | TPair of ptype * ptype
   | TUnion of ptype * ptype
   | TInter of ptype * ptype

tests/lambda/src/printer.ml

@@ -62,6 +62,7 @@ and pp_typed_aux ppf e =
       Format.fprintf ppf "Match(%a,%a)" pp_typed e pp_branches b
   | Typed.Subst(e, s) ->
       Format.fprintf ppf "Subst(%a,[%a])" pp_typed e pp_typedsigma s
+  | Typed.Op(s, i, l) -> Format.fprintf ppf "(%s, %d, " s i; (print_lst pp_typed ppf l); Format.fprintf ppf ")"
   | _ -> assert false
 
 and pp_abst ppf abstr = 

tests/lambda/tests/Makefile

+COMPILER	?= ocamlbuild
+SRCDIR		?= src
+
+RM		?= rm -f
+OUT		?= gen_test.native
+OUTDEBUG	?= gen_test.byte
+
+.PHONY: clean
+
+all:
+	$(COMPILER) -use-ocamlfind $(OUT)
+
+debug:
+	$(COMPILER) -use-ocamlfind -tag debug $(OUTDEBUG)
+
+clean:
+	$(COMPILER) -clean

tests/lambda/tests/_tags

+<src>: include
+<src/parse*>: pp(camlp4orf.opt), package(camlp4.lib)
+<src/compute*>: pp(camlp4orf.opt), package(camlp4.lib)
+<src/gen_test*>: pp(camlp4orf.opt), package(camlp4.lib)

tests/lambda/tests/src/compute.ml

+open Parse
+open Camlp4.PreCast
+
+module Rules = Map.Make(String)
+
+let rules = ref Rules.empty
+let arules = ref [||]
+
+exception Error
+
+let rec init l = match l with
+  | Rule(_, name, tokens) :: rest -> rules := Rules.add name tokens !rules;
+    arules := Array.append !arules [| name |]; init rest
+  | [] -> ()
+
+let rec is_terminal state = match state with
+  | RefRule(_) :: rest -> false
+  | _ :: rest -> is_terminal rest
+  | [] -> true
+
+let rec get_state nb = function
+  (* Fix this: If no terminal state in rule, here we choose the last one *)
+  | state :: [] -> if nb <= 0 then state else assert false
+  | state :: rest -> if (nb < 0 && not (is_terminal state)) || nb > 0
+    then get_state (nb - 1) rest else state
+  | _ -> assert false
+
+let rec g_ident nb res =
+  if nb = 0 || (res != "" && Random.int 2 = 0) then res else
+    let rand = Random.int 63 in
+    let res = res ^
+      (if rand < 26 then
+	 String.make 1 (char_of_int (int_of_char 'a' + rand))
+       else if rand < 52 then
+	 String.make 1 (char_of_int (int_of_char 'A' + rand - 26))
+       else if rand < 62 then
+	 String.make 1 (char_of_int (int_of_char '0' + rand - 52))
+       else "_"
+      )
+    in
+    g_ident (nb - 1) res
+
+let g_lident nb res =
+  if nb = 0 then res else
+    let rand = Random.int 27 in
+    let res = res ^ " " ^ (if rand = 26 then "_"
+      else String.make 1 (char_of_int (int_of_char 'a' + rand))) in
+    g_ident (nb - 1) res
+
+let g_uident nb res =
+  if nb = 0 then res else
+    let rand = Random.int 26 in
+    let res = res ^ (String.make 1 (char_of_int (int_of_char 'A' + rand))) in
+    g_ident (nb - 1) res
+
+let rec g_token n = function
+  | RefRule(loc, name) ->
+    let states =
+      try Rules.find name !rules
+      with Not_found ->
+	let l = Loc.start_line loc in
+	let cbegin = Loc.start_off loc - Loc.start_bol loc in
+	let cend = Loc.stop_off loc - Loc.start_bol loc in
+	Printf.eprintf "File %s, line %d, characters %d-%d:Unknown rule %s\n"
+	  (Loc.file_name loc) l cbegin cend name; raise Error
+    in g_states "" (max (n-1) 0) states
+  | String(_, s) -> " " ^ s ^ " "
+  | Special(loc, spe) -> match spe with
+      | "LIDENT" -> g_lident 3 ""
+      | "UIDENT" -> g_uident 3 ""
+      | "STRING" -> "\"" ^ g_ident 3 "" ^ "\""
+      | "INTEGER" -> string_of_int (Random.int 1000)
+      | _ ->
+	let l = Loc.start_line loc in
+	let cbegin = Loc.start_off loc - Loc.start_bol loc in
+	let cend = Loc.stop_off loc - Loc.start_bol loc in
+	Printf.eprintf "File %s, line %d, characters %d-%d:Unknown special keyword %s\n"
+	  (Loc.file_name loc) l cbegin cend spe; raise Error
+
+and g_tokens res n = function
+  | token :: rest -> g_tokens (res ^ (g_token n token)) n rest
+  | [] -> res
+
+and g_states res n states =
+  let max_rand = List.length states in
+  let rand = Random.int max_rand in
+  let rand = if n != 0 then rand else -1 in
+  g_tokens res n (get_state rand states