Commit 3ed45960 authored by Francois Bobot's avatar Francois Bobot

register : reimplementation factorisee

parent 0177bc23
......@@ -26,6 +26,9 @@ type 'a value = env option -> clone option -> 'a
type 'a registered = {mutable value : 'a value;
generate : unit -> 'a value;
tag : int}
let cl_tag cl = cl.cl_tag
let c = ref (-1)
let create gen =
......@@ -46,30 +49,22 @@ let memo f tag h = function
let r = f x in
Hashtbl.add h t r;
r
let store f = create (fun () ->
let value = f () in
fun _ _ -> value)
let store_env f =
let f env =
let v = f env in
fun cl -> v in
let f () =
let memo_t = Hashtbl.create 7 in
memo f env_tag memo_t in
create f
let cl_tag cl = cl.cl_tag
let store_clone f =
let f env =
let memo_t = Hashtbl.create 7 in
memo (f env) cl_tag memo_t in
let f () =
let memo_t = Hashtbl.create 7 in
memo f env_tag memo_t in
create f
let memo0 tag f =
let memo_t = Hashtbl.create 7 in
memo f tag memo_t
let unused0 f = fun _ -> f
let store0 memo_env memo_cl f =
let gen () =
let f2 = memo_env (f ()) in
fun env -> memo_cl (f2 env) in
create gen
let store f = store0 unused0 unused0 f
let store_env f = store0 (memo0 env_tag) unused0 f
let store_clone f = store0 (memo0 env_tag) (memo0 cl_tag) f
let apply0 reg = reg.value
let apply_clone reg env clone = apply0 reg (Some env) (Some clone)
......
......@@ -23,8 +23,8 @@ open Trans
type 'a registered
val store : (unit -> 'a) -> 'a registered
val store_env : (env -> 'a) -> 'a registered
val store_clone : (env -> clone -> 'a) -> 'a registered
val store_env : (unit -> env -> 'a) -> 'a registered
val store_clone : (unit -> env -> clone -> 'a) -> 'a registered
exception ArgumentNeeded
val apply0 : 'a registered -> env option -> clone option -> 'a
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment