Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 139 lines (122 sloc) 5.588 kb
fccc685 Initial open-source release
MLstate authored
1 (*
662e95e @BourgerieQuentin [enhance] compiler, packages: Allows to have several backends (separated...
BourgerieQuentin authored
2 Copyright © 2011, 2012 MLstate
fccc685 Initial open-source release
MLstate authored
3
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
4 This file is part of Opa.
fccc685 Initial open-source release
MLstate authored
5
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
6 Opa is free software: you can redistribute it and/or modify it under the
fccc685 Initial open-source release
MLstate authored
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
10 Opa is distributed in the hope that it will be useful, but WITHOUT ANY
fccc685 Initial open-source release
MLstate authored
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
5bb0f1a @Aqua-Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
16 along with Opa. If not, see <http://www.gnu.org/licenses/>.
fccc685 Initial open-source release
MLstate authored
17 *)
18 (* rebel open *)
19 open SurfaceAst
20 open SurfaceAstHelper
21 open OpaEnv
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support fo...
OpaOnWindowsNow authored
22 open SurfaceAstPassesTypes
fccc685 Initial open-source release
MLstate authored
23
24 (* refactoring in progress *)
25
26 (* alias *)
27 module C = SurfaceAstCons.ExprIdentCons
28 module CS = SurfaceAstCons.StringCons
29
30
31
32 let pass_load_objects ~options (special_parsed_files, user_parsed_files) k =
33 let extract_package_decl = function
34 | (Package ((`declaration | `import) as kind, name), label) ->
35 Some (kind, name, label.QmlLoc.pos)
36 | _ -> None in
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support fo...
OpaOnWindowsNow authored
37 let extract_current_package_name = function
38 | Package (`declaration, name), _label -> Some(name)
39 | _ -> None in
40 let package_name code = Base.List.find_map extract_current_package_name code in
41 let label s = {QmlLoc.pos=FilePos.nopos ("i18n, import "^s); QmlLoc.notes=SurfaceAstCons.Fresh.id()} in
fccc685 Initial open-source release
MLstate authored
42 let map { parsedFile_lcode = code; parsedFile_filename = name; parsedFile_content = content } =
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support fo...
OpaOnWindowsNow authored
43 let exists = ObjectFiles.exists_package ~extrapath:options.OpaEnv.extrapath in
44 let package = package_name code in
45 (* adding internationalisation import *)
46 let i18n_to_import = I18nAndComputedString.may_import_package ?package ~exists ~options in
47 let imports = List.map (fun s -> Package(`import, s), label s) i18n_to_import in
48 (name,content,imports @ code)
49 in
63b8275 @arthuraa [fix] qml2js: distinguish client and server runtime.
arthuraa authored
50 let main_file (entry : Qml2jsOptions.extra_lib) =
51 match entry with
52 | `client (file, _) -> file
53 | `server (nodejs_module, _) -> Filename.concat nodejs_module "main.js"
54 in
662e95e @BourgerieQuentin [enhance] compiler, packages: Allows to have several backends (separated...
BourgerieQuentin authored
55 ObjectFiles.set_relative_stdlib
56 (Printf.sprintf "stdlib.%s" (OpaEnv.string_of_available_back_end options.OpaEnv.back_end));
fccc685 Initial open-source release
MLstate authored
57 ObjectFiles.set_extrapaths ~no_stdlib:(not options.OpaEnv.stdlib) options.OpaEnv.extrapath;
58 ObjectFiles.load
3004a51 @OpaOnWindowsNow [feature] objectFile: parallel compilation
OpaOnWindowsNow authored
59 ~parallelism:options.parallelism
fccc685 Initial open-source release
MLstate authored
60 ~extrajs:(
61 (*
62 TODO(if needed): we can patch ObjectFiles for passing the conf as well
63 *)
a41ccd3 @arthuraa [enhance] qml2js: use runtime package instead of raw files.
arthuraa authored
64 List.map main_file options.OpaEnv.extrajs
fccc685 Initial open-source release
MLstate authored
65 )
66 ~no_stdlib:(not options.OpaEnv.stdlib)
67 extract_package_decl
68 (SurfaceAstStaticInclude.pass_analyse_static_include_deps ~options)
69 (List.map map special_parsed_files @ List.map map user_parsed_files)
70 k
71
72 let pass_parser_generation
73 ~options:_ (env : (string,parsing_directive) env_both_lcodes)
74 : (string,renaming_directive) env_both_lcodes =
75 let rewrite code =
76 (* map_down because the directive `xml_parser may contain parsers *)
77 SurfaceAstTraversal.ExprTraverse.Heterogeneous.lift_map_down_to_fixpoint
78 (function (* the filter function, to make the typer happy *)
79 | #renaming_directive as x -> x
80 | #parsing_directive -> assert false)
81 (function (* the actual mapping function *)
82 | (Directive (`parser_ e, [], _), label) ->
83 SurfaceAstCons.with_label' label SurfaceAstTrx.translate_rule e
84 | (Directive (`xml_parser xml_parser, [], _), label) as e ->
85 SurfaceAstCons.with_label' label (SurfaceAstXmlPattern.process_parser e) xml_parser
86 | e -> e) code in
87 { env with
88 lcodeNotUser = rewrite env.lcodeNotUser;
89 lcodeUser = rewrite env.lcodeUser;
90 }
91
92 (**
93 Check for duplication of idents and some more.
94
95 This pass
96 - checks for level-0 identifiers with two definitions -- having two definitions of the same level-0 identifier
97 is either a warning or an error, depending on options
98 - renames all identifiers to make them unique
99
100 If the option [--warn-error duplicateL0] is set, having two level-0 identifiers with the same name is cause for
101 an error. Otherwise, it's an warning.
102 *)
103
104 let pass_check_duplication
105 compiler_inserted_names compiler_inserted_types ~options:_
106 (env : (string,renaming_directive) env_both_lcodes)
107 : (Ident.t,dependency_directive) env_both_lcodes =
108 let envs = SurfaceAstRenaming.init_env compiler_inserted_names compiler_inserted_types in
109 let envs = SurfaceAstRenaming.load_env envs in
110 let envs, lcodeNotUser = SurfaceAstRenaming.code envs env.lcodeNotUser in
111 let envs, lcodeUser = SurfaceAstRenaming.code envs env.lcodeUser in
112 SurfaceAstRenaming.save_env envs;
113 {
114 env with
115 lcodeNotUser ;
116 lcodeUser ;
117 lcodeTypeRenaming = SurfaceAstRenaming.extract_types_in_scope envs;
118 exported_values_idents = SurfaceAstRenaming.get_exported_values envs
119 }
120
121
122 let pass_tuple_types ~options:_ lcode =
123 SurfaceAstCons.with_builtin_position
124 (fun () ->
125 let intmap = SurfaceAstRenaming.get_tuple_int_map () in
126 let typedefs =
127 IntMap.fold
128 (fun n ident acc ->
129 let name = Printf.sprintf "tuple_%d" n in
130 let var d = Printf.sprintf "%s_%d" name d in
131 let vars = List.init n (fun n -> Ident.next (var n)) in
132 C.T.typedef
133 SurfaceAst.TDV_public ident ~tyvs: (List.map flatvar vars)
134 (C.T.tuple (List.map C.T.var vars))
135 :: acc)
136 intmap [] in
137 let defs = List.map C.C.newtype typedefs in
138 defs @ lcode)
Something went wrong with that request. Please try again.