Merge branch 'master' of https://git.cduce.org/cduce

Makefile.distrib

@@ -147,7 +147,7 @@ OBJECTS = \
  \
  types/compunit.cmo types/sortedList.cmo misc/bool.cmo types/ident.cmo \
  types/intervals.cmo types/chars.cmo types/atoms.cmo types/normal.cmo \
- types/types.cmo compile/auto_pat.cmo \
+ types/var.cmo types/boolVar.cmo types/types.cmo compile/auto_pat.cmo \
  types/sequence.cmo types/builtin_defs.cmo \
  \
  runtime/value.cmo \
@@ -309,14 +309,26 @@ misc/q_symbol.cmo: misc/q_symbol.ml
 	@echo "Build $@"		  
 	$(HIDE)$(CAMLC) -c -pp camlp4orf $<
 
+types/%.cmo: types/%.ml
+	@echo "Build $@"
+	$(HIDE)$(CAMLC) -c $(INCLUDES) $<
+
 .ml.cmo:
 	@echo "Build $@"
 	$(HIDE)$(CAMLC) -c $(INCLUDES) $(SYNTAX_PARSER) $<
 
+types/%.cmx: types/%.ml
+	@echo "Build $@"
+	$(HIDE)$(CAMLOPT) $(FORPACKOPT) -c $(INCLUDES) $<
+
 .ml.cmx:
 	@echo "Build $@"
 	$(HIDE)$(CAMLOPT) $(FORPACKOPT) -c $(SYNTAX_PARSER) $(INCLUDES) $<
 
+types/%.cmi: types/%.mli
+	@echo "Build $@"
+	$(HIDE)$(CAMLC) -c $(INCLUDES) $<
+
 .mli.cmi:
 	@echo "Build $@"
 	$(HIDE)$(CAMLC) -c $(SYNTAX_PARSER) $(INCLUDES) $<

compile/compile.ml

@@ -55,6 +55,7 @@ and compile_aux env = function
       let d = Patterns.Compile.make_checker !t0 (Types.descr t) in
       Check (compile env e, d)
   | Typed.Var x -> Var (find x env)
+  | Typed.TVar x -> Var (find x env)
   | Typed.ExtVar (cu,x,_) -> Var (find_ext cu x)
   | Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
   | Typed.Abstraction a -> compile_abstr env a
@@ -121,7 +122,7 @@ and compile_abstr env a =
   let slots = Array.of_list (List.rev slots) in  
   let env = { env with vars = fun_env; stack_size = 0; max_stack = ref 0 } in
   let body = compile_branches env a.Typed.fun_body in
