(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

(* $Id$ *)

open Misc
open Asttypes
open Types
open Typedtree
open Lambda
open Translobj
open Translcore

(* XXX Rajouter des evenements... *)

let lfunction params body =
  match body with
    Lfunction (Curried, params', body') ->
      Lfunction (Curried, params @ params', body')
  |  _ ->
      Lfunction (Curried, params, body)

let lapply func args =
  match func with
    Lapply(func', args') ->
      Lapply(func', args' @ args)
  | _ ->
      Lapply(func, args)

let lsequence l1 l2 =
  if l2 = lambda_unit then l1 else Lsequence(l1, l2)

let transl_label l = Lconst (Const_base (Const_string l))

let rec transl_meth_list lst =
  Lconst
    (List.fold_right
       (fun lab rem -> Const_block (0, [Const_base (Const_string lab); rem]))
       lst (Const_pointer 0))

let set_inst_var obj id expr =
  let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in
  Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr])

let copy_inst_var obj id expr templ offset =
  let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in
  let id' = Ident.create (Ident.name id) in
  Llet(Strict, id', Lprim (Pidentity, [Lvar id]),
  Lprim(Parraysetu kind,
        [Lvar obj; Lvar id';
         Lprim(Parrayrefu kind, [Lvar templ; Lprim(Paddint,
                                                   [Lvar id';
                                                    Lvar offset])])]))

let transl_val tbl create name id rem =
  Llet(StrictOpt, id, Lapply (oo_prim (if create then "new_variable"
                                       else           "get_variable"),
                              [Lvar tbl; transl_label name]),
       rem)

let transl_vals tbl create vals rem =
  List.fold_right
    (fun (name, id) rem -> transl_val tbl create name id rem)
    vals rem

let transl_super tbl meths inh_methods rem =
  List.fold_right
    (fun (nm, id) rem ->
       begin try
         Llet(StrictOpt, id, Lapply (oo_prim "get_method",
                                     [Lvar tbl; Lvar (Meths.find nm meths)]),
              rem)
       with Not_found ->
         rem
       end)
    inh_methods rem

let rec build_object_init obj inh_init cl =
  match cl.cl_desc with
    Tclass_ident path ->
      let obj_init = Ident.create "obj_init" in
      (obj_init::inh_init, Lapply(Lvar obj_init, [Lvar obj]))
  | Tclass_structure str ->
      List.fold_right
        (fun field (inh_init, obj_init) ->
           match field with
             Cf_inher (cl, _, _) ->
               let (inh_init, obj_init') = build_object_init obj inh_init cl in
               (inh_init, lsequence obj_init' obj_init)
           | Cf_val (_, id, exp) ->
               (inh_init, lsequence (set_inst_var obj id exp) obj_init)
           | Cf_meth _ | Cf_init _ ->
               (inh_init, obj_init)
           | Cf_let (rec_flag, defs, vals) ->
               (inh_init,
                Translcore.transl_let rec_flag defs
                  (List.fold_right
                     (fun (id, expr) rem ->
                        lsequence (Lifused(id, set_inst_var obj id expr)) rem)
                     vals obj_init)))
        str.cl_field
        (inh_init, lambda_unit)
  | Tclass_fun (pat, vals, cl) ->
      let build params rem =
        let param = name_pattern "param" [pat, ()] in
        let rem =
          List.fold_right
            (fun (id, expr) rem ->
              lsequence (Lifused (id, set_inst_var obj id expr)) rem)
            vals rem
        in
        Lfunction (Curried, param::params,
                   Matching.for_function
                     pat.pat_loc None (Lvar param) [pat, rem])
      in
      let (inh_init, obj_init) =  build_object_init obj inh_init cl in
      (inh_init,
       begin match obj_init with
         Lfunction (Curried, params, rem) -> build params rem
       | rem                              -> build [] rem
       end)
  | Tclass_apply (cl, exprs) ->
      let (inh_init, obj_init) =  build_object_init obj inh_init cl in
      (inh_init, lapply obj_init (List.map transl_exp exprs))
  | Tclass_let (rec_flag, defs, vals, cl) ->
      let (inh_init, obj_init) =  build_object_init obj inh_init cl in
      (inh_init,
       Translcore.transl_let rec_flag defs
         (List.fold_right
            (fun (id, expr) rem ->
              lsequence (Lifused(id, set_inst_var obj id expr)) rem)
            vals obj_init))
  | Tclass_constraint (cl, vals, pub_meths, concr_meths) ->
      build_object_init obj inh_init cl

(*
let inherited_values vals =
  Lconst
    (List.fold_right
       (fun (v, _) rem ->
          Const_block(0, [Const_base (Const_string v); rem]))
       vals (Const_pointer 0))

let inherited_meths methods =
  Lconst
    (List.fold_right
       (fun v rem ->
          Const_block(0, [Const_base (Const_string v); rem]))
       methods (Const_pointer 0))
*)

let bind_method tbl public_methods lab id cl_init =
  if List.mem lab public_methods then
    Llet(Alias, id, Lvar (meth lab), cl_init)
  else
    Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
                                [Lvar tbl; transl_label lab]),
    cl_init)

