Re: problem with ocamlmktop (contd)

[Pascal Brisset <Pascal.Brisset@wanadoo.fr>]

[-- Attachment #1: Type: text/plain, Size: 1160 bytes --]

Here is a more complete example demonstrating:

(1) destructors of global objects being called correctly on exit;
(2) translation of C++ exceptions to Caml exceptions;
(3) catching a C++ exception generated by a C++ primitive called
    through a Caml callback.

The only trick is that if you really need (3), you have to modify
libcamlrun.a (found in ocaml-1.07/byterun) as follows:

  - Insert `extern "C" {' at the beginning of interp.c and callback.c
  - Insert `}' at the end of interp.c and callback.c
  - Compile interp.c and callback.c with g++ (This will add
    ".eh_frame" sections which are required for exceptions handling):
          g++ -O -fno-defer-pop -Wall   -c interp.c -o interp.o
          g++ -O -fno-defer-pop -Wall   -c callback.c -o callback.o
  - Compile everything else normally (make libcamlrun.a)

The Makefile assumes that the modified libcamlrun.a is in
/tmp/ocaml-1.07/byterun/. This was tested with ocaml-1.07 and
g++-2.8.1. Again, things seem to have improved a lot since gcc-2.7.

- Pascal Brisset <pascal.brisset@cnet.francetelecom.fr> +33296051928 -
- France Telecom CNET DTL/MSV | 2 av Pierre Marzin | F-22307 Lannion -


[-- Attachment #2: Makefile --]
[-- Type: text/plain, Size: 271 bytes --]

LIBCAMLRUN=-cclib /tmp/ocaml-1.07/byterun/libcamlrun.a

run:
	g++ -I/usr/local/lib/ocaml -c libcell.C
	g++ -I/usr/local/lib/ocaml -c mlcell.C
	ocamlc -custom libcell.o mlcell.o cell.ml -o cell.out $(LIBCAMLRUN)
	./cell.out

clean:
	/bin/rm -f *.out *.o *.cm[io] *~ \#*\#

[-- Attachment #3: cell.ml --]
[-- Type: text/plain, Size: 963 bytes --]

module Cell = struct
  type t
  external global : unit -> t = "caml_global_cell"
  external create : int -> t = "caml_cell_create"
  external set : t -> int -> unit = "caml_cell_set"
  external get : t -> int = "caml_cell_get"

  external throw : unit -> string = "caml_cell_throw"
  external call : string -> string = "caml_cell_call"
end

let test_cell c =
  Printf.printf "c=%d\n" (Cell.get c); flush stdout;
  Printf.printf "set 42... "; flush stdout;
  Cell.set c 42;
  Printf.printf "c=%d\n" (Cell.get c); flush stdout;
  begin try
    Printf.printf "set -1... "; flush stdout;
    Cell.set c (-1);
  with e -> print_endline (Printexc.to_string e); flush stdout
  end

let _ =
  print_endline "start"; flush stdout;
  test_cell (Cell.create 271828);
  Gc.full_major (); print_newline ();
  test_cell (Cell.global ()); print_newline ()

let _ =
  Callback.register "caml-throw" Cell.throw;
  print_endline ("callback: "^Cell.call "caml-throw"); flush stdout

[-- Attachment #4: libcell.C --]
[-- Type: text/plain, Size: 345 bytes --]

#include <stdio.h>
#include "libcell.h"

Exc::Exc(const char *m) : msg(m) { } 

Cell::Cell(int init) : val(init) { printf("init %p=%d\n", this, init); }
Cell::~Cell() { printf("free %p (was %d)\n", this, val); }

void Cell::set(int x) {
  if ( x < 0 ) throw Exc("< 0");
  val = x;
}
 
int Cell::get() { return val; }

Cell global_cell(3141592);

[-- Attachment #5: libcell.h --]
[-- Type: text/plain, Size: 189 bytes --]

class Exc {
public:
  Exc(const char *m);
  const char *msg;
};

class Cell {
public:
  Cell(int);
  ~Cell();
  void set(int);
  int get();
private:
  int val;
};

extern Cell global_cell;

[-- Attachment #6: mlcell.C --]
[-- Type: text/plain, Size: 1182 bytes --]

#include <stdio.h>

extern "C" {
# include <caml/mlvalues.h>
# include <caml/alloc.h>
# include <caml/callback.h>
extern void failwith(char *s);
}

#include "libcell.h"

typedef struct {
  final_fun f;
  Cell *c;
} mlcell;

static void free_cell(value mlc) {
  delete ((mlcell*)mlc)->c;
}

static mlcell mlglobal_cell = { free_cell, &global_cell };

extern "C" value caml_global_cell(value) {
  return (value)&mlglobal_cell;
}

extern "C" value caml_cell_create(value mlv) {
  value res = alloc_final(sizeof(mlcell)/sizeof(value),
				     free_cell, 1, 1000); /* ? */
  ((mlcell*)res)->c = new Cell(Int_val(mlv));
  return res;
}
			  
extern "C" value caml_cell_set(value mlc, value mlv) {
  try { ((mlcell*)mlc)->c->set(Int_val(mlv)); }
  catch (Exc e) { failwith((char*)e.msg); }
  return Val_unit;
}

extern "C" value caml_cell_get(value mlc) {
  int v = ((mlcell*)mlc)->c->get();
  return Val_int(v);
}

extern "C" value caml_cell_throw(value) {
  throw Exc("caml_cell_throw");
}

extern "C" value caml_cell_call(value mlname) {
  value f = *caml_named_value(String_val(mlname));
  try { return callback(f, Val_unit); }
  catch (Exc e) { return copy_string((char*)e.msg); }
}