predef.ml

(**************************************************************************)
(*                                                                        *)
(*                                 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 GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Predefined type constructors (with special typing rules in typecore) *)

open Path
open Types
open Btype

let builtin_idents = ref []

let wrap create s =
  let id = create s in
  builtin_idents := (s, id) :: !builtin_idents;
  id

let ident_create = wrap Ident.create
let ident_create_predef_exn = wrap Ident.create_predef_exn

let ident_int = ident_create "int"
and ident_char = ident_create "char"
and ident_bytes = ident_create "bytes"
and ident_float = ident_create "float"
and ident_bool = ident_create "bool"
and ident_unit = ident_create "unit"
and ident_exn = ident_create "exn"
and ident_array = ident_create "array"
and ident_list = ident_create "list"
and ident_option = ident_create "option"

and ident_int64 = ident_create "int64"
and ident_lazy_t = ident_create "lazy_t"
and ident_string = ident_create "string"
and ident_extension_constructor = ident_create "extension_constructor"
and ident_floatarray = ident_create "floatarray"

and ident_unknown = ident_create "unknown"

type test =
  | For_sure_yes
  | For_sure_no 
  | NA

let type_is_builtin_path_but_option (p : Path.t) : test  =
  match p with
  | Pident {stamp} ->
      if 
        stamp >= ident_int.stamp
        && stamp  <= ident_floatarray.stamp    
      then    
        if  (stamp = ident_option.stamp)
         || (stamp = ident_unit.stamp) then 
          For_sure_no
        else For_sure_yes
      else NA 
  | _ -> NA

let path_int = Pident ident_int
and path_char = Pident ident_char
and path_bytes = Pident ident_bytes
and path_float = Pident ident_float
and path_bool = Pident ident_bool
and path_unit = Pident ident_unit
and path_exn = Pident ident_exn
and path_array = Pident ident_array
and path_list = Pident ident_list
and path_option = Pident ident_option


and path_int64 = Pident ident_int64
and path_lazy_t = Pident ident_lazy_t
and path_string = Pident ident_string

and path_unkonwn = Pident ident_unknown
and path_extension_constructor = Pident ident_extension_constructor
and path_floatarray = Pident ident_floatarray

let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
and type_bytes = newgenty (Tconstr(path_bytes, [], ref Mnil))
and type_float = newgenty (Tconstr(path_float, [], ref Mnil))
and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil))
and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil))
and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil))
and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil))
and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil))
and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil))


and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil))
and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil))
and type_string = newgenty (Tconstr(path_string, [], ref Mnil))

and type_unknown = newgenty (Tconstr(path_unkonwn, [], ref Mnil))
and type_extension_constructor =
      newgenty (Tconstr(path_extension_constructor, [], ref Mnil))
and type_floatarray = newgenty (Tconstr(path_floatarray, [], ref Mnil))

let ident_match_failure = ident_create_predef_exn "Match_failure"

and ident_invalid_argument = ident_create_predef_exn "Invalid_argument"
and ident_failure = ident_create_predef_exn "Failure"

and ident_js_error = ident_create_predef_exn "JsError"
and ident_not_found = ident_create_predef_exn "Not_found"

and ident_end_of_file = ident_create_predef_exn "End_of_file"
and ident_division_by_zero = ident_create_predef_exn "Division_by_zero"


and ident_assert_failure = ident_create_predef_exn "Assert_failure"
and ident_undefined_recursive_module =
        ident_create_predef_exn "Undefined_recursive_module"

let all_predef_exns = [
  ident_match_failure;
  ident_invalid_argument;
  ident_failure;
  ident_js_error;
  ident_not_found;
  ident_end_of_file;
  ident_division_by_zero;
  ident_assert_failure;
  ident_undefined_recursive_module;
]

let path_match_failure = Pident ident_match_failure
and path_assert_failure = Pident ident_assert_failure
and path_undefined_recursive_module = Pident ident_undefined_recursive_module

let decl_abstr =
  {type_params = [];
   type_arity = 0;
   type_kind = Type_abstract;
   type_loc = Location.none;
   type_private = Asttypes.Public;
   type_manifest = None;
   type_variance = [];
   type_newtype_level = None;
   type_attributes = [];
   type_immediate = false;
   type_unboxed = unboxed_false_default_false;
  }

let decl_abstr_imm = {decl_abstr with type_immediate = true}

let cstr id args =
  {
    cd_id = id;
    cd_args = Cstr_tuple args;
    cd_res = None;
    cd_loc = Location.none;
    cd_attributes = [];
  }