-  Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack))
+  Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack), true, List [[]])
 
 and compile_branches env (brs : Typed.branches) =
   (* Don't compile unused branches, because they have not been

tests/lambda/GRAMMAR

+expr = id
+| integer
+| string
+| abstr
+| expr "." expr
+| expr "," expr
+| "(" expr ")"
+| "match" expr ":" type_id "with" "|" match_value "->" expr branches
+
+(* TODO: Add the "_" special keyword *)
+abstr = "fun" id id ":" type_id params ":" type_id "->" expr
+
+match_value = id ":" type_id
+| integer
+| string
+| match_value "," match_value
+| "(" match_value ")"
+
+params = (* empty *)
+| id ":" type_id params
+
+branches = (* empty *)
+| "|" match_value "->" expr branches
+
+id = [a-z_][A-Za-z0-9_]*
+
+(* TODO: Add union and polymorphic types *)
+type_id = [A-Z][A-Za-z0-9_]*
+| (complex_type_id)
+
+complex_type_id = [A-Z][A-Za-z0-9_]*
+| complex_type_id * complex_type_id
+| complex_type_id -> complex_type_id
+
+integer = [0-9]+

tests/lambda/Makefile

+COMPILER	?= ocamlbuild
+ROOTDIR		?= ../..
+SRCDIR		?= src
+EXTDIR		?= $(SRCDIR)/externals
+
+LIBFLAGS	?= -libs nums,netstring,pcre,ulexing\
+ -lflags -I,`ocamlfind query netstring` -lflags -I,`ocamlfind query pcre`\
+ -lflags -I,`ocamlfind query ulex`
+DEBUGFLAGS	?= -cflags -g -lflags -g
+
+INEXTFILES	= misc/custom.ml misc/encodings.ml misc/upool.ml misc/ns.ml\
+ types/sortedList.ml types/ident.ml misc/html.ml types/sequence.ml\
+ types/patterns.ml parser/cduce_loc.mli parser/cduce_loc.ml typing/typed.ml\
+ types/builtin_defs.ml parser/ast.ml typing/typepat.mli typing/typepat.ml\
+ types/externals.mli types/externals.ml typing/typer.ml\
+ runtime/run_dispatch.ml runtime/explain.ml schema/schema_pcre.ml\
+ schema/schema_xml.mli schema/schema_xml.ml schema/schema_common.mli\
+ schema/schema_common.ml runtime/eval.mli runtime/eval.ml\
+ compile/compile.ml types/compunit.mli types/compunit.ml types/var.ml\
+ types/boolVar.ml misc/imap.ml types/atoms.ml types/intervals.ml\
+ types/chars.mli types/chars.ml misc/bool.mli misc/bool.ml types/types.mli\
+ misc/stats.mli misc/stats.ml types/normal.mli types/normal.ml misc/pretty.mli\
+ misc/pretty.ml types/types.ml compile/auto_pat.mli runtime/value.mli\
+ runtime/value.ml schema/schema_types.mli schema/schema_validator.mli\
+ schema/schema_builtin.mli schema/schema_builtin.ml schema/schema_validator.ml\
+ compile/lambda.ml
+EXTFILES	= $(INEXTFILES:%=$(ROOTDIR)/%)
+
+RM		?= rm -f
+OUT		?= main.native
+OUTDEBUG	?= main.byte
+
+.PHONY: clean check test _import
+
+all: _import
+	$(COMPILER) -use-ocamlfind $(LIBFLAGS) $(OUT)
+
+debug: _import
+	$(COMPILER) -use-ocamlfind $(DEBUGFLAGS) $(LIBFLAGS) $(OUTDEBUG)
+
+_import:
+	@echo -n "Copying external files..."
+	@test -d $(EXTDIR) || mkdir $(EXTDIR)
+	@cp $(EXTFILES) $(EXTDIR)
+	@echo "done"
+
+clean:
+	$(COMPILER) -clean
+	test $(EXTDIR) = "src" || test $(EXTDIR) = "." || $(RM) -r $(EXTDIR)
+
+check: test
+
+test: all
+	tests/test.sh

tests/lambda/_tags

+<src>: include
+<src/parse*>: pp(camlp4orf.opt), package(camlp4.lib)
+<src/compute*>: pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str)
+<src/main*>: pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str)
+
+<src/externals>: include
+<src/externals/schema_*>: package(pcre, netcgi2)
+<src/externals/cduce_loc*>: package(ulex), syntax(camlp4o)

tests/lambda/src/compute.ml

