CLOS and ML?

CLOS and ML?

[David McClain]

I have been missing CLOS sooo much that I decided to give it a try in OCAML.
It turns out that to first order, one can quite readily acheive multi-method
dispatch using ML-like languages (see below...) Of course it would be far
more convenient if this were an inherent part of the language. I have
thought briefly about making a front-end that would accept an extended
syntax incorporating some notion of multi-methods and having it translate to
standard OCAML as a result. This would alleviate all runtime dispatching
except for those cases where a possibly ambiguous data type is acted upon.

Is there any reason not to make CLOS-like behavior (e.g., STklos, CLOS,
Dylan) in an ML language?

- DM

(* -------------------------------------------------------------------------
------------------- *)
(* gf.ml -- CLOS Generic Functions with Multimethod Dispatch for OCAML *)
(* DM/MCFA  07/99 *)

type user_type = {ut_super : user_type option;
    ut_iflds : string list;
    ut_cflds : (string * opnd ref) list}

and user_instance = user_type * opnd list ref

and opnd =
    FLOAT  of float
  | INT    of int
  | LIST   of opnd list
  | ARRAY  of opnd array
  | STRING of string
  | CHAR   of char
  | BOOL   of bool
  | NIL
  | USER   of user_instance

type opnd_type =
    TCHAR
  | TSTRING
  | TINT
  | TFLOAT
  | TBOOL
  | TLIST
  | TARRAY
  | TTOP
  | TSEQUENCE
  | TNUMBER
  | TNULL
  | TUSER of user_type

let type_of = function
    INT _     -> TINT
  | FLOAT _   -> TFLOAT
  | CHAR _    -> TCHAR
  | STRING _  -> TSTRING
  | BOOL _    -> TBOOL
  | LIST _    -> TLIST
  | ARRAY _   -> TARRAY
  | NIL       -> TNULL
  | USER(t,_) -> TUSER(t)

type gf_method_function =
    FUNARY  of (opnd -> gf_method list -> opnd)
  | FBINARY of (opnd -> opnd -> gf_method list -> opnd)
  | FAPPLY  of (opnd list -> gf_method list -> opnd)

and gf_method = {gf_sig  : opnd_type list;
   gf_spec : int list;
   gf_fn   : gf_method_function}

type 'a tree =
    LEAF  of 'a                 (* real, instantiable *)
  | RNODE of 'a * 'a tree list  (* real, instantiable *)
  | VNODE of 'a * 'a tree list  (* virtual, not instantiable *)

let type_tree =
  VNODE(TTOP,
 [LEAF TBOOL;
  LEAF TCHAR;
  VNODE(TNUMBER,
        [LEAF TINT;
  LEAF TFLOAT]);
  VNODE(TSEQUENCE,
        [RNODE(TLIST,
        [LEAF TNULL]);
  LEAF TARRAY;
  LEAF TSTRING])])

