The unpac monorepo manager self-hosting as a monorepo using unpac
Merge commit '8949e28fa1995de9fa72ee377993624af0f4a616' into 5.00
+567
-265
+6
-4
.depend
+6
-4
.depend
···
1543
1543
typing/env.cmi
1544
1544
typing/typedecl_unboxed.cmo : \
1545
1545
typing/types.cmi \
1546
-
typing/predef.cmi \
1547
1546
typing/env.cmi \
1548
1547
typing/ctype.cmi \
1549
1548
typing/typedecl_unboxed.cmi
1550
1549
typing/typedecl_unboxed.cmx : \
1551
1550
typing/types.cmx \
1552
-
typing/predef.cmx \
1553
1551
typing/env.cmx \
1554
1552
typing/ctype.cmx \
1555
1553
typing/typedecl_unboxed.cmi
···
1704
1702
typing/typeopt.cmo : \
1705
1703
typing/types.cmi \
1706
1704
typing/typedtree.cmi \
1707
-
typing/typedecl.cmi \
1705
+
typing/typedecl_unboxed.cmi \
1706
+
typing/type_immediacy.cmi \
1708
1707
typing/predef.cmi \
1709
1708
typing/path.cmi \
1710
1709
lambda/lambda.cmi \
···
1712
1711
typing/env.cmi \
1713
1712
typing/ctype.cmi \
1714
1713
utils/config.cmi \
1714
+
utils/clflags.cmi \
1715
1715
parsing/asttypes.cmi \
1716
1716
typing/typeopt.cmi
1717
1717
typing/typeopt.cmx : \
1718
1718
typing/types.cmx \
1719
1719
typing/typedtree.cmx \
1720
-
typing/typedecl.cmx \
1720
+
typing/typedecl_unboxed.cmx \
1721
+
typing/type_immediacy.cmx \
1721
1722
typing/predef.cmx \
1722
1723
typing/path.cmx \
1723
1724
lambda/lambda.cmx \
···
1725
1726
typing/env.cmx \
1726
1727
typing/ctype.cmx \
1727
1728
utils/config.cmx \
1729
+
utils/clflags.cmx \
1728
1730
parsing/asttypes.cmi \
1729
1731
typing/typeopt.cmi
1730
1732
typing/typeopt.cmi : \
+14
Changes
+14
Changes
···
64
64
65
65
### Internal/compiler-libs changes:
66
66
67
+
- #1599: add unset directive to ocamltest to clear environment variables before
68
+
running tests.
69
+
(David Allsopp, review by Damien Doligez and Sébastien Hinderer)
70
+
67
71
- #10433: Remove the distinction between 32-bit aligned and 64-bit aligned
68
72
64-bit floats in Cmm.memory_chunk.
69
73
(Greta Yorsh, review by Xavier Leroy)
···
84
88
85
89
### Build system:
86
90
91
+
- #10471: Fix detection of arm32 architectures with musl in the configure
92
+
script.
93
+
(Louis Gesbert)
94
+
87
95
### Bug fixes:
88
96
89
97
- #10473: Add CFI directives to RISC-V runtime and asmcomp.
···
96
104
otherwise the derived pointer is live across a poll point.
97
105
(Vincent Laviron and Xavier Leroy, review by Xavier Leroy and Sadiq Jaffer)
98
106
107
+
- #10542: Fix detection of immediate64 types through unboxed types.
108
+
(Leo White, review by Stephen Dolan and Gabriel Scherer)
99
109
100
110
OCaml 4.13.0
101
111
-------------
···
534
544
535
545
- #10307: Make build_other_constrs work with names instead of tags.
536
546
(Nicolas Chataing, review by Florian Angeletti)
547
+
548
+
- #10543: Fix Ast_mapper to apply the mapping function to the constants in
549
+
"interval" patterns `c1..c2`.
550
+
(Guillaume Petiot, review by Gabriel Scherer and Nicolás Ojeda Bär)
537
551
538
552
### Build system:
539
553
-4
INSTALL.adoc
-4
INSTALL.adoc
···
164
164
the C locale (`export LC_ALL=C`) before compiling if you have strange errors
165
165
while compiling OCaml.
166
166
167
-
* On HP 9000/700 machines under HP/UX 9, some versions of `cc` are unable to
168
-
compile correctly the runtime system (wrong code is generated for `(x - y)`
169
-
where `x` is a pointer and `y` an integer). Fix: use `gcc`.
170
-
171
167
* In the unlikely case that a platform does not offer all C99 float operations
172
168
that the runtime needs, a configuration error will result. Users
173
169
can work around this problem by calling `configure` with the flag
+16
-12
configure
+16
-12
configure
···
14287
14287
fi; system=elf ;; #(
14288
14288
s390x*-*-linux*) :
14289
14289
arch=s390x; model=z10; system=elf ;; #(
14290
-
armv6*-*-linux-gnueabihf) :
14290
+
# expected to match "gnueabihf" as well as "musleabihf"
14291
+
armv6*-*-linux-*eabihf) :
14291
14292
arch=arm; model=armv6; system=linux_eabihf ;; #(
14292
-
armv7*-*-linux-gnueabihf) :
14293
+
armv7*-*-linux-*eabihf) :
14293
14294
arch=arm; model=armv7; system=linux_eabihf ;; #(
14294
-
armv8*-*-linux-gnueabihf) :
14295
+
armv8*-*-linux-*eabihf) :
14295
14296
arch=arm; model=armv8; system=linux_eabihf ;; #(
14296
-
armv8*-*-linux-gnueabi) :
14297
+
armv8*-*-linux-*eabi) :
14297
14298
arch=arm; model=armv8; system=linux_eabi ;; #(
14298
-
armv7*-*-linux-gnueabi) :
14299
+
armv7*-*-linux-*eabi) :
14299
14300
arch=arm; model=armv7; system=linux_eabi ;; #(
14300
-
armv6t2*-*-linux-gnueabi) :
14301
+
armv6t2*-*-linux-*eabi) :
14301
14302
arch=arm; model=armv6t2; system=linux_eabi ;; #(
14302
-
armv6*-*-linux-gnueabi) :
14303
+
armv6*-*-linux-*eabi) :
14303
14304
arch=arm; model=armv6; system=linux_eabi ;; #(
14304
14305
armv6*-*-freebsd*) :
14305
14306
arch=arm; model=armv6; system=freebsd ;; #(
···
14307
14308
arch=arm; model=armv6; system=netbsd ;; #(
14308
14309
earmv7*-*-netbsd*) :
14309
14310
arch=arm; model=armv7; system=netbsd ;; #(
14310
-
armv5te*-*-linux-gnueabi) :
14311
+
armv5te*-*-linux-*eabi) :
14311
14312
arch=arm; model=armv5te; system=linux_eabi ;; #(
14312
-
armv5*-*-linux-gnueabi) :
14313
+
armv5*-*-linux-*eabi) :
14313
14314
arch=arm; model=armv5; system=linux_eabi ;; #(
14314
-
arm*-*-linux-gnueabihf) :
14315
+
arm*-*-linux-*eabihf) :
14315
14316
arch=arm; system=linux_eabihf ;; #(
14316
-
arm*-*-linux-gnueabi) :
14317
+
arm*-*-linux-*eabi) :
14317
14318
arch=arm; system=linux_eabi ;; #(
14318
14319
arm*-*-openbsd*) :
14319
14320
arch=arm; system=bsd ;; #(
···
14333
14334
arch=amd64; system=netbsd ;; #(
14334
14335
x86_64-*-openbsd*) :
14335
14336
arch=amd64; system=openbsd ;; #(
14337
+
x86_64-*-haiku*) :
14338
+
arch=amd64; system=beos ;; #(
14336
14339
arm64-*-darwin*) :
14337
14340
arch=arm64; system=macosx ;; #(
14338
14341
aarch64-*-darwin*) :
···
14514
14517
;; #(
14515
14518
*) :
14516
14519
case $host in #(
14517
-
*-linux-musl) :
14520
+
# expected to match "*-linux-musl" as well as "*-linux-musleabi*"
14521
+
*-linux-musl*) :
14518
14522
# Alpine and other musl-based Linux distributions
14519
14523
common_cflags="-no-pie $common_cflags" ;; #(
14520
14524
*) :
+16
-12
configure.ac
+16
-12
configure.ac
···
1073
1073
[arch=power; AS_IF([$arch64],[model=ppc64],[model=ppc]); system=elf],
1074
1074
[[s390x*-*-linux*]],
1075
1075
[arch=s390x; model=z10; system=elf],
1076
-
[armv6*-*-linux-gnueabihf],
1076
+
# expected to match "gnueabihf" as well as "musleabihf"
1077
+
[armv6*-*-linux-*eabihf],
1077
1078
[arch=arm; model=armv6; system=linux_eabihf],
1078
-
[armv7*-*-linux-gnueabihf],
1079
+
[armv7*-*-linux-*eabihf],
1079
1080
[arch=arm; model=armv7; system=linux_eabihf],
1080
-
[armv8*-*-linux-gnueabihf],
1081
+
[armv8*-*-linux-*eabihf],
1081
1082
[arch=arm; model=armv8; system=linux_eabihf],
1082
-
[armv8*-*-linux-gnueabi],
1083
+
[armv8*-*-linux-*eabi],
1083
1084
[arch=arm; model=armv8; system=linux_eabi],
1084
-
[armv7*-*-linux-gnueabi],
1085
+
[armv7*-*-linux-*eabi],
1085
1086
[arch=arm; model=armv7; system=linux_eabi],
1086
-
[armv6t2*-*-linux-gnueabi],
1087
+
[armv6t2*-*-linux-*eabi],
1087
1088
[arch=arm; model=armv6t2; system=linux_eabi],
1088
-
[armv6*-*-linux-gnueabi],
1089
+
[armv6*-*-linux-*eabi],
1089
1090
[arch=arm; model=armv6; system=linux_eabi],
1090
1091
[armv6*-*-freebsd*],
1091
1092
[arch=arm; model=armv6; system=freebsd],
···
1093
1094
[arch=arm; model=armv6; system=netbsd],
1094
1095
[earmv7*-*-netbsd*],
1095
1096
[arch=arm; model=armv7; system=netbsd],
1096
-
[armv5te*-*-linux-gnueabi],
1097
+
[armv5te*-*-linux-*eabi],
1097
1098
[arch=arm; model=armv5te; system=linux_eabi],
1098
-
[armv5*-*-linux-gnueabi],
1099
+
[armv5*-*-linux-*eabi],
1099
1100
[arch=arm; model=armv5; system=linux_eabi],
1100
-
[arm*-*-linux-gnueabihf],
1101
+
[arm*-*-linux-*eabihf],
1101
1102
[arch=arm; system=linux_eabihf],
1102
-
[arm*-*-linux-gnueabi],
1103
+
[arm*-*-linux-*eabi],
1103
1104
[arch=arm; system=linux_eabi],
1104
1105
[arm*-*-openbsd*],
1105
1106
[arch=arm; system=bsd],
···
1119
1120
[arch=amd64; system=netbsd],
1120
1121
[x86_64-*-openbsd*],
1121
1122
[arch=amd64; system=openbsd],
1123
+
[x86_64-*-haiku*],
1124
+
[arch=amd64; system=beos],
1122
1125
[arm64-*-darwin*],
1123
1126
[arch=arm64; system=macosx],
1124
1127
[aarch64-*-darwin*],
···
1183
1186
# ocamlopt generates PIC code or doesn't generate code at all
1184
1187
[],
1185
1188
[AS_CASE([$host],
1186
-
[*-linux-musl],
1189
+
# expected to match "*-linux-musl" as well as "*-linux-musleabi*"
1190
+
[*-linux-musl*],
1187
1191
# Alpine and other musl-based Linux distributions
1188
1192
[common_cflags="-no-pie $common_cflags"],
1189
1193
[])])
+1
manual/src/cmds/ocamldoc.etex
+1
manual/src/cmds/ocamldoc.etex
···
779
779
in \ref{sss:ocamldoc-target-specific-syntax}) \\
780
780
@||@&@ '{!' string '}' @ & insert a cross-reference to an element
781
781
(see section \ref{sss:ocamldoc-crossref} for the syntax of cross-references).\\
782
+
@||@&@ '{{!' string '}' inline-text '}' @ & insert a cross-reference with the given text. \\
782
783
@||@&@ '{!modules:' string string ... '}' @ & insert an index table
783
784
for the given module names. Used in HTML only.\\
784
785
@||@&@ '{!indexlist}' @ & insert a table of links to the various indexes
+1
-1
manual/src/html_processing/Makefile
+1
-1
manual/src/html_processing/Makefile
···
26
26
$(WEBDIRMAN)/manual.css: scss/_common.scss scss/manual.scss | $(WEBDIRMAN)
27
27
sass scss/manual.scss > $(WEBDIRMAN)/manual.css
28
28
29
-
$(WEBDIRAPI)/style.css: scss/_common.scss scss/style.scss | $(WEBDIRAPI)
29
+
$(WEBDIRAPI)/style.css: scss/_common.scss scss/style.scss | $(WEBDIRAPI) $(WEBDIRCOMP)
30
30
sass scss/style.scss > $(WEBDIRAPI)/style.css
31
31
cp $(WEBDIRAPI)/style.css $(WEBDIRCOMP)/style.css
32
32
+1
-1
manual/src/html_processing/src/process_manual.ml
+1
-1
manual/src/html_processing/src/process_manual.ml
···
136
136
(regexp (">[0-9]+\\.\\([0-9]+\\)" ^ preg_anyspace)))
137
137
{|><span class="number">\1</span>|}
138
138
|> Re.Str.(global_replace
139
-
(regexp ("[0-9]+\\.\\([0-9]+\\.[0-9]+\\)" ^ preg_anyspace)))
139
+
(regexp ("[0-9]+\\.\\([0-9]+\\(\\.[0-9]+\\)+\\)" ^ preg_anyspace)))
140
140
{|<span class="number">\1</span>|}
141
141
142
142
(* The API (libref and compilerlibref directories) should be separate
+11
manual/src/refman/modtypes.etex
+11
manual/src/refman/modtypes.etex
···
262
262
particular, a functor may take another functor as argument
263
263
(``higher-order'' functor).
264
264
265
+
When the result module type is itself a functor,
266
+
\begin{center}
267
+
@'functor' '(' name_1 ':' module-type_1 ')' '->' \ldots '->'
268
+
'functor' '(' name_n ':' module-type_n ')' '->' module-type@
269
+
\end{center}
270
+
one may use the abbreviated form
271
+
\begin{center}
272
+
@'functor' '(' name_1 ':' module-type_1 ')' \ldots
273
+
'(' name_n ':' module-type_n ')' '->' module-type@
274
+
\end{center}
275
+
265
276
\subsection{ss:mty-with}{The "with" operator}
266
277
267
278
\ikwd{with\@\texttt{with}}
+11
manual/src/refman/modules.etex
+11
manual/src/refman/modules.etex
···
228
228
functor argument; in particular, a functor may take another functor as
229
229
argument (``higher-order'' functor).
230
230
231
+
When the result module expression is itself a functor,
232
+
\begin{center}
233
+
@'functor' '(' name_1 ':' module-type_1 ')' '->' \ldots '->'
234
+
'functor' '(' name_n ':' module-type_n ')' '->' module-expr@
235
+
\end{center}
236
+
one may use the abbreviated form
237
+
\begin{center}
238
+
@'functor' '(' name_1 ':' module-type_1 ')' \ldots
239
+
'(' name_n ':' module-type_n ')' '->' module-expr@
240
+
\end{center}
241
+
231
242
\subsubsection*{sss:mexpr-functor-app}{Functor application}
232
243
233
244
The expression @module-expr_1 '(' module-expr_2 ')'@ evaluates
+2
-2
ocamltest/actions_helpers.ml
+2
-2
ocamltest/actions_helpers.ml
···
160
160
log_redirection "stdout" stdout_filename;
161
161
log_redirection "stderr" stderr_filename;
162
162
let systemenv =
163
-
Array.append
163
+
Environments.append_to_system_env
164
164
environment
165
-
(Environments.to_system_env env)
165
+
env
166
166
in
167
167
let timeout =
168
168
match timeout with
+48
-8
ocamltest/environments.ml
+48
-8
ocamltest/environments.ml
···
19
19
20
20
module VariableMap = Map.Make (Variables)
21
21
22
-
type t = string VariableMap.t
22
+
type t = string option VariableMap.t
23
23
24
24
let empty = VariableMap.empty
25
25
26
26
let to_bindings env =
27
-
let f variable value lst = (variable, value) :: lst in
27
+
let f variable value lst =
28
+
Option.fold ~none:lst ~some:(fun value -> (variable, value) :: lst) value
29
+
in
28
30
VariableMap.fold f env []
29
31
30
32
let expand_aux env value =
···
39
41
let expanded = expand_aux env value in
40
42
if expanded=value then value else expand env expanded
41
43
42
-
let to_system_env env =
44
+
let expand env = function
45
+
| None -> raise Not_found
46
+
| Some value -> expand env value
47
+
48
+
let append_to_system_env environment env =
49
+
(* Augment env with any bindings which are only in environment. This must be
50
+
done here as the Windows C implementation doesn't process multiple values
51
+
in settings.envp. *)
52
+
let env =
53
+
let update env binding =
54
+
let name, value =
55
+
match String.index binding '=' with
56
+
| c ->
57
+
let name = String.sub binding 0 c in
58
+
let value =
59
+
String.sub binding (c + 1) (String.length binding - c - 1) in
60
+
(name, Some value)
61
+
| exception Not_found ->
62
+
(binding, None)
63
+
in
64
+
let var = Variables.make (name, "system env var") in
65
+
if not (VariableMap.mem var env) then
66
+
VariableMap.add var value env
67
+
else
68
+
env
69
+
in
70
+
Array.fold_left update env environment
71
+
in
43
72
let system_env = Array.make (VariableMap.cardinal env) "" in
44
73
let i = ref 0 in
45
74
let store variable value =
75
+
let some value =
76
+
Variables.string_of_binding variable (expand env (Some value)) in
46
77
system_env.(!i) <-
47
-
Variables.string_of_binding variable (expand env value);
78
+
Option.fold ~none:(Variables.name_of_variable variable) ~some value;
48
79
incr i in
49
80
VariableMap.iter store env;
50
81
system_env
82
+
83
+
let to_system_env env =
84
+
append_to_system_env [||] env
51
85
52
86
let lookup variable env =
53
87
try Some (expand env (VariableMap.find variable env)) with Not_found -> None
···
75
109
let is_variable_defined variable env =
76
110
VariableMap.mem variable env
77
111
78
-
let add variable value env = VariableMap.add variable value env
112
+
let add variable value env = VariableMap.add variable (Some value) env
79
113
80
114
let add_if_undefined variable value env =
81
115
if VariableMap.mem variable env then env else add variable value env
···
83
117
let append variable appened_value environment =
84
118
let previous_value = safe_lookup variable environment in
85
119
let new_value = previous_value ^ appened_value in
86
-
VariableMap.add variable new_value environment
120
+
VariableMap.add variable (Some new_value) environment
87
121
88
122
let remove = VariableMap.remove
123
+
124
+
let unsetenv variable environment =
125
+
VariableMap.add variable None environment
89
126
90
127
let add_bindings bindings env =
91
128
let f env (variable, value) = add variable value env in
···
93
130
94
131
let from_bindings bindings = add_bindings bindings empty
95
132
96
-
let dump_assignment log (variable, value) =
97
-
Printf.fprintf log "%s = %s\n%!" (Variables.name_of_variable variable) value
133
+
let dump_assignment log = function
134
+
| (variable, Some value) ->
135
+
Printf.fprintf log "%s = %s\n%!" (Variables.name_of_variable variable) value
136
+
| (variable, None) ->
137
+
Printf.fprintf log "unsetenv %s\n%!" (Variables.name_of_variable variable)
98
138
99
139
let dump log environment =
100
140
List.iter (dump_assignment log) (VariableMap.bindings environment)
+5
ocamltest/environments.mli
+5
ocamltest/environments.mli
···
22
22
val from_bindings : (Variables.t * string) list -> t
23
23
val to_bindings : t -> (Variables.t * string) list
24
24
val to_system_env : t -> string array
25
+
val append_to_system_env : string array -> t -> string array
25
26
26
27
val lookup : Variables.t -> t -> string option
27
28
val lookup_nonempty : Variables.t -> t -> string option
···
41
42
val add : Variables.t -> string -> t -> t
42
43
val add_if_undefined : Variables.t -> string -> t -> t
43
44
val add_bindings : (Variables.t * string) list -> t -> t
45
+
46
+
val unsetenv : Variables.t -> t -> t
47
+
(** [unsetenv env name] causes [name] to be ignored from the underlying system
48
+
environment *)
44
49
45
50
val append : Variables.t -> string -> t -> t
46
51
+2
-3
ocamltest/main.ml
+2
-3
ocamltest/main.ml
···
86
86
let (msg, children_behavior, summary) = match behavior with
87
87
| Skip_all_tests -> "n/a", Skip_all_tests, No_failure
88
88
| Run env ->
89
-
let testenv0 = interprete_environment_statements env testenvspec in
89
+
let testenv0 = interpret_environment_statements env testenvspec in
90
90
let testenv = List.fold_left apply_modifiers testenv0 env_modifiers in
91
91
let (result, newenv) = Tests.run log testenv test in
92
92
let msg = Result.string_of_result result in
···
193
193
let rootenv =
194
194
Environments.initialize Environments.Pre log initial_environment in
195
195
let rootenv =
196
-
interprete_environment_statements
197
-
rootenv rootenv_statements in
196
+
interpret_environment_statements rootenv rootenv_statements in
198
197
let rootenv = Environments.initialize Environments.Post log rootenv in
199
198
let common_prefix = " ... testing '" ^ test_basename ^ "' with" in
200
199
let initial_status =
+9
-8
ocamltest/ocaml_actions.ml
+9
-8
ocamltest/ocaml_actions.ml
···
533
533
program
534
534
] in
535
535
let systemenv =
536
-
Array.append
536
+
Environments.append_to_system_env
537
537
default_ocaml_env
538
-
(Environments.to_system_env (env_with_lib_unix env))
538
+
(env_with_lib_unix env)
539
539
in
540
540
let expected_exit_status = 0 in
541
541
let exit_status =
···
570
570
] in
571
571
let ocamllib = [| (Printf.sprintf "OCAMLLIB=%s" tools_directory) |] in
572
572
let systemenv =
573
-
Array.concat
574
-
[
575
-
default_ocaml_env;
576
-
ocamllib;
577
-
(Environments.to_system_env (env_with_lib_unix env))
578
-
]
573
+
Environments.append_to_system_env
574
+
(Array.concat
575
+
[
576
+
default_ocaml_env;
577
+
ocamllib;
578
+
])
579
+
(env_with_lib_unix env)
579
580
in
580
581
let expected_exit_status = 0 in
581
582
let exit_status =
+2
-2
ocamltest/ocaml_variables.ml
+2
-2
ocamltest/ocaml_variables.ml
···
54
54
if local_value="" then current_value else
55
55
if current_value="" then local_value else
56
56
String.concat Filename.path_sep [local_value; current_value] in
57
-
Printf.sprintf "%s=%s" caml_ld_library_path_name new_value
57
+
(caml_ld_library_path_name, new_value)
58
58
59
59
let caml_ld_library_path =
60
60
make_with_exporter
···
183
183
"Expected exit status of ocamlopt.opt")
184
184
185
185
let export_ocamlrunparam value =
186
-
Printf.sprintf "%s=%s" "OCAMLRUNPARAM" value
186
+
("OCAMLRUNPARAM", value)
187
187
188
188
let ocamlrunparam =
189
189
make_with_exporter
+2
ocamltest/run_unix.c
+2
ocamltest/run_unix.c
+27
-11
ocamltest/run_win32.c
+27
-11
ocamltest/run_win32.c
···
163
163
164
164
/* Compute length of local environment */
165
165
localenv_length = 0;
166
-
q = localenv;
167
-
while (*q != NULL) {
166
+
for (q = localenv; *q != NULL; q++) {
168
167
localenv_length += wcslen(*q) + 1;
169
-
q++;
170
168
}
171
169
172
170
/* Build new env that contains both process and local env */
···
178
176
}
179
177
r = env;
180
178
p = process_env;
179
+
/* Copy process_env to env only if the given names are not in localenv */
181
180
while (*p != L'\0') {
181
+
wchar_t *pos_eq = wcschr(p, L'=');
182
+
int copy = 1;
182
183
l = wcslen(p) + 1; /* also count terminating '\0' */
183
-
memcpy(r, p, l * sizeof(WCHAR));
184
+
/* Temporarily change the = to \0 for wcscmp */
185
+
*pos_eq = L'\0';
186
+
for (q = localenv; *q != NULL; q++) {
187
+
wchar_t *pos_eq2 = wcschr(*q, L'=');
188
+
/* Compare this name in localenv with the current one in processenv */
189
+
if (pos_eq2) *pos_eq2 = L'\0';
190
+
if (!wcscmp(*q, p)) copy = 0;
191
+
if (pos_eq2) *pos_eq2 = L'=';
192
+
}
193
+
*pos_eq = L'=';
194
+
if (copy) {
195
+
/* This name is not marked for deletion/update in localenv, so copy */
196
+
memcpy(r, p, l * sizeof(WCHAR));
197
+
r += l;
198
+
}
184
199
p += l;
185
-
r += l;
186
200
}
187
201
FreeEnvironmentStrings(process_env);
188
-
q = localenv;
189
-
while (*q != NULL) {
190
-
l = wcslen(*q) + 1;
191
-
memcpy(r, *q, l * sizeof(WCHAR));
192
-
r += l;
193
-
q++;
202
+
for (q = localenv; *q != NULL; q++) {
203
+
/* A string in localenv without '=' signals deletion, which has been done */
204
+
wchar_t *pos_eq = wcschr(*q, L'=');
205
+
if (pos_eq) {
206
+
l = wcslen(*q) + 1;
207
+
memcpy(r, *q, l * sizeof(WCHAR));
208
+
r += l;
209
+
}
194
210
}
195
211
*r = L'\0';
196
212
return env;
+1
ocamltest/tsl_ast.ml
+1
ocamltest/tsl_ast.ml
···
24
24
| Assignment of bool * string located * string located (* variable = value *)
25
25
| Append of string located * string located
26
26
| Include of string located (* include named environment *)
27
+
| Unset of string located (* clear environment variable *)
27
28
28
29
type tsl_item =
29
30
| Environment_statement of environment_statement located
+1
ocamltest/tsl_ast.mli
+1
ocamltest/tsl_ast.mli
···
24
24
| Assignment of bool * string located * string located (* variable = value *)
25
25
| Append of string located * string located (* variable += value *)
26
26
| Include of string located (* include named environment *)
27
+
| Unset of string located (* clear environment variable *)
27
28
28
29
type tsl_item =
29
30
| Environment_statement of environment_statement located
+1
ocamltest/tsl_lexer.mll
+1
ocamltest/tsl_lexer.mll
+3
-1
ocamltest/tsl_parser.mly
+3
-1
ocamltest/tsl_parser.mly
···
37
37
%token <int> TEST_DEPTH
38
38
%token EQUAL PLUSEQUAL
39
39
/* %token COLON */
40
-
%token INCLUDE SET WITH
40
+
%token INCLUDE SET UNSET WITH
41
41
%token <string> IDENTIFIER
42
42
%token <string> STRING
43
43
···
76
76
{ mkenvstmt (Append ($1, $3)) }
77
77
| SET identifier EQUAL string
78
78
{ mkenvstmt (Assignment (true, $2, $4)) }
79
+
| UNSET identifier
80
+
{ mkenvstmt (Unset $2) }
79
81
80
82
| INCLUDE identifier
81
83
{ mkenvstmt (Include $2) }
+10
-3
ocamltest/tsl_semantics.ml
+10
-3
ocamltest/tsl_semantics.ml
···
67
67
with Variables.No_such_variable name ->
68
68
no_such_variable loc name
69
69
70
-
let interprete_environment_statement env statement = match statement.node with
70
+
let interpret_environment_statement env statement = match statement.node with
71
71
| Assignment (decl, var, value) ->
72
72
add_to_env decl statement.loc var.node value.node env
73
73
| Append (var, value) ->
74
74
append_to_env statement.loc var.node value.node env
75
75
| Include modifiers_name ->
76
76
apply_modifiers env modifiers_name
77
+
| Unset var ->
78
+
let var =
79
+
match Variables.find_variable var.node with
80
+
| None -> Variables.make (var.node,"User variable")
81
+
| Some var -> var
82
+
in
83
+
Environments.unsetenv var env
77
84
78
-
let interprete_environment_statements env l =
79
-
List.fold_left interprete_environment_statement env l
85
+
let interpret_environment_statements env l =
86
+
List.fold_left interpret_environment_statement env l
80
87
81
88
type test_tree =
82
89
| Node of
+2
-2
ocamltest/tsl_semantics.mli
+2
-2
ocamltest/tsl_semantics.mli
···
19
19
20
20
val apply_modifiers : Environments.t -> string located -> Environments.t
21
21
22
-
val interprete_environment_statement :
22
+
val interpret_environment_statement :
23
23
Environments.t -> Tsl_ast.environment_statement Tsl_ast.located ->
24
24
Environments.t
25
25
26
-
val interprete_environment_statements :
26
+
val interpret_environment_statements :
27
27
Environments.t -> Tsl_ast.environment_statement Tsl_ast.located list ->
28
28
Environments.t
29
29
+4
-3
ocamltest/variables.ml
+4
-3
ocamltest/variables.ml
···
17
17
18
18
type value = string
19
19
20
-
type exporter = value -> string
20
+
type exporter = value -> string * string
21
21
22
22
type t = {
23
23
variable_name : string;
···
33
33
34
34
exception No_such_variable of string
35
35
36
-
let default_exporter varname value = Printf.sprintf "%s=%s" varname value
36
+
let default_exporter varname value = (varname, value)
37
37
38
38
let make (name, description) =
39
39
if name="" then raise Empty_variable_name else {
···
65
65
with Not_found -> None
66
66
67
67
let string_of_binding variable value =
68
-
variable.variable_exporter value
68
+
let (varname, value) = variable.variable_exporter value in
69
+
Printf.sprintf "%s=%s" varname value
69
70
70
71
let get_registered_variables () =
71
72
let f _variable_name variable variable_list = variable::variable_list in
+1
-1
ocamltest/variables.mli
+1
-1
ocamltest/variables.mli
+2
-1
parsing/ast_mapper.ml
+2
-1
parsing/ast_mapper.ml
···
486
486
| Ppat_var s -> var ~loc ~attrs (map_loc sub s)
487
487
| Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s)
488
488
| Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c)
489
-
| Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2
489
+
| Ppat_interval (c1, c2) ->
490
+
interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2)
490
491
| Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
491
492
| Ppat_construct (l, p) ->
492
493
construct ~loc ~attrs (map_loc sub l)
+2
-2
testsuite/tests/basic-modules/anonymous.ocamlc.reference
+2
-2
testsuite/tests/basic-modules/anonymous.ocamlc.reference
···
13
13
(apply (field_imm 1 (global CamlinternalMod!)) [0: [0]] B
14
14
(module-defn(B) Anonymous anonymous.ml(33):703-773
15
15
(let (x = [0: "foo" "bar"]) (makeblock 0))))
16
-
(let (f = (function param 0) s = (makemutable 0 ""))
16
+
(let (f = (function param : int 0) s = (makemutable 0 ""))
17
17
(seq
18
18
(ignore
19
19
(let (*match* = (setfield_ptr 0 s "Hello World!"))
20
20
(makeblock 0)))
21
21
(let
22
-
(drop = (function param 0)
22
+
(drop = (function param : int 0)
23
23
*match* = (apply drop (field_mut 0 s)))
24
24
(makeblock 0 A B f s drop))))))))
+4
-2
testsuite/tests/basic-modules/anonymous.ocamlopt.flambda.reference
+4
-2
testsuite/tests/basic-modules/anonymous.ocamlopt.flambda.reference
···
12
12
(apply (field_imm 1 (global CamlinternalMod!)) [0: [0]] B
13
13
(module-defn(B) anonymous.ml(33):703-773
14
14
(let (x = [0: "foo" "bar"]) (makeblock 0))))
15
-
(let (f = (function param 0) s = (makemutable 0 ""))
15
+
(let (f = (function param : int 0) s = (makemutable 0 ""))
16
16
(seq
17
17
(ignore
18
18
(let (*match* = (setfield_ptr 0 s "Hello World!")) (makeblock 0)))
19
-
(let (drop = (function param 0) *match* = (apply drop (field 0 s)))
19
+
(let
20
+
(drop = (function param : int 0)
21
+
*match* = (apply drop (field 0 s)))
20
22
(makeblock 0 A B f s drop)))))))
+2
-2
testsuite/tests/basic-modules/anonymous.ocamlopt.reference
+2
-2
testsuite/tests/basic-modules/anonymous.ocamlopt.reference
···
12
12
(let (x = [0: "foo" "bar"]) (makeblock 0)))
13
13
(setfield_ptr(root-init) 0 (global Anonymous!) A)
14
14
(setfield_ptr(root-init) 1 (global Anonymous!) B)
15
-
(let (f = (function param 0))
15
+
(let (f = (function param : int 0))
16
16
(setfield_ptr(root-init) 2 (global Anonymous!) f))
17
17
(let (s = (makemutable 0 ""))
18
18
(setfield_ptr(root-init) 3 (global Anonymous!) s))
···
22
22
(setfield_ptr 0 (field_imm 3 (global Anonymous!))
23
23
"Hello World!"))
24
24
(makeblock 0)))
25
-
(let (drop = (function param 0))
25
+
(let (drop = (function param : int 0))
26
26
(setfield_ptr(root-init) 4 (global Anonymous!) drop))
27
27
(let
28
28
(*match* =
+4
-2
testsuite/tests/basic/opt_variants.ml
+4
-2
testsuite/tests/basic/opt_variants.ml
+157
testsuite/tests/basic/patmatch_for_multiple.ml
+157
testsuite/tests/basic/patmatch_for_multiple.ml
···
44
44
with (4 x/95) (seq (ignore x/95) 1)))
45
45
- : bool = false
46
46
|}];;
47
+
48
+
(* Regression test for #3780 *)
49
+
let _ = fun a b ->
50
+
match a, b with
51
+
| ((true, _) as _g)
52
+
| ((false, _) as _g) -> ()
53
+
[%%expect{|
54
+
(function a/102[int] b/103 : int 0)
55
+
- : bool -> 'a -> unit = <fun>
56
+
|}];;
57
+
58
+
(* More complete tests.
59
+
60
+
The test cases below compare the compiler output on alias patterns
61
+
that are outside an or-pattern (handled during half-simplification,
62
+
then flattened) or inside an or-pattern (handled during simplification).
63
+
64
+
We used to have a Cannot_flatten exception that would result in fairly
65
+
different code generated in both cases, but now the compilation strategy
66
+
is fairly similar.
67
+
*)
68
+
let _ = fun a b -> match a, b with
69
+
| (true, _) as p -> p
70
+
| (false, _) as p -> p
71
+
(* outside, trivial *)
72
+
[%%expect {|
73
+
(function a/106[int] b/107 (let (p/108 =a (makeblock 0 a/106 b/107)) p/108))
74
+
- : bool -> 'a -> bool * 'a = <fun>
75
+
|}]
76
+
77
+
let _ = fun a b -> match a, b with
78
+
| ((true, _) as p)
79
+
| ((false, _) as p) -> p
80
+
(* inside, trivial *)
81
+
[%%expect{|
82
+
(function a/110[int] b/111 (let (p/112 =a (makeblock 0 a/110 b/111)) p/112))
83
+
- : bool -> 'a -> bool * 'a = <fun>
84
+
|}];;
85
+
86
+
let _ = fun a b -> match a, b with
87
+
| (true as x, _) as p -> x, p
88
+
| (false as x, _) as p -> x, p
89
+
(* outside, simple *)
90
+
[%%expect {|
91
+
(function a/116[int] b/117
92
+
(let (x/118 =a[int] a/116 p/119 =a (makeblock 0 a/116 b/117))
93
+
(makeblock 0 (int,*) x/118 p/119)))
94
+
- : bool -> 'a -> bool * (bool * 'a) = <fun>
95
+
|}]
96
+
97
+
let _ = fun a b -> match a, b with
98
+
| ((true as x, _) as p)
99
+
| ((false as x, _) as p) -> x, p
100
+
(* inside, simple *)
101
+
[%%expect {|
102
+
(function a/122[int] b/123
103
+
(let (x/124 =a[int] a/122 p/125 =a (makeblock 0 a/122 b/123))
104
+
(makeblock 0 (int,*) x/124 p/125)))
105
+
- : bool -> 'a -> bool * (bool * 'a) = <fun>
106
+
|}]
107
+
108
+
let _ = fun a b -> match a, b with
109
+
| (true as x, _) as p -> x, p
110
+
| (false, x) as p -> x, p
111
+
(* outside, complex *)
112
+
[%%expect{|
113
+
(function a/132[int] b/133[int]
114
+
(if a/132
115
+
(let (x/134 =a[int] a/132 p/135 =a (makeblock 0 a/132 b/133))
116
+
(makeblock 0 (int,*) x/134 p/135))
117
+
(let (x/136 =a b/133 p/137 =a (makeblock 0 a/132 b/133))
118
+
(makeblock 0 (int,*) x/136 p/137))))
119
+
- : bool -> bool -> bool * (bool * bool) = <fun>
120
+
|}]
121
+
122
+
let _ = fun a b -> match a, b with
123
+
| ((true as x, _) as p)
124
+
| ((false, x) as p)
125
+
-> x, p
126
+
(* inside, complex *)
127
+
[%%expect{|
128
+
(function a/138[int] b/139[int]
129
+
(catch
130
+
(if a/138
131
+
(let (x/146 =a[int] a/138 p/147 =a (makeblock 0 a/138 b/139))
132
+
(exit 10 x/146 p/147))
133
+
(let (x/144 =a b/139 p/145 =a (makeblock 0 a/138 b/139))
134
+
(exit 10 x/144 p/145)))
135
+
with (10 x/140[int] p/141) (makeblock 0 (int,*) x/140 p/141)))
136
+
- : bool -> bool -> bool * (bool * bool) = <fun>
137
+
|}]
138
+
139
+
(* here flattening is an optimisation: the allocation is moved as an
140
+
alias within each branch, and in the first branch it is unused and
141
+
will be removed by simplification, so the final code
142
+
(see the -dlambda output) will not allocate in the first branch. *)
143
+
let _ = fun a b -> match a, b with
144
+
| (true as x, _) as _p -> x, (true, true)
145
+
| (false as x, _) as p -> x, p
146
+
(* outside, onecase *)
147
+
[%%expect {|
148
+
(function a/148[int] b/149[int]
149
+
(if a/148
150
+
(let (x/150 =a[int] a/148 _p/151 =a (makeblock 0 a/148 b/149))
151
+
(makeblock 0 (int,*) x/150 [0: 1 1]))
152
+
(let (x/152 =a[int] a/148 p/153 =a (makeblock 0 a/148 b/149))
153
+
(makeblock 0 (int,*) x/152 p/153))))
154
+
- : bool -> bool -> bool * (bool * bool) = <fun>
155
+
|}]
156
+
157
+
let _ = fun a b -> match a, b with
158
+
| ((true as x, _) as p)
159
+
| ((false as x, _) as p) -> x, p
160
+
(* inside, onecase *)
161
+
[%%expect{|
162
+
(function a/154[int] b/155
163
+
(let (x/156 =a[int] a/154 p/157 =a (makeblock 0 a/154 b/155))
164
+
(makeblock 0 (int,*) x/156 p/157)))
165
+
- : bool -> 'a -> bool * (bool * 'a) = <fun>
166
+
|}]
167
+
168
+
type 'a tuplist = Nil | Cons of ('a * 'a tuplist)
169
+
[%%expect{|
170
+
0
171
+
type 'a tuplist = Nil | Cons of ('a * 'a tuplist)
172
+
|}]
173
+
174
+
(* another example where we avoid an allocation in the first case *)
175
+
let _ =fun a b -> match a, b with
176
+
| (true, Cons p) -> p
177
+
| (_, _) as p -> p
178
+
(* outside, tuplist *)
179
+
[%%expect {|
180
+
(function a/167[int] b/168
181
+
(catch
182
+
(if a/167 (if b/168 (let (p/169 =a (field_imm 0 b/168)) p/169) (exit 12))
183
+
(exit 12))
184
+
with (12) (let (p/170 =a (makeblock 0 a/167 b/168)) p/170)))
185
+
- : bool -> bool tuplist -> bool * bool tuplist = <fun>
186
+
|}]
187
+
188
+
let _ = fun a b -> match a, b with
189
+
| (true, Cons p)
190
+
| ((_, _) as p) -> p
191
+
(* inside, tuplist *)
192
+
[%%expect{|
193
+
(function a/171[int] b/172
194
+
(catch
195
+
(catch
196
+
(if a/171
197
+
(if b/172 (let (p/176 =a (field_imm 0 b/172)) (exit 13 p/176))
198
+
(exit 14))
199
+
(exit 14))
200
+
with (14) (let (p/175 =a (makeblock 0 a/171 b/172)) (exit 13 p/175)))
201
+
with (13 p/173) p/173))
202
+
- : bool -> bool tuplist -> bool * bool tuplist = <fun>
203
+
|}]
+3
-1
testsuite/tests/lib-threads/pr7638.ml
+3
-1
testsuite/tests/lib-threads/pr7638.ml
···
1
1
(* TEST
2
2
3
+
unset DOES_NOT_EXIST
4
+
3
5
* hassysthreads
4
6
include systhreads
5
7
** bytecode
···
15
17
| s -> print_string "Surprising but OK\n"
16
18
17
19
let _ =
18
-
let th = Thread.create crashme "no such variable" in
20
+
let th = Thread.create crashme "DOES_NOT_EXIST" in
19
21
Thread.join th
+1
testsuite/tests/lib-unix/common/redirections.ml
+1
testsuite/tests/lib-unix/common/redirections.ml
+6
-8
testsuite/tests/lib-unix/common/test_unix_cmdline.ml
+6
-8
testsuite/tests/lib-unix/common/test_unix_cmdline.ml
···
31
31
32
32
*)
33
33
34
-
open Unix
35
-
36
34
let prog_name = "cmdline_prog.exe"
37
35
38
36
let run args =
39
-
let out, inp = pipe () in
40
-
let in_chan = in_channel_of_descr out in
37
+
let out, inp = Unix.pipe () in
38
+
let in_chan = Unix.in_channel_of_descr out in
41
39
set_binary_mode_in in_chan false;
42
40
let pid =
43
-
create_process ("./" ^ prog_name) (Array.of_list (prog_name :: args))
41
+
Unix.create_process ("./" ^ prog_name) (Array.of_list (prog_name :: args))
44
42
Unix.stdin inp Unix.stderr in
45
43
List.iter (fun arg ->
46
44
let s = input_line in_chan in
47
45
Printf.printf "%S -> %S [%s]\n" arg s (if s = arg then "OK" else "FAIL")
48
46
) args;
49
47
close_in in_chan;
50
-
let _, exit = waitpid [] pid in
51
-
assert (exit = WEXITED 0)
48
+
let _, exit = Unix.waitpid [] pid in
49
+
assert (exit = Unix.WEXITED 0)
52
50
53
51
let exec args =
54
-
execv ("./" ^ prog_name) (Array.of_list (prog_name :: args))
52
+
Unix.execv ("./" ^ prog_name) (Array.of_list (prog_name :: args))
55
53
56
54
let () =
57
55
List.iter run
+1
testsuite/tests/lib-unix/unix-execvpe/exec.ml
+1
testsuite/tests/lib-unix/unix-execvpe/exec.ml
+8
-10
testsuite/tests/lib-unix/unix-socket/recvfrom.ml
+8
-10
testsuite/tests/lib-unix/unix-socket/recvfrom.ml
···
1
-
open Unix
2
-
3
1
let path_of_addr = function
4
-
| ADDR_UNIX path -> path
2
+
| Unix.ADDR_UNIX path -> path
5
3
| _ -> assert false
6
4
;;
7
5
8
6
let test_sender ~client_socket ~server_socket ~server_addr ~client_addr =
9
7
Printf.printf "%S" (path_of_addr client_addr);
10
8
let byte = Bytes.make 1 't' in
11
-
let sent_len = sendto client_socket byte 0 1 [] server_addr in
9
+
let sent_len = Unix.sendto client_socket byte 0 1 [] server_addr in
12
10
assert (sent_len = 1);
13
11
let buf = Bytes.make 1024 '\x00' in
14
-
let (recv_len, sender) = recvfrom server_socket buf 0 1024 [] in
12
+
let (recv_len, sender) = Unix.recvfrom server_socket buf 0 1024 [] in
15
13
16
14
Printf.printf " as %S: " (path_of_addr sender);
17
15
assert (sender = client_addr);
···
19
17
print_endline "OK";;
20
18
21
19
let ensure_no_file path =
22
-
try unlink path with Unix_error (ENOENT, _, _) -> ();;
20
+
try Unix.unlink path with Unix.Unix_error (ENOENT, _, _) -> ();;
23
21
24
22
let with_socket fn =
25
-
let s = socket PF_UNIX SOCK_DGRAM 0 in
26
-
Fun.protect ~finally:(fun () -> close s) (fun () -> fn s)
23
+
let s = Unix.socket PF_UNIX SOCK_DGRAM 0 in
24
+
Fun.protect ~finally:(fun () -> Unix.close s) (fun () -> fn s)
27
25
28
26
let with_bound_socket path fn =
29
27
with_socket (fun s ->
30
-
let addr = ADDR_UNIX path in
31
-
bind s addr;
28
+
let addr = Unix.ADDR_UNIX path in
29
+
Unix.bind s addr;
32
30
fn addr s
33
31
)
+2
testsuite/tests/lib-unix/win-env/test_env.ml
+2
testsuite/tests/lib-unix/win-env/test_env.ml
+2
-3
testsuite/tests/lib-unix/win-stat/test.ml
+2
-3
testsuite/tests/lib-unix/win-stat/test.ml
···
6
6
** native
7
7
*)
8
8
9
-
open Unix
10
-
11
9
external set_fake_clock : int64 -> unit = "set_fake_clock"
12
10
13
-
let real_time tm = {tm with tm_year = tm.tm_year + 1900; tm_mon = tm.tm_mon + 1}
11
+
let real_time tm =
12
+
Unix.{tm with tm_year = tm.tm_year + 1900; tm_mon = tm.tm_mon + 1}
14
13
15
14
let print_time () =
16
15
let time = Unix.time () |> Unix.gmtime |> real_time in
+1
testsuite/tests/output-complete-obj/test2.ml
+1
testsuite/tests/output-complete-obj/test2.ml
+3
-2
testsuite/tests/translprim/array_spec.compilers.flat.reference
+3
-2
testsuite/tests/translprim/array_spec.compilers.flat.reference
···
11
11
(array.unsafe_get[addr] addr_a 0)
12
12
(function a (array.unsafe_get[gen] a 0)) (array.set[int] int_a 0 1)
13
13
(array.set[float] float_a 0 1.) (array.set[addr] addr_a 0 "a")
14
-
(function a x (array.set[gen] a 0 x)) (array.unsafe_set[int] int_a 0 1)
14
+
(function a x : int (array.set[gen] a 0 x))
15
+
(array.unsafe_set[int] int_a 0 1)
15
16
(array.unsafe_set[float] float_a 0 1.)
16
17
(array.unsafe_set[addr] addr_a 0 "a")
17
-
(function a x (array.unsafe_set[gen] a 0 x))
18
+
(function a x : int (array.unsafe_set[gen] a 0 x))
18
19
(let
19
20
(eta_gen_len = (function prim stub (array.length[gen] prim))
20
21
eta_gen_safe_get =
+2
-2
testsuite/tests/translprim/array_spec.compilers.no-flat.reference
+2
-2
testsuite/tests/translprim/array_spec.compilers.no-flat.reference
···
11
11
(array.unsafe_get[addr] addr_a 0)
12
12
(function a (array.unsafe_get[addr] a 0)) (array.set[int] int_a 0 1)
13
13
(array.set[addr] float_a 0 1.) (array.set[addr] addr_a 0 "a")
14
-
(function a x (array.set[addr] a 0 x))
14
+
(function a x : int (array.set[addr] a 0 x))
15
15
(array.unsafe_set[int] int_a 0 1) (array.unsafe_set[addr] float_a 0 1.)
16
16
(array.unsafe_set[addr] addr_a 0 "a")
17
-
(function a x (array.unsafe_set[addr] a 0 x))
17
+
(function a x : int (array.unsafe_set[addr] a 0 x))
18
18
(let
19
19
(eta_gen_len = (function prim stub (array.length[addr] prim))
20
20
eta_gen_safe_get =
+62
-56
testsuite/tests/translprim/comparison_table.compilers.reference
+62
-56
testsuite/tests/translprim/comparison_table.compilers.reference
···
2
2
(let
3
3
(gen_cmp = (function x y : int (caml_compare x y))
4
4
int_cmp = (function x[int] y[int] : int (compare_ints x y))
5
-
bool_cmp = (function x y : int (compare_ints x y))
6
-
intlike_cmp = (function x y : int (compare_ints x y))
5
+
bool_cmp = (function x[int] y[int] : int (compare_ints x y))
6
+
intlike_cmp = (function x[int] y[int] : int (compare_ints x y))
7
7
float_cmp = (function x[float] y[float] : int (compare_floats x y))
8
8
string_cmp = (function x y : int (caml_string_compare x y))
9
9
int32_cmp = (function x[int32] y[int32] : int (compare_bints int32 x y))
···
11
11
nativeint_cmp =
12
12
(function x[nativeint] y[nativeint] : int
13
13
(compare_bints nativeint x y))
14
-
gen_eq = (function x y (caml_equal x y))
15
-
int_eq = (function x[int] y[int] (== x y))
16
-
bool_eq = (function x y (== x y))
17
-
intlike_eq = (function x y (== x y))
18
-
float_eq = (function x[float] y[float] (==. x y))
19
-
string_eq = (function x y (caml_string_equal x y))
20
-
int32_eq = (function x[int32] y[int32] (Int32.== x y))
21
-
int64_eq = (function x[int64] y[int64] (Int64.== x y))
22
-
nativeint_eq = (function x[nativeint] y[nativeint] (Nativeint.== x y))
23
-
gen_ne = (function x y (caml_notequal x y))
24
-
int_ne = (function x[int] y[int] (!= x y))
25
-
bool_ne = (function x y (!= x y))
26
-
intlike_ne = (function x y (!= x y))
27
-
float_ne = (function x[float] y[float] (!=. x y))
28
-
string_ne = (function x y (caml_string_notequal x y))
29
-
int32_ne = (function x[int32] y[int32] (Int32.!= x y))
30
-
int64_ne = (function x[int64] y[int64] (Int64.!= x y))
31
-
nativeint_ne = (function x[nativeint] y[nativeint] (Nativeint.!= x y))
32
-
gen_lt = (function x y (caml_lessthan x y))
33
-
int_lt = (function x[int] y[int] (< x y))
34
-
bool_lt = (function x y (< x y))
35
-
intlike_lt = (function x y (< x y))
36
-
float_lt = (function x[float] y[float] (<. x y))
37
-
string_lt = (function x y (caml_string_lessthan x y))
38
-
int32_lt = (function x[int32] y[int32] (Int32.< x y))
39
-
int64_lt = (function x[int64] y[int64] (Int64.< x y))
40
-
nativeint_lt = (function x[nativeint] y[nativeint] (Nativeint.< x y))
41
-
gen_gt = (function x y (caml_greaterthan x y))
42
-
int_gt = (function x[int] y[int] (> x y))
43
-
bool_gt = (function x y (> x y))
44
-
intlike_gt = (function x y (> x y))
45
-
float_gt = (function x[float] y[float] (>. x y))
46
-
string_gt = (function x y (caml_string_greaterthan x y))
47
-
int32_gt = (function x[int32] y[int32] (Int32.> x y))
48
-
int64_gt = (function x[int64] y[int64] (Int64.> x y))
49
-
nativeint_gt = (function x[nativeint] y[nativeint] (Nativeint.> x y))
50
-
gen_le = (function x y (caml_lessequal x y))
51
-
int_le = (function x[int] y[int] (<= x y))
52
-
bool_le = (function x y (<= x y))
53
-
intlike_le = (function x y (<= x y))
54
-
float_le = (function x[float] y[float] (<=. x y))
55
-
string_le = (function x y (caml_string_lessequal x y))
56
-
int32_le = (function x[int32] y[int32] (Int32.<= x y))
57
-
int64_le = (function x[int64] y[int64] (Int64.<= x y))
58
-
nativeint_le = (function x[nativeint] y[nativeint] (Nativeint.<= x y))
59
-
gen_ge = (function x y (caml_greaterequal x y))
60
-
int_ge = (function x[int] y[int] (>= x y))
61
-
bool_ge = (function x y (>= x y))
62
-
intlike_ge = (function x y (>= x y))
63
-
float_ge = (function x[float] y[float] (>=. x y))
64
-
string_ge = (function x y (caml_string_greaterequal x y))
65
-
int32_ge = (function x[int32] y[int32] (Int32.>= x y))
66
-
int64_ge = (function x[int64] y[int64] (Int64.>= x y))
67
-
nativeint_ge = (function x[nativeint] y[nativeint] (Nativeint.>= x y))
14
+
gen_eq = (function x y : int (caml_equal x y))
15
+
int_eq = (function x[int] y[int] : int (== x y))
16
+
bool_eq = (function x[int] y[int] : int (== x y))
17
+
intlike_eq = (function x[int] y[int] : int (== x y))
18
+
float_eq = (function x[float] y[float] : int (==. x y))
19
+
string_eq = (function x y : int (caml_string_equal x y))
20
+
int32_eq = (function x[int32] y[int32] : int (Int32.== x y))
21
+
int64_eq = (function x[int64] y[int64] : int (Int64.== x y))
22
+
nativeint_eq =
23
+
(function x[nativeint] y[nativeint] : int (Nativeint.== x y))
24
+
gen_ne = (function x y : int (caml_notequal x y))
25
+
int_ne = (function x[int] y[int] : int (!= x y))
26
+
bool_ne = (function x[int] y[int] : int (!= x y))
27
+
intlike_ne = (function x[int] y[int] : int (!= x y))
28
+
float_ne = (function x[float] y[float] : int (!=. x y))
29
+
string_ne = (function x y : int (caml_string_notequal x y))
30
+
int32_ne = (function x[int32] y[int32] : int (Int32.!= x y))
31
+
int64_ne = (function x[int64] y[int64] : int (Int64.!= x y))
32
+
nativeint_ne =
33
+
(function x[nativeint] y[nativeint] : int (Nativeint.!= x y))
34
+
gen_lt = (function x y : int (caml_lessthan x y))
35
+
int_lt = (function x[int] y[int] : int (< x y))
36
+
bool_lt = (function x[int] y[int] : int (< x y))
37
+
intlike_lt = (function x[int] y[int] : int (< x y))
38
+
float_lt = (function x[float] y[float] : int (<. x y))
39
+
string_lt = (function x y : int (caml_string_lessthan x y))
40
+
int32_lt = (function x[int32] y[int32] : int (Int32.< x y))
41
+
int64_lt = (function x[int64] y[int64] : int (Int64.< x y))
42
+
nativeint_lt =
43
+
(function x[nativeint] y[nativeint] : int (Nativeint.< x y))
44
+
gen_gt = (function x y : int (caml_greaterthan x y))
45
+
int_gt = (function x[int] y[int] : int (> x y))
46
+
bool_gt = (function x[int] y[int] : int (> x y))
47
+
intlike_gt = (function x[int] y[int] : int (> x y))
48
+
float_gt = (function x[float] y[float] : int (>. x y))
49
+
string_gt = (function x y : int (caml_string_greaterthan x y))
50
+
int32_gt = (function x[int32] y[int32] : int (Int32.> x y))
51
+
int64_gt = (function x[int64] y[int64] : int (Int64.> x y))
52
+
nativeint_gt =
53
+
(function x[nativeint] y[nativeint] : int (Nativeint.> x y))
54
+
gen_le = (function x y : int (caml_lessequal x y))
55
+
int_le = (function x[int] y[int] : int (<= x y))
56
+
bool_le = (function x[int] y[int] : int (<= x y))
57
+
intlike_le = (function x[int] y[int] : int (<= x y))
58
+
float_le = (function x[float] y[float] : int (<=. x y))
59
+
string_le = (function x y : int (caml_string_lessequal x y))
60
+
int32_le = (function x[int32] y[int32] : int (Int32.<= x y))
61
+
int64_le = (function x[int64] y[int64] : int (Int64.<= x y))
62
+
nativeint_le =
63
+
(function x[nativeint] y[nativeint] : int (Nativeint.<= x y))
64
+
gen_ge = (function x y : int (caml_greaterequal x y))
65
+
int_ge = (function x[int] y[int] : int (>= x y))
66
+
bool_ge = (function x[int] y[int] : int (>= x y))
67
+
intlike_ge = (function x[int] y[int] : int (>= x y))
68
+
float_ge = (function x[float] y[float] : int (>=. x y))
69
+
string_ge = (function x y : int (caml_string_greaterequal x y))
70
+
int32_ge = (function x[int32] y[int32] : int (Int32.>= x y))
71
+
int64_ge = (function x[int64] y[int64] : int (Int64.>= x y))
72
+
nativeint_ge =
73
+
(function x[nativeint] y[nativeint] : int (Nativeint.>= x y))
68
74
eta_gen_cmp = (function prim prim stub (caml_compare prim prim))
69
75
eta_int_cmp = (function prim prim stub (compare_ints prim prim))
70
76
eta_bool_cmp = (function prim prim stub (compare_ints prim prim))
+16
-16
testsuite/tests/translprim/ref_spec.compilers.reference
+16
-16
testsuite/tests/translprim/ref_spec.compilers.reference
···
1
1
(setglobal Ref_spec!
2
2
(let
3
3
(int_ref = (makemutable 0 (int) 1)
4
-
var_ref = (makemutable 0 65)
4
+
var_ref = (makemutable 0 (int) 65)
5
5
vargen_ref = (makemutable 0 65)
6
-
cst_ref = (makemutable 0 0)
6
+
cst_ref = (makemutable 0 (int) 0)
7
7
gen_ref = (makemutable 0 0)
8
8
flt_ref = (makemutable 0 (float) 0.))
9
9
(seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66)
···
11
11
(setfield_imm 0 cst_ref 1) (setfield_ptr 0 gen_ref [0: "foo"])
12
12
(setfield_ptr 0 gen_ref 0) (setfield_ptr 0 flt_ref 1.)
13
13
(let
14
-
(int_rec = (makemutable 0 (*,int) 0 1)
15
-
var_rec = (makemutable 0 0 65)
16
-
vargen_rec = (makemutable 0 0 65)
17
-
cst_rec = (makemutable 0 0 0)
18
-
gen_rec = (makemutable 0 0 0)
19
-
flt_rec = (makemutable 0 (*,float) 0 0.)
14
+
(int_rec = (makemutable 0 (int,int) 0 1)
15
+
var_rec = (makemutable 0 (int,int) 0 65)
16
+
vargen_rec = (makemutable 0 (int,*) 0 65)
17
+
cst_rec = (makemutable 0 (int,int) 0 0)
18
+
gen_rec = (makemutable 0 (int,*) 0 0)
19
+
flt_rec = (makemutable 0 (int,float) 0 0.)
20
20
flt_rec' = (makearray[float] 0. 0.))
21
21
(seq (setfield_imm 1 int_rec 2) (setfield_imm 1 var_rec 66)
22
22
(setfield_ptr 1 vargen_rec [0: 66 0])
···
24
24
(setfield_ptr 1 gen_rec [0: "foo"]) (setfield_ptr 1 gen_rec 0)
25
25
(setfield_ptr 1 flt_rec 1.) (setfloatfield 1 flt_rec' 1.)
26
26
(let
27
-
(set_open_poly = (function r y (setfield_ptr 0 r y))
28
-
set_open_poly = (function r y (setfield_imm 0 r y))
29
-
set_open_poly = (function r y (setfield_imm 0 r y))
30
-
set_open_poly = (function r y (setfield_imm 0 r y))
31
-
set_open_poly = (function r y (setfield_ptr 0 r y))
32
-
set_open_poly = (function r y (setfield_ptr 0 r y))
33
-
set_open_poly = (function r y (setfield_ptr 0 r y))
34
-
set_open_poly = (function r y (setfield_ptr 0 r y)))
27
+
(set_open_poly = (function r y : int (setfield_ptr 0 r y))
28
+
set_open_poly = (function r y[int] : int (setfield_imm 0 r y))
29
+
set_open_poly = (function r y[int] : int (setfield_imm 0 r y))
30
+
set_open_poly = (function r y[int] : int (setfield_imm 0 r y))
31
+
set_open_poly = (function r y : int (setfield_ptr 0 r y))
32
+
set_open_poly = (function r y : int (setfield_ptr 0 r y))
33
+
set_open_poly = (function r y : int (setfield_ptr 0 r y))
34
+
set_open_poly = (function r y : int (setfield_ptr 0 r y)))
35
35
(makeblock 0 int_ref var_ref vargen_ref cst_ref gen_ref flt_ref
36
36
int_rec var_rec vargen_rec cst_rec gen_rec flt_rec flt_rec'
37
37
set_open_poly)))))))
+31
testsuite/tests/typing-modules/private.ml
+31
testsuite/tests/typing-modules/private.ml
···
1
+
(* TEST
2
+
* expect
3
+
*)
4
+
5
+
module M :
6
+
sig type t = private [< `A | `B of string] end
7
+
= struct type t = [`A|`B of string] end;;
8
+
[%%expect{|
9
+
module M : sig type t = private [< `A | `B of string ] end
10
+
|}]
11
+
12
+
module M = struct type header_item_tag =
13
+
[ `CO | `HD | `Other of string | `PG | `RG | `SQ ]
14
+
end;;
15
+
[%%expect{|
16
+
module M :
17
+
sig
18
+
type header_item_tag = [ `CO | `HD | `Other of string | `PG | `RG | `SQ ]
19
+
end
20
+
|}]
21
+
22
+
module M' : sig type header_item_tag =
23
+
private [< `CO | `HD | `Other of string | `PG | `RG | `SQ ]
24
+
end = M;;
25
+
[%%expect{|
26
+
module M' :
27
+
sig
28
+
type header_item_tag = private
29
+
[< `CO | `HD | `Other of string | `PG | `RG | `SQ ]
30
+
end
31
+
|}]
+8
-4
testsuite/tests/win-unicode/mltest.compilers.reference
+8
-4
testsuite/tests/win-unicode/mltest.compilers.reference
···
14
14
val sys_readdir : string -> string list = <fun>
15
15
val test_readdir : (string -> string list) -> string list = <fun>
16
16
val test_open_in : unit -> string list = <fun>
17
-
val test_getenv : unit -> (string * string) list = <fun>
17
+
val test_getenv : unit -> ((string * string) * (string * string)) list =
18
+
<fun>
18
19
val test_mkdir : unit -> (bool * bool) list = <fun>
19
20
val test_chdir : (string -> unit) -> (unit -> 'a) -> 'a list = <fun>
20
21
val test_rmdir : unit -> bool list = <fun>
···
76
77
val t_sys_chdir : string list = ["été"; "simple"; "sœur"; "你好"]
77
78
val t_unix_chdir : string list = ["été"; "simple"; "sœur"; "你好"]
78
79
- : bool list = [false; false; false; false]
79
-
val t_getenv : (string * string) list =
80
-
[("верблюды", "верблюды"); ("骆驼", "骆驼");
81
-
("קעמל", "קעמל"); ("اونٹ", "اونٹ")]
80
+
val t_getenv : ((string * string) * (string * string)) list =
81
+
[(("верблюды", "верблюды"),
82
+
("верблюдыверблюды", "верблюдыверблюды"));
83
+
(("骆驼", "骆驼"), ("骆驼骆驼", "骆驼骆驼"));
84
+
(("קעמל", "קעמל"), ("קעמלקעמל", "קעמלקעמל"));
85
+
(("اونٹ", "اونٹ"), ("اونٹاونٹ", "اونٹاونٹ"))]
82
86
- : bool = true
83
87
+10
-1
testsuite/tests/win-unicode/mltest.ml
+10
-1
testsuite/tests/win-unicode/mltest.ml
···
144
144
;;
145
145
146
146
let test_getenv () =
147
+
let equiv l r =
148
+
assert (l = r);
149
+
l, r
150
+
in
147
151
let doit key s =
148
152
Unix.putenv key s;
149
-
Sys.getenv key, getenvironmentenv key
153
+
let l = equiv (Sys.getenv key) (getenvironmentenv key) in
154
+
let r =
155
+
Unix.putenv key (s ^ s);
156
+
equiv (Sys.getenv key) (getenvironmentenv key)
157
+
in
158
+
l, r
150
159
in
151
160
List.map2 doit foreign_names foreign_names2
152
161
;;
+4
-2
tools/ci/inria/bootstrap/script
+4
-2
tools/ci/inria/bootstrap/script
···
64
64
new="$1"
65
65
echo Changing executable magic number from ${old} to ${new}
66
66
# Change magic number in runtime/caml/exec.h
67
-
sed -i 's/\x23define \+EXEC_MAGIC \+\x22'${old}\
67
+
sed -i.tmp 's/\x23define \+EXEC_MAGIC \+\x22'${old}\
68
68
'\x22/#define EXEC_MAGIC "'${new}'"/' runtime/caml/exec.h
69
+
rm -f runtime/caml/exec.h.tmp
69
70
# Change magic number in utils/config.mlp
70
-
sed -i 's/let \+exec_magic_number \+= \+\x22'${old}\
71
+
sed -i.tmp 's/let \+exec_magic_number \+= \+\x22'${old}\
71
72
'\x22/let exec_magic_number = "'${new}'"/' utils/config.mlp
73
+
rm -f utils/config.mlp.tmp
72
74
}
73
75
74
76
remove_primitive()
-10
typing/ctype.ml
-10
typing/ctype.ml
···
5390
5390
let () =
5391
5391
Env.same_constr := same_constr
5392
5392
5393
-
let is_immediate = function
5394
-
| Type_immediacy.Unknown -> false
5395
-
| Type_immediacy.Always -> true
5396
-
| Type_immediacy.Always_on_64bits ->
5397
-
(* In bytecode, we don't know at compile time whether we are
5398
-
targeting 32 or 64 bits. *)
5399
-
!Clflags.native_code && Sys.word_size = 64
5400
-
5401
5393
let immediacy env typ =
5402
5394
match get_desc typ with
5403
5395
| Tconstr(p, _args, _abbrev) ->
···
5424
5416
else
5425
5417
Type_immediacy.Always
5426
5418
| _ -> Type_immediacy.Unknown
5427
-
5428
-
let maybe_pointer_type env typ = not (is_immediate (immediacy env typ))
-3
typing/ctype.mli
-3
typing/ctype.mli
···
415
415
416
416
val immediacy : Env.t -> type_expr -> Type_immediacy.t
417
417
418
-
val maybe_pointer_type : Env.t -> type_expr -> bool
419
-
(* True if type is possibly pointer, false if definitely not a pointer *)
420
-
421
418
(* Stubs *)
422
419
val package_subtype :
423
420
(Env.t -> Path.t -> (Longident.t * type_expr) list ->
+2
-2
typing/includecore.ml
+2
-2
typing/includecore.ml
···
759
759
| Some _, None | None, Some _ ->
760
760
Some (Incompatible_types_for s)
761
761
end
762
-
| Rpresent to1, Reither(const2, tl2, _, _) -> begin
763
-
match to1, const2, tl2 with
762
+
| Rpresent to1, Reither(const2, ts2, _, _) -> begin
763
+
match to1, const2, ts2 with
764
764
| Some t1, false, [t2] -> loop (t1 :: tl1) (t2 :: tl2) pairs
765
765
| None, true, [] -> loop tl1 tl2 pairs
766
766
| _, _, _ -> Some (Incompatible_types_for s)
+1
-6
typing/typedecl.ml
+1
-6
typing/typedecl.ml
···
134
134
with Ctype.Unify err ->
135
135
raise (Error(loc, Type_clash (env, err)))
136
136
137
-
let get_unboxed_type_representation env ty =
138
-
match Typedecl_unboxed.get_unboxed_type_representation env ty with
139
-
| Typedecl_unboxed.This x -> Some x
140
-
| _ -> None
141
-
142
137
(* Determine if a type's values are represented by floats at run-time. *)
143
138
let is_float env ty =
144
-
match get_unboxed_type_representation env ty with
139
+
match Typedecl_unboxed.get_unboxed_type_representation env ty with
145
140
Some ty' ->
146
141
begin match get_desc ty' with
147
142
Tconstr(p, _, _) -> Path.same p Predef.path_float
-4
typing/typedecl.mli
-4
typing/typedecl.mli
+2
-6
typing/typedecl_immediacy.ml
+2
-6
typing/typedecl_immediacy.ml
···
26
26
Variant_unboxed)
27
27
| Type_record ([{ld_type = arg; _}], Record_unboxed _)), _ ->
28
28
begin match Typedecl_unboxed.get_unboxed_type_representation env arg with
29
-
| Typedecl_unboxed.Unavailable -> Type_immediacy.Unknown
30
-
| Typedecl_unboxed.This argrepr -> Ctype.immediacy env argrepr
31
-
| Typedecl_unboxed.Only_on_64_bits argrepr ->
32
-
match Ctype.immediacy env argrepr with
33
-
| Type_immediacy.Always -> Type_immediacy.Always_on_64bits
34
-
| Type_immediacy.Always_on_64bits | Type_immediacy.Unknown as x -> x
29
+
| None -> Type_immediacy.Unknown
30
+
| Some argrepr -> Ctype.immediacy env argrepr
35
31
end
36
32
| (Type_variant (_ :: _ as cstrs, _), _) ->
37
33
if not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs)
+4
-13
typing/typedecl_unboxed.ml
+4
-13
typing/typedecl_unboxed.ml
···
16
16
17
17
open Types
18
18
19
-
type t =
20
-
| Unavailable
21
-
| This of type_expr
22
-
| Only_on_64_bits of type_expr
23
-
24
19
(* We use the Ctype.expand_head_opt version of expand_head to get access
25
20
to the manifest type of private abbreviations. *)
26
21
let rec get_unboxed_type_representation env ty fuel =
27
-
if fuel < 0 then Unavailable else
22
+
if fuel < 0 then None else
28
23
let ty = Ctype.expand_head_opt env ty in
29
24
match get_desc ty with
30
25
| Tconstr (p, args, _) ->
31
26
begin match Env.find_type p env with
32
-
| exception Not_found -> This ty
33
-
| {type_immediate = Always; _} ->
34
-
This Predef.type_int
35
-
| {type_immediate = Always_on_64bits; _} ->
36
-
Only_on_64_bits Predef.type_int
27
+
| exception Not_found -> Some ty
37
28
| {type_params; type_kind =
38
29
Type_record ([{ld_type = ty2; _}], Record_unboxed _)
39
30
| Type_variant ([{cd_args = Cstr_tuple [ty2]; _}], Variant_unboxed)
···
43
34
let ty2 = match get_desc ty2 with Tpoly (t, _) -> t | _ -> ty2 in
44
35
get_unboxed_type_representation env
45
36
(Ctype.apply env type_params ty2 args) (fuel - 1)
46
-
| _ -> This ty
37
+
| _ -> Some ty
47
38
end
48
-
| _ -> This ty
39
+
| _ -> Some ty
49
40
50
41
let get_unboxed_type_representation env ty =
51
42
(* Do not give too much fuel: PR#7424 *)
+1
-6
typing/typedecl_unboxed.mli
+1
-6
typing/typedecl_unboxed.mli
···
16
16
17
17
open Types
18
18
19
-
type t =
20
-
| Unavailable
21
-
| This of type_expr
22
-
| Only_on_64_bits of type_expr
23
-
24
19
(* for typeopt.ml *)
25
-
val get_unboxed_type_representation: Env.t -> type_expr -> t
20
+
val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option
+29
-23
typing/typeopt.ml
+29
-23
typing/typeopt.ml
···
27
27
| Tconstr (p, _, _) ->
28
28
begin match Env.find_type p env with
29
29
| {type_kind = ( Type_variant (_, Variant_unboxed)
30
-
| Type_record (_, Record_unboxed _) ); _} ->
31
-
begin match Typedecl.get_unboxed_type_representation env ty with
32
-
| None -> ty
33
-
| Some ty2 -> ty2
30
+
| Type_record (_, Record_unboxed _) ); _} -> begin
31
+
match Typedecl_unboxed.get_unboxed_type_representation env ty with
32
+
| None -> ty
33
+
| Some ty2 -> ty2
34
34
end
35
35
| _ -> ty
36
36
| exception Not_found -> ty
···
56
56
| Tconstr(p, _, _) -> Path.same p base_ty_path
57
57
| _ -> false
58
58
59
+
let is_immediate = function
60
+
| Type_immediacy.Unknown -> false
61
+
| Type_immediacy.Always -> true
62
+
| Type_immediacy.Always_on_64bits ->
63
+
(* In bytecode, we don't know at compile time whether we are
64
+
targeting 32 or 64 bits. *)
65
+
!Clflags.native_code && Sys.word_size = 64
66
+
59
67
let maybe_pointer_type env ty =
60
68
let ty = scrape_ty env ty in
61
-
if Ctype.maybe_pointer_type env ty then
62
-
Pointer
63
-
else
64
-
Immediate
69
+
if is_immediate (Ctype.immediacy env ty) then Immediate
70
+
else Pointer
65
71
66
72
let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type
67
73
···
160
166
(Pbigarray_unknown, Pbigarray_unknown_layout)
161
167
162
168
let value_kind env ty =
163
-
match scrape env ty with
164
-
| Tconstr(p, _, _) when Path.same p Predef.path_int ->
165
-
Pintval
166
-
| Tconstr(p, _, _) when Path.same p Predef.path_char ->
167
-
Pintval
168
-
| Tconstr(p, _, _) when Path.same p Predef.path_float ->
169
-
Pfloatval
170
-
| Tconstr(p, _, _) when Path.same p Predef.path_int32 ->
171
-
Pboxedintval Pint32
172
-
| Tconstr(p, _, _) when Path.same p Predef.path_int64 ->
173
-
Pboxedintval Pint64
174
-
| Tconstr(p, _, _) when Path.same p Predef.path_nativeint ->
175
-
Pboxedintval Pnativeint
176
-
| _ ->
177
-
Pgenval
169
+
let ty = scrape_ty env ty in
170
+
if is_immediate (Ctype.immediacy env ty) then Pintval
171
+
else begin
172
+
match get_desc ty with
173
+
| Tconstr(p, _, _) when Path.same p Predef.path_float ->
174
+
Pfloatval
175
+
| Tconstr(p, _, _) when Path.same p Predef.path_int32 ->
176
+
Pboxedintval Pint32
177
+
| Tconstr(p, _, _) when Path.same p Predef.path_int64 ->
178
+
Pboxedintval Pint64
179
+
| Tconstr(p, _, _) when Path.same p Predef.path_nativeint ->
180
+
Pboxedintval Pnativeint
181
+
| _ ->
182
+
Pgenval
183
+
end
178
184
179
185
let function_return_value_kind env ty =
180
186
match is_function_type env ty with