+open Parse
+open Typed
+open Compile
+open Camlp4.PreCast
+open Types
+open Big_int
+
+(* Gives a unique id for a name *)
+module Locals = Map.Make(String)
+
+(* To throw in case of an unbound name *)
+exception Error
+
+(* TODO: We will need a much better representation of types and a much better
+function when we'll add union types and polymorphism. *)
+let is_subtype t1 t2 = if String.compare t1 t2 = 0 then true else false
+
+let rec _to_typed env l expr =
+  (* From Camlp4 locations to CDuce locations *)
+  let loc = caml_loc_to_cduce (get_loc expr) in
+  match expr with
+    | Parse.Apply (_, 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=Types.empty; exp_descr=Apply(e1, e2) }
+    | Abstr (_, fun_name, params, return_type, body) ->
+      parse_abstr env l loc (Some(0, fun_name)) params return_type body
+    | Match (_, e, t, b) ->
+      let b = parse_branches env l t b [] in
+      let brs = { br_typ=Types.empty; br_accept=Types.empty; br_branches=b } in
+      let _, _, exp_descr = _to_typed env l e in
+      env, l, { exp_loc=loc; exp_typ=Types.empty;
+		exp_descr=Match(exp_descr, brs) }
+    | Pair (_, e1, e2) ->
+      let _, _, exp_descr1 = _to_typed env l e1 in
+      let _, _, exp_descr2 = _to_typed env l e2 in
+      env, l, { exp_loc=loc; exp_typ=Types.empty;
+		exp_descr=Pair(exp_descr1, exp_descr2) }
+    | 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
+      let index = (try Locals.find vname l with Not_found ->
+	Printf.eprintf "File %s, line %d, characters %d-%d:\nUnbound identifier %s\n"
+          (Loc.file_name origloc) line cbegin cend vname; raise Error) in
+      env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Var(index, vname) }
+    | Int (_, i) ->
+      let i = Big_int.big_int_of_int i in
+      env, l, { exp_loc=loc; exp_typ=Types.empty;
+		exp_descr=Cst(Types.Integer i) }
+    | String (_, s) ->
+      let s = Types.String (0, (String.length s) - 1, s,
+			    Types.Integer (Big_int.big_int_of_int 0)) in
+      env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Cst s }
+
+and parse_abstr env l loc fun_name params return_type body =
+  let rec _parse_abstr env l fv loc fun_name params return_type body nb =
+    let brloc = caml_loc_to_cduce (get_loc body) in
+    let empty, env, l, nfv, iface, rest = parse_iface env l params [] nb [] in
+    let node = make_node (fv @ nfv) nfv in
+    let body = if empty
+      then let _, _, body = _to_typed env l body in body
+      else let _, _, body = _parse_abstr env l (fv @ nfv) loc None rest
+	     return_type body (nb + 1) in body
+    in
+    let b = { br_loc=brloc; br_used=true; br_ghost=false; br_vars_empty=[];
+	      br_pat=node; br_body=body } in
+    let brs = { br_typ=Types.empty; br_accept=Types.empty; br_branches=[b] } in
+    let abstr = { fun_name=fun_name; fun_iface=iface; fun_body=brs;
+		  fun_typ=Types.empty; fun_fv=[] } in
+    env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Abstraction(abstr) }
+  in
+  _parse_abstr env l [] loc fun_name params return_type body 0
+
+and make_node fv nfv =
+  let d = (match nfv with
+    | el :: rest -> Patterns.Capture(el)
+    | [] -> Patterns.Dummy)
+  in
+  incr Patterns.counter;
+  { Patterns.id=(!Patterns.counter); Patterns.descr=(Types.empty, fv, d);
+    Patterns.accept=(Types.make ()); Patterns.fv=fv }
+
+and parse_iface env l params fv nb iface = match params with
+  | (_, pname, _) :: [] -> true, env, (Locals.add pname nb l),
+    (fv @ [nb, pname]), (iface @ [Types.empty, Types.empty]), []
+  | (_, pname, _) :: rest -> false, env, (Locals.add pname nb l),
+    (fv @ [nb, pname]), (iface @ [Types.empty, Types.empty]), rest
+  | [] -> true, env, l, fv, iface, []
+
+and parse_branches env l toptype brs res = match brs with
+  | (loc, p, e) :: rest ->
+    let brloc = caml_loc_to_cduce loc in
+    let t, list, br_locals, br_used = parse_match_value env l [] p toptype in
+    let line = 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
+    let _, _, br_body = _to_typed env br_locals e in
+    let fname = Loc.file_name loc in
+    let node =
+      (if not br_used then
+	  (Printf.eprintf
+	     "File %s, line %d, characters %d-%d:\nWarning: This branch is not used\n"
+	     fname line cbegin cend; make_patterns [] t)
+       else make_patterns list t) in
+    let b = { br_loc=brloc; br_used=br_used; br_ghost=false; br_vars_empty=[];
+	      br_pat=node; br_body=br_body} in
+    parse_branches env l toptype rest (res @ [b])
+  | [] -> res
+
+and make_patterns fv pattype = incr Patterns.counter;
+  { Patterns.id=(!Patterns.counter);
+    Patterns.descr=(Types.empty,Ident.IdSet.empty,pattype);
+    Patterns.accept=(Types.make()); fv=fv }
+
+and parse_match_value env l list p toptype = match p with
+  | MPair (_) -> Patterns.Dummy, list, l, false;
+  (* TODO: Allow pairs in types *)
+  | MVar (_, mname, mtype) ->
+    let lsize = Locals.cardinal l in
+    Patterns.Dummy, (list @ [lsize, mname]), Locals.add mname lsize l,
+    is_subtype toptype mtype
+  | MInt (_, i) -> Patterns.Constr(constant (Integer(big_int_of_int i))), list,
+    l, is_subtype toptype "Int"
+  | MString (_, s) -> Patterns.Constr(constant (
+    String(0,String.length s - 1,s, Integer(big_int_of_int 0)))),
+    list, l, is_subtype toptype "String"
+
+let to_typed expr =
+  let env, _, expr = _to_typed empty_toplevel Locals.empty expr in
+  env, expr

