libmojave/util/lm_symbol_hash.ml

   1 (*
   2  * Right now the symbol table is just a representation of strings.
   3  *
   4  * ----------------------------------------------------------------
   5  *
   6  * Copyright (C) 1999-2002-2005 Mojave Group, Caltech
   7  *
   8  * This library is free software; you can redistribute it and/or
   9  * modify it under the terms of the GNU Lesser General Public
  10  * License as published by the Free Software Foundation,
  11  * version 2.1 of the License.
  12  *
  13  * This library is distributed in the hope that it will be useful,
  14  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16  * Lesser General Public License for more details.
  17  *
  18  * You should have received a copy of the GNU Lesser General Public
  19  * License along with this library; if not, write to the Free Software
  20  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
  21  *
  22  * Additional permission is given to link this library with the
  23  * OpenSSL project's "OpenSSL" library, and with the OCaml runtime,
  24  * and you may distribute the linked executables.  See the file
  25  * LICENSE.libmojave for more details.
  26  *
  27  * Author: Jason Hickey
  28  * jyh@cs.caltech.edu
  29  *
  30  * ----------------------------------------------------------------
  31  * Revision History
  32  *
  33  *  2002  Dec  4  Michael Maire  Added SymbolIndex
  34  *                               Added sets, tables, indices for
  35  *                               symbol pairs and triples
  36  *)
  37 open Lm_debug
  38 open Lm_printf
  39 open Lm_thread
  40
  41 let debug_symbol = ref false
  42
  43 (*
  44  * Hash-cons the symbols.
  45  *)
  46 (* %%MAGICBEGIN%% *)
  47 module SymbolHashArg =
  48 struct
  49    type t = int * string
  50
  51    let debug = "Symbol"
  52
  53    let hash = Hashtbl.hash
  54
  55    let compare (i1, s1) (i2, s2) =
  56       if i1 < i2 then
  57          -1
  58       else if i1 > i2 then
  59          1
  60       else
  61          Lm_string_util.string_compare s1 s2
  62
  63    let reintern s =
  64       s
  65 end;;
  66
  67 module SymbolHash = Lm_hash.MakeHashMarshal (SymbolHashArg);;
  68
  69 type symbol = SymbolHash.t
  70 (* %%MAGICEND%% *)
  71
  72 (*
  73  * We no longer use a hashtable.
  74  * Symbols with a 0 index are interned.
  75  *)
  76 type var = symbol
  77
  78 (* An "empty" variable name *)
  79 let empty_var = SymbolHash.create (0, "")
  80
  81 let new_number, make =
  82    let count = ref 100 in
  83    let lock = Mutex.create () in
  84       (fun () ->
  85             Mutex.lock lock;
  86             let i = !count in
  87                count := succ i;
  88                Mutex.unlock lock;
  89                i),
  90       (fun s i ->
  91          if i >= !count then begin
  92             Mutex.lock lock;
  93             count := max (!count) (succ i);
  94             Mutex.unlock lock
  95          end;
  96          SymbolHash.create (i, s))
  97
  98 (*
  99  * Get the integer prefix.
 100  *)
 101 let to_int v =
 102    fst (SymbolHash.get v)
 103
 104 (*
 105  * Get the string suffix.
 106  *)
 107 let to_string v =
 108    snd (SymbolHash.get v)
 109
 110 (*
 111  * Mangle a string so it uses printable characters.
 112  *)
 113 let is_special s =
 114    let len = String.length s in
 115    let rec search i =
 116       if i = len then
 117          false
 118       else
 119          match s.[i] with
 120             'a'..'z'
 121           | 'A'..'Z'
 122           | '0'..'9'
 123           | '_'
 124           | '.'
 125           | '%' ->
 126                search (succ i)
 127           | _ ->
 128                true
 129    in
 130       search 0
 131
 132 let rec buffer_mangle buf s i len =
 133    if len <> 0 then
 134       let c = s.[i] in
 135       let _ =
 136          match c with
 137             'a'..'z'
 138           | 'A'..'Z'
 139           | '0'..'9'
 140           | '_' ->
 141                Buffer.add_char buf c
 142           | _ ->
 143                Buffer.add_char buf '.';
 144                Buffer.add_string buf (string_of_int (Char.code c))
 145       in
 146          buffer_mangle buf s (succ i) (pred len)
 147
 148 let mangle s =
 149    let len = String.length s in
 150    let buf = Buffer.create len in
 151       buffer_mangle buf s 0 len;
 152       Buffer.contents buf
 153
 154
 155 (*
 156  * Add a symbol to the table.
 157  *)
 158 let stop s =
 159    eprintf "Bogus symbol %s@." s;
 160    false
 161
 162 let char0 = Char.code '0'
 163
 164 let rec zeros s i =
 165    (i < 0) || match s.[i] with
 166       '1'..'9' -> false
 167     | '0' -> zeros s (pred i)
 168     | _ -> true
 169
 170 let rec all_digits s i =
 171    (i<0) || match s.[i] with
 172       '0' .. '9' -> all_digits s (pred i)
 173     | _ -> false
 174
 175 let rec pad_with_underscore n s i =
 176    if i <= 0 then
 177       n > 0
 178    else
 179       let i = pred i in
 180          match s.[i] with
 181             '_' -> pad_with_underscore n s i
 182           | '0' -> not (zeros s (pred i)) && ((n>0) || not (all_digits s (pred i)))
 183           | '1' .. '9' -> (n>0) || not (all_digits s (pred i))
 184           | _ -> false
 185
 186 let add =
 187    let rec loop s fact n i =
 188       if i < 0 then
 189          SymbolHash.create (0, s)
 190       else
 191          match s.[i] with
 192             '_' ->
 193                make (String.sub s 0 (if pad_with_underscore n s i then i else i + 1)) n
 194           | '0' when zeros s (i - 1) ->
 195                make (String.sub s 0 (succ i)) n
 196           | '0'..'9' as c ->
 197                loop s (fact * 10) (n + fact * (Char.code c - char0)) (pred i)
 198           | _ ->
 199                make (String.sub s 0 (succ i)) n
 200    in
 201       (fun s -> loop s 1 0 (String.length s - 1))
 202
 203 let add_mangle s =
 204    add (mangle s)
 205
 206 let reintern = SymbolHash.reintern
 207
 208 let is_numeric_symbol v =
 209    match SymbolHash.get v with
 210       (0, s) -> all_digits s (String.length s - 1)
 211     | _ -> false
 212
 213 (*
 214  * Create a new symbol.
 215  * Don't add it to the table.
 216  *)
 217 let new_symbol_string s =
 218    SymbolHash.create (new_number (), s)
 219
 220 let new_symbol v =
 221    new_symbol_string (to_string v)
 222
 223 let new_symbol_pre pre v =
 224    let v = to_string v in
 225    let s =
 226       if debug debug_symbol then
 227          v ^ "/" ^ pre
 228       else
 229          v
 230    in
 231       new_symbol_string s
 232
 233 (*
 234  * Create a new symbol, avoiding the ones defined by the predicate.
 235  *)
 236 let new_name v pred =
 237    let v = to_string v in
 238    let rec search i =
 239       let nv = make v i in
 240          if pred nv then
 241             search (succ i)
 242          else
 243             nv
 244    in
 245       search 0
 246
 247 (*
 248  * Create a new symbol, calling the function f until it
 249  * returns non-nil.
 250  *)
 251 let new_name_gen v f =
 252    let v = to_string v in
 253    let rec search i =
 254       let nv = make v i in
 255          match f nv with
 256             Some x ->
 257                x
 258           | None ->
 259                search (succ i)
 260    in
 261       search 0
 262
 263 (*
 264  * Check if the symbol is in the table.
 265  *)
 266 let is_interned v =
 267    to_int v = 0
 268
 269 (*
 270  * Printer.
 271  * If the symbol is not a defined symbol,
 272  * print the index.
 273  *)
 274 let string_of_symbol v =
 275    let i, s = SymbolHash.get v in
 276    let len = String.length s in
 277    let s = if pad_with_underscore i s len then s ^ "_" else s in
 278       if i = 0 then
 279          s
 280       else
 281          s ^ string_of_int i
 282
 283 let output_symbol out v =
 284    Lm_printf.output_string out (string_of_symbol v)
 285
 286 let rec output_symbol_list out vl =
 287    match vl with
 288       [v] ->
 289          output_symbol out v
 290     | v :: vl ->
 291          Lm_printf.fprintf out "%a, %a" output_symbol v output_symbol_list vl
 292     | [] ->
 293          ()
 294
 295 (*
 296  * Print extended symbols. Used in FIR printing.
 297  *)
 298 exception Has;;
 299
 300 let string_of_ext_symbol v =
 301    let i, s = SymbolHash.get v in
 302    let has_special_char s =
 303       try
 304          for i = 0 to String.length s - 1 do
 305             let c = Char.lowercase (String.get s i) in
 306                if not ((Char.code c >= Char.code 'a' && Char.code c <= Char.code 'z')
 307                        || (Char.code c >= Char.code '0' && Char.code c <= Char.code '9')
 308                        || c = '_')
 309                then
 310                   raise Has
 311          done;
 312          false
 313       with
 314          Has ->
 315             true
 316    in
 317    let s =
 318       if i = 0 then
 319          s
 320       else
 321          sprintf "%s%d" s i
 322    in
 323       if has_special_char s then
 324          sprintf "`\"%s\"" s
 325       else
 326          s
 327
 328 let pp_print_ext_symbol buf v =
 329    pp_print_string buf (string_of_ext_symbol v)
 330
 331 let pp_print_symbol buf v =
 332    pp_print_string buf (string_of_symbol v)
 333
 334 let rec pp_print_symbol_list buf vl =
 335    match vl with
 336       [v] ->
 337          pp_print_symbol buf v
 338     | v :: vl ->
 339          fprintf buf "%a, %a" pp_print_symbol v pp_print_symbol_list vl
 340     | [] ->
 341          ()
 342
 343 (*
 344  * Compare for equality.
 345  *)
 346 let eq = SymbolHash.equal
 347
 348 let compare = SymbolHash.compare
 349
 350 let hash = SymbolHash.hash
 351
 352 (*
 353  * Compare pair of symbols for equality.
 354  *)
 355 let compare_pair (s1, s2) (s1', s2') =
 356    let cmp = compare s1 s1' in
 357       if cmp = 0 then
 358          compare s2 s2'
 359       else
 360          cmp
 361
 362 (*
 363  * Compare triple of symbols for equality.
 364  *)
 365 let compare_triple (s1, s2, s3) (s1', s2', s3') =
 366    let cmp = compare s1 s1' in
 367       if cmp = 0 then
 368          let cmp = compare s2 s2' in
 369             if cmp = 0 then
 370                compare s3 s3'
 371             else
 372                cmp
 373       else
 374          cmp
 375
 376 (*
 377  * Compare lists of symbols for equality.
 378  *)
 379 let rec compare_lists sl1 sl2 =
 380    match sl1, sl2 with
 381       s1 :: sl1, s2 :: sl2 ->
 382          let cmp = compare s1 s2 in
 383             if cmp = 0 then
 384                compare_lists sl1 sl2
 385             else
 386                cmp
 387     | [], [] ->
 388          0
 389     | [], _ :: _ ->
 390          -1
 391     | _ :: _, [] ->
 392          1
 393
 394 (*
 395  * Build sets, tables, indices where the keys are symbols,
 396  * ordered symbol pairs, or orderd symbol triples.
 397  *)
 398 module Base =
 399 struct
 400    type t = symbol
 401    let compare = compare
 402 end
 403
 404 module PairBase =
 405 struct
 406    type t = symbol * symbol
 407    let compare = compare_pair
 408 end
 409
 410 module TripleBase =
 411 struct
 412    type t = symbol * symbol * symbol
 413    let compare = compare_triple
 414 end
 415
 416 module SymbolSet = Lm_set.LmMake (Base)
 417 module SymbolTable = Lm_map.LmMake (Base)
 418 module SymbolMTable = Lm_map.LmMakeList (Base)
 419 module SymbolIndex = Lm_index.LmMake (Base)
 420
 421 module SymbolPairSet = Lm_set.LmMake (PairBase)
 422 module SymbolPairTable = Lm_map.LmMake (PairBase)
 423 module SymbolPairMTable = Lm_map.LmMakeList (PairBase)
 424 module SymbolPairIndex = Lm_index.LmMake (PairBase)
 425
 426 module SymbolTripleSet = Lm_set.LmMake (TripleBase)
 427 module SymbolTripleTable = Lm_map.LmMake (TripleBase)
 428 module SymbolTripleMTable = Lm_map.LmMakeList (TripleBase)
 429 module SymbolTripleIndex = Lm_index.LmMake (TripleBase)
 430
 431 (*
 432  * Symbol lists are also useful.
 433  *)
 434 module SymbolListCompare =
 435 struct
 436    type t = symbol list
 437
 438    let rec compare l1 l2 =
 439       match l1, l2 with
 440          v1 :: l1, v2 :: l2 ->
 441             let cmp = Base.compare v1 v2 in
 442                if cmp = 0 then
 443                   compare l1 l2
 444                else
 445                   cmp
 446        | [], _ :: _ ->
 447             -1
 448        | _ :: _, [] ->
 449             1
 450        | [], [] ->
 451             0
 452 end
 453
 454 module SymbolListSet = Lm_set.LmMake (SymbolListCompare)
 455 module SymbolListTable = Lm_map.LmMake (SymbolListCompare)
 456
 457 let output_symbol_set out s =
 458    output_symbol_list out (SymbolSet.to_list s)
 459
 460 let pp_print_symbol_set buf s =
 461    pp_print_symbol_list buf (SymbolSet.to_list s)
 462
 463 (*
 464  * -*-
 465  * Local Variables:
 466  * Caml-master: "set"
 467  * End:
 468  * -*-
 469  *)