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
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id$ *)
open Format
type t = { stamp: int; name: string; mutable global: bool }
(* A stamp of 0 denotes a persistent identifier *)
let currentstamp = ref 0
let create s =
incr currentstamp;
{ name = s; stamp = !currentstamp; global = false }
let create_persistent s =
{ name = s; stamp = 0; global = true }
let rename i =
incr currentstamp;
{ i with stamp = !currentstamp }
let name i = i.name
let unique_name i = i.name ^ "_" ^ string_of_int i.stamp
let persistent i = (i.stamp = 0)
let equal i1 i2 = i1.name = i2.name
let same i1 i2 = i1 = i2
(* Possibly more efficient version (with a real compiler, at least):
if i1.stamp <> 0
then i1.stamp = i2.stamp
else i2.stamp = 0 && i1.name = i2.name *)
let binding_time i = i.stamp
let current_time() = !currentstamp
let set_current_time t = currentstamp := max !currentstamp t
let hide i =
{ i with stamp = -1 }
let make_global i =
i.global <- true
let global i =
i.global
let print ppf i =
match i.stamp with
| 0 -> fprintf ppf "%s!" i.name
| -1 -> fprintf ppf "%s#" i.name
| n -> fprintf ppf "%s/%i%s" i.name n (if i.global then "g" else "")
type 'a tbl =
Empty
| Node of 'a tbl * 'a data * 'a tbl * int
and 'a data =
{ ident: t;
data: 'a;
previous: 'a data option }
let empty = Empty
(* Inline expansion of height for better speed
* let height = function
* Empty -> 0
* | Node(_,_,_,h) -> h
*)
let mknode l d r =
let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
Node(l, d, r, (if hl >= hr then hl + 1 else hr + 1))
let balance l d r =
let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
if hl > hr + 1 then
match l with
| Node (ll, ld, lr, _)
when (match ll with Empty -> 0 | Node(_,_,_,h) -> h) >=
(match lr with Empty -> 0 | Node(_,_,_,h) -> h) ->
mknode ll ld (mknode lr d r)
| Node (ll, ld, Node(lrl, lrd, lrr, _), _) ->
mknode (mknode ll ld lrl) lrd (mknode lrr d r)
| _ -> assert false
else if hr > hl + 1 then
match r with
| Node (rl, rd, rr, _)
when (match rr with Empty -> 0 | Node(_,_,_,h) -> h) >=
(match rl with Empty -> 0 | Node(_,_,_,h) -> h) ->
mknode (mknode l d rl) rd rr
| Node (Node (rll, rld, rlr, _), rd, rr, _) ->
mknode (mknode l d rll) rld (mknode rlr rd rr)
| _ -> assert false
else
mknode l d r
let rec add id data = function
Empty ->
Node(Empty, {ident = id; data = data; previous = None}, Empty, 1)
| Node(l, k, r, h) ->
let c = compare id.name k.ident.name in
if c = 0 then
Node(l, {ident = id; data = data; previous = Some k}, r, h)
else if c < 0 then
balance (add id data l) k r
else
balance l k (add id data r)
let rec find_stamp s = function
None ->
raise Not_found
| Some k ->
if k.ident.stamp = s then k.data else find_stamp s k.previous
let rec find_same id = function
Empty ->
raise Not_found
| Node(l, k, r, _) ->
let c = compare id.name k.ident.name in
if c = 0 then
if id.stamp = k.ident.stamp
then k.data
else find_stamp id.stamp k.previous
else
find_same id (if c < 0 then l else r)
let rec find_name name = function
Empty ->
raise Not_found
| Node(l, k, r, _) ->
let c = compare name k.ident.name in
if c = 0 then
k.data
else
find_name name (if c < 0 then l else r)
|
