Here is another try. it has the drawback that classes need to be 
parametric, but it seems to work, and to be scalable (the added code is 
always the same). Of course, some syntactic sugar would help.

Tiphaine Turpin

Richard Jones a écrit :
> I only briefly read over this, but maybe the thing you want is an
> object memo.  There's a specialized one in lablgtk called GUtil.memo,
> but the basic source for it could be adapted:
>
>   class ['a] memo () = object
>     constraint 'a = #widget
>     val tbl = Hashtbl.create 7
>     method add (obj : 'a) =
>       Hashtbl.add tbl obj#get_id obj
>     method find (obj : widget) = Hashtbl.find tbl obj#get_id
>     method remove (obj : widget) = Hashtbl.remove tbl obj#get_id
>   end
>
> There's an example of using this if you search down for 'memo' on this
> page:
>
>   http://www.ocaml-tutorial.org/introduction_to_gtk
>
> Rich.
>
>   
#load "extLib.cma"

open ExtList
exception Class_cast_exception

let cast f o =
  match List.filter_map f o#supers with
    | [] -> raise Class_cast_exception
    | o' :: _ -> o'

class ['super] a = object (self : 'self)
  method supers : 'super list = [`a (self :> _ a)]
  method a = ()
end

class ['super] b = object (self : 'self)
  inherit ['super] a as a
  method supers = `b (self :> _ b) :: a#supers
  method b = ()
end

class ['super] c = object (self : 'self)
  inherit ['super] a as a
  method supers = `c (self :> _ c) :: a#supers
  method c = ()
end

class ['super] d = object (self : 'self)
  inherit ['super] b as b
  inherit ['super] c as c
  method supers =  `d (self :> _ d) :: b#supers @ c#supers
  method d = ()
end

class ['super] e = object (self : 'self)
  inherit ['super] d as d
  method supers = `e (self :> _ e) :: d#supers
  method e = ()
end

let d = (new d :> _ a)
let a : _ a = cast (function `a o -> Some o | _ -> None) d
let b : _ b = cast (function `b o -> Some o | _ -> None) d
let c : _ c = cast (function `c o -> Some o | _ -> None) d
let d : _ d = cast (function `d o -> Some o | _ -> None) d

let c = new c
let error : _ b = cast (function `b o -> Some o | _ -> None) c