Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 218 lines (182 sloc) 6.734 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 (* CF mli *)
19 module Char = BaseChar
20 module String = BaseString
21
22 type uniq = Fresh.t_fresh
23 type t =
24 | Source of string
25 | FakeSource of string
26 (* like source, except that
27 * they can be 'renamed' (to_string can do operations on them)
28 * because they won't ever be used to refer to external identifiers
29 * (like "Pervasives") *)
30 | Internal of uniq
31
32 type t' = t
33
34 (** compare : uniqs and strings are comparable with Pervasives *)
35 let compare i1 i2 =
36 match i1,i2 with
37 | Source s1, Source s2 -> compare s1 s2
38 | Source _, _ -> -1
39 | _, Source _ -> 1
40 | FakeSource s1, FakeSource s2 -> compare s1 s2
41 | FakeSource _, _ -> -1
42 | _, FakeSource _ -> 1
43 | Internal (i1,_,_,package1), Internal (i2,_,_,package2) ->
44 (match compare i1 i2 with
45 | 0 -> String.compare package1 package2
46 | c -> c)
47
48 let equal x y =
49 match x, y with
50 | Source s1, Source s2 -> s1 = s2
51 | FakeSource s1, FakeSource s2 -> s1 = s2
52 | Internal (i1,_,_,package1), Internal (i2,_,_,package2) ->
53 i1 = i2 && package1 = package2
54 | _ -> false
55
56 let hash = function
57 | Source s -> Hashtbl.hash s
58 | FakeSource s -> Hashtbl.hash s
59 | Internal (i, _, _, package) -> Hashtbl.hash i + Hashtbl.hash package
60
61 module IHashtbl = Hashtbl.Make (struct type t = t' let hash = hash let equal = equal end)
62
63 let _alpha_protection = ref false
64
65 let active_alpha_protection () = _alpha_protection := true
66
67 let source x =
68 if !_alpha_protection
69 then assert false (* [ qml_Ast.ml; #54190 ] no source allowed after an alpha conv *)
70 else Source x
71
72 let fake_source x = FakeSource x
73
74 let pattern = "^\\(\\([-+^@!&]+[-.+^*/<>=&|]*\\)\\|\\([*/<>=]+[-.+^*/<>=&|]*\\)\\|\\([|][-.+^*/<>=&|]+\\)\\)$"
75 let regexp = Str.regexp pattern
76
77 let is_operator_string s =
78 (* the regexp was taken from libqmlcompil/qmlMainParser/qmlMainParser.trx -- but is now desynchronized
79 it's be better to have something simpler, like:
80 match s.[0] with '_' | 'a'..'z' | 'A'..'Z' -> false | _ -> true
81 but the main point is the synchronisation with the parser (printed code should reparse) *)
82 Str.string_match regexp s 0
83
84 let is_operator = function
85 | Source s -> is_operator_string s
86 | _ -> false
87
88 let maybe_digest n =
89 let digest s = String.sub (Digest.to_hex (Digest.string s)) 0 8 in
90 if Base.String.is_word n && not (is_operator_string n) then n else digest n
91
92 let print id n d =
93 Printf.sprintf "_v%d_%s%s%s" id n (if d = "" then "" else "_") d
94
95 let original_name = function
96 | FakeSource n
97 | Source n -> n
98 | Internal (_, _, n, _) -> n
99
100 let start_with_n_underscore s =
101 let i = ref 0 in
102 let n = String.length s in
103 while !i < n && s.[!i] = '_' do incr i done;
104 !i
105
106 let renaming_should_warn_when i =
107 let s = original_name i in
108 (* not warning on xmlns: it is a bit hacky, we should be able
109 * to say that we don't want warnings for a specific ident instead *)
110 if String.is_prefix "xmlns:" s then
111 `never
112 else
113 match start_with_n_underscore s with
114 | 0 -> `unused
115 | 1 -> `used
116 | _ -> `never
117
118 (** see note *)
119 let to_string =
120 #<If:TESTING>
121 original_name (* making sure we don't have _v34_f in tests refs *)
122 #<Else>
123 function
124 | FakeSource n
125 | Source n -> if Base.String.is_word n || is_operator_string n then n else "`" ^ n ^ "`"
126 | Internal (_, id, n, d) ->
127 let n = print id n d in
128 if Base.String.is_word n then n else "`" ^ n ^ "`"
129 #<End>
130
131 let opa_syntax ?(dont_protect_operator=false) id =
132 #<If:TESTING>
133 original_name id (* making sure we don't have _v34_f in tests refs *)
134 #<Else>
135 let n =
136 match id with
137 | FakeSource n
138 | Source n -> n
139 | Internal (_, id, n, d) -> print id n d
140 in
141 if Base.String.is_word n || (dont_protect_operator && is_operator_string n)
142 then n else "`" ^ n ^ "`"
143 #<End>
144
145 let to_uniq_string = function
146 | FakeSource _
147 | Source _ -> assert false
148 | Internal (_, id, n, d) -> print id n d
149
150 (** Fixed : don't allow anonymous internal *)
151 (** /!\ Keep the name of ident safe for qml, and ocaml generation (it would break compilers) *)
152 let next =
153 let get = Fresh.fresh_named_factory (fun i -> i) in
154 fun ?(filename="") ?(descr="") n ->
155 (* the description need to contain the package name for separate compilation *)
156 let descr = (* TODO: remove this check once s2 is removed *)
157 if ObjectFiles.Arg.is_separated () then
158 ObjectFiles.get_current_package_name ()
159 else
160 filename ^ descr in
161 let fresh = get ~name:n ~descr () in
162 Internal fresh
163
164 let get_package_name = function
165 | Internal (_,_,_,d) -> d
166 | FakeSource s
167 | Source s -> Base.invalid_argf "Ident.get_package_name: %s" s
168 let safe_get_package_name = function
169 | Internal (_,_,_,d) -> Some d
170 | FakeSource _
171 | Source _ -> None
172
173 let nextf = fun ?filename ?descr fmt -> Printf.ksprintf (next ?filename ?descr) fmt
174
175
176 let escape =
177 let valid_chars = function
178 | '_'
179 | 'a'..'z'
180 | 'A'..'Z'
181 | '0'..'9' -> true | _ -> false in
182 let escape_char = '\'' in
183 String.escape ~valid_chars ~escape_char
184
185 (** BIG BIG warning : do not print ` in function stident used in libconvert !
186 or some ident will have really ` in it *)
187 let stident = function
188 | Source n -> n
189 | FakeSource n -> "s"^escape n
190 | Internal (_, id, n, d) -> print id (maybe_digest n) (maybe_digest d)
191
192 let memo_stident = IHashtbl.create 1024
193 let stident id =
194 try
195 IHashtbl.find memo_stident id
196 with
197 | Not_found ->
198 let s = stident id in
199 IHashtbl.add memo_stident id s ;
200 s
201
202 let refresh ?(map=fun s -> s) y =
203 match y with
204 | Source n -> next (map n)
205 | FakeSource s -> next (map s)
206 | Internal (_, _, n, d) -> next ~descr:d (map n)
207 let refreshf ~map y = refresh ~map:(Printf.sprintf map) y
208
209 let concrete_string = function
210 | Source n -> Printf.sprintf "Source(%s)" n
211 | FakeSource s -> Printf.sprintf "FakeSource(%s)" s
212 | Internal (argh, i, n, d) -> Printf.sprintf "Internal(%d, %d, %s , %s)" argh i n d
213
214 let light_ident = function
215 | FakeSource n
216 | Source n -> n
217 | Internal (_, id, n, _) -> Printf.sprintf "_v%d_%s" id n
Something went wrong with that request. Please try again.