Setepenre pushed to branch master at Stefan / Typer

Commits: 1a13cb32 by Pierre Delaunay at 2016-03-16T20:02:23-04:00 add new eval/lexp/pexp string

- - - - - 94117ebf by Pierre Delaunay at 2016-03-16T20:04:24-04:00 variable cascade

- - - - - d27dd338 by Pierre Delaunay at 2016-03-16T20:11:37-04:00 eval does not return ctx anymore

- - - - - 9bbc1472 by Pierre Delaunay at 2016-03-16T20:40:54-04:00 removed useless definitions

- - - - - 408e47b6 by Pierre Delaunay at 2016-03-16T20:44:38-04:00 fix double declarations

- - - - - bcc59cc4 by Pierre Delaunay at 2016-03-16T21:00:23-04:00 dbi info

- - - - - 86861d63 by Pierre Delaunay at 2016-03-16T21:11:55-04:00 lexp does not return ctx anymore

- - - - - eceb5ece by Pierre Delaunay at 2016-03-17T09:49:49-04:00 check

- - - - - 49bf1cb1 by Pierre Delaunay at 2016-03-19T17:56:51-04:00 utest check return code

- - - - - 48362db8 by Pierre Delaunay at 2016-03-19T18:07:41-04:00 Debruijn partial fix

- - - - - e502bfc8 by Pierre Delaunay at 2016-03-20T12:35:44-04:00 builtin type inference

- - - - - df91a4f1 by Pierre Delaunay at 2016-03-20T17:14:15-04:00 free var

- - - - - 96867ec2 by U-SDM-9528\Etudiants at 2016-03-21T13:31:48-04:00 merging

- - - - - 7a0bb44f by U-SDM-9528\Etudiants at 2016-03-21T13:59:33-04:00 merging (compile)

- - - - - d14e36a4 by Pierre Delaunay at 2016-03-21T14:05:35-04:00 rollback

- - - - - 015c8a70 by Pierre Delaunay at 2016-03-21T14:26:42-04:00 merged

- - - - - a3eb218d by Pierre Delaunay at 2016-03-21T14:32:59-04:00 merge with experimental branch

- - - - - 932370de by Pierre Delaunay at 2016-03-21T14:46:09-04:00 merge again

- - - - -

17 changed files:

- .gitignore - GNUmakefile - + samples/test__.typer - src/debruijn.ml - src/eval.ml - src/fmt.ml - src/grammar.ml - src/lexp.ml - src/lparse.ml - src/pexp.ml - tests/REPL.ml - tests/debug.ml - tests/eval_test.ml - tests/full_debug.ml - tests/lexp_test.ml - tests/utest_lib.ml - tests/utest_main.ml

Changes:

===================================== .gitignore ===================================== --- a/.gitignore +++ b/.gitignore @@ -18,3 +18,4 @@ manual.?? test__.ml _temp_hack test__.typer +*.orig \ No newline at end of file