let ident_false = ident_create "false"
and ident_true = ident_create "true"
and ident_void = ident_create "()"
and ident_nil = ident_create "[]"
and ident_cons = ident_create "::"
and ident_none = ident_create "None"
and ident_some = ident_create "Some"

and ident_ctor_unknown = ident_create "Unknown"
let common_initial_env add_type add_extension empty_env =
  let decl_bool =
    {decl_abstr with
     type_kind = Type_variant([cstr ident_false []; cstr ident_true []]);
     type_immediate = true}
  and decl_unit =
    {decl_abstr with
     type_kind = Type_variant([cstr ident_void []]);
     type_immediate = true}
  and decl_exn =
    {decl_abstr with
     type_kind = Type_open}
  and decl_array =
    let tvar = newgenvar() in
    {decl_abstr with
     type_params = [tvar];
     type_arity = 1;
     type_variance = [Variance.full]}
  and decl_list =
    let tvar = newgenvar() in
    {decl_abstr with
     type_params = [tvar];
     type_arity = 1;
     type_kind =
     Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]);
     type_variance = [Variance.covariant]}
  and decl_option =
    let tvar = newgenvar() in
    {decl_abstr with
     type_params = [tvar];
     type_arity = 1;
     type_kind = Type_variant([cstr ident_none []; cstr ident_some [tvar]]);
     type_variance = [Variance.covariant]}
  and decl_unknown = 
    let tvar = newgenvar () in 
    {decl_abstr with 
      type_params = [];
      type_arity = 0;
      type_kind = Type_variant ([ {
        cd_id = ident_ctor_unknown;
        cd_args = Cstr_tuple [tvar]; 
        cd_res = Some type_unknown; 
        cd_loc = Location.none;
        cd_attributes = []
      }]);
      type_unboxed = Types.unboxed_true_default_false
    }   
  and decl_lazy_t =
    let tvar = newgenvar() in
    {decl_abstr with
     type_params = [tvar];
     type_arity = 1;
     type_variance = [Variance.covariant]}
  in

  let add_extension id l =
    add_extension id
      { ext_type_path = path_exn;
        ext_type_params = [];
        ext_args = Cstr_tuple l;
        ext_ret_type = None;
        ext_private = Asttypes.Public;
        ext_loc = Location.none;
        ext_attributes = [{Asttypes.txt="ocaml.warn_on_literal_pattern";
                           loc=Location.none},
                          Parsetree.PStr[]] }
  in
  add_extension ident_match_failure
                         [newgenty (Ttuple[type_string; type_int; type_int])] (
  add_extension ident_invalid_argument [type_string] (
  add_extension ident_js_error [type_unknown] (
  add_extension ident_failure [type_string] (
  add_extension ident_not_found [] (
  add_extension ident_end_of_file [] (
  add_extension ident_division_by_zero [] (
  add_extension ident_assert_failure
                         [newgenty (Ttuple[type_string; type_int; type_int])] (
  add_extension ident_undefined_recursive_module
                         [newgenty (Ttuple[type_string; type_int; type_int])] (
  add_type ident_int64 decl_abstr (

  add_type ident_lazy_t decl_lazy_t (
  add_type ident_option decl_option (
  add_type ident_list decl_list (
  add_type ident_array decl_array (
  add_type ident_exn decl_exn (
  add_type ident_unit decl_unit (
  add_type ident_bool decl_bool (
  add_type ident_float decl_abstr (
  add_type ident_unknown decl_unknown(  
  add_type ident_string decl_abstr (
  add_type ident_int decl_abstr_imm (
  add_type ident_extension_constructor decl_abstr (
  add_type ident_floatarray decl_abstr (
    empty_env)))))))))))))))))))))))

let build_initial_env add_type add_exception empty_env =
  let common = common_initial_env add_type add_exception empty_env in
  let res = add_type ident_bytes decl_abstr common in 
  let decl_type_char = 
        {decl_abstr with 
        type_manifest = Some type_int; 
        type_private = Private} in 
    add_type ident_char decl_type_char res 
  
  
let builtin_values =
  List.map (fun id -> Ident.make_global id; (Ident.name id, id))
      [ident_match_failure; 
       ident_invalid_argument;
       ident_failure; ident_js_error; ident_not_found;  ident_end_of_file;
       ident_division_by_zero; 
       ident_assert_failure; ident_undefined_recursive_module ]

(* Start non-predef identifiers at 1000.  This way, more predefs can
   be defined in this file (above!) without breaking .cmi
   compatibility. *)

let _ = Ident.set_current_time 999
let builtin_idents = List.rev !builtin_idents