let bind_methods tbl public_methods meths cl_init =
  Meths.fold (bind_method tbl public_methods) meths cl_init

let rec build_class_init cla pub_meths cstr inh_init cl_init cl =
  match cl.cl_desc with
    Tclass_ident path ->
      begin match inh_init with
        obj_init::inh_init ->
          (inh_init,
           Llet (Strict, obj_init, 
(*                 Lapply(oo_prim "get_class", [Lvar cla; transl_path path]), *)
                 Lapply(Lprim(Pfield 1,
                              [Lapply(Lprim(Pfield 1, [transl_path path]),
                                      [Lvar cla])]), [lambda_unit]),
                 cl_init))
      | _ ->
          assert false
      end
  | Tclass_structure str ->
      let (inh_init, cl_init) =
        List.fold_right
          (fun field (inh_init, cl_init) ->
            match field with
              Cf_inher (cl, vals, meths) ->
                build_class_init cla pub_meths false inh_init
                  (transl_vals cla false vals
                     (transl_super cla str.cl_meths meths cl_init))
                  cl
            | Cf_val (name, id, exp) ->
                (inh_init, transl_val cla true name id cl_init)
            | Cf_meth (name, exp) ->
                let met = Ident.create ("method_" ^ name) in
                (inh_init,
                 Lsequence(Lapply (oo_prim "set_method",
                                   [Lvar cla;
                                    Lvar (Meths.find name str.cl_meths);
                                    Llet(Strict, met, transl_exp exp,
                                         Lvar met)]),
                           cl_init))
            | Cf_let (rec_flag, defs, vals) ->
                let vals =
                  List.map (function (id, _) -> (Ident.name id, id)) vals
                in
                (inh_init, transl_vals cla true vals cl_init)
            | Cf_init exp ->
                (inh_init,
                 Lsequence(Lapply (oo_prim "add_initializer",
                                   [Lvar cla; transl_exp exp]),
                           cl_init)))
          str.cl_field
          (inh_init, cl_init)
      in
      (inh_init, bind_methods cla pub_meths str.cl_meths cl_init)
  | Tclass_fun (pat, vals, cl) ->
      let (inh_init, cl_init) =
        build_class_init cla pub_meths cstr inh_init cl_init cl
      in
      let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
      (inh_init, transl_vals cla true vals cl_init)
  | Tclass_apply (cl, exprs) ->
      build_class_init cla pub_meths cstr inh_init cl_init cl
  | Tclass_let (rec_flag, defs, vals, cl) ->
      let (inh_init, cl_init) =
        build_class_init cla pub_meths cstr inh_init cl_init cl
      in
      let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
      (inh_init, transl_vals cla true vals cl_init)
  | Tclass_constraint (cl, vals, meths, concr_meths) ->
      let core cl_init =
        build_class_init cla pub_meths true inh_init cl_init cl
      in
      if cstr then
        core cl_init
      else
        let virt_meths =
          List.fold_right
            (fun lab rem ->
               if Concr.mem lab concr_meths then rem else lab::rem)
            meths
            []
        in
        let (inh_init, cl_init) =
          core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]),
                           cl_init))
        in
        (inh_init,
         Lsequence(Lapply (oo_prim "narrow",
                           [Lvar cla;
                             transl_meth_list vals;
                             transl_meth_list virt_meths;
                             transl_meth_list (Concr.elements concr_meths)]),
                   cl_init))

let rec make_params =
  function
    0 -> []
  | n -> (Ident.create "param") :: (make_params (n - 1))

let creator arity cla obj_init =
  let params = make_params arity in
  let params' = List.map (fun p -> Lvar p) params in
  let self = Ident.create "self" in
  let rem = Lvar self in
  let rem =
    if arity = 0 then rem else
    Lsequence(Lapply (oo_prim "run_initializers", [Lvar self; Lvar cla]),
              rem)
  in
  let body =
    Llet(Strict, self,
         Lapply (oo_prim "create_object", [Lvar cla]),
         Lsequence(Lapply (Lvar obj_init, (Lvar self) :: params'),
                   rem))
  in
  if arity = 0 then body else Lfunction (Curried, params, body)

(*
   XXX Il devrait etre peu couteux d'ecrire des classes :
     class c x y = d e f
*)
(*
   XXX
   Exploiter le fait que les methodes sont definies dans l'ordre pour
   l'initialisation des classes (et les variables liees par un
   let ???) ?
*)

