| 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 | |