tests/lambda/src/compute.mli

+exception Error
+
+val to_typed : Parse.expr -> Compile.env * Typed.texpr

tests/lambda/src/main.ml

+open Printf
+open Parse
+open Value
+open Typed
+open Types
+open Camlp4.PreCast
+
+let load_file f =
+  let ic = open_in f in
+  let n = in_channel_length ic in
+  let s = String.create n in
+  really_input ic s 0 n;
+  close_in ic;
+  s
+
+let rec typed_to_string e = match e with
+  | Typed.Forget(e, _) -> "Forget(" ^ typed_to_string e.Typed.exp_descr ^ ")"
+  | Typed.Check(_, e, _) -> "Check(" ^ typed_to_string e.Typed.exp_descr ^ ")"
+  | Typed.Var(id, name) -> "Var(" ^ (string_of_int (Upool.int id)) ^ ", "
+    ^ (Encodings.Utf8.to_string name) ^ ")"
+  | Typed.ExtVar(_, (id, name), _) -> "ExtVar("
+    ^ (string_of_int (Upool.int id)) ^ ", " ^ (Encodings.Utf8.to_string name)
+    ^ ")"
+  | Typed.Apply(e1, e2) -> "(" ^ typed_to_string e1.Typed.exp_descr ^ ").("
+    ^ (typed_to_string e2.Typed.exp_descr) ^ ")"
+  | Typed.Abstraction(abstr) -> "Abstraction(" ^ (abst abstr) ^ ")"
+  | Typed.Cst(cst) -> const cst
+  | Typed.Pair(e1, e2) -> "(" ^ (typed_to_string e1.Typed.exp_descr) ^ ", " ^
+    (typed_to_string e2.Typed.exp_descr) ^ ")"
+  | Typed.String(_, _, s, _) -> "\"" ^ (Encodings.Utf8.to_string s) ^ "\""
+  | Typed.Match(e, b) -> "Match(" ^ (typed_to_string e.Typed.exp_descr) ^ ", "
+    ^ (branches b.Typed.br_branches) ^ ")"
+  | _ -> assert false
+
+and const cst = match cst with
+  | Types.Integer(i) -> "Integer(" ^ (Intervals.V.to_string i) ^ ")"
+  | Types.Atom(a) -> "Atom(" ^ (Atoms.V.to_string a) ^ ")"
+  | Types.Char(c) -> "Char(" ^ (string_of_int (Chars.V.to_int c)) ^ ")"
+  | Types.Pair(c1, c2) -> "(" ^ const c1 ^ ", " ^ const c2 ^ ")"
+  | Types.String(_, _, s, _) -> "\"" ^ (Encodings.Utf8.to_string s) ^ "\""
+  | _ -> assert false
+
+and abst abstr = (match abstr.Typed.fun_name with
+  | Some (id, name) -> "name:(" ^ (string_of_int (Upool.int id)) ^ ", "
+    ^ (Encodings.Utf8.to_string name) ^ "), body:["
+  | None -> "name:<none>, body:[") ^
+  (branches abstr.Typed.fun_body.Typed.br_branches) ^ "], fv:["
+  ^ (fv_to_string abstr.Typed.fun_fv) ^ "]"
+
+and branches brs = match brs with
+  | br :: [] -> "{used:" ^ (string_of_bool br.Typed.br_used) ^ "; ghost:"
+    ^ (string_of_bool br.Typed.br_ghost) ^ "; br_vars_empty:["
+    ^ (fv_to_string br.Typed.br_vars_empty) ^ "]; pat:{"
+    ^ (node br.Typed.br_pat) ^ "}; body:"
+    ^ (typed_to_string br.Typed.br_body.Typed.exp_descr) ^ "}"
+  | br :: rest -> "{used:" ^ (string_of_bool br.Typed.br_used) ^ "; ghost:"
+    ^ (string_of_bool br.Typed.br_ghost) ^ "; br_vars_empty:["
+    ^ (fv_to_string br.Typed.br_vars_empty) ^ "]; pat:{"
+    ^ (node br.Typed.br_pat) ^ "}; body:"
+    ^ (typed_to_string br.Typed.br_body.Typed.exp_descr) ^ "}, "
+    ^ (branches rest)
+  | [] -> ""
+
+and node node = "id:" ^ (string_of_int node.Patterns.id) ^ "; descr:["
+  ^ (descr node.Patterns.descr) ^ "]; fv:[" ^ (fv_to_string node.Patterns.fv)
+  ^ "]"
+
+and descr (t, fv, d) = "<type>; [" ^ (fv_to_string fv) ^ "]; " ^ descr2 d
+
+and descr2 d = match d with
+  | Patterns.Constr(t) -> "<type>"
+  | Patterns.Cup(d1, d2) -> "Cup(" ^ (descr d1) ^ ", " ^ (descr d2) ^ ")"
+  | Patterns.Cap(d1, d2) -> "Cap(" ^ (descr d1) ^ ", " ^ (descr d2) ^ ")"
+  | Patterns.Times(n1, n2) -> "Times(" ^ (node n1) ^ ", " ^ (node n2) ^ ")"
+  | Patterns.Xml(n1, n2) -> "Xml(" ^ (node n1) ^ ", " ^ (node n2) ^ ")"
+  | Patterns.Record(l, n) -> "Record(" ^ (Ns.Label.string_of_tag l) ^ ", "
+    ^ (node n) ^ ")"
+  | Patterns.Capture((id, name)) -> "Capture(" ^ "<id>, "
+    ^ (Encodings.Utf8.to_string name) ^ ")"
+  | Patterns.Constant((id, name), ct) -> "Constant((" ^ "<id>, "
+    ^ (Encodings.Utf8.to_string name) ^ "), " ^ const ct ^ ")"
+  | Patterns.Dummy -> "Dummy"
+
+and fv_to_string fv = match fv with
+  | (id, name) :: [] -> "(" ^ (string_of_int (Upool.int id)) ^ ", "
+    ^ (Encodings.Utf8.to_string name) ^ ")"
+  | (id, name) :: rest -> "(" ^ (string_of_int (Upool.int id)) ^ ", "
+    ^ (Encodings.Utf8.to_string name) ^ "), " ^ (fv_to_string rest)
+  | [] -> ""
+
+let rec print_value v = match v with
+  | Value.Pair(v1, v2) -> printf "("; print_value v1; printf ", ";
+    print_value v2; printf ")"
+  | Xml(_,_,_) -> printf "Xml"
+  | XmlNs(_,_,_,_) -> printf "XmlNs"
+  | Record(_) -> printf "Record"
+  | Atom(_) -> printf "Atom"
+  | Integer(i) -> printf "%d" (Big_int.int_of_big_int i)
+  | Char(i) -> printf "Char()"
+  | Abstraction(_, _) -> printf "Abstraction()"
+  | Abstract((name, _)) -> printf "Abstract(%s)" name
+  | String_latin1(i1, i2, s, v) -> printf "String_latin1(%d, %d, %s)" i1 i2 s;
+    print_value v
+  | String_utf8(_,_,s,_) -> printf "String(%s)" s
+  | Concat(v1, v2) -> printf "Concat("; print_value v1; printf ", ";
+    print_value v2; printf ")"
+  | Absent -> printf "Absent"
+
+let str, file =
+  if Array.length Sys.argv > 1 then load_file Sys.argv.(1), Sys.argv.(1)
+  else (eprintf "Fatal error: No input file\n"; exit 1)
+in
+try
+  let expr = ExprParser.of_string str file in
+  let env, texpr = Compute.to_typed expr in
+(*  printf "%s\n" (typed_to_string texpr.exp_descr);*)
+  let evalexpr = Compile.compile_eval_expr env texpr in
+  print_value evalexpr; printf "\n"
+with
+  | Compute.Error -> exit 3
+  | Loc.Exc_located (loc, exn) ->
+    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
+    eprintf "File %s, line %d, characters %d-%d:\n" (Loc.file_name loc) l
+      cbegin cend; raise exn
+  | e -> eprintf "Runtime error.\n"; raise e

