1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
(*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
|
