Lib/ocaml/class.swg

   1 (*Stream:class_ctors*)
   2 let create_$classname_from_ptr raw_ptr =
   3   C_obj
   4 begin
   5   let h = Hashtbl.create 20 in
   6     List.iter (fun (nm,fn) -> Hashtbl.replace h nm fn)
   7         [ "nop", (fun args -> C_void) ;
   8           $classbody
   9          "&", (fun args -> raw_ptr) ;
  10        ":parents",
  11        (fun args ->
  12           C_list
  13           (let out = ref [] in
  14             Hashtbl.iter (fun x y -> out := (x,y) :: !out) h ;
  15           (List.map
  16              (fun (x,y) ->
  17                 C_string (String.sub x 2 ((String.length x) - 2)))
  18              (List.filter
  19                 (fun (x,y) ->
  20                    ((String.length x) > 2)
  21                    && x.[0] == ':' && x.[1] == ':') !out)))) ;
  22        ":classof", (fun args -> C_string "$realname") ;
  23        ":methods", (fun args ->
  24           C_list (let out = ref [] in
  25             Hashtbl.iter (fun x y -> out := (C_string x) :: !out) h ; !out))
  26         ] ;
  27         let rec invoke_inner raw_ptr mth arg =
  28         begin
  29           try
  30             let application = Hashtbl.find h mth in
  31               application
  32                 (match arg with
  33                      C_list l -> (C_list (raw_ptr :: l))
  34                    | C_void -> (C_list [ raw_ptr ])
  35                    | v -> (C_list [ raw_ptr ; v ]))
  36           with Not_found ->
  37                 (* Try parent classes *)
  38                 begin
  39                   let parent_classes = [
  40                     $baselist
  41                   ] in
  42                   let rec try_parent plist raw_ptr =
  43                     match plist with
  44                         p :: tl ->
  45                           begin
  46                             try
  47                               (invoke (p raw_ptr)) mth arg
  48                             with (BadMethodName (p,m,s)) ->
  49                               try_parent tl raw_ptr
  50                           end
  51                       | [] ->
  52                           raise (BadMethodName (raw_ptr,mth,"$realname"))
  53                   in try_parent parent_classes raw_ptr
  54                 end
  55         end in
  56           (fun mth arg -> invoke_inner raw_ptr mth arg)
  57 end
  58
  59 let _ = Callback.register
  60           "create_$normalized_from_ptr"
  61           create_$classname_from_ptr
  62
  63
  64 (*Stream:mli*)
  65 val create_$classname_from_ptr : c_obj -> c_obj
  66