tests/lambda/src/parse.ml

+open Printf
+open Camlp4.PreCast
+
+type expr =
+  | Apply of Loc.t * expr * expr
+  | Abstr of Loc.t * fun_name * params * ptype * expr
+  | Match of Loc.t * expr * ptype * branches
+  | Pair of Loc.t * expr * expr
+  | Var of Loc.t * string
+  | Int of Loc.t * int
+  | String of Loc.t * string
+and fun_name = string
+and params = (Loc.t * string * ptype) list
+and branches = (Loc.t * match_value * expr) list
+and match_value =
+  | MPair of Loc.t * match_value * match_value
+  | MVar of Loc.t * string * ptype
+  | MInt of Loc.t * int
+  | MString of Loc.t * string
+and ptype = string
+
+module ExprParser = struct
+
+  let exp_eoi = Gram.Entry.mk "exp_eoi"
+
+    EXTEND Gram
+    GLOBAL: exp_eoi;
+
+    exp_eoi:[[e = expression; `EOI -> e]];
+
+    expression:
+      [
+	"abstr" RIGHTA
+	  [ "fun"; x = LIDENT; p = LIST1 param; ":"; t = type_id; "->";
+	    e = SELF -> Abstr(_loc, x, p, t, e)
+          | "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) ]
+      | "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) ]
+      ];
+
+    param:[[p = LIDENT; ":"; t = type_id -> _loc, p, t]];
+
+    branch:[ "branch" [ "|"; t = match_value; "->"; e = expression ->
+    _loc, t, e ]];
+
+    match_value:
+      [
+	"pair" LEFTA [ e1 = SELF; ","; e2 = SELF -> MPair(_loc, e1, e2) ]
+      | "paren" [ "("; e = SELF; ")" -> e ]
+      | "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) ]
+      ];
+
+    type_id: [ "atom_type" [ t = UIDENT -> t ]
+	     | [ "("; t = complex_type_id; ")" -> t ]];
+
+    complex_type_id: [ "complex_type" LEFTA [ t = UIDENT -> t ]
+		     | [ t1 = SELF; "*"; t2 = SELF -> t1 ^ "*" ^ t2
+		       | t1 = SELF; "->"; t2 = SELF -> t1 ^ "->" ^ t2 ]];
+
+    END;;
+
+  let of_string s file = Gram.parse_string exp_eoi (Loc.mk file) s
+end
+
+let get_loc expr = match expr with
+  | Apply (loc, _, _) -> loc
+  | Abstr (loc, _, _, _, _) -> loc
+  | Match (loc, _, _, _) -> loc
+  | Pair (loc, _, _) -> loc
+  | Var (loc, _) -> loc
+  | Int (loc, _) -> loc
+  | String (loc, _) -> loc
+
+let caml_loc_to_cduce loc =
+  `File(Loc.file_name loc), Loc.start_off loc - Loc.start_bol loc,
+  Loc.stop_off loc - Loc.start_bol loc

tests/lambda/src/parse.mli

+open Camlp4.PreCast
+
+type expr =
+  | Apply of Loc.t * expr * expr
+  | Abstr of Loc.t * fun_name * params * ptype * expr
+  | Match of Loc.t * expr * ptype * branches
+  | Pair of Loc.t * expr * expr
+  | Var of Loc.t * string
+  | Int of Loc.t * int
+  | String of Loc.t * string
+and fun_name = string
+and params = (Loc.t * string * ptype) list
+and branches = (Loc.t * match_value * expr) list
+and match_value =
+  | MPair of Loc.t * match_value * match_value
+  | MVar of Loc.t * string * ptype
+  | MInt of Loc.t * int
+  | MString of Loc.t * string
+and ptype = string
+
+module ExprParser : sig
+  val of_string : string -> string -> expr
+end
+
+val get_loc : expr -> Loc.t
+val caml_loc_to_cduce : Loc.t -> Cduce_loc.loc

tests/lambda/tests/eval/refs/abstraction_simple.ref

+Abstraction()

tests/lambda/tests/eval/refs/abstraction_simple.res

+0

tests/lambda/tests/eval/refs/apply_medium.ref

+(2, 3)

tests/lambda/tests/eval/refs/apply_medium.res

+0

tests/lambda/tests/eval/refs/apply_simple.ref

+2

tests/lambda/tests/eval/refs/apply_simple.res

+0

tests/lambda/tests/eval/refs/apply_simple_pair.ref

+(3, 2)

tests/lambda/tests/eval/refs/apply_simple_pair.res

+0

tests/lambda/tests/eval/refs/match_error_simple.ref

+File ./tests/eval/tests/match_error_simple.test, line 1, characters 49-50:
+Unbound identifier a

tests/lambda/tests/eval/refs/match_error_simple.res

+3