===================================== GNUmakefile ===================================== --- a/GNUmakefile +++ b/GNUmakefile @@ -4,39 +4,40 @@ SRC_FILES := $(wildcard ./src/*.ml) CPL_FILES := $(wildcard ./_build/src/*.cmo) TEST_FILES := $(wildcard ./tests/*_test.ml)

+CFLAG = -cflag -rectypes -build-dir _build + # This is for windows: windows version is old -ifeq ($(OS),Windows_NT) -SHELL=C:/Windows/System32/cmd.exe -endif +

all: ityper typer debug tests

typer: - ocamlbuild src/main.byte -cflag -rectypes - mv _build/src/main.byte _build/typer # move and rename executable + ocamlbuild src/main.native $(CFLAG) + @mv _build/src/main.native _build/typer

# debug file eval debug: - ocamlbuild tests/full_debug.native -I src -cflag -rectypes - mv _build/tests/full_debug.native _build/full_debug + ocamlbuild tests/full_debug.native -I src $(CFLAG) + @mv _build/tests/full_debug.native _build/full_debug

# interactive typer ityper: - ocamlbuild tests/REPL.native -I src -cflag -rectypes - mv _build/tests/REPL.native _build/ityper + ocamlbuild tests/REPL.native -I src $(CFLAG) + @mv _build/tests/REPL.native _build/ityper

tests-build: -# ============================ -# Build tests -# ============================ - $(foreach test, $(TEST_FILES), ocamlbuild $(subst ./,,$(subst .ml,.native,$(test))) -I src -cflag -rectypes;) + # ============================ + # Build tests + # ============================ + @$(foreach test, $(TEST_FILES), ocamlbuild $(subst ./,,$(subst .ml,.native,$(test))) -I src $(CFLAG);) + @ocamlbuild tests/utest_main.native $(CFLAG) + @mv _build/tests/utest_main.native _build/tests/utests

tests-run: -# ============================ -# Run tests -# ============================ - ocamlbuild tests/utest_main.native - ./_build/tests/utest_main.native + # ============================ + # Run tests + # ============================ + @./_build/tests/utests

# Make language doc doc-tex: @@ -44,9 +45,10 @@ doc-tex:

# Make implementation doc doc-ocaml: - ocamldoc -html -d _build $(SRC_FILES) + ocamldoc -html -d _build/doc $(SRC_FILES) + +# everything is expected to be compiled in the "./_build/" folder +clean: + -rm -rf _build

-.PHONY: ityper -.PHONY: typer -.PHONY: debug -.PHONY: tests +.PHONY: ityper typer debug tests

===================================== samples/test__.typer ===================================== --- /dev/null +++ b/samples/test__.typer @@ -0,0 +1,61 @@ + + + +%a = lambda x -> +% let a1 : Nat; a1 = 2; b1 : Nat; b1 = 3; in +% a1 + b1 + x +%; + +% main = (a 2) + + +a = 2; + +Nat = inductive_ (dNat) (zero) (succ Nat); + +zero = inductive-cons Nat zero; +succ = inductive-cons Nat succ; + +one = (succ zero); +two = (succ one); +three = (succ two); + +tonum = lambda x -> case x + | (succ y) => (1 + (tonum y)) + | _ => 0 +; + +x = zero; +% main = zero; => zero(Nat[1]) +% main = x; => succ(Nat[2]) + +main = (tonum one); + + + +%================================ CALL TRACE ================================ +% size = 6 +%---------------------------------------------------------------------------- +%|+- Call: (tonum[1] zero[6]) +%|:+- Var: zero[6] +%|:+- Lambda: lambda (x: unkwn) -> case x[0]: unkwn| succ y -> 1 + (tonum[4] y[0]); | zero -> 0; +%|:|+- Case: case x[0]: unkwn| succ y -> 1 + (tonum[4] y[0]); | zero -> 0; +%|:|:+- Var: x[0] +%|:|:+- Imm: 0 +%============================================================================ + +%================================ CALL TRACE ================================ +% size = 11 +%---------------------------------------------------------------------------- +%|+- Call: (tonum[2] x[1]) +%|:+- Var: x[1] +%|:+- Lambda: lambda (x: unkwn) -> case x[0]: unkwn| succ y -> 1 + (tonum[2] y[0]); | _ -> 0; +%|:|+- Case: case x[0]: unkwn| succ y -> 1 + (tonum[2] y[0]); | _ -> 0; +%|:|:+- Var: x[0] +%|:|:+- Var: zero[6] +%|:|:+- Call: 1 + (tonum[2] y[0]) +%|:|:|+- Imm: 1 +%|:|:|+- Call: (tonum[2] y[0]) +%|:|:|:+- Var: y[0] +%|:|:|:+- Var: zero[6] +%============================================================================

===================================== src/debruijn.ml ===================================== --- a/src/debruijn.ml +++ b/src/debruijn.ml @@ -52,6 +52,7 @@ module StringMap = Map.Make (struct type t = string let compare = String.compare end) ;;

+ (* Map matching variable name and its distance in the current scope *) type scope = (int) StringMap.t (* Map<String, int>*)

@@ -136,10 +137,3 @@ let env_lookup_type ctx (v : vref) =

let env_lookup_by_index index ctx = Myers.nth index (_get_env ctx);;

- - - - - - - \ No newline at end of file

===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -20,18 +20,18 @@ * FOR A PARTICULAR PURPOSE. See the GNU General Public License for * more details. * - * You should have received a copy of the GNU General Public License along - * with this program. If not, see http://www.gnu.org/licenses/. + * You should have received a copy of the GNU General Public License along + * with this program. If not, see http://www.gnu.org/licenses/. * * --------------------------------------------------------------------------- - * + * * Description: * Simple interpreter * * --------------------------------------------------------------------------- *) - + open Util -open Lexp +open Lexp open Lparse open Myers open Sexp @@ -40,7 +40,7 @@ open Debruijn open Grammar

-let _eval_error loc msg = +let _eval_error loc msg = msg_error "eval" loc msg; raise (internal_error msg) ;; @@ -55,13 +55,13 @@ let add_call cll i = global_trace := (i, cll)::!global_trace

let reinit_call_trace () = global_trace := []

-let print_myers_list l print_fun = +let print_myers_list l print_fun = let n = (length l) - 1 in - + print_string (make_title " ENVIRONMENT "); make_rheader [(None, "INDEX"); (None, "VARIABLE NAME"); (None, "VALUE")]; print_string (make_sep '-'); - + for i = 0 to n do print_string " | "; ralign_print_int (n - i) 5; @@ -79,7 +79,7 @@ let get_function_name fname =

let get_int lxp = match lxp with - | Imm(Integer(_, l)) -> l + | Imm(Integer(_, l)) -> l | _ -> lexp_print lxp; -40 ;;

@@ -95,9 +95,9 @@ let get_rte_variable (idx: int) (l: runtime_env): lexp =

let get_rte_size (l: runtime_env): int = length l;;

-let print_rte_ctx l = print_myers_list l - (fun (n, g) -> - let _ = +let print_rte_ctx l = print_myers_list l + (fun (n, g) -> + let _ = match n with | Some m -> lalign_print_string m 12; print_string " | " | None -> print_string (make_line ' ' 12); print_string " | " in @@ -106,7 +106,7 @@ let print_rte_ctx l = print_myers_list l

let nfirst_rte_var n ctx = - let rec loop i acc = + let rec loop i acc = if i < n then loop (i + 1) ((get_rte_variable i ctx)::acc) else @@ -119,33 +119,43 @@ type value_type = lexp

(* This is an internal definition * 'i' is the recursion depth used to print the call trace *) -let rec _eval lxp ctx i: (value_type) = - - (if i > 255 then +let rec _eval lxp ctx i: (value_type) = + + (if i > 255 then raise (internal_error "Recursion Depth exceeded"));

add_call lxp i; match lxp with (* This is already a leaf *) | Imm(v) -> lxp - + (* Return a value stored in the environ *) - | Var((loc, name), idx) -> begin + | Var((loc, name), idx) as e -> begin + (* find variable binding i.e we do not want a another variable *) + let rec var_crawling expr i k = + (if k > 255 then( + lexp_print expr; print_string "\n"; flush stdout; + raise (internal_error "Variable lookup failed"))); + match expr with + | Var(_, j) -> + let p = (get_rte_variable (i + j) ctx) in + var_crawling p (i + j) (k + 1) + | _ -> expr in + try - (get_rte_variable idx ctx) - with + (var_crawling e 0 0) + with Not_found -> - print_string ("Variable: " ^ name ^ " was not found | "); + print_string ("Variable: " ^ name ^ " was not found | "); print_int idx; print_string "\n"; flush stdout; raise Not_found end - + (* this works for non recursive let *) - | Let(_, decls, inst) -> begin - (* First we _evaluate all declaration *) + | Let(_, decls, inst) -> + (* First we _evaluate all declaration then we eval the instruction *) let nctx = build_ctx decls ctx i in - (* Then we eval the body *) - _eval inst nctx (i + 1) end - + _eval inst nctx (i + 1) + (* Function call *) | Call (lname, args) -> ( (* Try to extract name *) @@ -159,49 +169,48 @@ let rec _eval lxp ctx i: (value_type) = (* + is read as a nested binary operator *) | Var((_, name), _) when name = "_+_" -> let nctx = build_arg_list args ctx i in - + let l = get_int (get_rte_variable 0 nctx) in - let r = get_int (get_rte_variable 1 nctx) in + let r = get_int (get_rte_variable 1 nctx) in Imm(Integer(dloc, l + r)) - + (* _*_ is reas as a single function with x args *) | Var((_, name), _) when name = "_*_" -> let nctx = build_arg_list args ctx i in - + let vint = (nfirst_rte_var n nctx) in let varg = List.map (fun g -> get_int g) vint in let v = List.fold_left (fun a g -> a * g) 1 varg in

Imm(Integer(dloc, v)) - + (* This is a named function call *) | Var((_, name), idx) -> (* Check if the call is a constructor call *) - + (* get function body *) let body = get_rte_variable idx ctx in - + (* Add args in the scope *) let nctx = build_arg_list args ctx i in - (* eval body *) _eval body nctx (i + 1) - + (* TODO Everything else *) (* Which includes a call to a lambda *) | _ -> Imm(String(dloc, "Funct Not Implemented"))) - + (* Lambdas have one single mandatory argument *) (* Nested lambda are collapsed then executed *) (* I am thinking about building a 'get_free_variable' to be able to *) (* handle partial application i.e build a new lambda if Partial App *) - | Lambda(_, vr, _, body) -> begin + | Lambda(_, vr, _, body) -> begin let (loc, name) = vr in (* Get first arg *) let value = (get_rte_variable 0 ctx) in let nctx = add_rte_variable (Some name) value ctx in - + (* Collapse nested lambdas *) - let rec build_body bd idx nctx = + let rec build_body bd idx nctx = match bd with | Lambda(_, vr, _, body) -> let (loc, name) = vr in @@ -211,76 +220,61 @@ let rec _eval lxp ctx i: (value_type) = let nctx = add_rte_variable (Some name) value nctx in (build_body body (idx + 1) nctx) | _ -> bd, nctx in - + let body, nctx = build_body body 1 nctx in - (* eval lambda body *) - _eval body nctx (i + 1) end - + _eval body nctx (i + 1) end + (* Inductive is a type declaration. We have nothing to eval *) | Inductive (_, _, _, _) as e -> e - + (* inductive-cons build a type too? *) | Cons (_, _) as e -> e - - (* Case *) + + (* Case *) | Case (loc, target, _, pat, dflt) -> begin - + (* Eval target *) let v = _eval target ctx (i + 1) in - - let check_ctor ctor_name type_idx = - let info = get_rte_variable type_idx ctx in - match info with - | Inductive(_, _, _, ctor_def) -> SMap.find ctor_name ctor_def - | _ -> _eval_error loc "Target is not a Constructor" in - - (* 'v' must be a constructor *) - let ctor_name, args, idx = match v with - - (* multi arg constructor are parsed as Call *) + let nctx = ctx in + + (* V must be a constructor Call *) + let ctor_name, args = match v with | Call(lname, args) -> (match lname with - | Var((_, ctor_name), idx) -> - let offset = (get_rte_size ctx) - idx - 1 in - let tidx = idx + offset in - ctor_name, args, tidx - - | _ -> _eval_error loc "Target is not a Constructor" ) - - | Cons((_, idx), (_, cname)) -> - let offset = (get_rte_size ctx) - idx - 1 in - let tidx = idx + offset in - cname, [], tidx - - | _ -> lexp_print v; + | Var((_, ctor_name), _) -> ctor_name, args + | _ -> _eval_error loc "Target is not a Constructor" ) + + | Cons((_, idx), (_, cname)) -> begin + (* retrieve type definition *) + print_int idx; + let info = get_rte_variable idx ctx in + let Inductive(_, _, _, ctor_def) = info in + try let args = SMap.find cname ctor_def in + cname, args + with + Not_found -> + _eval_error loc "Constructor does not exist" end + + | _ -> lexp_print target; print_string "\n"; + lexp_print v; print_string "\n"; _eval_error loc "Can't match expression" in - - (* Check if the constructor was defined *) - let targs = try check_ctor ctor_name idx - with Not_found -> _eval_error loc "Constructor does not exist" in - - (* Check number of args *) - let n_targs = List.length targs in - let n_args = List.length args in - (if n_targs != n_args then - _eval_error loc "Wrong number of arguments"); - + (* Check if a default is present *) - let run_default df = + let run_default df = match df with | None -> Imm(String(loc, "Match Failure")) | Some lxp -> _eval lxp ctx (i + 1) in - + let ctor_n = List.length args in - + (* Build a filter option *) let is_true key value = let (_, pat_args, _) = value in let pat_n = List.length pat_args in - if pat_n = ctor_n && ctor_name = key then + if pat_n = ctor_n && ctor_name = key then true - else + else false in - + (* Search for the working pattern *) let sol = SMap.filter is_true pat in if SMap.is_empty sol then @@ -288,54 +282,51 @@ let rec _eval lxp ctx i: (value_type) = else (* Get working pattern *) let key, (_, pat_args, exp) = SMap.min_binding sol in - + (* build context *) let nctx = List.fold_left2 (fun nctx pat cl -> match pat with - | None -> nctx + | None -> nctx | Some (_, (_, name)) -> let (_, xp) = cl in - add_rte_variable (Some name) xp nctx) - + add_rte_variable (Some name) xp nctx) + ctx pat_args args in (* eval body *) _eval exp nctx (i + 1) end

| _ -> Imm(String(dloc, "eval Not Implemented")) - + and build_arg_list args ctx i = (* _eval every args *) - let arg_val = List.map ( - fun (k, e) -> _eval e ctx (i + 1)) - args in - + let arg_val = List.map (fun (k, e) -> _eval e ctx (i + 1)) args in + (* Add args inside context *) List.fold_left (fun c v -> add_rte_variable None v c) ctx arg_val

and build_ctx decls ctx i = - match decls with - | [] -> ctx - | hd::tl -> - let (v, exp, tp) = hd in - let value = _eval exp ctx (i + 1) in - let nctx = add_rte_variable None value ctx in - build_ctx tl nctx i - + let f nctx e = + let (v, exp, tp) = e in + let value = _eval exp ctx (i + 1) in + add_rte_variable None value nctx in + + List.fold_left f ctx decls + and eval_decl ((l, n), lxp, ltp) ctx = add_rte_variable (Some n) lxp ctx - + (* Eval a declaration if a main is found it is returned *) -and eval_decls (decls: ((vdef * lexp * ltype) list)) +and eval_decls (decls: ((vdef * lexp * ltype) list)) (ctx: runtime_env): runtime_env = let rec loop decls ctx = - match decls with + match decls with | [] -> ctx - | hd::tl -> + | hd::tl -> let ((_, n), lxp, ltp) = hd in let nctx = add_rte_variable (Some n) lxp ctx in loop tl nctx in

loop decls ctx - + and print_eval_result i lxp = print_string " Out["; ralign_print_int i 2; @@ -343,27 +334,25 @@ and print_eval_result i lxp = match lxp with | Imm(v) -> sexp_print v; print_string "\n" | e -> lexp_print e; print_string "\n" - and print_call_trace () = print_string (make_title " CALL TRACE "); - + let n = List.length !global_trace in print_string " size = "; print_int n; print_string "\n"; print_string (make_sep '-'); - + let racc = List.rev !global_trace in - print_first 50 racc (fun j (i, g) -> + print_first 50 racc (fun j (i, g) -> _print_ct_tree i; print_string "+- "; print_string (lexp_to_string g); print_string ": "; lexp_print g; print_string "\n"); - + print_string (make_sep '='); ;;

-(* eval_expr *) -let eval lxp ctx = +let eval lxp ctx = try - (_eval lxp ctx 1) + _eval lxp ctx 1 with e -> ( print_rte_ctx ctx; print_call_trace ();

===================================== src/fmt.ml ===================================== --- a/src/fmt.ml +++ b/src/fmt.ml

===================================== src/grammar.ml ===================================== --- a/src/grammar.ml +++ b/src/grammar.ml

===================================== src/lexp.ml ===================================== --- a/src/lexp.ml +++ b/src/lexp.ml @@ -72,7 +72,7 @@ type ltype = lexp | Call of lexp * (arg_kind * lexp) list (* Curried call. *) | Inductive of location * label * ((arg_kind * vdef * ltype) list) * ((arg_kind * ltype) list) SMap.t - | Cons of vref * symbol + | Cons of vref * symbol (* = Type info * ctor_name*) | Case of location * lexp * ltype (* The base inductive type over which we switch. *) * (location * (arg_kind * vdef) option list * lexp) SMap.t

===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -62,16 +62,37 @@ let lexp_fatal loc msg = ;;

+module StringSet + = Set.Make (struct type t = string let compare = String.compare end) +;; + (* pretty ? * indent level * print_type? *) type print_context = (bool * int * bool)

-(* Vdef is exactly similar to Pvar but need to modify our ctx *) -let pvar_to_vdef p = p;; +(* Built-in list of types/functions *) +let lexp_builtins = [ +(* NAME | LXP *) + ("Int" , type_int); + ("Float", type_float); + ("_=_" , type_eq); (* t -> t -> bool *) + ("_+_" , iop_binary); (* int -> int -> int *) +] + +(* Make lxp context with built-in types *) +let default_lctx = + (* Empty context *) + let lctx = make_lexp_context in + + (* populate ctx *) + List.fold_left (fun ctx (name, lxp) -> + let ctx = senv_add_var name dloc ctx in + env_add_var_info (0, (dloc, name), lxp, lxp) ctx) + lctx + lexp_builtins +;;

-(* PEXP is not giving SEXP types this is why types are always unknown *)

-(* - * The main job of lexp (currently) is to determine variable name (index) +(* The main job of lexp (currently) is to determine variable name (index) * and to regroup type specification with their variable * * lexp_context is composed of two environment: senv and env. @@ -89,8 +110,13 @@ let pvar_to_vdef p = p;; * *)

+let rec lexp_parse p ctx: lexp = + _lexp_parse p ctx (0, 0)

-let rec lexp_parse (p: pexp) (ctx: lexp_context): lexp = +(* bound is used to determine if the variable require shifting + * bound = (inner_size, r_offset) + *) +and _lexp_parse (p: pexp) (ctx: lexp_context) bound: lexp = (* So I don't have to extract it *) let tloc = pexp_location p in match p with @@ -98,37 +124,42 @@ let rec lexp_parse (p: pexp) (ctx: lexp_context): lexp = | Pimm value -> Imm(value)

(* Symbol i.e identifier *) - | Pvar (loc, name) -> - (try + | Pvar (loc, name) -> begin + try (* Send Variable loc *) - let idx = senv_lookup name ctx in - make_var name idx loc; + let (isize, rof) = bound in + let idx = senv_lookup name ctx in( + if idx > isize then + (make_var name (idx - rof) loc) + else + (make_var name idx loc))

with Not_found -> (lexp_error loc ("The Variable: " ^ name ^ " was not declared"); (* Error recovery. The -1 index will raise an error later on *) - make_var name (-1) loc)) + (make_var name (-1) loc)) end

(* Let, Variable declaration + local scope *) | Plet(loc, decls, body) -> let decl, nctx = lexp_decls decls ctx in (* Body cannot modify context *) - let bdy = lexp_parse body nctx in - (* Send back old context as we exit the inner scope *) + let (_, rof) = bound in + let bound = ((List.length decl), rof) in + let bdy = _lexp_parse body nctx bound in Let(tloc, decl, bdy)

(* ->/=> *) | Parrow (kind, Some var, tp, loc, expr) -> - let nvar = pvar_to_vdef var in (* /!\ HERE *) - let ltyp = lexp_parse tp ctx in - let lxp = lexp_parse expr ctx in (* FIXME: add nvar to ctx! *) + let nvar = var in (* /!\ HERE *) + let ltyp = _lexp_parse tp ctx bound in + let lxp = _lexp_parse expr ctx bound in Arrow(kind, Some nvar, ltyp, tloc, lxp)

| Parrow (kind, None, tp, loc, expr) -> - let ltyp = lexp_parse tp ctx in - let lxp = lexp_parse expr ctx in - Arrow(kind, None, ltyp, tloc, lxp) - + let ltyp = _lexp_parse tp ctx bound in + let lxp = _lexp_parse expr ctx bound in + Arrow(kind, None, ltyp, tloc, lxp) + (* *) | Plambda (kind, var, Some ptype, body) -> (* Add argument to context *) @@ -138,10 +169,11 @@ let rec lexp_parse (p: pexp) (ctx: lexp_context): lexp = let nctx = senv_add_var vname loc ctx in let nctx = env_add_var_info (0, (loc, vname), dlxp, ltp) nctx in

- let lbody = lexp_parse body nctx in - - (* Return old context as we exit lambda scope*) - Lambda(kind, var, ltp, lbody) + let ltyp = _lexp_parse ptype nctx bound in + let (_, rof) = bound in + let bound = (1, rof) in + let lbody = _lexp_parse body nctx bound in + Lambda(kind, var, ltyp, lbody)

| Plambda (kind, var, None, body) -> let (loc, vname) = var in @@ -149,28 +181,31 @@ let rec lexp_parse (p: pexp) (ctx: lexp_context): lexp = let nctx = senv_add_var vname loc ctx in let nctx = env_add_var_info (0, (loc, vname), dlxp, dltype) nctx in

- let lbody = lexp_parse body nctx in + let (_, rof) = bound in + let bound = (1, rof) in + let lbody = _lexp_parse body nctx bound in Lambda(kind, var, UnknownType(tloc), lbody)

- | Pcall (fname, args) -> lexp_call fname args ctx + | Pcall (fname, _args) -> + lexp_call fname _args ctx bound

(* Pinductive *) | Pinductive (label, [], ctors) -> - let map_ctor = lexp_parse_constructors ctors ctx in + let map_ctor, nctx = lexp_parse_constructors ctors ctx bound in Inductive(tloc, label, [], map_ctor)

(* Pcons *) | Pcons(vr, sym) -> ( let (loc, type_name) = vr in let (_, ctor_name) = sym in - + let (isize, rof) = bound in (* An inductive type named type_name must be in the environment *) try let idx = senv_lookup type_name ctx in (* Check if the constructor exists *) (* TODO *) - Cons((vr, idx), sym) + Cons((vr, idx - rof), sym) with Not_found -> - lexp_error loc + lexp_error loc ("The inductive type: " ^ type_name ^ " was not declared"); Cons((vr, -1), sym))

@@ -178,7 +213,7 @@ let rec lexp_parse (p: pexp) (ctx: lexp_context): lexp = | Pcase (loc, target, patterns) ->

(* I need type info HERE *) - let lxp = lexp_parse target ctx in + let lxp = _lexp_parse target ctx bound in let ltp = UnknownType(loc) in

(* Read patterns one by one *) @@ -188,10 +223,9 @@ let rec lexp_parse (p: pexp) (ctx: lexp_context): lexp = | hd::tl -> let (pat, exp) = hd in (* Create pattern context *) - let (name, iloc, arg), nctx2 = - lexp_read_pattern pat exp lxp ctx in + let (name, iloc, arg), nctx = lexp_read_pattern pat exp lxp ctx in (* parse using pattern context *) - let exp = lexp_parse exp nctx2 in + let exp = _lexp_parse exp nctx bound in

if name = "_" then loop tl merged (Some exp) @@ -207,7 +241,7 @@ let rec lexp_parse (p: pexp) (ctx: lexp_context): lexp = -> UnknownType(tloc)

(* Identify Call Type and return processed call *) -and lexp_call (fname: pexp) (_args: sexp list) ctx = +and lexp_call (fname: pexp) (_args: sexp list) ctx bound = (* Process Arguments *) let pargs = List.map pexp_parse _args in

@@ -220,7 +254,7 @@ and lexp_call (fname: pexp) (_args: sexp list) ctx = | Pcons (_, (loc, nm)) -> nm, loc | _ -> raise Not_found in

- let largs, fctx = lexp_parse_all pargs ctx in + let largs, fctx = lexp_parse_all pargs ctx bound in let new_args = List.map (fun g -> (Aexplicit, g)) largs in

try @@ -239,11 +273,11 @@ and lexp_call (fname: pexp) (_args: sexp list) ctx =

(* Call to a nameless function *) with Not_found -> - let largs, fctx = lexp_parse_all pargs ctx in + let largs, fctx = lexp_parse_all pargs ctx bound in let new_args = List.map (fun g -> (Aexplicit, g)) largs in (* I think this should not modify context. * if so, funny things might happen when evaluating *) - let fname = lexp_parse fname ctx in + let fname = _lexp_parse fname ctx bound in Call(fname, new_args) end

(* Read a pattern and create the equivalent representation *) @@ -266,7 +300,7 @@ and lexp_read_pattern pattern exp target ctx: (* Create a variable containing target *) let nctx = senv_add_var name loc ctx in let nctx = env_add_var_info (0, (loc, name), target, dltype) nctx in - ("_", loc, []), nctx) + (name, loc, []), nctx)

| Ppatcons (ctor_name, args) -> let (loc, name) = ctor_name in @@ -299,7 +333,7 @@ and lexp_read_pattern_args args ctx: in loop args [] ctx

(* Parse inductive constructor *) -and lexp_parse_constructors ctors ctx = +and lexp_parse_constructors ctors ctx bound =

let make_args (args:(arg_kind * pvar option * pexp) list): (arg_kind * ltype) list * lexp_context = @@ -311,13 +345,13 @@ and lexp_parse_constructors ctors ctx = (* What does the optional Pvar do ? that expression does not exist in LEXP*) | (kind, _, exp) -> - let lxp = lexp_parse exp ctx in + let lxp = _lexp_parse exp ctx bound in loop tl ((kind, lxp)::acc) ctx end in loop args [] ctx in

let rec loop ctors merged ctx = match ctors with - | [] -> merged + | [] -> merged, ctx | hd::tl -> begin match hd with | ((loc, name), args) -> @@ -332,11 +366,6 @@ and lexp_parse_constructors ctors ctx = and lexp_decls decls ctx: (((vdef * lexp * ltype) list) * lexp_context) =

(* Merge Type info and declaration together *) - (* We use a list because order matters and Maps reorder elements *) - (* - let rec is_equal target (p:(vdef * pexp option * pexp option)): bool = - let ((_, name), _, _) = p in - if name == target then true else false in *)

(* merge with a map to guarantee uniqueness. *) let rec merge_decls (decls: (pvar * pexp * bool) list) merged acc: @@ -376,7 +405,7 @@ and lexp_decls decls ctx: (((vdef * lexp * ltype) list) * lexp_context) =

let mdecls, ord = merge_decls decls SMap.empty [] in

- (* cast map to list*) + (* cast map to list to preserve declaration order *) let decls = List.map (fun name -> let (l, inst, tp) = SMap.find name mdecls in ((l, name), inst, tp) ) ord @@ -389,44 +418,106 @@ and lexp_decls decls ctx: (((vdef * lexp * ltype) list) * lexp_context) = | ((loc, name), _, _) -> senv_add_var name loc ctx) ctx decls in

- let n_decls = List.length decls in + let n = (List.length decls) - 1 in

(* Add Variable info *) - let rec process_var_info dcl_lst _ctx acc i = + let rec process_var_info dcl_lst _ctx acc m = match dcl_lst with | [] -> (List.rev acc), _ctx | hd::tl -> match hd with | ((loc, name), Some pinst, None) ->( - let lxp, ltp = lexp_p_infer pinst _ctx in + let bound = (0, m) in + let lxp, ltp = lexp_p_infer pinst _ctx bound in let nacc = ((loc, name), lxp, ltp)::acc in - let ctx2 = env_add_var_info (n_decls - i, (loc, name), lxp, ltp) _ctx in - process_var_info tl ctx2 nacc (i + 1)) + let ctx2 = env_add_var_info (0, (loc, name), lxp, ltp) _ctx in + process_var_info tl ctx2 nacc (m - 1))

| ((loc, name), Some pinst, Some ptype) ->( - let linst = lexp_parse pinst _ctx in - let ltyp = lexp_parse ptype _ctx in + let bound = (0, m) in + let linst = _lexp_parse pinst _ctx bound in + let ltyp = _lexp_parse ptype _ctx bound in let nacc = ((loc, name), linst, ltyp)::acc in - let ctx3 = env_add_var_info (n_decls - i, (loc, name), linst, ltyp) _ctx in - process_var_info tl ctx3 nacc (i + 1)) + let ctx3 = env_add_var_info (0, (loc, name), linst, ltyp) _ctx in + process_var_info tl ctx3 nacc (m - 1))

(* Skip the variable *) - | ((loc, name), None, _) -> (lexp_warning loc ("Unused Variable: " ^ name); - process_var_info tl _ctx acc i) in + | ((loc, name), None, _) -> (lexp_warning loc "Unused Variable"; + process_var_info tl _ctx acc m) in

- let acc, ctx = process_var_info decls nctx [] 0 in + let acc, ctx = process_var_info decls nctx [] n in acc, ctx

-and lexp_parse_all (p: pexp list) (ctx: lexp_context): +and lexp_parse_all (p: pexp list) (ctx: lexp_context) bound: (lexp list * lexp_context) = let rec loop (plst: pexp list) ctx (acc: lexp list) = match plst with | [] -> ((List.rev acc), ctx) - | _ -> let lxp = lexp_parse (List.hd plst) ctx in + | _ -> let lxp = _lexp_parse (List.hd plst) ctx bound in (loop (List.tl plst) ctx (lxp::acc)) in (loop p ctx [])

(* + * Free Variables + * --------------------- *) +(** Return a list of all free variables contained in an expression lxp *) + +(* Tree Nodes that make reference to declarations are: + * Call/Var/Cons + *) + +(* free_var should use a lexp since we are going to need free_v during eval *) +and free_variable pxp = +(* Expression that can have free variables: + * - Lambda + * - Let + * - Call + * Expression that can be free variables: + * - Var/ Function (Call) *) + + let bound = StringSet.empty in (* bound variables *) + let free = ([], StringSet.empty) in (* decl order * map *) + + let rec _fv pxp (bound, free) = + match pxp with + | Plambda (_, (_, name), _, body) -> + let bound = StringSet.add name bound in + _fv body (bound, free) + + (* + | Plet (_, args, body) -> + + let bound = List.fold_left + (fun s ((_, name), _, _) -> StringSet.add name s) bound args in + _fv body bound free *) + + | Pcall (xp, lst) -> + (* check if function is declared outside *) + let (bound, free) = _fv xp (bound, free) in + let pargs = List.map pexp_parse lst in + (* check for fv inside call args *) + List.fold_left (fun a g -> _fv g a) (bound, free) pargs + + | Pvar (_, name) ->( + try let _ = StringSet.find name bound in + (bound, free) + with + Not_found ->( + let (arr, set) = free in + try let _ = StringSet.find name set in + (bound, free) + with + Not_found ->( + let set = StringSet.add name set in + let arr = name :: arr in + (bound, (arr, set))))) + | _ -> (bound, free) in + + let (bound, (afree, sfree)) = _fv pxp (bound, free) in + (bound, (List.rev afree, sfree)) + + +(* * Type Inference * --------------------- *) (* Parsing a Pexp into an Lexp is really "elaboration", i.e. it needs to @@ -446,14 +537,43 @@ and lexp_parse_all (p: pexp list) (ctx: lexp_context): * - use lexp_p_check whenever you can. *)

-and lexp_p_infer (p : pexp) (env : lexp_context) : lexp * ltype = - let lxp = lexp_parse p env in - lxp, UnknownType(dummy_location) +and lexp_p_infer (p : pexp) (env : lexp_context) bound: lexp * ltype = + + (* Parse expr *) + let tloc = pexp_location p in + let lxp = _lexp_parse p env bound in + + (* determine type *) + match lxp with + (* Trivial *) + | Imm (sxp) -> ( + match sxp with + | Integer _ -> (lxp, type_int) + | Float _ -> (lxp, type_float) + | _ -> lexp_error tloc "Could not infer type"; + (lxp, UnknownType(tloc))) + + + (* Pcall lookup fname *) + (* Pinductive *) + (* PCons return its Pinductive type *) + + (* Plambda *) + (* we need to build (t0 -> ... -> tn) *) + + (* PCase *) + (* return target type *) + + (**) + + (* dev catch all *) + | _ -> (lxp, UnknownType(dloc)) +

and lexp_p_check (p : pexp) (t : ltype) (env : lexp_context): lexp = match p with | _ - -> let (e, inferred_t) = lexp_p_infer p env in + -> let (e, inferred_t) = lexp_p_infer p env (0, 0) in (* FIXME: check that inferred_t = t! *) e (* @@ -461,7 +581,6 @@ and lexp_p_check (p : pexp) (t : ltype) (env : lexp_context): lexp = * --------------------- *)

(* Print back in CET (Close Enough Typer) easier to read *) -(* So print can be called while parsing *) and lexp_print_adv opt exp = let slexp_print = lexp_print_adv opt in (* short_lexp_print *) let (pty, indent, prtp) = opt in @@ -549,9 +668,12 @@ and lexp_print_adv opt exp = print_string "| _ -> "; slexp_print df; print_string ";"; if pty then print_string "\n"; end

+ | Builtin (tp, name, lxp) -> + print_string name; + (* debug catch all *) | UnknownType (loc) -> print_string "unkwn"; - | _ -> print_string "Printint Not Implemented" + | _ -> print_string "Printing Not Implemented"

and lexp_print_ctors opt ctors = @@ -650,7 +772,7 @@ let _lexp_expr_str (str: string) (tenv: bool array) let toks = lex tenv pretoks in let sxps = sexp_parse_all_to_list grm toks limit in let pxps = pexp_parse_all sxps in - lexp_parse_all pxps ctx + lexp_parse_all pxps ctx (0, 0) ;;

(* specialized version *)

===================================== src/pexp.ml ===================================== --- a/src/pexp.ml +++ b/src/pexp.ml @@ -353,6 +353,18 @@ and pexp_u_decls ds = let pexp_print e = sexp_print (pexp_unparse e)

+(* Parse All Pexp as a list *) +let pexp_parse_all (nodes: sexp list) = + List.map pexp_parse nodes +;; + +let pexp_parse_string (str: string) tenv grm limit = + let pretoks = prelex_string str in + let toks = lex tenv pretoks in + let sxps = sexp_parse_all_to_list grm toks limit in + pexp_parse_all sxps +;; + let pexp_decls_all (nodes: sexp list): ((pvar * pexp * bool) list) = let rec loop nodes acc = match nodes with @@ -364,20 +376,19 @@ let pexp_decls_all (nodes: sexp list): ((pvar * pexp * bool) list) = loop nodes [] ;;

-(* Parse All Pexp as a list *) -let pexp_parse_all (nodes: sexp list) = - List.map pexp_parse nodes -;; +(* String Parsing + * ------------------------ *)

-(* Pexp String - * ------------------- *) -let _pexp_expr_str (str: string) tenv grm limit = +(* Lexp helper *) +let _pexp_expr_str (str: string) (tenv: bool array) + (grm: grammar) (limit: string option) = let pretoks = prelex_string str in let toks = lex tenv pretoks in let sxps = sexp_parse_all_to_list grm toks limit in pexp_parse_all sxps ;;

+(* specialized version *) let pexp_expr_str str = _pexp_expr_str str default_stt default_grammar (Some ";") ;; @@ -390,6 +401,7 @@ let _pexp_decl_str (str: string) tenv grm limit = pexp_decls_all sxps ;;

+(* specialized version *) let pexp_decl_str str = _pexp_decl_str str default_stt default_grammar (Some ";") ;;

===================================== tests/REPL.ml ===================================== --- a/tests/REPL.ml +++ b/tests/REPL.ml @@ -116,7 +116,7 @@ let ieval_string str lctx rctx = let v, rctx = ieval_all lxps rctx in v, lctx, rctx ;; - + (* Specials commands %[command-name] *) let rec repl () = let tenv = default_stt in

===================================== tests/debug.ml ===================================== --- a/tests/debug.ml +++ b/tests/debug.ml @@ -43,7 +43,6 @@ open Lparse open Debruijn open Fmt open Grammar -open Eval

(* Print aPretokens *) let rec debug_pretokens_print pretoken =

===================================== tests/eval_test.ml ===================================== --- a/tests/eval_test.ml +++ b/tests/eval_test.ml @@ -9,6 +9,28 @@ let lctx = make_lexp_context let lctx = add_def "_+_" lctx let lctx = add_def "_*_" lctx let rctx = make_runtime_ctx +let rctx = add_rte_variable (Some "_+_") dlxp rctx +let rctx = add_rte_variable (Some "_-_") dlxp rctx + + +let _ = (add_test "EVAL" "Variable Cascade" (fun () -> + + let dcode = " + a = 10; + b = a; + c = b; + d = c;" in + + let rctx, lctx = eval_decl_str dcode lctx rctx in + + let ecode = "d;" in + + let ret = eval_expr_str ecode lctx rctx in + + match ret with + | [r] -> expect_equal_int (get_int r) 10 + | _ -> failure ()) +);;

(* Let @@ -17,7 +39,7 @@ let rctx = make_runtime_ctx let _ = (add_test "EVAL" "Let" (fun () -> (* Noise. Makes sure the correct variables are selected *) let dcode = " - c = 3; a = 1; b = 2; d = 4;" in + c = 3; e = 1; f = 2; d = 4;" in let rctx, lctx = eval_decl_str dcode lctx rctx in

let ecode = " @@ -26,7 +48,7 @@ let _ = (add_test "EVAL" "Let" (fun () -> let ret = eval_expr_str ecode lctx rctx in (* Expect a single result *) match ret with - | [r] -> expect_equal_int 30 (get_int r) + | [r] -> expect_equal_int (get_int r) 30 | _ -> failure ()) ) ;; @@ -65,25 +87,29 @@ let _ = (add_test "EVAL" "Nested Lambda" (fun () -> ;;

(* Cases + Inductive types - * ------------------------ *) (* + * ------------------------ *)

let _ = (add_test "EVAL" "Case" (fun () -> - (* Inductive type declaration *) + (* Inductive type declaration + Noisy declarations *) let code = " + i = 90;\n idt = inductive_ (idtd) (ctr0) (ctr1 idt) (ctr2 idt) (ctr3 idt);\n + j = 100;\n

- ctr0 = inductive-cons idt ctr0;\n - ctr1 = inductive-cons idt ctr1;\n - ctr2 = inductive-cons idt ctr2;\n - ctr3 = inductive-cons idt ctr2;\n + d = 10;\n + ctr0 = inductive-cons idt ctr0;\n e = 20;\n + ctr1 = inductive-cons idt ctr1;\n f = 30;\n + ctr2 = inductive-cons idt ctr2;\n g = 40;\n + ctr3 = inductive-cons idt ctr2;\n h = 50;\n

- a = (ctr1 (ctr2 ctr0));\n - b = (ctr2 (ctr2 ctr0));\n - c = (ctr3 (ctr2 ctr0));\n + x = 1;\n + a = (ctr1 (ctr2 ctr0));\n y = 2;\n + b = (ctr2 (ctr2 ctr0));\n z = 3;\n + c = (ctr3 (ctr2 ctr0));\n w = 4;\n

- test_fun = lambda x -> case x\n - | ctr1 y => 1\n - | ctr2 y => 2\n + test_fun = lambda k -> case k\n + | ctr1 l => 1\n + | ctr2 l => 2\n | _ => 3;\n" in

let rctx, lctx = eval_decl_str code lctx rctx in @@ -92,7 +118,7 @@ let _ = (add_test "EVAL" "Case" (fun () ->

(* Eval defined lambda *) let ret = eval_expr_str rcode lctx rctx in - (* Expect a 3 results *) + (* Expect 3 results *) match ret with | [a; b; c] -> let t1 = expect_equal_int (get_int a) 1 in @@ -104,19 +130,21 @@ let _ = (add_test "EVAL" "Case" (fun () -> failure () | _ -> failure ()) ) -;; *) +;; +

let _ = (add_test "EVAL" "Recursive Call" (fun () -> (* Inductive type declaration *) let code = " - Nat = inductive_ (dNat) (zero) (succ Nat); + a = 1;\n + Nat = inductive_ (dNat) (zero) (succ Nat); b = 2;\n

- zero = inductive-cons Nat zero; - succ = inductive-cons Nat succ; + zero = inductive-cons Nat zero; c = 3;\n + succ = inductive-cons Nat succ; d = 4;\n

- one = (succ zero); - two = (succ one); - three = (succ three); + one = (succ zero); e = 5;\n + two = (succ one); f = 6;\n + three = (succ three); g = 7;\n

tonum = lambda x -> case x | (succ y) => (1 + (tonum y)) @@ -124,22 +152,20 @@ let _ = (add_test "EVAL" "Recursive Call" (fun () ->

let rctx, lctx = eval_decl_str code lctx rctx in

- let rcode = "(tonum one);"in + let rcode = "(tonum zero); (tonum zero); (tonum zero);"in

(* Eval defined lambda *) let ret = eval_expr_str rcode lctx rctx in (* Expect a 3 results *) match ret with - | [a] -> expect_equal_int (get_int a) 1 - - (*| [a; b; c] -> - let t1 = expect_equal_int (get_int a) 1 in - let t2 = expect_equal_int (get_int b) 2 in - let t3 = expect_equal_int (get_int c) 3 in + | [a; b; c] -> + let t1 = expect_equal_int (get_int a) 0 in + let t2 = expect_equal_int (get_int b) 1 in + let t3 = expect_equal_int (get_int c) 2 in if t1 = 0 && t2 = 0 && t3 = 0 then success () else - failure () *) + failure () | _ -> failure ()) ) ;;

===================================== tests/full_debug.ml ===================================== --- a/tests/full_debug.ml +++ b/tests/full_debug.ml

===================================== tests/lexp_test.ml ===================================== --- a/tests/lexp_test.ml +++ b/tests/lexp_test.ml @@ -1,47 +1,64 @@ -open Lparse +open Lparse (* add_def *) open Debruijn (* make_lexp_context *) -open Lexp -open Utest_lib +open Lexp +open Utest_lib

(* default environment *) let lctx = make_lexp_context let lctx = add_def "_+_" lctx let lctx = add_def "_*_" lctx + + +let _ = (add_test "LEXP" "Built-in Inference" (fun () -> + + let dcode = "a = 10; b = 1.12;" in + + let ret, _ = lexp_decl_str dcode lctx in

-(* Check if annotation are parsed and kept *) -(* Let and top level declarations are using the same code *) -(* We only have to check if let's type parsing is correct *) -let _ = (add_test "LEXP" "Type Parsing" (fun () -> + match ret with + (* (vdef * lexp * ltype) *) + | [(_, _, Builtin(_, "Int", _)); + (_, _, Builtin(_, "Float", _))] -> + success() + + | _ -> failure ()) +);; + +open Pexp + + +let set_to_list s = + StringSet.fold (fun g a -> g::a) s [] +;; + +let _ = (add_test "LEXP" "Free Variable" (fun () ->

- (* This is garbage. I just want Nat to be defined *) let dcode = " - Nat = inductive_ (dNat) (zero) (succ Nat);\n" in - - let _, lctx = lexp_decl_str dcode lctx in + a = 2; + b = 3; + f = lambda n -> (a + n); % a is a fv + g = lambda x -> ((f b) + a + x); % f,a,b is fv + " in + + let ret = pexp_decl_str dcode in + let (_, g, _)::_ = List.rev ret in + + let (bound, free) = free_variable g in

- let ecode = " - let a : Nat; a = 1; b : Nat; b = 3; - in - a + b;" in - - let ret, _ = lexp_expr_str ecode lctx in - match ret with - | [expr] ->( - match expr with - | Let(_, arg, _) -> match arg with - | [] -> failure () - | (_, xp, tp)::_ ->( - (* tp must match Nat *) - match tp with - | Var((_, name), _) -> expect_equal_str name "Nat" - | _ -> failure () - ) + let bound = set_to_list bound in + let (free, _) = free in + + match bound with + | ["x"] ->( + match free with + | ["_+_"; "f"; "b"; "a"] -> success () | _ -> failure ()) - | [] -> failure ()) -) -;; + | _ -> failure ()

+));; +

+(* run all tests *) run_all () ;; \ No newline at end of file

===================================== tests/utest_lib.ml ===================================== --- a/tests/utest_lib.ml +++ b/tests/utest_lib.ml @@ -30,6 +30,7 @@ * * --------------------------------------------------------------------------- *)

+open Util

module StringMap = @@ -39,7 +40,7 @@ module StringMap =

type test_fun = (unit -> int) type tests = (test_fun) StringMap.t -type sections = (tests) StringMap.t +type sections = ((tests) StringMap.t) * string list

let success () = 0;; let failure () = (-1);; @@ -52,6 +53,8 @@ let failure () = (-1);; * "Lambda" - "Nested" *) let _global_sections = ref StringMap.empty +let _insertion_order = ref [] +let _ret_code = ref 0

(* USAGE *) @@ -70,35 +73,76 @@ let _global_sections = ref StringMap.empty let add_test sname tname tfun =

(* Does Section Exists ? *) - let tmap = - try + let (tmap, lst) = + try StringMap.find sname (!_global_sections) with - Not_found -> StringMap.empty in + Not_found -> + _insertion_order := sname::(!_insertion_order); + StringMap.empty, ref [] in + + try let _ = StringMap.find tname tmap in + print_string "TEST ALREADY EXISTS" + with + Not_found -> + + lst := tname::(!lst);

(* add test *) let ntmap = StringMap.add tname tfun tmap in - _global_sections := StringMap.add sname ntmap (!_global_sections); + _global_sections := StringMap.add sname (ntmap, lst) (!_global_sections); + +;; + +let unexpected_throw sk tk e = + print_string ("[ FAIL] " ^ sk ^ " - " ^ tk ^ "\n"); + match e with + | Internal_error msg -> + print_string ("[ ] UNEXPECTED THROW: " ^ msg ^ "\n") + | _ ->( + print_string "[ ] UNEXPECTED THROW: \n"; + print_string "[ ] "; + print_string (Printexc.to_string e); print_string "\n") ;;

(* Run all *) let run_all () = + _insertion_order := List.rev (!_insertion_order); + (* iter over all sections *) - StringMap.iter (fun sk sv -> + List.iter (fun sk -> + + let tmap, tst = StringMap.find sk (!_global_sections) in + tst := List.rev (!tst); + print_string ("[RUN ] " ^ sk ^ " \n"); + (* iter over all tests in the current sections *) - StringMap.iter (fun tk tv -> - (* RUN TEST*) - let r = tv () in - if r = 0 then - (print_string ("[ OK] " ^ sk ^ " - " ^ tk ^ "\n")) - else - (print_string ("[ FAIL] " ^ sk ^ " - " ^ tk ^ "\n")) + List.iter (fun tk -> + let tv = StringMap.find tk tmap in + + (* RUN TEST *) + flush stdout; + try + let r = tv () in + if r = 0 then + (print_string ("[ OK] " ^ sk ^ " - " ^ tk ^ "\n")) + else( + (print_string ("[ FAIL] " ^ sk ^ " - " ^ tk ^ "\n"); + _ret_code := failure () + )) + with e + -> _ret_code := failure (); + unexpected_throw sk tk e ) - sv; - flush stdout; + (!tst); + ) - (!_global_sections) + (!_insertion_order); + + (* return success or failure *) + exit !_ret_code +;;

let expect_equal_int value expect =

===================================== tests/utest_main.ml ===================================== --- a/tests/utest_main.ml +++ b/tests/utest_main.ml @@ -66,8 +66,10 @@ let main () = begin

tests_n := !tests_n + 1; - exit_code := Sys.command (folder ^ files.(i) ^ " " ^ root_folder); + + (if !exit_code != 0 then + failed_test := !failed_test + 1)

end) done;

View it on GitLab: https://gitlab.com/monnier/typer/compare/6cd883591bc13c03681fd31b642bc04fa55...