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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
(***********************************************************************)
(* *)
(* Caml Special Light *)
(* *)
(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
(* $Id$ *)
open Misc
open Asttypes
open Typedtree
open Lambda
open Translobj
open Translcore
let transl_label l = Lconst (Const_base (Const_string l.Label.lab_name))
(* Instance variable initialization *)
let set_inst_var obj var id expr =
Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
[Lvar obj; Lvar id; transl_exp expr])
let transl_super tbl inh_methods rem =
List.fold_right
(fun (nm, id) rem ->
Llet(StrictOpt, id, Lapply (oo_prim "get_method",
[Lvar tbl; Lvar (meth nm)]),
rem))
inh_methods rem
let transl_val tbl name id rem =
Llet(StrictOpt, id, Lapply (oo_prim "get_variable",
[Lvar tbl; transl_label name]),
rem)
let transl_private_val tbl name id rem =
Llet(StrictOpt, id, Lapply (oo_prim "get_private_variable",
[Lvar tbl; transl_label name]),
rem)
let transl_vals tbl vals rem =
List.fold_right
(fun (name, id) rem -> transl_val tbl name id rem)
vals rem
let transl_field_obj obj field (obj_init, anc_id) =
match field with
Cf_inher (name, args, vals, meths) ->
let init = Ident.create "init" in
(Lsequence(Lapply(Lvar init, Lvar obj :: (List.map transl_exp args)),
obj_init),
init::anc_id)
| Cf_val (name, id, priv, Some exp) ->
(Lsequence(set_inst_var obj name id exp, obj_init),
anc_id)
| Cf_val (name, id, priv, None) ->
(obj_init, anc_id)
| Cf_meth (name, exp) ->
(obj_init, anc_id)
let transl_field_cl tbl field cl_init =
match field with
Cf_inher (name, args, vals, meths) ->
Lsequence(Lapply (oo_prim "inheritance", [Lvar tbl; transl_path name]),
transl_vals tbl vals (
transl_super tbl meths cl_init))
| Cf_val (name, id, priv, exp) ->
if priv = Private then
transl_private_val tbl name id cl_init
else
transl_val tbl name id cl_init
| Cf_meth (name, exp) ->
Lsequence(Lapply (oo_prim "set_method",
[Lvar tbl; Lvar (meth name); transl_exp exp]),
cl_init)
let transl_val_hiding tbl field cl_init =
match field with
Cf_inher _ | Cf_meth _ | Cf_val (_, _, Public, _) ->
cl_init
| Cf_val (name, id, Private, exp) ->
Lsequence(Lapply (oo_prim "hide_variable",
[Lvar tbl; transl_label name]),
cl_init)
let transl_class cl =
let obj = Ident.create "obj" in
let (field_init, anc_id) =
List.fold_right (transl_field_obj obj) cl.cl_field (Lvar obj, [])
in
let (params, body) =
List.fold_right
(fun pat (params, rem) ->
let param = name_pattern "param" [pat, ()] in
(param::params,
Matching.for_function pat.pat_loc (Lvar param) [pat, rem]))
cl.cl_args
([], field_init)
in
let obj_init = Lfunction(anc_id @ obj::params, body) in
let table = Ident.create "table" in
let cl_init =
Lfunction ([table],
List.fold_right (transl_val_hiding table) cl.cl_field
(List.fold_right (transl_field_cl table) cl.cl_field
(Lapply (oo_prim "set_initializer",
[Lvar table; obj_init]))))
in
Lapply (oo_prim "create_class", [cl_init])
|
