mutated_ocaml / typing / datarepr.ml

j...@vmware 743bd00 

camlspotter 35cc436 
j...@vmware 743bd00 








camlspotter 4eace9a 
j...@vmware 743bd00 






camlspotter 35cc436 




camlspotter 4eace9a 
camlspotter 35cc436 



camlspotter 7146b35 
camlspotter 35cc436 





camlspotter 4eace9a 
camlspotter 35cc436 




j...@vmware 743bd00 

camlspotter 35cc436 
j...@vmware 743bd00 
camlspotter 35cc436 


j...@vmware 743bd00 


camlspotter 35cc436 
camlspotter 4eace9a 




j...@vmware 743bd00 





camlspotter 4eace9a 










j...@vmware 743bd00 




camlspotter 4eace9a 
camlspotter 35cc436 
camlspotter 4eace9a 

j...@vmware 743bd00 
camlspotter 4eace9a 
j...@vmware 743bd00 


camlspotter 35cc436 
camlspotter 34e8d4a 


j...@vmware 743bd00 

camlspotter 35cc436 


j...@vmware 743bd00 



camlspotter d2116cf 
j...@vmware 743bd00 








camlspotter bb92dae 
camlspotter d2116cf 
j...@vmware 743bd00 














camlspotter 35cc436 
j...@vmware 743bd00 
camlspotter 35cc436 
j...@vmware 743bd00 
camlspotter 35cc436 
j...@vmware 743bd00 
camlspotter 35cc436 
j...@vmware 743bd00 


(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            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 12800 2012-07-30 18:59:07Z doligez $ *)

(* Compute constructor and label descriptions from type declarations,
   determining their representation. *)

open Misc
open Asttypes
open Types
open Btype

(* Simplified version of Ctype.free_vars *)
let rec free_vars ty =
  let ret = ref TypeSet.empty in
  let rec loop ty =
    let ty = repr ty in
    if ty.level >= lowest_level then begin
      ty.level <- pivot_level - ty.level;
      match ty.desc with
      | Tvar _ ->
          ret := TypeSet.add ty !ret
      | Tvariant row ->
          let row = row_repr row in
          iter_row loop row;
          if not (static_row row) then loop row.row_more
      | _ ->
          iter_type_expr loop ty
    end
  in
  loop ty;
  unmark_type ty;
  !ret

let constructor_descrs ty_res cstrs priv =
  let num_consts = ref 0 and num_nonconsts = ref 0  and num_normal = ref 0 in
  List.iter
    (fun (name, args, ret) ->
      if args = [] then incr num_consts else incr num_nonconsts;
      if ret = None then incr num_normal)
    cstrs;
  let rec describe_constructors idx_const idx_nonconst = function
      [] -> []
    | (name, ty_args, ty_res_opt) :: rem ->
        let ty_res =
          match ty_res_opt with
          | Some ty_res' -> ty_res'
          | None -> ty_res
        in
        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 existentials =
          match ty_res_opt with
          | None -> []
          | Some type_ret ->
              let res_vars = free_vars type_ret in
              let arg_vars = free_vars (newgenty (Ttuple ty_args)) in
              TypeSet.elements (TypeSet.diff arg_vars res_vars)
        in
        let cstr =
          { cstr_res = ty_res;
            cstr_existentials = existentials;
            cstr_args = ty_args;
            cstr_arity = List.length ty_args;
            cstr_tag = tag;
            cstr_consts = !num_consts;
            cstr_nonconsts = !num_nonconsts;
            cstr_normal = !num_normal;
            cstr_private = priv;
            cstr_generalized = ty_res_opt <> None
          } in
        (name, cstr) :: descr_rem in
  describe_constructors 0 0 cstrs

let exception_descr path_exc decl =
  { cstr_res = Predef.type_exn;
    cstr_existentials = [];
    cstr_args = decl.exn_args;
    cstr_arity = List.length decl.exn_args;
    cstr_tag = Cstr_exception (path_exc, decl.exn_loc);
    cstr_consts = -1;
    cstr_nonconsts = -1;
    cstr_private = Public;
    cstr_normal = -1;
    cstr_generalized = false }

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 = Ident.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),(_ as ret_type_opt)) :: rem ->
      if tag = Cstr_constant num_const
      then (name,cstr,ret_type_opt)
      else find_constr tag (num_const + 1) num_nonconst rem
  | (name, (_ as cstr),(_ as ret_type_opt)) :: rem ->
      if tag = Cstr_block num_nonconst
      then (name,cstr,ret_type_opt)
      else find_constr tag num_const (num_nonconst + 1) rem

let find_constr_by_tag tag cstrlist =
  find_constr tag 0 0 cstrlist
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.