let cpl_of_type t =
  match t with
      TUSER t' ->
 let rec scan = function
     {ut_super = None}    -> [TTOP]
   | {ut_super = Some t'} -> (TUSER t') :: scan t'
 in
   t :: scan t'
    | _ ->
 let rec augment t' subtrees =
   List.fold_left
     (fun rslt subtree ->
        match (rslt,scan subtree) with
     (_,None) -> rslt
   | (None,Some lst) -> Some(t' :: lst)
   | _ -> failwith "invalid type-tree")
     None subtrees
 and scan = function
     LEAF t' ->
       if t == t' then Some [t] else None
   | VNODE(t',subtrees) ->
       augment t' subtrees
   | RNODE(t',subtrees) ->
       if t == t' then Some [t] else augment t' subtrees
 in
   match scan type_tree with
       None     -> failwith "type not instantiable"
     | Some lst -> List.rev lst

let cpl_of_arg arg =
  cpl_of_type (type_of arg)

let gf_apply {gf_fn = fn} args next_methods =
  match fn with
      FUNARY fn' ->
 fn' (List.hd args) next_methods
    | FBINARY fn' ->
 fn' (List.hd args) (List.nth args 1) next_methods
    | FAPPLY fn'  ->
 fn' args next_methods

let call_next_method args = function
    [] -> failwith "no next method"
  | h::t -> gf_apply h args t

(* ------------------------------------------------- *)
let say str =
  print_string str;
  print_newline()

class type generic_function_type =
      object
 method add_method :
   opnd_type list -> gf_method_function -> unit
 method call :
   opnd list -> opnd
 method methods :
   unit -> gf_method list
 method applicable_methods :
   opnd list -> gf_method list
 method remove_sig :
   opnd_type list -> unit
      end

class generic_function nargs : generic_function_type =
  object(self)
    val methods = ref []

    method add_method signat fnbody =
      if List.length signat != nargs then
 failwith "incommensurate gf signature"
      else
 let meth = {gf_sig  = signat;
      gf_spec =
        List.map
   (function typ ->
      List.length (cpl_of_type typ))
   signat;
      gf_fn = fnbody}
 in
   self#remove_sig signat;
   methods := meth :: !methods

    method remove_sig signat =
      methods :=
      List.fold_right
 (fun meth rslt ->
    if meth.gf_sig = signat then rslt else meth :: rslt)
 !methods []

    method methods () = !methods

    method applicable_methods args =
      let cpls = List.map cpl_of_arg args in
 Sort.list
   (fun {gf_spec = spec1} {gf_spec = spec2} ->
      spec1 > spec2)
   (List.fold_right
      (fun ({gf_sig = signat} as gf) rslt ->
  if List.for_all2 List.memq signat cpls then
    gf :: rslt
  else
    rslt)
      !methods [])

    method call args =
      if List.length args != nargs then
 failwith "gf called with incorrect arg count";
      match self#applicable_methods args with
   [] ->
     failwith "no applicable methods";
 | h :: t ->
     gf_apply h args t
  end

(* test it out... *)
let gf_add = new generic_function 2
let _ =
  List.iter
    (function (signat,fnbody) ->
       gf_add#add_method signat (FBINARY fnbody))
    [
      [TINT;TINT],      (fun (INT a) (INT b) _ ->
      INT (a + b));
      [TINT;TFLOAT],    (fun (INT a) (FLOAT b) _ ->
      FLOAT(float a +. b));
      [TFLOAT;TINT],    (fun (FLOAT a) (INT b) _ ->
      FLOAT(a +. float b));
      [TFLOAT;TFLOAT],  (fun (FLOAT a) (FLOAT b) _ ->
      FLOAT(a +. b));
      [TSTRING;TSTRING],(fun (STRING s1) (STRING s2) _ ->
      STRING(s1 ^ s2));
      [TCHAR;TSTRING],  (fun (CHAR c) (STRING s) _ ->
      STRING(String.make 1 c ^ s));
      [TSTRING;TCHAR],  (fun (STRING s) (CHAR c) _ ->
      STRING(s ^ String.make 1 c))
    ]


(* CLOS Class and Instance Objects *)

let top = { ut_super = None;
     ut_iflds = [];
     ut_cflds = [] }

let union l1 l2 =
  let weed_out l1 l2 =
    (* remove items from l1 that already exist in l2 *)
    List.filter
      (fun item ->
  not (List.mem item l2))
      l1
  in
    l2 @ weed_out l1 l2

let new_class super iflds cflds =
  let iflds' = union iflds super.ut_iflds in
  let cflds' =
    union (List.map fst cflds)
      (List.map fst super.ut_cflds)
  in
  let cflds'' =
    List.fold_right
      (fun name rslt ->
  try
    (name, ref (List.assoc name cflds)) :: rslt
  with
      Not_found ->
        (name, ref !(List.assoc name super.ut_cflds)) :: rslt)
      cflds' []
  in
    { ut_super = Some super;
      ut_iflds = iflds';
      ut_cflds = cflds'' }

let new_instance usr_class =
  USER(usr_class,
       ref (List.map
       (fun _ -> NIL)
       usr_class.ut_iflds))

let get_slot (USER(cls,slots)) name =
  let rec iiter names vals =
    match (names,vals) with
 ([],[]) -> raise Not_found
      | (nh::nt,vh::vt) ->
   if nh = name then vh else iiter nt vt
      | _ -> failwith "get_slot: invalid instance"
  in
  let rec citer = function
      [] -> raise Not_found
    | (n,vr) :: tl ->
 if n = name then !vr else citer tl
  in
    try
      iiter cls.ut_iflds !slots
    with
 Not_found ->
   citer cls.ut_cflds


let set_slot (USER(cls,slots)) name valu =
  let rec iiter names vals =
    match (names,vals) with
 ([],[]) -> raise Not_found
      | (nh::nt,vh::vt) ->
   if nh = name then
     valu :: vt
   else
     vh :: iiter nt vt
      | _ -> failwith "get_slot: invalid instance"
  in
  let rec citer = function
      [] -> raise Not_found
    | (n,vr) :: tl ->
 if n = name then
   vr := valu
 else
   citer tl
  in
    try
      slots := iiter cls.ut_iflds !slots
    with
 Not_found ->
   citer cls.ut_cflds

(* test it out... *)
let cx = new_class top ["a";"b";"c"] ["cc",INT 15]
let x  = new_instance cx
let _ =
  gf_add#add_method [TUSER(cx);TUSER(cx)]
    (FBINARY(fun (USER(cx,_) as a) (USER(cx,_) as b) _ ->
        let ans = new_instance cx in
   set_slot ans "a" (get_slot a "a");
   set_slot ans "b" (gf_add#call
         [get_slot a "b";
          get_slot b "b"]);
   set_slot ans "c" (get_slot b "c");
   ans))

Re: CLOS and ML?

[Didier.Remy]

> I have been missing CLOS sooo much that I decided to give it a try in OCAML.
> It turns out that to first order, one can quite readily acheive multi-method
> dispatch using ML-like languages (see below...) Of course it would be far
> more convenient if this were an inherent part of the language. I have
> thought briefly about making a front-end that would accept an extended
> syntax incorporating some notion of multi-methods and having it translate to
> standard OCAML as a result. This would alleviate all runtime dispatching
> except for those cases where a possibly ambiguous data type is acted upon.

What you showed is one way to compile multi-methods in Ocaml, but you turned
off the type system by using dynamic types (implemented as variant types).
An ML user would expect some typechecking, so that in particular 'message not
understood' cannot arise.

> Is there any reason not to make CLOS-like behavior (e.g., STklos, CLOS,
> Dylan) in an ML language?

Typing CLOS-like objects and classes, including polymorphism, remains an
interesting topic for research.

    -Didier