Re: [Caml-list] is it possible to embed an OCaml interpreter into an OCaml Module?

["Christoph Höger" <christoph.hoeger@tu-berlin.de>]

-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1

Thanks for the hint. I wasn't able to figure out, how MetaOCaml does
the trick, though. So, here is my solution.

The trick is to store away the old "toploop" global variable from the
Symtable module. This seems to work, although it looks a bit hacky. I
am unsure whether this works _outside_ of a toplevel. The sane way
would be to also fork Translmod and add a completely new global
variable for my interpreter, but that seems to be impossible (adding
that global variable programatically). I do not understand, why there
is no API dealing with it. Is there a deeper reason?

let toploop_id = Ident.create_persistent "Toploop"

let execute_phrase print_outcome ppf phr =
  match phr with
  | Ptop_def sstr ->
      let outer_toploop = Symtable.get_global_value toploop_id in
      let _ = Symtable.assign_global_value toploop_id (Obj.repr
toplevel_value_api) in
      let oldenv = !toplevel_env in
      Typecore.reset_delayed_checks ();
      let (str, sg, newenv) = Typemod.type_toplevel_phrase oldenv sstr in
      if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
      let sg' = Typemod.simplify_signature sg in
      ignore (Includemod.signatures oldenv sg sg');
      Typecore.force_delayed_checks ();
      let lam = Translmod.transl_toplevel_definition str in
      Warnings.check_fatal ();
      begin try
        toplevel_env := newenv;
        let res = load_lambda ppf lam in
        let out_phr =
          match res with
          | Result v ->
	     let res =
               if print_outcome then
                 Printtyp.wrap_printing_env oldenv (fun () ->
						    match str.str_items with
						    | [ { str_desc = Tstr_eval (exp, _attrs) }] ->
						       let outv = outval_of_value newenv v exp.exp_type in
						       let ty = Printtyp.tree_of_type_scheme exp.exp_type in
						       Ophr_eval (outv, ty)
						    | [] -> Ophr_signature []
						    | _ -> Ophr_signature (item_list newenv sg'))
               else Ophr_signature []
	     in Symtable.assign_global_value toploop_id outer_toploop ; res
          | Exception exn ->
	     Symtable.assign_global_value toploop_id outer_toploop ;
             toplevel_env := oldenv;
             if exn = Out_of_memory then Gc.full_major();
             let outv =
               outval_of_value !toplevel_env (Obj.repr exn)
Predef.type_exn
             in
             Ophr_exception (exn, outv)
        in
        !print_out_phrase ppf out_phr;
        begin match out_phr with
        | Ophr_eval (_, _) | Ophr_signature _ -> true
        | Ophr_exception _ -> false
        end
      with x ->
        toplevel_env := oldenv; raise x				
      end
  | Ptop_dir(dir_name, dir_arg) ->
      let d =
        try Some (Hashtbl.find directive_table dir_name)
        with Not_found -> None
      in
      begin match d with
      | None ->
          fprintf ppf "Unknown directive `%s'.@." dir_name;
          false
      | Some d ->
          match d, dir_arg with
          | Directive_none f, Pdir_none -> f (); true
          | Directive_string f, Pdir_string s -> f s; true
          | Directive_int f, Pdir_int n -> f n; true
          | Directive_ident f, Pdir_ident lid -> f lid; true
          | Directive_bool f, Pdir_bool b -> f b; true
          | _ ->
              fprintf ppf "Wrong type of argument for directive `%s'.@."
                dir_name;
              false
      end


- -- 
Christoph Höger

Technische Universität Berlin
Fakultät IV - Elektrotechnik und Informatik
Übersetzerbau und Programmiersprachen

Sekr. TEL12-2, Ernst-Reuter-Platz 7, 10587 Berlin

Tel.: +49 (30) 314-24890
E-Mail: christoph.hoeger@tu-berlin.de
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1

iEYEARECAAYFAlRXjZMACgkQhMBO4cVSGS946ACdG788ViovGE5X6j0XbuswsZ3z
uJ4An2BXxlFRMSiagkIYi9EQb0SqrHwz
=xCBd
-----END PGP SIGNATURE-----