ident.ml 6.95 KB
Newer Older
1 2 3
(**************************************************************************)
(*                                                                        *)
(*  Copyright (C) 2010-                                                   *)
MARCHE Claude's avatar
MARCHE Claude committed
4 5 6
(*    François Bobot                                                     *)
(*    Jean-Christophe Filliâtre                                          *)
(*    Claude Marché                                                      *)
7 8 9 10 11 12 13 14 15 16 17 18 19
(*    Andrei Paskevich                                                    *)
(*                                                                        *)
(*  This software is free software; you can redistribute it and/or        *)
(*  modify it under the terms of the GNU Library General Public           *)
(*  License version 2.1, with the special exception on linking            *)
(*  described in file LICENSE.                                            *)
(*                                                                        *)
(*  This software 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.                  *)
(*                                                                        *)
(**************************************************************************)

François Bobot's avatar
François Bobot committed
20
open Stdlib
21 22
open Util

MARCHE Claude's avatar
MARCHE Claude committed
23 24 25 26 27 28
(** Labels *)

type label = string * Loc.position option

let label ?loc s = (s,loc)

29 30 31
(** Identifiers *)

type ident = {
32 33
  id_string : string;       (* non-unique name *)
  id_origin : origin;       (* origin of the ident *)
Andrei Paskevich's avatar
Andrei Paskevich committed
34
  id_label  : label list;   (* identifier labels *)
Andrei Paskevich's avatar
Andrei Paskevich committed
35
  id_tag    : Hashweak.tag; (* unique magical tag *)
36 37 38 39 40 41 42
}

and origin =
  | User of Loc.position
  | Derived of ident
  | Fresh

Andrei Paskevich's avatar
Andrei Paskevich committed
43
module Id = WeakStructMake (struct
44
  type t = ident
45 46 47 48 49 50
  let tag id = id.id_tag
end)

module Sid = Id.S
module Mid = Id.M
module Hid = Id.H
51

52 53
type preid = ident

54
let id_equal : ident -> ident -> bool = (==)
55

Andrei Paskevich's avatar
Andrei Paskevich committed
56
let id_hash id = Hashweak.tag_hash id.id_tag
57

Andrei Paskevich's avatar
Andrei Paskevich committed
58
(* constructors *)
59

Andrei Paskevich's avatar
Andrei Paskevich committed
60 61
let id_register = let r = ref 0 in fun id ->
  { id with id_tag = (incr r; Hashweak.create_tag !r) }
62

Andrei Paskevich's avatar
Andrei Paskevich committed
63
let create_ident name origin labels = {
64
  id_string = name;
65
  id_origin = origin;
Andrei Paskevich's avatar
Andrei Paskevich committed
66
  id_label  = labels;
Andrei Paskevich's avatar
Andrei Paskevich committed
67
  id_tag    = Hashweak.dummy_tag;
68 69
}

70 71 72 73 74
let file_regexp = Str.regexp "file:\\(.*\\)"
let line_regexp = Str.regexp "line:\\([0-9]+\\)"
let begin_regexp = Str.regexp "begin:\\([0-9]+\\)"
let end_regexp = Str.regexp "end:\\([0-9]+\\)"

Andrei Paskevich's avatar
Andrei Paskevich committed
75
let id_fresh ?(labels = []) nm = create_ident nm Fresh labels
76
let id_user ?(labels = []) nm loc =
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
  let (f,li,b,e) = Loc.extract loc in
  let f = ref f in
  let li = ref li in
  let b = ref b in
  let e = ref e in
  let l = List.fold_left
    (fun acc ((s,_) as lab) ->
       if Str.string_match file_regexp s 0 then
         (f := Str.matched_group 1 s; acc)
       else
       if Str.string_match line_regexp s 0 then
         (li := int_of_string (Str.matched_group 1 s); acc)
       else
       if Str.string_match begin_regexp s 0 then
         (b := int_of_string (Str.matched_group 1 s); acc)
       else
       if Str.string_match end_regexp s 0 then
         (e := int_of_string (Str.matched_group 1 s); acc)
       else lab :: acc)
    [] labels
  in
  let loc =
    ({Lexing.pos_fname = !f; Lexing.pos_lnum = !li;
      Lexing.pos_bol = 0; Lexing.pos_cnum = !b},
     {Lexing.pos_fname = !f; Lexing.pos_lnum = !li;
      Lexing.pos_bol = 0; Lexing.pos_cnum = !e})
  in
105 106
*)
  let l = labels in
107 108
  create_ident nm (User loc) l

Andrei Paskevich's avatar
Andrei Paskevich committed
109 110 111 112 113 114 115
let id_derive ?(labels = []) nm id = create_ident nm (Derived id) labels

let id_clone ?(labels = []) id =
  create_ident id.id_string (Derived id) (labels @ id.id_label)

let id_dup ?(labels = []) id =
  create_ident id.id_string id.id_origin (labels @ id.id_label)
116

