Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 88 lines (78 sloc) 3.275 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* depends *)
19 module List = Base.List
20
21 (* shorthands *)
22 module Q = QmlAst
23
24
25 module S =
26 struct
27 type t = QmlTypes.gamma
28 let pass = "pass_TypeDefinition"
29 let pp f _ = Format.pp_print_string f "<dummy>"
30 end
31
32 module R = ObjectFiles.Make(S)
33
34 let process_code register typerEnv code =
35 let new_gamma = QmlTypes.Env.empty in
36 let gamma = typerEnv.QmlTypes.gamma in
5242af3 @BourgerieQuentin [enhance] compiler: Add compiler packages (Import packages that not p…
BourgerieQuentin authored
37 let (gamma, stdlib) =
fccc685 Initial open-source release
MLstate authored
38 (* during pre_linking, the whole gamma is loaded
39 because dbGen loads the whole database schema *)
40 let options_packages = ObjectFiles.compilation_mode() = `init in
41 R.fold_with_name
42 ~packages: options_packages
43 ~deep:true (* need to go deep because you can depend directly on a unit
44 * that says type t = u
45 * when u is defined in another package saying type u = v
46 * when v is defined in another package etc.
47 *)
5242af3 @BourgerieQuentin [enhance] compiler: Add compiler packages (Import packages that not p…
BourgerieQuentin authored
48 (fun package (acc_gamma, acc_stdlib) gamma ->
fccc685 Initial open-source release
MLstate authored
49 let gamma = QmlRefresh.refresh_gamma package gamma in
5242af3 @BourgerieQuentin [enhance] compiler: Add compiler packages (Import packages that not p…
BourgerieQuentin authored
50 let stdlib =
51 if ObjectFiles.compiler_package package then
52 QmlTypes.Env.append acc_stdlib gamma
53 else acc_stdlib
54 in (QmlTypes.Env.append acc_gamma gamma, stdlib))
55 (gamma, QmlTypes.Env.empty) in
fccc685 Initial open-source release
MLstate authored
56 let typerEnv = { typerEnv with QmlTypes.gamma = gamma } in
57 (* Rgeister fields declared on [ty] *)
58 let rec register_type ty =
59 let reg_fields = List.iter (fun (x,_) -> register x) in
60 QmlAstWalk.Type.iter
61 (function
62 | Q.TypeRecord (Q.TyRow (fields, _)) -> reg_fields fields
63 | Q.TypeSum (Q.TyCol (fields, _)) -> List.iter reg_fields fields
64 | _ -> ()
65 )
66 ty
67 in
68 let ((local_typedefs, new_gamma, typerEnv), code) =
69 let aux ((local_typedefs, new_gamma, typerEnv) as acc) = function
70 | Q.NewType (_, typedefs) as code_elt ->
71 (* BEWARE: types such as #private_Date.date are not considered as being locals *)
72 let local_typedefs =
73 List.fold_left
74 (fun acc ty_def ->
75 register_type ty_def.Q.ty_def_body;
76 Q.TypeIdentSet.add ty_def.QmlAst.ty_def_name acc)
77 local_typedefs
78 typedefs in
79 let (new_gamma, typerEnv) =
80 QmlTyper.OfficialTyper.type_newtype_for_separation
81 ~more_gamma: new_gamma typerEnv code_elt typedefs in
82 (local_typedefs, new_gamma, typerEnv), None
83 | code_elt -> (acc, (Some code_elt)) in
84 List.fold_left_filter_map
85 aux (Q.TypeIdentSet.empty,new_gamma,typerEnv) code in
86 R.save new_gamma ;
5242af3 @BourgerieQuentin [enhance] compiler: Add compiler packages (Import packages that not p…
BourgerieQuentin authored
87 (local_typedefs, typerEnv, code, stdlib)
Something went wrong with that request. Please try again.