-
Notifications
You must be signed in to change notification settings - Fork 125
/
flat_Compiler.ml
174 lines (144 loc) · 4.77 KB
/
flat_Compiler.ml
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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
(*
Copyright © 2011 MLstate
This file is part of Opa.
Opa is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
Opa is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)
(*
TODO:
use positions for error reporting, update for Format instead of string concatenation.
Optimize ExtendRecord followed by Record
Handle pattern-matching for the "rest" of a record
optimize access/pattern-matching when type is statically known
share vtable when type is statically fully known even after record extension
*)
(* depends *)
module Format = Base.Format
(* refactoring in progress *)
(* alias *)
module FCons = Flat_Common.FCons
module ServerLib = Flat_Common.ServerLib
(* shorthands *)
module E = Flat_Env
module P = Qml2ocamlOptions
module Q = QmlAst
(* -- *)
(* type alias *)
type label = Flat_Common.label
(* field registration *)
let register_field_name label =
let _ = Flat_Shared.field label in
()
let compile_bindings env ~recursive:_ bindings =
let rec aux acc = function
| [] -> List.rev acc
| (id, expr)::tl ->
let expr = Flat_ExprGeneration.expr env expr in
(* A hack to overcome "variables that cannot be generalized". *)
let expr =
if env.E.options.P.top_magic && ( not ( DebugVariables.default DebugVariables.qmlc_no_magic )) then
match expr with
| Ocaml.Abs _
| Ocaml.Function _
| Ocaml.Var _ -> expr
| _ -> Ocaml.make_magic expr
else expr
in
aux ((FCons.param id, expr)::acc) tl
in
aux [] bindings
let compile_elt_aux env ~recursive make_Val bindings =
let bindings = compile_bindings env ~recursive bindings in
make_Val bindings
(*
We build a list for each val, so that we can insert toplevel definition between
ocamltoplevel values if we want.
*)
let compile_elt env ocaml_code elt =
let code =
match elt with
| Q.NewVal (_, bindings) ->
let val_ = compile_elt_aux env ~recursive:false Ocaml.make_Letand bindings in
[val_]
| Q.NewValRec (_, bindings) ->
let val_ = compile_elt_aux env ~recursive:true Ocaml.make_Letrecand bindings in
[val_]
| _ -> []
in
code :: ocaml_code
(*
FIXME
do not take ocaml_code in argument
simplify interface, no more returned env (unused)
*)
let compile (env, _) code =
(* imperative initialization *)
(* QmlPatternAnalysis.QmlOnion.typer_env_initialize env.typing ; *)
(* compilation *)
let code = List.fold_left (compile_elt env) [] code in
(* finalization, insertion of generated shared values *)
let code =
let fold acc definitions = List.rev_append definitions acc in
let code = List.fold_left fold [] code in
let code = Flat_Shared.Let.insert code in
code
in
(* compositionnality *)
(* dispose, reset *)
let () =
Flat_Bsl.reset () ;
Flat_Field.reset () ;
Flat_VTable.reset () ;
Flat_Simple.reset () ;
Flat_Shared.reset () ;
(* TODO: QmlPatternAnalysis dispose *)
()
in
env, code
(* FIXME: cf remark for simplifying the interface of backend *)
let empty_code = []
let get_code code = code
(*
Building : now : build from the table
which should be full because of a previous dynloading
todo : use a export/import feature from bsl
*)
let build_bymap ?filter options bsl =
let typesmap = BslLib.BSL.ByPassMap.typesmap bsl in
let ml_ctrans = Flat_Bsl.build_ctrans_env ~typesmap options in
Flat_Bsl.FlatBSL.RegisterTable.build_restrict_map_all ~ml_ctrans ?filter ~lang:[BslLanguage.ml] ()
let ocaml_init bymap =
Flat_Bsl.FlatBSL.ByPassMap.ocaml_init bymap
let env_initial = Flat_Env.initial
let back_end_factory :
(Flat_Bsl.FlatBSL.ByPassMap.t, Flat_Env.env, Ocaml.code) Qml2ocaml.back_end_factory
= { Qml2ocaml.
build_bymap = build_bymap ;
ocaml_init = ocaml_init ;
env_initial = env_initial ;
empty_code = empty_code ;
compile = compile ;
get_code = get_code
}
let dynloader plugin =
Flat_Bsl.FlatBSL.RegisterInterface.dynload plugin.BslPluginInterface.dynloader
let qml_to_ocaml options bsl blender =
Qml2ocaml.qml_to_ocaml_factory back_end_factory options bsl blender
let back_end = { Qml2ocaml.
dynloader = dynloader ;
qml_to_ocaml = qml_to_ocaml ;
}
(* options *)
module Arg =
struct
let options = Flat_Options.options
end
(* warnings *)
let warning_set = Flat_Warnings.warning_set