Re: problem with ocamlmktop (contd)

From: Pascal Brisset (Pascal.Brisset@wanadoo.fr)
Date: Fri Oct 30 1998 - 18:56:38 MET


From: Pascal Brisset <Pascal.Brisset@wanadoo.fr>
Date: Fri, 30 Oct 1998 18:56:38 +0100 (MET)
To: Thierry Bravier <thierry.bravier@dassault-aviation.fr>
Subject: Re: problem with ocamlmktop (contd)
In-Reply-To: <13881.37437.266875.483207@lsun162>
        <19981015192243.14795@pauillac.inria.fr>

--QQVnq0P0rj
Content-Type: text/plain; charset=us-ascii
Content-Transfer-Encoding: 7bit

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 -

--QQVnq0P0rj
Content-Type: text/plain
Content-Description: Makefile
Content-Disposition: inline;
        filename="Makefile"
Content-Transfer-Encoding: 7bit

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] *~ \#*\#

--QQVnq0P0rj
Content-Type: text/plain
Content-Description: cell.ml
Content-Disposition: inline;
        filename="cell.ml"
Content-Transfer-Encoding: 7bit

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

--QQVnq0P0rj
Content-Type: text/plain
Content-Description: libcell.C
Content-Disposition: inline;
        filename="libcell.C"
Content-Transfer-Encoding: 7bit

#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);

--QQVnq0P0rj
Content-Type: text/plain
Content-Description: libcell.h
Content-Disposition: inline;
        filename="libcell.h"
Content-Transfer-Encoding: 7bit

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;

--QQVnq0P0rj
Content-Type: text/plain
Content-Description: mlcell.C
Content-Disposition: inline;
        filename="mlcell.C"
Content-Transfer-Encoding: 7bit

#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); }
}

--QQVnq0P0rj--



This archive was generated by hypermail 2b29 : Sun Jan 02 2000 - 11:58:16 MET