Skip to content
This repository
tree: 72ef54aebe
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 226 lines (189 sloc) 6.922 kb
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
(*
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/>.
*)
(* CF mli *)
module Char = BaseChar
module String = BaseString

type uniq = Fresh.t_fresh
type t =
  | Source of string
  | FakeSource of string
      (* like source, except that
* they can be 'renamed' (to_string can do operations on them)
* because they won't ever be used to refer to external identifiers
* (like "Pervasives") *)
  | Internal of uniq

type t' = t

(** compare : uniqs and strings are comparable with Pervasives *)
let compare i1 i2 =
  match i1,i2 with
  | Source s1, Source s2 -> compare s1 s2
  | Source _, _ -> -1
  | _, Source _ -> 1
  | FakeSource s1, FakeSource s2 -> compare s1 s2
  | FakeSource _, _ -> -1
  | _, FakeSource _ -> 1
  | Internal (i1,_,_,package1), Internal (i2,_,_,package2) ->
      (match compare i1 i2 with
       | 0 -> String.compare package1 package2
       | c -> c)

let equal x y =
  match x, y with
  | Source s1, Source s2 -> s1 = s2
  | FakeSource s1, FakeSource s2 -> s1 = s2
  | Internal (i1,_,_,package1), Internal (i2,_,_,package2) ->
      i1 = i2 && package1 = package2
  | _ -> false

let hash = function
  | Source s -> Hashtbl.hash s
  | FakeSource s -> Hashtbl.hash s
  | Internal (i, _, _, package) -> Hashtbl.hash i + Hashtbl.hash package

module IHashtbl = Hashtbl.Make (struct type t = t' let hash = hash let equal = equal end)

let _alpha_protection = ref false

let active_alpha_protection () = _alpha_protection := true

let source x =
  if !_alpha_protection
  then assert false (* [ qml_Ast.ml; #54190 ] no source allowed after an alpha conv *)
  else Source x

let fake_source x = FakeSource x

let pattern = "^\\(\\([-+^@!&]+[-.+^*/<>=&|]*\\)\\|\\([*/<>=]+[-.+^*/<>=&|]*\\)\\|\\([|][-.+^*/<>=&|]+\\)\\)$"
let regexp = Str.regexp pattern

let is_operator_string s =
  (* the regexp was taken from libqmlcompil/qmlMainParser/qmlMainParser.trx -- but is now desynchronized
it's be better to have something simpler, like:
match s.[0] with '_' | 'a'..'z' | 'A'..'Z' -> false | _ -> true
but the main point is the synchronisation with the parser (printed code should reparse) *)
  Str.string_match regexp s 0

let is_operator = function
  | Source s -> is_operator_string s
  | _ -> false

let maybe_digest n =
  let digest s = String.sub (Digest.to_hex (Digest.string s)) 0 8 in
  if Base.String.is_word n && not (is_operator_string n) then n else digest n

let print id n d =
  Printf.sprintf "_v%d_%s%s%s" id n (if d = "" then "" else "_") d

let original_name = function
  | FakeSource n
  | Source n -> n
  | Internal (_, _, n, _) -> n

let start_with_n_underscore s =
  let i = ref 0 in
  let n = String.length s in
  while !i < n && s.[!i] = '_' do incr i done;
  !i

let renaming_should_warn_when i =
  let s = original_name i in
  (* not warning on xmlns: it is a bit hacky, we should be able
* to say that we don't want warnings for a specific ident instead *)
  if String.is_prefix "xmlns:" s then
    `never
  else
    match start_with_n_underscore s with
    | 0 -> `unused
    | 1 -> `used
    | _ -> `never

(** see note *)
let to_string =
  #<If:TESTING>
    original_name (* making sure we don't have _v34_f in tests refs *)
  #<Else>
    function
    | FakeSource n
    | Source n -> if Base.String.is_word n || is_operator_string n then n else "`" ^ n ^ "`"
    | Internal (_, id, n, d) ->
        let n = print id n d in
        if Base.String.is_word n then n else "`" ^ n ^ "`"
  #<End>

let opa_syntax ?(dont_protect_operator=false) id =
  #<If:TESTING>
    original_name id (* making sure we don't have _v34_f in tests refs *)
  #<Else>
    let n =
      match id with
      | FakeSource n
      | Source n -> n
      | Internal (_, id, n, d) -> print id n d
    in
    if Base.String.is_word n || (dont_protect_operator && is_operator_string n)
    then n else "`" ^ n ^ "`"
  #<End>

let to_uniq_string = function
  | FakeSource _
  | Source _ -> assert false
  | Internal (_, id, n, d) -> print id n d

(** Fixed : don't allow anonymous internal *)
(** /!\ Keep the name of ident safe for qml, and ocaml generation (it would break compilers) *)
let next =
  let get = Fresh.fresh_named_factory (fun i -> i) in
  fun ?(filename="") ?(descr="") n ->
    (* the description need to contain the package name for separate compilation *)
    let descr = (* TODO: remove this check once s2 is removed *)
      if ObjectFiles.Arg.is_separated () then
        ObjectFiles.get_current_package_name ()
      else
        filename ^ descr in
    let fresh = get ~name:n ~descr () in
    Internal fresh

let get_package_name = function
  | Internal (_,_,_,d) -> d
  | FakeSource s
  | Source s -> Base.invalid_argf "Ident.get_package_name: %s" s
let safe_get_package_name = function
  | Internal (_,_,_,d) -> Some d
  | FakeSource _
  | Source _ -> None

let nextf = fun ?filename ?descr fmt -> Printf.ksprintf (next ?filename ?descr) fmt


let escape =
  let valid_chars = function
    | '_'
    | 'a'..'z'
    | 'A'..'Z'
    | '0'..'9' -> true | _ -> false in
  let escape_char = '\'' in
  String.escape ~valid_chars ~escape_char

(** BIG BIG warning : do not print ` in function stident used in libconvert !
or some ident will have really ` in it *)
let stident = function
  | Source n -> n
  | FakeSource n -> "s"^escape n
  | Internal (_, id, n, d) -> print id (maybe_digest n) (maybe_digest d)

let memo_stident = IHashtbl.create 1024
let stident id =
  try
    IHashtbl.find memo_stident id
  with
  | Not_found ->
      let s = stident id in
      IHashtbl.add memo_stident id s ;
      s

let refresh ?(map=fun s -> s) y =
  match y with
  | Source n -> next (map n)
  | FakeSource s -> next (map s)
  | Internal (_, _, n, d) -> next ~descr:d (map n)
let refreshf ~map y = refresh ~map:(Printf.sprintf map) y

let concrete_string = function
  | Source n -> Printf.sprintf "Source(%s)" n
  | FakeSource s -> Printf.sprintf "FakeSource(%s)" s
  | Internal (argh, i, n, d) -> Printf.sprintf "Internal(%d, %d, %s , %s)" argh i n d

let light_ident = function
  | FakeSource n
  | Source n -> n
  | Internal (_, id, n, _) -> Printf.sprintf "_v%d_%s" id n

let is_universal_ident s =
  (String.length s > 0)
  && not (Char.is_digit s.[0])
  && (
    let valid c = Char.is_alpha c || Char.is_digit c || c = '_' in
    String.for_all valid s
  )
Something went wrong with that request. Please try again.