153 lines
4.3 KiB
OCaml
153 lines
4.3 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* 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)
|