(* Emulating the polymorphic shift/reset using multiple prompts
   and unsafe unions, i.e., _the_ universal type Obj.t

   This code is NOT suitable for production. 

   It is only used in the expository code to get the prompts out of
   the way and pretend that we have ordinary shift/reset with effect typing.  

   Our fully developed lifting library does NOT use this code. We use
   Delimcc (multi-prompt delimited continuations), which are safe.
*)


let pp = ref (Obj.repr (Delimcc.new_prompt ()));;

(* val with_prompt : 'a Delimcc.prompt -> (unit -> 'a) -> 'a = <fun> *)
let with_prompt p thunk =
  let pold = !pp in
  let () = pp := Obj.repr p in
  let v = Delimcc.push_prompt p thunk in
  pp := pold; v
;;
  
(* Emulating the polymorphic reset *)
(* val reset : (unit -> 'a) -> 'a = <fun> *)
let reset thunk = with_prompt (Delimcc.new_prompt ()) thunk;;

(* The following can leak memory, but this is a toy example anyway.
   For a non-leaking version, we have to use push_prompt_subcont
*)
(* (('a -> 'b) -> 'b) -> 'a = <fun> *)
let shift f = 
  let p = Obj.obj !pp in
  Delimcc.take_subcont p (fun sk () ->
    with_prompt p (fun () -> (f (fun c -> 
      with_prompt p (fun () -> Delimcc.push_subcont sk (fun () -> c))))))
;;