/usr/lib/ocaml/compiler-libs/typing/subst.ml is in ocaml-compiler-libs 3.12.1-2ubuntu2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 | (***********************************************************************)
(* *)
(* 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: subst.ml 10285 2010-04-20 14:11:28Z xleroy $ *)
(* Substitutions *)
open Misc
open Path
open Types
open Btype
type t =
{ types: (Ident.t, Path.t) Tbl.t;
modules: (Ident.t, Path.t) Tbl.t;
modtypes: (Ident.t, module_type) Tbl.t;
for_saving: bool }
let identity =
{ types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty;
for_saving = false }
let add_type id p s = { s with types = Tbl.add id p s.types }
let add_module id p s = { s with modules = Tbl.add id p s.modules }
let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes }
let for_saving s = { s with for_saving = true }
let rec module_path s = function
Pident id as p ->
begin try Tbl.find id s.modules with Not_found -> p end
| Pdot(p, n, pos) ->
Pdot(module_path s p, n, pos)
| Papply(p1, p2) ->
Papply(module_path s p1, module_path s p2)
let rec modtype_path s = function
Pident id as p ->
begin try
match Tbl.find id s.modtypes with
| Tmty_ident p -> p
| _ -> fatal_error "Subst.modtype_path"
with Not_found -> p end
| Pdot(p, n, pos) ->
Pdot(module_path s p, n, pos)
| Papply(p1, p2) ->
fatal_error "Subst.modtype_path"
let type_path s = function
Pident id as p ->
begin try Tbl.find id s.types with Not_found -> p end
| Pdot(p, n, pos) ->
Pdot(module_path s p, n, pos)
| Papply(p1, p2) ->
fatal_error "Subst.type_path"
(* Special type ids for saved signatures *)
let new_id = ref (-1)
let reset_for_saving () = new_id := -1
let newpersty desc =
decr new_id; { desc = desc; level = generic_level; id = !new_id }
(* Similar to [Ctype.nondep_type_rec]. *)
let rec typexp s ty =
let ty = repr ty in
match ty.desc with
Tvar | Tunivar ->
if s.for_saving || ty.id < 0 then
let ty' =
if s.for_saving then newpersty ty.desc else newty2 ty.level ty.desc
in
save_desc ty ty.desc; ty.desc <- Tsubst ty'; ty'
else ty
| Tsubst ty ->
ty
(* cannot do it, since it would omit subsitution
| Tvariant row when not (static_row row) ->
ty
*)
| _ ->
let desc = ty.desc in
save_desc ty desc;
(* Make a stub *)
let ty' = if s.for_saving then newpersty Tvar else newgenvar () in
ty.desc <- Tsubst ty';
ty'.desc <-
begin match desc with
| Tconstr(p, tl, abbrev) ->
Tconstr(type_path s p, List.map (typexp s) tl, ref Mnil)
| Tpackage(p, n, tl) ->
Tpackage(modtype_path s p, n, List.map (typexp s) tl)
| Tobject (t1, name) ->
Tobject (typexp s t1,
ref (match !name with
None -> None
| Some (p, tl) ->
Some (type_path s p, List.map (typexp s) tl)))
| Tvariant row ->
let row = row_repr row in
let more = repr row.row_more in
(* We must substitute in a subtle way *)
(* Tsubst takes a tuple containing the row var and the variant *)
begin match more.desc with
Tsubst {desc = Ttuple [_;ty2]} ->
(* This variant type has been already copied *)
ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
Tlink ty2
| _ ->
let dup =
s.for_saving || more.level = generic_level || static_row row ||
match more.desc with Tconstr _ -> true | _ -> false in
(* Various cases for the row variable *)
let more' =
match more.desc with
Tsubst ty -> ty
| Tconstr _ -> typexp s more
| Tunivar | Tvar ->
save_desc more more.desc;
if s.for_saving then newpersty more.desc else
if dup && more.desc <> Tunivar then newgenvar () else more
| _ -> assert false
in
(* Register new type first for recursion *)
more.desc <- Tsubst(newgenty(Ttuple[more';ty']));
(* Return a new copy *)
let row =
copy_row (typexp s) true row (not dup) more' in
match row.row_name with
Some (p, tl) ->
Tvariant {row with row_name = Some (type_path s p, tl)}
| None ->
Tvariant row
end
| Tfield(label, kind, t1, t2) when field_kind_repr kind = Fabsent ->
Tlink (typexp s t2)
| _ -> copy_type_desc (typexp s) desc
end;
ty'
(*
Always make a copy of the type. If this is not done, type levels
might not be correct.
*)
let type_expr s ty =
let ty' = typexp s ty in
cleanup_types ();
ty'
let type_declaration s decl =
let decl =
{ type_params = List.map (typexp s) decl.type_params;
type_arity = decl.type_arity;
type_kind =
begin match decl.type_kind with
Type_abstract -> Type_abstract
| Type_variant cstrs ->
Type_variant(
List.map (fun (n, args) -> (n, List.map (typexp s) args))
cstrs)
| Type_record(lbls, rep) ->
Type_record(
List.map (fun (n, mut, arg) -> (n, mut, typexp s arg))
lbls,
rep)
end;
type_manifest =
begin match decl.type_manifest with
None -> None
| Some ty -> Some(typexp s ty)
end;
type_private = decl.type_private;
type_variance = decl.type_variance;
}
in
cleanup_types ();
decl
let class_signature s sign =
{ cty_self = typexp s sign.cty_self;
cty_vars =
Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.cty_vars;
cty_concr = sign.cty_concr;
cty_inher =
List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl))
sign.cty_inher
}
let rec class_type s =
function
Tcty_constr (p, tyl, cty) ->
Tcty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty)
| Tcty_signature sign ->
Tcty_signature (class_signature s sign)
| Tcty_fun (l, ty, cty) ->
Tcty_fun (l, typexp s ty, class_type s cty)
let class_declaration s decl =
let decl =
{ cty_params = List.map (typexp s) decl.cty_params;
cty_variance = decl.cty_variance;
cty_type = class_type s decl.cty_type;
cty_path = type_path s decl.cty_path;
cty_new =
begin match decl.cty_new with
None -> None
| Some ty -> Some (typexp s ty)
end }
in
(* Do not clean up if saving: next is cltype_declaration *)
if not s.for_saving then cleanup_types ();
decl
let cltype_declaration s decl =
let decl =
{ clty_params = List.map (typexp s) decl.clty_params;
clty_variance = decl.clty_variance;
clty_type = class_type s decl.clty_type;
clty_path = type_path s decl.clty_path }
in
(* Do clean up even if saving: type_declaration may be recursive *)
cleanup_types ();
decl
let class_type s cty =
let cty = class_type s cty in
cleanup_types ();
cty
let value_description s descr =
{ val_type = type_expr s descr.val_type;
val_kind = descr.val_kind }
let exception_declaration s tyl =
List.map (type_expr s) tyl
let rec rename_bound_idents s idents = function
[] -> (List.rev idents, s)
| Tsig_type(id, d, _) :: sg ->
let id' = Ident.rename id in
rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg
| Tsig_module(id, mty, _) :: sg ->
let id' = Ident.rename id in
rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg
| Tsig_modtype(id, d) :: sg ->
let id' = Ident.rename id in
rename_bound_idents (add_modtype id (Tmty_ident(Pident id')) s)
(id' :: idents) sg
| (Tsig_value(id, _) | Tsig_exception(id, _) |
Tsig_class(id, _, _) | Tsig_cltype(id, _, _)) :: sg ->
let id' = Ident.rename id in
rename_bound_idents s (id' :: idents) sg
let rec modtype s = function
Tmty_ident p as mty ->
begin match p with
Pident id ->
begin try Tbl.find id s.modtypes with Not_found -> mty end
| Pdot(p, n, pos) ->
Tmty_ident(Pdot(module_path s p, n, pos))
| Papply(p1, p2) ->
fatal_error "Subst.modtype"
end
| Tmty_signature sg ->
Tmty_signature(signature s sg)
| Tmty_functor(id, arg, res) ->
let id' = Ident.rename id in
Tmty_functor(id', modtype s arg,
modtype (add_module id (Pident id') s) res)
and signature s sg =
(* Components of signature may be mutually recursive (e.g. type declarations
or class and type declarations), so first build global renaming
substitution... *)
let (new_idents, s') = rename_bound_idents s [] sg in
(* ... then apply it to each signature component in turn *)
List.map2 (signature_component s') sg new_idents
and signature_component s comp newid =
match comp with
Tsig_value(id, d) ->
Tsig_value(newid, value_description s d)
| Tsig_type(id, d, rs) ->
Tsig_type(newid, type_declaration s d, rs)
| Tsig_exception(id, d) ->
Tsig_exception(newid, exception_declaration s d)
| Tsig_module(id, mty, rs) ->
Tsig_module(newid, modtype s mty, rs)
| Tsig_modtype(id, d) ->
Tsig_modtype(newid, modtype_declaration s d)
| Tsig_class(id, d, rs) ->
Tsig_class(newid, class_declaration s d, rs)
| Tsig_cltype(id, d, rs) ->
Tsig_cltype(newid, cltype_declaration s d, rs)
and modtype_declaration s = function
Tmodtype_abstract -> Tmodtype_abstract
| Tmodtype_manifest mty -> Tmodtype_manifest(modtype s mty)
(* For every binding k |-> d of m1, add k |-> f d to m2
and return resulting merged map. *)
let merge_tbls f m1 m2 =
Tbl.fold (fun k d accu -> Tbl.add k (f d) accu) m1 m2
(* Composition of substitutions:
apply (compose s1 s2) x = apply s2 (apply s1 x) *)
let compose s1 s2 =
{ types = merge_tbls (type_path s2) s1.types s2.types;
modules = merge_tbls (module_path s2) s1.modules s2.modules;
modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes;
for_saving = false }
|