123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566 |
- (*Stream:class_ctors*)
- let create_$classname_from_ptr raw_ptr =
- C_obj
- begin
- let h = Hashtbl.create 20 in
- List.iter (fun (nm,fn) -> Hashtbl.replace h nm fn)
- [ "nop", (fun args -> C_void) ;
- $classbody
- "&", (fun args -> raw_ptr) ;
- ":parents",
- (fun args ->
- C_list
- (let out = ref [] in
- Hashtbl.iter (fun x y -> out := (x,y) :: !out) h ;
- (List.map
- (fun (x,y) ->
- C_string (String.sub x 2 ((String.length x) - 2)))
- (List.filter
- (fun (x,y) ->
- ((String.length x) > 2)
- && x.[0] == ':' && x.[1] == ':') !out)))) ;
- ":classof", (fun args -> C_string "$realname") ;
- ":methods", (fun args ->
- C_list (let out = ref [] in
- Hashtbl.iter (fun x y -> out := (C_string x) :: !out) h ; !out))
- ] ;
- let rec invoke_inner raw_ptr mth arg =
- begin
- try
- let application = Hashtbl.find h mth in
- application
- (match arg with
- C_list l -> (C_list (raw_ptr :: l))
- | C_void -> (C_list [ raw_ptr ])
- | v -> (C_list [ raw_ptr ; v ]))
- with Not_found ->
- (* Try parent classes *)
- begin
- let parent_classes = [
- $baselist
- ] in
- let rec try_parent plist raw_ptr =
- match plist with
- p :: tl ->
- begin
- try
- (invoke (p raw_ptr)) mth arg
- with (BadMethodName (p,m,s)) ->
- try_parent tl raw_ptr
- end
- | [] ->
- raise (BadMethodName (raw_ptr,mth,"$realname"))
- in try_parent parent_classes raw_ptr
- end
- end in
- (fun mth arg -> invoke_inner raw_ptr mth arg)
- end
- let _ = Callback.register
- "create_$normalized_from_ptr"
- create_$classname_from_ptr
- (*Stream:mli*)
- val create_$classname_from_ptr : c_obj -> c_obj
|