(*
let rec simpl_class =
  function
    Tclass_ident path     -> true
  | Tclass_structure _    -> false
  | Tclass_fun (_, _, cl) -> simpl_class cl
  | Tclass_apply (cl, _)  -> simpl_class cl
  | Tclass_constraint (cl, _, _, _) -> simpl_class cl
*)
let rec transl_var_copy_rec inh_init self offset templ cl rem =
  match cl.cl_desc with
    Tclass_ident path ->
      begin match inh_init with
        obj_init::inh_init ->
          (inh_init, lsequence (Lapply (Lvar obj_init, [Lvar self])) rem)
      | _ ->
          assert false
      end
  | Tclass_structure str ->
      List.fold_right (fun field (inh_init, rem) ->
        match field with
          Cf_inher (cl, _, _) ->
            transl_var_copy_rec inh_init self offset templ cl rem
        | Cf_val (name, id, expr) ->
            (inh_init, lsequence (copy_inst_var self id expr templ offset) rem)
        | Cf_let (rec_flag, defs, vals) ->
            (inh_init,
             Translcore.transl_let rec_flag defs
               (List.fold_right
                  (fun (id, expr) rem ->
                    lsequence (Lifused(id,
                                       copy_inst_var self id expr
                                         templ offset))
                              rem)
                  vals rem))
        | Cf_init _ | Cf_meth _ ->
            (inh_init, rem))
        str.cl_field
        (inh_init, rem)
  | Tclass_constraint (cl, _, _, _) ->
      transl_var_copy_rec inh_init self offset templ cl rem
  | Tclass_fun _ | Tclass_apply _ | Tclass_let _ ->
      raise Exit

let transl_var_copy inh_init cl_id cla cl =
  try
    let templ = Ident.create "template" in
    let offset = Ident.create "offset" in
    let self = Ident.create "self" in
    let (inh_init, body) =
      transl_var_copy_rec inh_init self offset templ cl lambda_unit
    in
    assert (inh_init = []);
    Lfunction (Curried, [Ident.create "any"],
               Llet(StrictOpt, templ, Lprim(Pfield 0, [Lvar cl_id]),
               Llet(StrictOpt, offset,
                    Lprim(Psubint,
                          [Lprim(Pfield 0, [Lprim(Pfield 2, [Lvar cl_id])]);
                           Lprim(Pfield 0, [Lvar cla])]),
               Lfunction (Curried, [self], body))))
  with Exit ->
    Lapply(oo_prim "copy_variables", [Lvar cl_id; Lvar cla])

let transl_class cl_id arity pub_meths cl =
  let obj = Ident.create "self" in
  let (inh_init, obj_init) = build_object_init obj [] cl in
  let cla = Ident.create "class" in
  let obj_init =
    if arity = 0 then
      Lprim(Pmakeblock(0, Immutable),
            [lfunction [obj] obj_init;
(*
              Lapply(oo_prim "copy_variables", [Lvar cl_id; Lvar cla])])
*)
        transl_var_copy (List.rev inh_init) cl_id cla cl])
    else
      let init = Ident.create "init" in
      Llet(Strict, init, lfunction [obj] obj_init,
           Lprim(Pmakeblock(0, Immutable),
                 [Lvar init; Lfunction (Curried, [Ident.create "any"],
                                        Lvar init)]))
  in
  let (inh_init, cl_init) =
    build_class_init cla pub_meths true (List.rev inh_init) obj_init cl
  in
  assert (inh_init = []);
(*
  Lapply (oo_prim "create_class",
          [Lvar cl_id;
           transl_meth_list pub_meths;
           Lfunction(Curried, [cla; initial], cl_init);
           creator arity])
*)
  let table = Ident.create "table" in
  let class_init = Ident.create "class_init" in
  let obj_init = Ident.create "obj_init" in
  Llet(Strict, table,
       Lapply (oo_prim "create_table", [transl_meth_list pub_meths]),
  Llet(Strict, class_init,
       Lfunction(Curried, [cla], cl_init),
  Llet(Strict, obj_init,
       Lprim(Pfield 0, [Lapply(Lvar class_init, [Lvar table])]),
  Lsequence(Lapply (oo_prim "init_class", [Lvar table]),
            Lprim(Pmakeblock(0, Immutable),
                  [creator arity table obj_init;
                   Lvar class_init;
                   Lvar table])))))

let class_stub =
  Lprim(Pmakeblock(0, Mutable), [lambda_unit; lambda_unit; lambda_unit])