1(**************************************************************************)
2(*                                                                        *)
3(*                                 OCaml                                  *)
4(*                                                                        *)
5(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
6(*                                                                        *)
7(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
8(*     en Automatique.                                                    *)
9(*                                                                        *)
10(*   All rights reserved.  This file is distributed under the terms of    *)
11(*   the GNU Lesser General Public License version 2.1, with the          *)
12(*   special exception on linking described in the file LICENSE.          *)
13(*                                                                        *)
14(**************************************************************************)
15
16(* Predefined type constructors (with special typing rules in typecore) *)
17
18open Path
19open Types
20open Btype
21
22let builtin_idents = ref []
23
24let wrap create s =
25  let id = create s in
26  builtin_idents := (s, id) :: !builtin_idents;
27  id
28
29let ident_create = wrap Ident.create
30let ident_create_predef_exn = wrap Ident.create_predef_exn
31
32let ident_int = ident_create "int"
33and ident_char = ident_create "char"
34and ident_bytes = ident_create "bytes"
35and ident_float = ident_create "float"
36and ident_bool = ident_create "bool"
37and ident_unit = ident_create "unit"
38and ident_exn = ident_create "exn"
39and ident_array = ident_create "array"
40and ident_list = ident_create "list"
41and ident_option = ident_create "option"
42and ident_nativeint = ident_create "nativeint"
43and ident_int32 = ident_create "int32"
44and ident_int64 = ident_create "int64"
45and ident_lazy_t = ident_create "lazy_t"
46and ident_string = ident_create "string"
47and ident_extension_constructor = ident_create "extension_constructor"
48
49let path_int = Pident ident_int
50and path_char = Pident ident_char
51and path_bytes = Pident ident_bytes
52and path_float = Pident ident_float
53and path_bool = Pident ident_bool
54and path_unit = Pident ident_unit
55and path_exn = Pident ident_exn
56and path_array = Pident ident_array
57and path_list = Pident ident_list
58and path_option = Pident ident_option
59and path_nativeint = Pident ident_nativeint
60and path_int32 = Pident ident_int32
61and path_int64 = Pident ident_int64
62and path_lazy_t = Pident ident_lazy_t
63and path_string = Pident ident_string
64and path_extension_constructor = Pident ident_extension_constructor
65
66let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
67and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
68and type_bytes = newgenty (Tconstr(path_bytes, [], ref Mnil))
69and type_float = newgenty (Tconstr(path_float, [], ref Mnil))
70and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil))
71and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil))
72and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil))
73and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil))
74and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil))
75and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil))
76and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil))
77and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil))
78and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil))
79and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil))
80and type_string = newgenty (Tconstr(path_string, [], ref Mnil))
81and type_extension_constructor =
82      newgenty (Tconstr(path_extension_constructor, [], ref Mnil))
83
84let ident_match_failure = ident_create_predef_exn "Match_failure"
85and ident_out_of_memory = ident_create_predef_exn "Out_of_memory"
86and ident_invalid_argument = ident_create_predef_exn "Invalid_argument"
87and ident_failure = ident_create_predef_exn "Failure"
88and ident_not_found = ident_create_predef_exn "Not_found"
89and ident_sys_error = ident_create_predef_exn "Sys_error"
90and ident_end_of_file = ident_create_predef_exn "End_of_file"
91and ident_division_by_zero = ident_create_predef_exn "Division_by_zero"
92and ident_stack_overflow = ident_create_predef_exn "Stack_overflow"
93and ident_sys_blocked_io = ident_create_predef_exn "Sys_blocked_io"
94and ident_assert_failure = ident_create_predef_exn "Assert_failure"
95and ident_undefined_recursive_module =
96        ident_create_predef_exn "Undefined_recursive_module"
97
98let all_predef_exns = [
99  ident_match_failure;
100  ident_out_of_memory;
101  ident_invalid_argument;
102  ident_failure;
103  ident_not_found;
104  ident_sys_error;
105  ident_end_of_file;
106  ident_division_by_zero;
107  ident_stack_overflow;
108  ident_sys_blocked_io;
109  ident_assert_failure;
110  ident_undefined_recursive_module;
111]
112
113let path_match_failure = Pident ident_match_failure
114and path_assert_failure = Pident ident_assert_failure
115and path_undefined_recursive_module = Pident ident_undefined_recursive_module
116
117let decl_abstr =
118  {type_params = [];
119   type_arity = 0;
120   type_kind = Type_abstract;
121   type_loc = Location.none;
122   type_private = Asttypes.Public;
123   type_manifest = None;
124   type_variance = [];
125   type_newtype_level = None;
126   type_attributes = [];
127   type_immediate = false;
128   type_unboxed = unboxed_false_default_false;
129  }
130
131let decl_abstr_imm = {decl_abstr with type_immediate = true}
132
133let cstr id args =
134  {
135    cd_id = id;
136    cd_args = Cstr_tuple args;
137    cd_res = None;
138    cd_loc = Location.none;
139    cd_attributes = [];
140  }
141
142let ident_false = ident_create "false"
143and ident_true = ident_create "true"
144and ident_void = ident_create "()"
145and ident_nil = ident_create "[]"
146and ident_cons = ident_create "::"
147and ident_none = ident_create "None"
148and ident_some = ident_create "Some"
149let common_initial_env add_type add_extension empty_env =
150  let decl_bool =
151    {decl_abstr with
152     type_kind = Type_variant([cstr ident_false []; cstr ident_true []]);
153     type_immediate = true}
154  and decl_unit =
155    {decl_abstr with
156     type_kind = Type_variant([cstr ident_void []]);
157     type_immediate = true}
158  and decl_exn =
159    {decl_abstr with
160     type_kind = Type_open}
161  and decl_array =
162    let tvar = newgenvar() in
163    {decl_abstr with
164     type_params = [tvar];
165     type_arity = 1;
166     type_variance = [Variance.full]}
167  and decl_list =
168    let tvar = newgenvar() in
169    {decl_abstr with
170     type_params = [tvar];
171     type_arity = 1;
172     type_kind =
173     Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]);
174     type_variance = [Variance.covariant]}
175  and decl_option =
176    let tvar = newgenvar() in
177    {decl_abstr with
178     type_params = [tvar];
179     type_arity = 1;
180     type_kind = Type_variant([cstr ident_none []; cstr ident_some [tvar]]);
181     type_variance = [Variance.covariant]}
182  and decl_lazy_t =
183    let tvar = newgenvar() in
184    {decl_abstr with
185     type_params = [tvar];
186     type_arity = 1;
187     type_variance = [Variance.covariant]}
188  in
189
190  let add_extension id l =
191    add_extension id
192      { ext_type_path = path_exn;
193        ext_type_params = [];
194        ext_args = Cstr_tuple l;
195        ext_ret_type = None;
196        ext_private = Asttypes.Public;
197        ext_loc = Location.none;
198        ext_attributes = [{Asttypes.txt="ocaml.warn_on_literal_pattern";
199                           loc=Location.none},
200                          Parsetree.PStr[]] }
201  in
202  add_extension ident_match_failure
203                         [newgenty (Ttuple[type_string; type_int; type_int])] (
204  add_extension ident_out_of_memory [] (
205  add_extension ident_stack_overflow [] (
206  add_extension ident_invalid_argument [type_string] (
207  add_extension ident_failure [type_string] (
208  add_extension ident_not_found [] (
209  add_extension ident_sys_blocked_io [] (
210  add_extension ident_sys_error [type_string] (
211  add_extension ident_end_of_file [] (
212  add_extension ident_division_by_zero [] (
213  add_extension ident_assert_failure
214                         [newgenty (Ttuple[type_string; type_int; type_int])] (
215  add_extension ident_undefined_recursive_module
216                         [newgenty (Ttuple[type_string; type_int; type_int])] (
217  add_type ident_int64 decl_abstr (
218  add_type ident_int32 decl_abstr (
219  add_type ident_nativeint decl_abstr (
220  add_type ident_lazy_t decl_lazy_t (
221  add_type ident_option decl_option (
222  add_type ident_list decl_list (
223  add_type ident_array decl_array (
224  add_type ident_exn decl_exn (
225  add_type ident_unit decl_unit (
226  add_type ident_bool decl_bool (
227  add_type ident_float decl_abstr (
228  add_type ident_string decl_abstr (
229  add_type ident_char decl_abstr_imm (
230  add_type ident_int decl_abstr_imm (
231  add_type ident_extension_constructor decl_abstr (
232    empty_env)))))))))))))))))))))))))))
233
234let build_initial_env add_type add_exception empty_env =
235  let common = common_initial_env add_type add_exception empty_env in
236  let safe_string = add_type ident_bytes decl_abstr common in
237  let decl_bytes_unsafe = {decl_abstr with type_manifest = Some type_string} in
238  let unsafe_string = add_type ident_bytes decl_bytes_unsafe common in
239  (safe_string, unsafe_string)
240
241let builtin_values =
242  List.map (fun id -> Ident.make_global id; (Ident.name id, id))
243      [ident_match_failure; ident_out_of_memory; ident_stack_overflow;
244       ident_invalid_argument;
245       ident_failure; ident_not_found; ident_sys_error; ident_end_of_file;
246       ident_division_by_zero; ident_sys_blocked_io;
247       ident_assert_failure; ident_undefined_recursive_module ]
248
249(* Start non-predef identifiers at 1000.  This way, more predefs can
250   be defined in this file (above!) without breaking .cmi
251   compatibility. *)
252
253let _ = Ident.set_current_time 999
254let builtin_idents = List.rev !builtin_idents
255