/usr/lib/ocaml/compiler-libs/typing/datarepr.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 | (***********************************************************************)
(* *)
(* 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: datarepr.ml 9331 2009-09-12 12:41:07Z xleroy $ *)
(* Compute constructor and label descriptions from type declarations,
determining their representation. *)
open Misc
open Asttypes
open Types
let constructor_descrs ty_res cstrs priv =
let num_consts = ref 0 and num_nonconsts = ref 0 in
List.iter
(function (name, []) -> incr num_consts
| (name, _) -> incr num_nonconsts)
cstrs;
let rec describe_constructors idx_const idx_nonconst = function
[] -> []
| (name, ty_args) :: rem ->
let (tag, descr_rem) =
match ty_args with
[] -> (Cstr_constant idx_const,
describe_constructors (idx_const+1) idx_nonconst rem)
| _ -> (Cstr_block idx_nonconst,
describe_constructors idx_const (idx_nonconst+1) rem) in
let cstr =
{ cstr_res = ty_res;
cstr_args = ty_args;
cstr_arity = List.length ty_args;
cstr_tag = tag;
cstr_consts = !num_consts;
cstr_nonconsts = !num_nonconsts;
cstr_private = priv } in
(name, cstr) :: descr_rem in
describe_constructors 0 0 cstrs
let exception_descr path_exc decl =
{ cstr_res = Predef.type_exn;
cstr_args = decl;
cstr_arity = List.length decl;
cstr_tag = Cstr_exception path_exc;
cstr_consts = -1;
cstr_nonconsts = -1;
cstr_private = Public }
let none = {desc = Ttuple []; level = -1; id = -1}
(* Clearly ill-formed type *)
let dummy_label =
{ lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
lbl_private = Public }
let label_descrs ty_res lbls repres priv =
let all_labels = Array.create (List.length lbls) dummy_label in
let rec describe_labels num = function
[] -> []
| (name, mut_flag, ty_arg) :: rest ->
let lbl =
{ lbl_name = name;
lbl_res = ty_res;
lbl_arg = ty_arg;
lbl_mut = mut_flag;
lbl_pos = num;
lbl_all = all_labels;
lbl_repres = repres;
lbl_private = priv } in
all_labels.(num) <- lbl;
(name, lbl) :: describe_labels (num+1) rest in
describe_labels 0 lbls
exception Constr_not_found
let rec find_constr tag num_const num_nonconst = function
[] ->
raise Constr_not_found
| (name, [] as cstr) :: rem ->
if tag = Cstr_constant num_const
then cstr
else find_constr tag (num_const + 1) num_nonconst rem
| (name, _ as cstr) :: rem ->
if tag = Cstr_block num_nonconst
then cstr
else find_constr tag num_const (num_nonconst + 1) rem
let find_constr_by_tag tag cstrlist =
find_constr tag 0 0 cstrlist
|