117
let rec id_derived_from i1 i2 = id_equal i1 i2 ||
118 119 120
  (match i1.id_origin with
    | Derived i3 -> id_derived_from i3 i2
    | _ -> false)
121

122
let rec id_from_user i =
Francois Bobot's avatar
Francois Bobot committed
123 124 125 126 127
  match i.id_origin with
    | Derived i -> id_from_user i
    | User l -> Some l
    | Fresh -> None

128 129
(** Unique names for pretty printing *)

130 131
type ident_printer = {
  indices   : (string, int) Hashtbl.t;
Andrei Paskevich's avatar
Andrei Paskevich committed
132
  values    : string Hid.t;
133 134 135
  sanitizer : string -> string;
  blacklist : string list;
}
136 137 138 139 140 141

let rec find_index indices name ind =
  if Hashtbl.mem indices (name ^ string_of_int ind)
  then find_index indices name (succ ind) else ind

let find_unique indices name =
142
  let name = try
143 144
    let ind = Hashtbl.find indices name + 1 in
    let ind = find_index indices name ind in
145
    Hashtbl.replace indices name ind;
146
    name ^ string_of_int ind
147 148 149
  with Not_found -> name in
  Hashtbl.replace indices name 0;
  name
150

151 152
let reserve indices name = ignore (find_unique indices name)

153 154
let same x = x

155
let create_ident_printer ?(sanitizer = same) sl =
156
  let indices = Hashtbl.create 1997 in
157 158
  List.iter (reserve indices) sl;
  { indices   = indices;
Andrei Paskevich's avatar
Andrei Paskevich committed
159
    values    = Hid.create 1997;
160 161
    sanitizer = sanitizer;
    blacklist = sl }
162

163
let id_unique printer ?(sanitizer = same) id =
164
  try
Andrei Paskevich's avatar
Andrei Paskevich committed
165
    Hid.find printer.values id
166
  with Not_found ->
167
    let name = sanitizer (printer.sanitizer id.id_string) in
168
    let name = find_unique printer.indices name in
Andrei Paskevich's avatar
Andrei Paskevich committed
169
    Hid.replace printer.values id name;
170 171
    name

172
let string_unique printer s = find_unique printer.indices s
173

174
let forget_id printer id =
175
  try
Andrei Paskevich's avatar
Andrei Paskevich committed
176
    let name = Hid.find printer.values id in
177
    Hashtbl.remove printer.indices name;
Andrei Paskevich's avatar
Andrei Paskevich committed
178
    Hid.remove printer.values id
179 180
  with Not_found -> ()

181
let forget_all printer =
Andrei Paskevich's avatar
Andrei Paskevich committed
182
  Hid.clear printer.values;
183 184
  Hashtbl.clear printer.indices;
  List.iter (reserve printer.indices) printer.blacklist
185

186 187
(** Sanitizers *)

188
let unsanitizable = Debug.register_flag "unsanitizable"
189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205

let char_to_alpha c = match c with
  | 'a'..'z' | 'A'..'Z' -> String.make 1 c
  | ' ' -> "sp" | '_'  -> "us" | '#' -> "sh"
  | '`' -> "bq" | '~'  -> "tl" | '!' -> "ex"
  | '@' -> "at" | '$'  -> "dl" | '%' -> "pc"
  | '^' -> "cf" | '&'  -> "et" | '*' -> "as"
  | '(' -> "lp" | ')'  -> "rp" | '-' -> "mn"
  | '+' -> "pl" | '='  -> "eq" | '[' -> "lb"
  | ']' -> "rb" | '{'  -> "lc" | '}' -> "rc"
  | ':' -> "cl" | '\'' -> "qt" | '"' -> "dq"
  | '<' -> "ls" | '>'  -> "gt" | '/' -> "sl"
  | '?' -> "qu" | '\\' -> "bs" | '|' -> "br"
  | ';' -> "sc" | ','  -> "cm" | '.' -> "dt"
  | '0' -> "zr" | '1'  -> "un" | '2' -> "du"
  | '3' -> "tr" | '4'  -> "qr" | '5' -> "qn"
  | '6' -> "sx" | '7'  -> "st" | '8' -> "oc"
206 207 208 209
  | '9' -> "nn" | '\n' -> "br"
  | _ ->
    Debug.dprintf unsanitizable "Unsanitizable : '%c' can't be sanitized@." c;
    "zz"
210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227

let char_to_lalpha c = String.uncapitalize (char_to_alpha c)
let char_to_ualpha c = String.capitalize (char_to_alpha c)

let char_to_alnum c =
  match c with '0'..'9' -> String.make 1 c | _ -> char_to_alpha c

let char_to_alnumus c =
  match c with '_' | ' ' -> "_" | _ -> char_to_alnum c

let sanitizer head rest n =
  let lst = ref [] in
  let code c = lst := rest c :: !lst in
  let n = if n = "" then "zilch" else n in
  String.iter code n;
  let rst = List.tl (List.rev !lst) in
  let cs = head (String.get n 0) :: rst in
  String.concat "" cs