Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 135 lines (116 sloc) 5.327 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 (* shorthands *)
19 module P = Passes
20
21
22 module S =
23 struct
24 type t = (QmlAst.ty, unit) QmlGenericScheme.tsc IdentMap.t
25 let pass = "pass_Typing"
5fc8bb9 [fix] qmlAstCons: not generating source names when where are potentially...
Valentin Gatien-Baron authored
26 let pp f map =
27 IdentMap.iter
28 (fun k v ->
29 Format.fprintf f "@[<2>%s ->@ %a@]@\n" (Ident.to_string k) QmlPrint.pp#tsc v
30 ) map
fccc685 Initial open-source release
MLstate authored
31 end
32
33 module R = ObjectFiles.Make(S)
34
35
36
37 (* ************************************************************************** *)
38 (** {b Descr}: Module used to make the type of exceptions persistent along
39 separate compilation. In effect, to be safe, we must remind the type of
40 exceptions encountered in modules a module depends on.
41 The aim is to prevent a guy raising { A : int } and a guy catching
42 { A = x } then using x as a string.
43 The persistent information stored is the QML type, assumed by invariant to
44 be a sum type always with a column variable (i.e. opened sum) representing
45 the structure of the type of exceptions.
46 {b Visibility}: Not exported outside this module. *)
47 (* ************************************************************************** *)
48 module SExceptions =
49 struct
50 type t = QmlAst.ty
51 let pass = "pass_TypingExceptions"
52 let pp f _ = Format.pp_print_string f "<dummy>"
53 end
54
55 module RExceptions = ObjectFiles.Make(SExceptions)
56
57
58
59 let process_code ?(save = true) env =
60 (* ATTENTION ! Since the W-based typechecker uses global memoization tables
61 to speed-up type schemes importation from QML, we must empty them for
62 each new package compilation otherwise we will retain and confuse the
63 schemes renamed by different separate compilation-purpose refreshes. *)
64 Typer_w.reset_toplevel_tydefs_schemes_env_memo () ;
65 Typer_w.reset_toplevel_valdefs_schemes_env_memo () ;
66 (* Also reset the type of exceptions, to drop cases coming from usages of
67 other packages we don't depend on. *)
68 Typer_w.reset_type_exception () ;
69 let typerEnv = env.P.typerEnv in
70 let schema = typerEnv.QmlTypes.schema in
71 let code = env.P.qmlAst in
72 let initial_gamma = typerEnv.QmlTypes.gamma in
73 let (rebuilt_gamma, stdlib_map) =
74 let (map, map_stdlib) =
75 R.fold_with_name ~deep: true
76 (fun package (acc_map, acc_stdlib) map ->
77 let map =
78 IdentMap.map (QmlRefresh.refresh_typevars_from_tsc package) map in
79 let acc_map = IdentMap.safe_merge acc_map map in
80 let acc_stdlib =
81 if ObjectFiles.stdlib_packages package then
82 IdentMap.safe_merge acc_stdlib map
83 else acc_stdlib in
84 (acc_map, acc_stdlib))
85 (QmlTypes.Env.Ident.to_map initial_gamma, IdentMap.empty) in
86 QmlTypes.Env.Ident.from_map map initial_gamma,
87 map_stdlib in
88 let typerEnv = { typerEnv with QmlTypes.gamma = rebuilt_gamma } in
89 (* Restore the structure of the type "exception". We get the list of types
90 assumed to be sums, that each module we depend on created. *)
91 let exn_tys_list =
92 RExceptions.fold_with_name ~deep: true
93 (fun _package accu_exn_ty exn_ty ->
94 exn_ty :: accu_exn_ty)
95 [] in
96 (* Inject this structure inside the typechecker by cascading unifications
97 of all the types found for type "exception" in all the modules we depend
98 on. *)
99 Typer_w.init_type_exception rebuilt_gamma exn_tys_list ;
100
101 let typerEnv = QmlTyper.OfficialTyper.fold typerEnv code in
102 let typerEnv =
103 if ObjectFiles.compilation_mode() = `init then typerEnv
104 else
105 QmlDbGen.Schema.fold_expr
106 QmlTyper.OfficialTyper.fold_expr typerEnv schema in
107 let final_gamma = typerEnv.QmlTypes.gamma in
108 (* we remove anything from the gamma that does not come from this compilation,
109 * i.e. that is in rebuilt gamma but not in initial gamma *)
110 let diff_map =
111 IdentMap.diff2
112 (QmlTypes.Env.Ident.to_map final_gamma)
113 (QmlTypes.Env.Ident.to_map rebuilt_gamma)
114 (QmlTypes.Env.Ident.to_map initial_gamma) in
115
116 (* Now, recover the structure of the sum type representing the type
117 "exception". *)
118 let exception_ty_structure = Typer_w.get_type_exception_description () in
119
120 if save then (
121 R.save diff_map ;
122 RExceptions.save exception_ty_structure (* Save the type "exception". *)
123 ) ;
124
125 let stdlib_map =
126 if ObjectFiles.stdlib_packages (ObjectFiles.get_current_package ()) then
127 QmlTypes.Env.Ident.to_map final_gamma
128 else stdlib_map in
129 let stdlib_gamma =
130 QmlTypes.Env.Ident.from_map stdlib_map QmlTypes.Env.empty in
131 let diff_gamma = QmlTypes.Env.Ident.from_map diff_map initial_gamma in
132 let typerEnv = { typerEnv with QmlTypes.gamma = diff_gamma } in
133 { env with
134 P.typerEnv = typerEnv ; qmlAst = code ; stdlib_gamma = stdlib_gamma }
Something went wrong with that request. Please try again.