atoms.ml 3.34 KB
Newer Older
1
open Encodings
2

3
4
module Symbol = Pool.Make(Utf8)

5
6
module V = struct

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
  include Custom.Pair(Ns)(Symbol)

  let atom_table = Hashtbl.create 63

  (* Hash-consing: only to reduce memory usage *)
  (* TODO: also after deserialization ? *)
  let mk ns x =
    let a = (ns, x) in
    try Hashtbl.find atom_table a 
    with Not_found ->
      let b = (ns, Symbol.mk x) in
      Hashtbl.add atom_table a b;
      b

  let mk_ascii s = mk Ns.empty (Utf8.mk s)
22
  let get_ascii (_,x) = Utf8.get_str (Symbol.value x)
23
24
25
26
27
28
29
30
31
32
33
		     
  let value (ns,x) = (ns, Symbol.value x)
		       
  let print ppf (ns,x) = 
    Format.fprintf ppf "%s" (Ns.InternalPrinter.tag (ns, Symbol.value x))
      
  let print_any_in_ns ppf ns =
    Format.fprintf ppf "%s" (Ns.InternalPrinter.any_ns ns)
      
  let print_quote ppf a = 
    Format.fprintf ppf "`%a" print a
34
35

end
36

37
module SymbolSet = SortedList.FiniteCofinite(Symbol)
38

39
40
41
42
43
44
45
46
47
48
49
50
let rec iter_sep sep f = function
  | [] -> ()
  | [ h ] -> f h
  | h :: t -> f h; sep (); iter_sep sep f t
      
let print_symbolset ns ppf = function
  | SymbolSet.Finite l -> 
      iter_sep 
	(fun () -> Format.fprintf ppf " |@ ") 
	(fun x -> V.print_quote ppf (ns,x)) l
  | SymbolSet.Cofinite t ->
      Format.fprintf ppf "@[`%a" V.print_any_in_ns ns;
51
      List.iter (fun x -> Format.fprintf ppf " \\@ %a" V.print_quote (ns,x)) t;
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
      Format.fprintf ppf "@]"

include SortedList.FiniteCofiniteMap(Ns)(SymbolSet)

let print_tag s = match get s with
  | `Finite [ns, SymbolSet.Finite [a]] -> 
      Some (fun ppf -> V.print ppf (ns,a))
  | `Finite [ns, SymbolSet.Cofinite []] -> 
      Some (fun ppf -> Format.fprintf ppf "%a" V.print_any_in_ns ns)
  | `Cofinite [] ->
      Some (fun ppf -> Format.fprintf ppf "_")
  | _ -> None

let print s = match get s with
  | `Finite l -> 
      List.map (fun (ns,s) ppf -> print_symbolset ns ppf s) l
  | `Cofinite [] ->
      [ fun ppf -> Format.fprintf ppf "Atom" ]
  | `Cofinite l ->
      [ fun ppf ->
	  Format.fprintf ppf "Atom";
	  List.iter 
	    (fun (ns,s) -> 
75
	       Format.fprintf ppf " \\@ (%a)" (print_symbolset ns) s)
76
77
78
	    l ]

type 'a map = 'a Imap.s Imap.s
79

80
let get_map (ns,x) m =   
81
  Imap.find x (Imap.find ns m)
82

83
84
module IntSet = 
  Set.Make(struct type t = int let compare (x:int) y = Pervasives.compare x y end)
85
86

let mk_map l =
87
  let all_ns = ref IntSet.empty in
88
89
  let def = ref None in
  List.iter 
90
91
92
93
94
    (function (s,x) ->
       match get s with
       | `Finite s -> 
	   List.iter (fun (ns,_) -> all_ns := IntSet.add ns !all_ns) s
       | `Cofinite _ -> def := Some (Imap.return x)) l;
95
96
97
98

  let one_ns ns =
    let def = ref None in
    let t = 
99
100
101
102
      List.fold_left
        (fun accu (s, y) -> 
	   match (symbol_set ns s) with
	     | SymbolSet.Finite syms ->
103
		 List.fold_left (fun accu x -> Imap.add x y accu) accu syms
104
	     | SymbolSet.Cofinite syms ->
105
		 def := Some y; accu)
106
        Imap.empty 
107
        l in
108
    Imap.prepare !def t
109
110
111
  in

  let t = 
112
113
    List.fold_left (fun accu ns -> Imap.add ns (one_ns ns) accu)
      Imap.empty 
114
      (IntSet.elements !all_ns) in
115
  let t = Imap.prepare !def t in
116
117
118
119
120
121
122
123

(*
  let rec rank y i = function
    | (_,x)::_ when x == y -> i
    | _::r -> rank y (succ i) r
    | [] -> assert false in

  let dump_ns =
124
    Imap.dump (fun ppf y -> Format.fprintf ppf "[%i]" (rank y 0 l)) in
125
126

  Format.fprintf Format.std_formatter "table: %a@." 
127
    (Imap.dump (fun ppf y -> Format.fprintf ppf "[%a]" dump_ns y)) t;
128
129
130
131
132
133
134
*)

  t




135