-
Notifications
You must be signed in to change notification settings - Fork 125
/
ocaml.ml
404 lines (337 loc) · 12.7 KB
/
ocaml.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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
(*
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/>.
*)
(*
@author Geoffroy Chollon
@author Henri Binsztok
@author Mathieu Barbin
**)
(* depends *)
module List = BaseList
(**)
(* REFACTOR: replace by Ident.t *)
type ident = Ident.t
type const_expr =
| String of string
| Int of int
| Float of float
| Bool of bool
| Char of char
| Unit
type const_type_expr =
| TypeString
| TypeInt
| TypeInt64
| TypeFloat
| TypeBool
| TypeUnit
(* Module.Module.name *)
type type_name = string list
type type_expr =
| TypeVar of string (* 'a *)
| TypeName of type_expr list * type_name (* ('a, ...) t *)
| TypeConst of const_type_expr
| TypeRef of type_expr
| TypeTuple of type_expr list
| TypeRecord of (bool (* mutable *) * string * type_expr) list
| TypeConstructor of (string * type_expr option) list
| TypeArrow of type_expr * type_expr
| TypeLabel of bool (* optional *) * string * type_expr
| TypeVerbatim of string
type mlIdent = ident list
(* and mlIdent = InModule of (string * mlIdent) | InVector of (expr * mlIdent option) | InRecord of (string * mlIdent option) *)
type pattern =
| PatVar of ident
| PatList of pattern * pattern (* hd :: tl *)
| PatEmptyList
| PatRecord of (string * pattern) list
| PatConstructor of mlIdent * pattern list
| PatVariant of mlIdent * pattern list
| PatPVariant of mlIdent * pattern list
(**
A polymorphic variant.
Note: The ocaml manual states that the name of the polymorphic variant should start with an uppercase latter.
This is not enforced, either by this module or by the ocaml compiler.
*)
| PatConst of const_expr
| PatAny
| PatAnnot of pattern * type_expr
| PatTuple of pattern list
| PatAs of pattern * ident
| PatArray of pattern list
| PatLazy of pattern
| PatOr of pattern list
type param_formel = (* FIXME: formal_param *)
(* ((~label:variable) : t) *)
| Label of string * pattern option * type_expr option (**A non-optional labelled argument*)
| Opt of string * type_expr option * expr option (**An optional labelled argument*)
| Pat of pattern
and param_effectif = (* FIXME: effective_param *)
| Labeled of string * expr option
| Pated of mlIdent * bool (* l'identifiant doit être protégé avec une parenthèse *)
and code = expr list
and signature =
| Inlined of code
| Referenced of string list
(* FIXME: manque signatures + signatures inlinees dans les modules *)
(* FIXME: contraindre les string a etres des noms de modules ou d'exceptions (majuscules), de variables de type ('...) *)
and expr =
| Type of (string list * string * type_expr) list (* type ('...) y = ... and ... *)
| Val of ident * type_expr (* val x : ... *)
| Open of mlIdent
| Module of string * expr option * code * expr option (**[Module(name, functor, contents, [Some e])] is a local module definition.
[Module(name, functor, contents, None)] is a global module definition.*)
| ModuleType of string * code
| Structure of code (* struct ... end *)
| Signature of signature (* sig ... end *)
| DeclareFunctor of string * (string * expr option) list * expr option * expr
| Constructor of mlIdent * expr list
| ConstructorPV of mlIdent * expr list (* `X (...): constructor of a polymorphic variant *)
| Const of const_expr
| Var of param_effectif
| MakeRef of expr
| GetRef of expr
| SetRef of expr * expr
| SetMutable of expr * expr
| Lazy of expr
| Tuple of expr list
| Cons of expr * expr (**Addition of an element before a list.
[Cons(a,b)] is [a::b]*)
| EmptyList
| Cond of expr * expr * expr (* if e then e else e *)
| App of expr * expr (* e e *)
| Abs of param_formel list * expr (* \lambda x.e *)
| Let of (param_formel * expr) list (* let x = e and ... *)
| Letrec of (param_formel * expr) list (* let rec x = e and ... *)
| Letin of (param_formel * expr) list * expr (* let x = e and ... in e *)
| Letrecin of (param_formel * expr) list * expr (* let rec x = e and ... in e *)
| Record of string option * (string * expr) list (* { f = e ; ... } *)
| Dot of expr * string (* e.f *)
| Match of expr * (pattern * expr option (* guard *) * expr) list
| Sequence of expr * expr
| Annot of expr * type_expr
| Function of (pattern * expr option (* guard *) * expr) list
(* exceptions *)
| Exception of string * type_expr option
| Raise of mlIdent * expr option
| Try of expr * (pattern * expr option (* guard *) * expr) list
| AnArray of expr list
| Comment of string (* stand-alone comment *)
| LineAnnot of int (* line number *) * string (* file name *) * expr
| Comments of string * expr
| Assert of expr
| Verbatim of string
(**
Special identifiers : need to be protected with parenthesis.
*)
let special_idents =
let t = Hashtbl.create 50 in
let spe_i = [ "mod"; "land"; "lor"; "lxor" ;
"+"; "+."; "="; "<>"; "=="; "!="; "-"; "-."; "*"; "**"; "*."; "/"; "/."; ">"; "<"; "<="; ">="; "<>"; "&&"; "||"; "~-"; "~-."; "^"; "@"; "asr"]
in
List.iter (fun s -> Hashtbl.add t s (Pated ([Ident.source s], true))) spe_i;
t
(**
{6 Shortcuts}
*)
(**
Construct a simple variable non protected by parenthesis.
The name is a source name, not analysed. (Ident.Source)
*)
let make_Var s =
try
Var (Hashtbl.find special_idents s)
with
| Not_found -> Var (Pated ([Ident.source s], false))
(**
Construct a complex variable 'List.Make.a_function' non protected by parenthesis
The names are source names, not analysed. (Ident.Source)
*)
let make_Varl sl = Var (Pated (List.map Ident.source sl, false))
(** Construct a toplevel let declaration for one element,
[let foo = bar;;]*)
let make_Let id c1 = Let ([id, c1])
(** Construct a toplevel let declaration for several elements,
[let foo = bar;; let sna = toto;;]*)
let make_Letand idcl = Let (idcl)
(** Construct a toplevel let rec declaration for one element,
[let rec foo = bar;;]*)
let make_Letrec id c1 = Letrec ([id, c1])
(** Construct a toplevel let rec declaration for several elements,
[let rec foo = bar;; let rec sna = toto;;]*)
let make_Letrecand idcl = Letrec (idcl)
(** Construct a local let declaration for one element,
[let foo = bar in e;;]*)
let make_Letin id c1 e = Letin ([id, c1], e)
(** Construct a local let declaration for several elements,
[let foo = bar and sna = toto in e]*)
let make_Letandin idcl e = Letin (idcl, e)
(** Construct a local let rec declaration for one element,
[let rec foo = bar in e]*)
let make_Letrecin id c1 e = Letrecin ([id, c1], e)
(** Construct a local let rec declaration for several elements,
[let rec foo = bar and rec sna = toto in e;;]*)
let make_Letrecandin idcl e = Letrecin (idcl, e)
let make_param_formel s = Pat (PatVar s)
let pf s = Pat (PatVar (Ident.source s))
(** Construct an array using Obj.magic *)
let make_polymorphic_array l = AnArray (List.map (fun e -> App (make_Varl ["Obj"; "magic"] , e)) l)
let make_pair l = Tuple (List.map (fun e -> App (make_Varl ["Obj"; "magic"] , e)) l)
(** Construct successive function applications from a list *)
let make_AppL l =
let rec aux l = match l with
| [] -> assert false
| [x] -> x
| a::q -> App (aux q, a)
in aux (List.rev l)
(** *)
let make_magic v = App (make_Varl ["Obj"; "magic"], v)
let make_obj v = App (make_Varl ["Obj"; "obj"], v)
let make_repr v = App (make_Varl ["Obj"; "repr"], v)
let make_lazy_force v = App (make_Varl ["Lazy"; "force"], v)
(**
[make_unsafe_get x i] is [Obj.obj (Obj.field (Obj.repr x) i)]
*)
let make_unsafe_get x p = make_obj ( make_AppL [
make_Varl ["Obj" ; "field"] ;
make_repr x ;
Const (Int p)
] )
(** Build [unsafe_get] / [unsafe_set]*)
let make_array_unsafe_get p t = make_magic (make_AppL [make_Varl ["Array"; "unsafe_get"]; make_magic t; Const (Int p)])
let make_array_unsafe_set p t x = make_magic (make_AppL [make_Varl ["Array"; "unsafe_set"]; make_magic t; Const (Int p); make_magic x])
let make_array_unsafe_get_no_magic p t = make_AppL [make_Varl ["Array"; "unsafe_get"]; t; Const (Int p)]
let make_array_unsafe_set_no_magic p t x = make_AppL [make_Varl ["Array"; "unsafe_set"]; t; Const (Int p); x]
(** Build [assert exp]*)
let make_assert b = Assert b
(** Build [assert false]*)
let make_assert_false = Assert (Const (Bool false))
(** Build [a = b]*)
let make_equals a b = App (App (Var (Pated ([Ident.source "="], true)), a), b)
(** Build [a == b] *)
let physical_equality a b = App (App (Var (Pated ([Ident.source "=="], true)), a), b)
(**
Abbreviations for commonly used expressions.
*)
module Cons =
struct
let simple_param_effec s = Pated ([s], false)
let param_effec sl = Pated (sl, false) (* FIXME : multiple definition *)
let var id = Var (Pated ([id], false))
let param s =
let pat = PatVar s in
let param = Pat pat in
param
let param_var s =
let pat = PatVar s in
let param = Pat pat in
let var = var s in
param, var
let pat_var s =
let pat = PatVar s in
let var = var s in
pat, var
let param_pat_var s =
let pat = PatVar s in
let param = Pat pat in
let var = var s in
param, pat, var
let app a b = App (a, b)
let app2 = app
let app3 a b c = app (app a b) c
let app4 a b c d = app (app3 a b c) d
let app5 a b c d e = app (app4 a b c d) e
let rec app_list = function
| [] -> failwith "[ ocaml.ml; #83726 ]"
| [x] -> x
| [x; y] -> app x y
| ls ->
let xs, x = List.extract_last ls in (*TODO: This looks like an anti-pattern for [List.fold_right]*)
app (app_list xs) x
let letin id c1 c2 = Letin ([id, c1], c2)
let letrec pel = Letrec pel
let letrecin pfe e = Letrecin (pfe, e)
let var_of_string s = Var (Pated ([s], false))
let array l = AnArray l
let lambda s f = Abs ([make_param_formel s], f)
let int i = Const (Int i)
let float f = Const (Float f)
let char c = Const (Char c)
let unit = Const (Unit)
let string s = Const (String s)
let bool b = Const (Bool b)
let true_ = bool true
let false_ = bool false
let none = Constructor ([Ident.source "None"], [])
let some e = Constructor ([Ident.source "Some"], [e])
let tuple e = Tuple e
let rec list = function
| x::xs -> Cons (x, list xs)
| [] -> EmptyList
let pat_none = PatConstructor ([Ident.source "None"], [])
let pat_some p = PatConstructor ([Ident.source "Some"], [p])
let pat_tuple t = PatTuple t
let pat_unit = PatConst Unit
let pat_int i = PatConst (Int i)
let pat_float f = PatConst (Float f)
let pat_string s = PatConst (String s)
let pat_char c = PatConst (Char c)
let make_match e pel = Match (e, pel)
let comment c s = Comments (c, s)
let verbatim c = Verbatim c
let plus a b = app3 (make_Var "+") a b
let minus a b = app3 (make_Var "-") a b
let equal a b = app3 (make_Var "=") a b
let neq a b = app3 (make_Var "<>") a b
let band a b = app3 (make_Var "&&") a b
let bor a b = app3 (make_Var "||") a b
let gt a b = app3 (make_Var ">") a b
let lt a b = app3 (make_Var "<") a b
let ge a b = app3 (make_Var ">=") a b
let le a b = app3 (make_Var "<=") a b
(* transforms [a; b; c] into [a -> b -> c] *)
let rec type_arrows = function
| [] | [_] -> failwith "[ ocaml.ml; #58253 ] impossible case in type_arrows"
| [x; y] -> TypeArrow (x, y)
| x::xs -> TypeArrow (x, type_arrows xs)
(* transforms a list [a; b; c] into a Sequence (a, Sequence (b, ...)) *)
let rec sequence = function
| [] -> unit
| [x] -> x
| x::xs -> Sequence (x, sequence xs)
module VarShortCut =
struct
let assert_ = make_Var "assert"
let magic = make_Varl ["Obj"; "magic"]
let magic_fun = make_Varl ["Base"; "magic_fun"]
let false_ = Const (Bool false)
end
module AppShortCut =
struct
let magic a = app VarShortCut.magic a
let magic_fun a = app VarShortCut.magic_fun a
let assert_false = app VarShortCut.assert_ VarShortCut.false_
end
let magic_array l = array (List.map AppShortCut.magic l)
module Pattern = (* TODO: remove? too long prefix, "pat_" is better *)
struct
let int i = PatConst (Int i)
let float f = PatConst (Float f)
let string s = PatConst (String s)
let char c = PatConst (Char c)
let unit = PatConst (Unit)
let array l = PatArray l
let pvar s = PatVar s
let any = PatAny
end
end