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 67
