Commit 180e9317 authored by Pietro Abate's avatar Pietro Abate
Browse files

More work on delayed evaluation

parent 54af7c3b
......@@ -3,7 +3,7 @@ open Lambda
type env = {
cu: Compunit.t option; (* None: toplevel *)
vars: var_loc Env.t;
vars: var_loc Env.t; (* Id.t to var_loc *)
sigma : sigma; (* symbolic substitutions (Lambda.sigma) *)
gamma : Types.Node.t IdMap.map; (* map of type variables to types *)
stack_size: int;
......@@ -59,10 +59,18 @@ let enter_global_cu cu env x =
global_size = env.global_size + 1 }
let rec domain = function
|Identity -> []
|Identity -> Var.Set.empty
|List l -> Types.Tallying.domain l
|Comp (s1,s2) -> Var.Set.union (domain s1) (domain s2)
|Sel(_,sigma) -> (domain sigma)
|Sel(_,_,sigma) -> (domain sigma)
let fresharg =
let count = ref 0 in
function () ->
let s = Printf.sprintf "__ARG%d" !count in
incr count;
(0,U.mk s)
;;
(* from intermediate explicitely typed language to Evaluation language (lambda) *)
(* Typed -> Lambda *)
......@@ -130,9 +138,12 @@ and compile_abstr env a =
| None -> Env.empty, []
in
(* we add a nameless empty slot for the argument *)
let fun_env = Env.add (0,U.mk "") (Env 1) fun_env in
let argvar = fresharg () in
let argloc = Env 1 in
let fun_env = Env.add argvar argloc fun_env in
let (slots,nb_slots,fun_env) =
(* here deburin indexes are reshuffled *)
List.fold_left
(fun (slots,nb_slots,fun_env) x ->
match find x env with
......@@ -157,7 +168,7 @@ and compile_abstr env a =
max_stack = ref 0 }
in
let body = compile_branches env a.Typed.fun_body in
let sigma = Sel(List.map snd a.Typed.fun_iface,env.sigma) in
let sigma = Sel(argloc,a.Typed.fun_iface,env.sigma) in
let polyvars =
let vs =
List.fold_left (fun acc (t1,t2) ->
......@@ -168,10 +179,8 @@ and compile_abstr env a =
in
Var.Set.inter (domain(env.sigma)) vs
in
if Var.Set.is_empty polyvars then
Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack), false, sigma)
else
Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack), true, sigma)
let flag = Var.Set.is_empty polyvars in
Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack), flag, sigma, argloc)
and compile_branches env (brs : Typed.branches) =
(* Don't compile unused branches, because they have not been type checked. *)
......
......@@ -22,20 +22,22 @@ type var_loc =
(* Only for the toplevel *)
| Dummy
(* only TVar (polymorphic type variable) and Abstraction have
* a sigma annotation *)
type iface = (Types.descr * Types.descr) list
type sigma =
| Identity
| List of Types.Tallying.CS.sl
| Comp of (sigma * sigma)
| Sel of (Types.t list * sigma)
| Sel of (var_loc * iface * sigma)
(* only TVar (polymorphic type variable) and Abstraction have
* a sigma annotation *)
type expr =
| Var of var_loc
| TVar of (var_loc * sigma)
| Apply of expr * expr
| Abstraction of var_loc array * (Types.t * Types.t) list * branches * int * bool * sigma
(* environment, interface, branches, size of locals *)
| Abstraction of var_loc array * iface * branches * int * bool * sigma * var_loc
(* environment, interface, branches, size of locals, sigma, x *)
| Check of expr * Auto_pat.state
| Const of Value.t
| Pair of expr * expr
......
......@@ -22,19 +22,21 @@ type var_loc =
(* Only for the toplevel *)
| Dummy
(* only TVar (polymorphic type variable) and Abstraction have
* a sigma annotation *)
let iface = (Types.t * Types.t) list
type sigma =
| Identity
| List of Types.Tallying.CS.sl
| Comp of (sigma * sigma)
| Sel of (Types.t list * sigma)
| Sel of (var_loc * iface * sigma)
(* only TVar (polymorphic type variable) and Abstraction have
* a sigma annotation *)
type expr =
| Var of var_loc
| TVar of (var_loc * sigma)
| Apply of expr * expr
| Abstraction of var_loc array * (Types.t * Types.t) list * branches * int * bool * sigma
| Abstraction of var_loc array * iface * branches * int * bool * sigma * var_loc
(* environment, interface, branches, size of locals *)
| Check of expr * Auto_pat.state
| Const of Value.t
......
......@@ -65,7 +65,7 @@ let tag_const = Obj.tag (Obj.repr (Const (Obj.magic 0)))
let apply_sigma sigma = function
|Value.Pair(v1,v2,sigma') -> Value.Pair(v1,v2,Value.Comp(sigma,sigma'))
|Value.Abstraction(sI,f,sigma') -> Value.Abstraction(sI,f,Value.Comp(sigma,sigma'))
|Value.Abstraction(iface,f,sigma') -> Value.Abstraction(iface,f,Value.Comp(sigma,sigma'))
|Value.Xml(v1,v2,v3,sigma') -> Value.Xml(v1,v2,v3,Value.Comp(sigma,sigma'))
|Value.XmlNs(v1,v2,v3,ns,sigma') -> Value.XmlNs(v1,v2,v3,ns,Value.Comp(sigma,sigma'))
|Value.Record(m,sigma') -> Value.Record(m,Value.Comp(sigma,sigma'))
......@@ -76,19 +76,16 @@ let rec eval_sigma env locals = function
|Lambda.Comp(s1,s2) -> Value.Comp(eval_sigma env locals s1,eval_sigma env locals s2)
|Lambda.Identity -> Value.Identity
|Lambda.List l -> Value.List l
|Lambda.Sel(sI,sigma) -> Value.Sel(sI,eval_sigma env locals sigma)
|Lambda.Sel(x,iface,sigma) -> Value.Sel(1,iface,eval_sigma env locals sigma)
(* env is an array implementing de bruines indexes *)
(* Evaluation rules : Lamda -> Value *)
(* Evaluation rules : Lambda -> Value *)
let rec eval env locals = function
| Var ((Global _ | Ext _ | External _ | Builtin _) as x) as e ->
let v = eval_var env locals x in
Obj.set_field (Obj.repr e) 0 (Obj.repr v);
Obj.set_tag (Obj.repr e) tag_const;
v
(* variable evaluation will be split in PEnv and Env.
* PEnv and Env belong to the runtime lambda language
* from the parsing ast + typing information *)
| Var x -> eval_var env locals x
| TVar (x,sigma) -> (* delayed sigma application *)
let sigma' = eval_sigma env locals sigma in
......@@ -97,7 +94,7 @@ let rec eval env locals = function
let v1 = eval env locals e1 in
let v2 = eval env locals e2 in
eval_apply v1 v2
| Abstraction (slots,iface,body,lsize,flag,sigma) ->
| Abstraction (slots,iface,body,lsize,flag,sigma,x) ->
let sigma' = eval_sigma env locals sigma in
eval_abstraction env locals slots iface body lsize sigma'
| Const c -> c
......@@ -141,13 +138,13 @@ let rec eval env locals = function
| Check (e,d) -> eval_check env locals e d
and eval_check env locals e d =
Explain.do_check d (eval env locals e)
Explain.do_check env d (eval env locals e)
and eval_abstraction env locals slots iface body lsize sigma =
let clousure = Array.map (eval_var env locals) slots in
let f arg = eval_branches clousure (Array.create lsize Value.Absent) body arg in
let env = Array.map (eval_var env locals) slots in
let f arg = eval_branches env (Array.create lsize Value.Absent) body arg in
let a = Value.Abstraction (Some iface,f,sigma) in
clousure.(0) <- a;
env.(0) <- a;
a
and eval_apply f arg = match f with
......@@ -155,13 +152,13 @@ and eval_apply f arg = match f with
| _ -> assert false
and eval_branches env locals brs arg =
(* \Epsilon, x -> v0 *)
env.(1) <- arg;
let (code, bindings) = Run_dispatch.run_dispatcher brs.brs_disp arg in
let (code, bindings) = Run_dispatch.run_dispatcher env brs.brs_disp arg in
match brs.brs_rhs.(code) with
| Auto_pat.Match (n,e) ->
Array.blit bindings 0 locals brs.brs_stack_pos n;
eval env locals e
(* copy n elements from bindings into locals starting
* from position brs.brs_stack_pos *)
Array.blit bindings 0 locals brs.brs_stack_pos n;
eval env locals e
| Auto_pat.Fail -> Value.Absent
and eval_ref env locals e t =
......@@ -271,7 +268,8 @@ let eval_toplevel = function
| Eval (e,lsize) -> ignore (expr e lsize)
| LetDecls (e,lsize,disp,n) ->
let v = expr e lsize in
let (_, bindings) = Run_dispatch.run_dispatcher disp v in
(* XXX Env.empty ??? *)
let (_, bindings) = Run_dispatch.run_dispatcher Env.empty disp v in
ensure globs (!nglobs + n);
Array.blit bindings 0 !globs !nglobs n;
nglobs := !nglobs + n
......@@ -294,7 +292,8 @@ let eval_unit globs nglobs = function
| Eval (e,lsize) -> ignore (expr e lsize)
| LetDecls (e,lsize,disp,n) ->
let v = expr e lsize in
let (_, bindings) = Run_dispatch.run_dispatcher disp v in
(* XXX Env.empty ??? *)
let (_, bindings) = Run_dispatch.run_dispatcher Env.empty disp v in
Array.blit bindings 0 globs !nglobs n;
nglobs := !nglobs + n
| LetDecl (e,lsize) ->
......
......@@ -18,7 +18,4 @@ val eval_var: var_loc -> t
val eval_unit: Value.t array -> code_item list -> unit
val eval_apply: Value.t -> Value.t -> Value.t
......@@ -125,25 +125,25 @@ let rec simplify = function
| x :: l -> (try [ x; List.find is_xml l ] with Not_found -> [ x ])
| [] -> assert false
let check d v =
let check env d v =
if (d.fail_code < 0) then ()
else
let (code,_) = Run_dispatch.run_dispatcher d v in
let (code,_) = Run_dispatch.run_dispatcher env d v in
if code == d.fail_code then (ignore (run_disp [] d v); assert false)
let explain d v =
try check d v; None
let explain env d v =
try check env d v; None
with Failed p -> Some p
let do_check d v =
try check d v; v
let do_check env d v =
try check env d v; v
with Failed p ->
let p = simplify p in
let s = print_to_string print p in
raise (CDuceExn (string_latin1 s))
let check_failure d v =
try check d v; v
let check_failure env d v =
try check env d v; v
with Failed p ->
let p = simplify p in
let s = print_to_string print p in
......
......@@ -181,37 +181,39 @@ let rec run_disp_basic v f = function
(* apply sigma to a value *)
let (@@) v sigma =
if sigma = Value.Identity then v else
match v with
|Value.Pair (v1,v2,Value.Identity) -> Value.Pair (v1,v2,sigma)
|Pair (v1,v2,s) -> Value.Pair (v1,v2,Value.Comp(sigma,s))
|Xml (v1,v2,v3,Value.Identity) -> Value.Xml (v1,v2,v3,sigma)
|Xml (v1,v2,v3,s) -> Xml (v1,v2,v3,Value.Comp(sigma,s))
|XmlNs (v1,v2,v3,a,Value.Identity) -> Value.XmlNs (v1,v2,v3,a,sigma)
|XmlNs (v1,v2,v3,a,s) -> Value.XmlNs (v1,v2,v3,a,Value.Comp(sigma,s))
|Record (r,Value.Identity) -> Value.Record (r,sigma)
|Record (r,s) -> Value.Record (r,Value.Comp(sigma,s))
|Abstraction (iface,t,Value.Identity) -> Value.Abstraction (iface,t,sigma)
|Abstraction (iface,t,s) -> Value.Abstraction (iface,t,Value.Comp(sigma,s))
|_ -> v
let open Value in
if sigma = Identity then v else
let comp = function
|Identity,s | s,Identity -> s
|s1,s2 -> Comp(s1,s2)
in
match v with
|Pair (v1,v2,s) -> Pair (v1,v2,comp(sigma,s))
|Xml (v1,v2,v3,s) -> Xml (v1,v2,v3,comp(sigma,s))
|XmlNs (v1,v2,v3,a,s) -> XmlNs (v1,v2,v3,a,comp(sigma,s))
|Record (r,s) -> Record (r,comp(sigma,s))
|Abstraction (iface,t,s) -> Abstraction (iface,t,comp(sigma,s))
|_ -> v
let rec eval_sigma env = function
|Value.Identity -> []
|Value.List l -> l
|Value.Comp(s1,s2) -> (eval_sigma env s1) @ (eval_sigma env s2)
|Value.Sel(sI,sigma) ->
let rec eval_sigma env =
let open Value in function
|Identity -> []
|List l -> l
|Comp(s1,s2) -> (eval_sigma env s1) @ (eval_sigma env s2)
|Sel(x,iface,sigma) ->
List.fold_left (fun acc sigma_j ->
(* we always put the argument in env(1) and we call eval only with
* a clousure from an abstraction *)
if List.exists (fun s_i ->
inzero env env.(1) (Types.Tallying.(s_i @@ sigma_j))
) sI
then sigma_j::acc
else acc
let exists_sub =
List.exists (fun (_,s_i) ->
inzero env env.(x) (Types.Tallying.(s_i @@ sigma_j))
) iface
in
if exists_sub then sigma_j::acc else acc
) [] (eval_sigma env sigma)
and inzero env v t = match v with (* XXX I should chech p1(t) and p2(t) or \Omega *)
| Value.Pair (v1,v2,sigma) -> (inzero env (v1 @@ sigma) t) && (inzero env (v2 @@ sigma) t)
and inzero env v t =
let open Value in
match v with (* XXX I should chech p1(t) and p2(t) or \Omega *)
| Pair (v1,v2,sigma) -> (inzero env (v1 @@ sigma) t) && (inzero env (v2 @@ sigma) t)
| XmlNs (v1,v2,v3,_,sigma)
| Xml (v1,v2,v3,sigma) -> (inzero env (v1 @@ sigma) t) && (inzero env ((Pair (v2,v3,sigma)) @@ sigma) t)
| Record (r,sigma) -> true (* XXX !!!! apply sigma here *)
......@@ -224,23 +226,22 @@ and inzero env v t = match v with (* XXX I should chech p1(t) and p2(t) or \Omeg
) (eval_sigma env sigma)
| _ -> true
let rec run_dispatcher d v =
let rec run_dispatcher env d v =
(* Format.fprintf Format.std_formatter "Matching (%a) with:@." Value.print v;
Patterns.Compile.print_dispatcher Format.std_formatter d; *)
match d.actions with
| AIgnore r -> make_result_basic v r
| AKind k -> run_disp_kind k v
| AKind k -> run_disp_kind env k v
and run_disp_kind actions v =
and run_disp_kind env actions v =
let open Value in
match v with
| Value.Pair (v1,v2,sigma) -> run_disp_prod v (v1 @@ sigma) (v2 @@ sigma) actions.prod
| Xml (v1,v2,v3,sigma)
| XmlNs (v1,v2,v3,_,sigma) -> run_disp_prod v (v1 @@ sigma) ((Pair (v2,v3,sigma)) @@ sigma) actions.xml
| Record (r,sigma) -> run_disp_record 0 v r actions.record (* XXX !!!! apply sigma here *)
| String_latin1 (i,j,s,q) -> (* run_disp_kind actions (Value.normalize v) *)
run_disp_string_latin1 i j s q actions
| String_utf8 (i,j,s,q) -> (* run_disp_kind actions (Value.normalize v) *)
run_disp_string_utf8 i j s q actions
| Pair (v1,v2,sigma) -> run_disp_prod env v (v1 @@ sigma) (v2 @@ sigma) actions.prod
| Xml (v1,v2,v3,sigma) | XmlNs (v1,v2,v3,_,sigma) ->
run_disp_prod env v (v1 @@ sigma) ((Pair (v2,v3,sigma)) @@ sigma) actions.xml
| Record (r,sigma) -> run_disp_record env 0 v r actions.record (* XXX !!!! apply sigma here *)
| String_latin1 (i,j,s,q) -> run_disp_string_latin1 env i j s q actions
| String_utf8 (i,j,s,q) -> run_disp_string_utf8 env i j s q actions
| Atom q -> make_result_basic v (Atoms.get_map q actions.atoms)
| Char c -> make_result_basic v (Chars.get_map c actions.chars)
| Integer i ->
......@@ -256,111 +257,111 @@ and run_disp_kind actions v =
actions.basic
| Absent ->
run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
| Concat (_,_) as v -> run_disp_kind actions (Value.normalize v)
| Concat (_,_) as v -> run_disp_kind env actions (Value.normalize v)
and run_disp_prod v v1 v2 = function
and run_disp_prod env v v1 v2 = function
| Impossible -> assert false
| TailCall d1 -> run_dispatcher d1 v1
| Ignore d2 -> run_disp_prod2 v1 v v2 d2
| TailCall d1 -> run_dispatcher env d1 v1
| Ignore d2 -> run_disp_prod2 env v1 v v2 d2
| Dispatch (d1,b1) ->
let code1 = run_dispatcher d1 v1 in
run_disp_prod2 v1 v v2 b1.(code1)
and run_disp_prod2 v1 v v2 = function
let code1 = run_dispatcher env d1 v1 in
run_disp_prod2 env v1 v v2 b1.(code1)
and run_disp_prod2 env v1 v v2 = function
| Impossible -> assert false
| Ignore r -> make_result_prod v1 v2 v r
| TailCall d2 -> run_dispatcher d2 v2
| TailCall d2 -> run_dispatcher env d2 v2
| Dispatch (d2,b2) ->
let code2 = run_dispatcher d2 v2 in
let code2 = run_dispatcher env d2 v2 in
make_result_prod v1 v2 v b2.(code2)
and run_disp_record n v fields = function
and run_disp_record env n v fields = function
| None -> assert false
| Some (RecLabel (l,d)) ->
(* TODO: get rid of this exception... *)
(try run_disp_record1 v (succ n) (Imap.find fields (Upool.int l)) fields d
with Not_found -> run_disp_record1 v n Absent fields d)
(try run_disp_record1 env v (succ n) (Imap.find fields (Upool.int l)) fields d
with Not_found -> run_disp_record1 env v n Absent fields d)
| Some (RecNolabel (some,none)) ->
let r = if (n < Imap.cardinal fields) then some else none in
match r with
| Some r -> make_result_basic v r
| None -> assert false
and run_disp_record1 v n v1 rem = function
and run_disp_record1 env v n v1 rem = function
| Impossible -> assert false
| TailCall d1 -> run_dispatcher d1 v1
| Ignore d2 -> run_disp_record2 v n v1 rem d2
| TailCall d1 -> run_dispatcher env d1 v1
| Ignore d2 -> run_disp_record2 env v n v1 rem d2
| Dispatch (d1,b1) ->
let code1 = run_dispatcher d1 v1 in
run_disp_record2 v n v1 rem b1.(code1)
and run_disp_record2 v n v1 rem = function
let code1 = run_dispatcher env d1 v1 in
run_disp_record2 env v n v1 rem b1.(code1)
and run_disp_record2 env v n v1 rem = function
| Impossible -> assert false
| Ignore r -> make_result_prod v1 Absent v r
| TailCall d2 -> run_disp_record_loop v n rem d2
| TailCall d2 -> run_disp_record_loop env v n rem d2
| Dispatch (d2,b2) ->
let code2 = run_disp_record_loop v n rem d2 in
let code2 = run_disp_record_loop env v n rem d2 in
make_result_prod v1 Absent v b2.(code2)
and run_disp_record_loop v n rem d =
and run_disp_record_loop env v n rem d =
match d.actions with
| AIgnore r -> make_result_basic v r
| AKind k -> run_disp_record n v rem k.record
| AKind k -> run_disp_record env n v rem k.record
and run_disp_string_latin1 i j s q actions =
if i == j then run_disp_kind actions q
and run_disp_string_latin1 env i j s q actions =
if i == j then run_disp_kind env actions q
else match actions.prod with
| Impossible -> assert false
| TailCall d1 -> run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i])
| Ignore d2 -> run_disp_string_latin1_2 i j s q d2
| Ignore d2 -> run_disp_string_latin1_2 env i j s q d2
| Dispatch (d1,b1) ->
let code1 = run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i]) in
run_disp_string_latin1_2 i j s q b1.(code1)
run_disp_string_latin1_2 env i j s q b1.(code1)
and run_disp_string_latin1_char d ch =
match d.actions with
| AIgnore r -> make_result_char ch r
| AKind k -> make_result_char ch (Chars.get_map ch k.chars)
and run_disp_string_latin1_2 i j s q = function
and run_disp_string_latin1_2 env i j s q = function
| Impossible -> assert false
| Ignore r ->
make_result_string_latin1 i j s q r
| TailCall d2 -> run_disp_string_latin1_loop i j s q d2
| TailCall d2 -> run_disp_string_latin1_loop env i j s q d2
| Dispatch (d2,b2) ->
let code2 = run_disp_string_latin1_loop i j s q d2 in
let code2 = run_disp_string_latin1_loop env i j s q d2 in
make_result_string_latin1 i j s q b2.(code2)
and run_disp_string_latin1_loop i j s q d =
and run_disp_string_latin1_loop env i j s q d =
let i = succ i in
if i == j then run_dispatcher d q else
if i == j then run_dispatcher env d q else
match d.actions with
| AIgnore r -> make_result_basic (Value.String_latin1 (i,j,s,q)) r
| AKind k -> run_disp_string_latin1 i j s q k
| AKind k -> run_disp_string_latin1 env i j s q k
and run_disp_string_utf8 i j s q actions =
if Utf8.equal_index i j then run_disp_kind actions q
and run_disp_string_utf8 env i j s q actions =
if Utf8.equal_index i j then run_disp_kind env actions q
else
match actions.prod with
| Impossible -> assert false
| TailCall d1 -> run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i))
| Ignore d2 -> run_disp_string_utf8_2 i j s q d2
| Ignore d2 -> run_disp_string_utf8_2 env i j s q d2
| Dispatch (d1,b1) ->
let code1 = run_disp_string_utf8_char d1 (Chars.V.mk_int (Utf8.get s i)) in
run_disp_string_utf8_2 i j s q b1.(code1)
run_disp_string_utf8_2 env i j s q b1.(code1)
and run_disp_string_utf8_char d ch =
match d.actions with
| AIgnore r -> make_result_char ch r
| AKind k -> make_result_char ch (Chars.get_map ch k.chars)
and run_disp_string_utf8_2 i j s q = function
and run_disp_string_utf8_2 env i j s q = function
| Impossible -> assert false
| Ignore r ->
make_result_string_utf8 i j s q r
| TailCall d2 -> run_disp_string_utf8_loop i j s q d2
| TailCall d2 -> run_disp_string_utf8_loop env i j s q d2
| Dispatch (d2,b2) ->
let code2 = run_disp_string_utf8_loop i j s q d2 in
let code2 = run_disp_string_utf8_loop env i j s q d2 in
make_result_string_utf8 i j s q b2.(code2)
and run_disp_string_utf8_loop i j s q d =
and run_disp_string_utf8_loop env i j s q d =
let i = Utf8.advance s i in
if Utf8.equal_index i j then run_dispatcher d q else
if Utf8.equal_index i j then run_dispatcher env d q else
match d.actions with
| AIgnore r -> make_result_basic (Value.String_utf8 (i,j,s,q)) r
| AKind k -> run_disp_string_utf8 i j s q k
| AKind k -> run_disp_string_utf8 env i j s q k
let run_dispatcher d v =
let code = run_dispatcher d v in
let run_dispatcher env d v =
let code = run_dispatcher env d v in
cursor := 0;
(code,!buffer)
open Ident
open Encodings
type iface = (Types.t * Types.t) list
type sigma =
| List of Types.Tallying.CS.sl
| Comp of (sigma * sigma)
| Sel of (Types.t list * sigma)
| Sel of (int * iface * sigma)
| Identity
and t =
......
open Ident
open Encodings
type iface = (Types.t * Types.t) list
type sigma =
| List of Types.Tallying.CS.sl
| Comp of (sigma * sigma)
| Sel of (Types.t list * sigma)
| Sel of (int * iface * sigma)
| Identity
and t =
......
......@@ -22,8 +22,8 @@ INEXTFILES = misc/custom.ml misc/encodings.ml misc/upool.ml misc/ns.ml\
EXTFILES = $(INEXTFILES:%=$(ROOTDIR)/%)
RM ?= rm -f
OUT ?= lambdaTests.native typedTests.native
OUTDEBUG ?= lambdaTests.byte typedTests.byte
OUT ?= valueTests.native lambdaTests.native typedTests.native
OUTDEBUG ?= valueTests.native lambdaTests.byte typedTests.byte
.PHONY: clean _import tests
......
open OUnit2
open Camlp4.PreCast
(* Typed -> Lamda *)
(* Typed -> Lambda *)
let run_test_compile msg expected totest =
let aux str =
try
let expr = Parse.ExprParser.of_string_no_file str in
let env, texpr = Compute.to_typed expr in
Format.printf "Compted Typed -> %s%!@." (Printer.typed_to_string texpr);
let lambdaexpr = Compile.compile env texpr in
Printer.lambda_to_string lambdaexpr
with
......@@ -63,6 +64,12 @@ Int
]