Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Synchronize with trunk. 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/abstract_intel_emit@15147 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2014-08-29 10:37:43 +00:00
parent c6d4264a09 f5f3ae77a9
commit 9248774af5
268 changed files with 3120 additions and 1462 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

123
.gitignore vendored
View File

@ -1219,6 +1219,27 @@
/testsuite/tests/basic-manyargs/.depend.nt
/testsuite/tests/basic-manyargs/.DS_Store
# /testsuite/tests/basic-modules/
/testsuite/tests/basic-modules/*.o
/testsuite/tests/basic-modules/*.a
/testsuite/tests/basic-modules/*.so
/testsuite/tests/basic-modules/*.obj
/testsuite/tests/basic-modules/*.lib
/testsuite/tests/basic-modules/*.dll
/testsuite/tests/basic-modules/*.cm[ioxat]
/testsuite/tests/basic-modules/*.cmx[as]
/testsuite/tests/basic-modules/*.cmti
/testsuite/tests/basic-modules/*.annot
/testsuite/tests/basic-modules/*.result
/testsuite/tests/basic-modules/*.byte
/testsuite/tests/basic-modules/*.native
/testsuite/tests/basic-modules/program
/testsuite/tests/basic-modules/*.exe
/testsuite/tests/basic-modules/*.exe.manifest
/testsuite/tests/basic-modules/.depend
/testsuite/tests/basic-modules/.depend.nt
/testsuite/tests/basic-modules/.DS_Store
# /testsuite/tests/basic-more/
/testsuite/tests/basic-more/*.o
/testsuite/tests/basic-more/*.a
@ -1343,6 +1364,8 @@
/testsuite/tests/formats-transition/*.a
/testsuite/tests/formats-transition/*.so
/testsuite/tests/formats-transition/*.obj
/testsuite/tests/formats-transition/*.lib
/testsuite/tests/formats-transition/*.dll
/testsuite/tests/formats-transition/*.cm[ioxat]
/testsuite/tests/formats-transition/*.cmx[as]
/testsuite/tests/formats-transition/*.cmti
@ -1351,7 +1374,8 @@
/testsuite/tests/formats-transition/*.byte
/testsuite/tests/formats-transition/*.native
/testsuite/tests/formats-transition/program
/testsuite/tests/formats-transition/program.exe
/testsuite/tests/formats-transition/*.exe
/testsuite/tests/formats-transition/*.exe.manifest
/testsuite/tests/formats-transition/.depend
/testsuite/tests/formats-transition/.depend.nt
/testsuite/tests/formats-transition/.DS_Store
@ -1819,6 +1843,8 @@
/testsuite/tests/match-exception/*.a
/testsuite/tests/match-exception/*.so
/testsuite/tests/match-exception/*.obj
/testsuite/tests/match-exception/*.lib
/testsuite/tests/match-exception/*.dll
/testsuite/tests/match-exception/*.cm[ioxat]
/testsuite/tests/match-exception/*.cmx[as]
/testsuite/tests/match-exception/*.cmti
@ -1827,11 +1853,33 @@
/testsuite/tests/match-exception/*.byte
/testsuite/tests/match-exception/*.native
/testsuite/tests/match-exception/program
/testsuite/tests/match-exception/program.exe
/testsuite/tests/match-exception/*.exe
/testsuite/tests/match-exception/*.exe.manifest
/testsuite/tests/match-exception/.depend
/testsuite/tests/match-exception/.depend.nt
/testsuite/tests/match-exception/.DS_Store
# /testsuite/tests/match-exception-warnings/
/testsuite/tests/match-exception-warnings/*.o
/testsuite/tests/match-exception-warnings/*.a
/testsuite/tests/match-exception-warnings/*.so
/testsuite/tests/match-exception-warnings/*.obj
/testsuite/tests/match-exception-warnings/*.lib
/testsuite/tests/match-exception-warnings/*.dll
/testsuite/tests/match-exception-warnings/*.cm[ioxat]
/testsuite/tests/match-exception-warnings/*.cmx[as]
/testsuite/tests/match-exception-warnings/*.cmti
/testsuite/tests/match-exception-warnings/*.annot
/testsuite/tests/match-exception-warnings/*.result
/testsuite/tests/match-exception-warnings/*.byte
/testsuite/tests/match-exception-warnings/*.native
/testsuite/tests/match-exception-warnings/program
/testsuite/tests/match-exception-warnings/*.exe
/testsuite/tests/match-exception-warnings/*.exe.manifest
/testsuite/tests/match-exception-warnings/.depend
/testsuite/tests/match-exception-warnings/.depend.nt
/testsuite/tests/match-exception-warnings/.DS_Store
# /testsuite/tests/misc/
/testsuite/tests/misc/*.o
/testsuite/tests/misc/*.a
@ -2067,6 +2115,51 @@
/testsuite/tests/tool-debugger/.DS_Store
/testsuite/tests/tool-debugger/compiler-libs
# /testsuite/tests/tool-debugger/basic/
/testsuite/tests/tool-debugger/basic/*.o
/testsuite/tests/tool-debugger/basic/*.a
/testsuite/tests/tool-debugger/basic/*.so
/testsuite/tests/tool-debugger/basic/*.obj
/testsuite/tests/tool-debugger/basic/*.lib
/testsuite/tests/tool-debugger/basic/*.dll
/testsuite/tests/tool-debugger/basic/*.cm[ioxat]
/testsuite/tests/tool-debugger/basic/*.cmx[as]
/testsuite/tests/tool-debugger/basic/*.cmti
/testsuite/tests/tool-debugger/basic/*.annot
/testsuite/tests/tool-debugger/basic/*.result
/testsuite/tests/tool-debugger/basic/*.byte
/testsuite/tests/tool-debugger/basic/*.native
/testsuite/tests/tool-debugger/basic/program
/testsuite/tests/tool-debugger/basic/*.exe
/testsuite/tests/tool-debugger/basic/*.exe.manifest
/testsuite/tests/tool-debugger/basic/.depend
/testsuite/tests/tool-debugger/basic/.depend.nt
/testsuite/tests/tool-debugger/basic/.DS_Store
/testsuite/tests/tool-debugger/basic/compiler-libs
# /testsuite/tests/tool-debugger/find-artifacts/
/testsuite/tests/tool-debugger/find-artifacts/*.o
/testsuite/tests/tool-debugger/find-artifacts/*.a
/testsuite/tests/tool-debugger/find-artifacts/*.so
/testsuite/tests/tool-debugger/find-artifacts/*.obj
/testsuite/tests/tool-debugger/find-artifacts/*.lib
/testsuite/tests/tool-debugger/find-artifacts/*.dll
/testsuite/tests/tool-debugger/find-artifacts/*.cm[ioxat]
/testsuite/tests/tool-debugger/find-artifacts/*.cmx[as]
/testsuite/tests/tool-debugger/find-artifacts/*.cmti
/testsuite/tests/tool-debugger/find-artifacts/*.annot
/testsuite/tests/tool-debugger/find-artifacts/*.result
/testsuite/tests/tool-debugger/find-artifacts/*.byte
/testsuite/tests/tool-debugger/find-artifacts/*.native
/testsuite/tests/tool-debugger/find-artifacts/program
/testsuite/tests/tool-debugger/find-artifacts/*.exe
/testsuite/tests/tool-debugger/find-artifacts/*.exe.manifest
/testsuite/tests/tool-debugger/find-artifacts/.depend
/testsuite/tests/tool-debugger/find-artifacts/.depend.nt
/testsuite/tests/tool-debugger/find-artifacts/.DS_Store
/testsuite/tests/tool-debugger/find-artifacts/compiler-libs
/testsuite/tests/tool-debugger/find-artifacts/out
# /testsuite/tests/tool-lexyacc/
/testsuite/tests/tool-lexyacc/*.o
/testsuite/tests/tool-lexyacc/*.a
@ -2124,11 +2217,34 @@
/testsuite/tests/tool-ocamldoc/*.css
/testsuite/tests/tool-ocamldoc/ocamldoc.out
# /testsuite/tests/tool-toplevel/
/testsuite/tests/tool-toplevel/*.o
/testsuite/tests/tool-toplevel/*.a
/testsuite/tests/tool-toplevel/*.so
/testsuite/tests/tool-toplevel/*.obj
/testsuite/tests/tool-toplevel/*.lib
/testsuite/tests/tool-toplevel/*.dll
/testsuite/tests/tool-toplevel/*.cm[ioxat]
/testsuite/tests/tool-toplevel/*.cmx[as]
/testsuite/tests/tool-toplevel/*.cmti
/testsuite/tests/tool-toplevel/*.annot
/testsuite/tests/tool-toplevel/*.result
/testsuite/tests/tool-toplevel/*.byte
/testsuite/tests/tool-toplevel/*.native
/testsuite/tests/tool-toplevel/program
/testsuite/tests/tool-toplevel/*.exe
/testsuite/tests/tool-toplevel/*.exe.manifest
/testsuite/tests/tool-toplevel/.depend
/testsuite/tests/tool-toplevel/.depend.nt
/testsuite/tests/tool-toplevel/.DS_Store
# /testsuite/tests/typing-extensions/
/testsuite/tests/typing-extensions/*.o
/testsuite/tests/typing-extensions/*.a
/testsuite/tests/typing-extensions/*.so
/testsuite/tests/typing-extensions/*.obj
/testsuite/tests/typing-extensions/*.lib
/testsuite/tests/typing-extensions/*.dll
/testsuite/tests/typing-extensions/*.cm[ioxat]
/testsuite/tests/typing-extensions/*.cmx[as]
/testsuite/tests/typing-extensions/*.cmti
@ -2137,7 +2253,8 @@
/testsuite/tests/typing-extensions/*.byte
/testsuite/tests/typing-extensions/*.native
/testsuite/tests/typing-extensions/program
/testsuite/tests/typing-extensions/program.exe
/testsuite/tests/typing-extensions/*.exe
/testsuite/tests/typing-extensions/*.exe.manifest
/testsuite/tests/typing-extensions/.depend
/testsuite/tests/typing-extensions/.depend.nt
/testsuite/tests/typing-extensions/.DS_Store

47
Changes
View File

@ -1,10 +1,14 @@
Next version:
OCaml 4.03.0:
-------------
Compilers:
- PR#6501: harden the native-code generator against certain uses of "%identity"
(Xavier Leroy, report by Antoine Miné).
Runtime system:
- PR#6517: use ISO C99 types {,u}int{32,64}_t in preference to our homegrown
types {,u}int{32,64}.
Ocaml 4.02.0:
-------------
@ -31,6 +35,7 @@ Language features:
Build system for the OCaml distribution:
- Use -bin-annot when building.
- Use GNU make instead of portable makefiles.
- Updated build instructions for 32-bit Mac OS X on Intel hardware.
Shedding weight:
* Removed Camlp4 from the distribution, now available as third-party software.
@ -100,6 +105,8 @@ Compilers:
(Vladimir Brankov)
- PR#6017: a new format implementation based on GADTs
(Benoît Vaugon and Gabriel Scherer)
- PR#6389: ocamlopt -opaque option for incremental native compilation
(Pierre Chambart, Gabriel Scherer)
Toplevel interactive system:
- PR#5377: New "#show_*" directives
@ -136,6 +143,8 @@ Runtime system:
Standard library:
* Add new modules: Bytes and BytesLabels.
(Damien Doligez)
- PR#6355: Improve documentation regarding finalisers and multithreading
(Daniel Bünzli, Mark Shinwell)
- PR#4986: add List.sort_uniq and Set.of_list
(Alain Frisch)
- PR#5935: a faster version of "raise" which does not maintain the backtrace
@ -146,11 +155,15 @@ Standard library:
(John Whitington)
- PR#6180: efficient creation of uninitialized float arrays
(Alain Frisch, request by Markus Mottl)
- Trigger warning 3 for all values marked as deprected in the documentation.
(Damien Doligez)
OCamldoc:
- PR#6257: handle full doc comments for variant constructors and
record fields
(Maxence Guesdon, request by ygrek)
- PR#6274: allow doc comments on object types
(Thomas Refis)
- PR#6310: fix ocamldoc's subscript/superscript CSS font size
(Anil Madhavapeddy)
- PR#6425: fix generation of man pages
@ -161,16 +174,28 @@ Bug fixes:
[caml_bottom_of_stack]. (Richard Jones, Mark Shinwell)
- PR#2719: wrong scheduling of bound checks within a
try...with Invalid_argument -> _ ... (Xavier Leroy)
- PR#4771: Clarify documentation of Dynlink.allow_only
(Damien Doligez, report by David Allsopp)
- PR#6232: Don't use [mktemp] on platforms where [mkstemp] is available
(Stéphane Glondu, Mark Shinwell)
- PR#6439: Don't use the deprecated [getpagesize] function
(John Whitington, Mark Shinwell)
- PR#4719: Sys.executable_name wrong if executable name contains dots (Windows)
(Alain Frisch, report by Bart Jacobs)
- PR#4855: 'camlp4 -I +dir' accepted, dir is relative to 'camlp4 -where'
(Jun Furuse and Hongbo Zhang, report by Dmitry Grebeniuk)
- PR#5201: ocamlbuild: add --norc to the bash invocation to help performances
(user 'daweil')
- PR#5406 ocamlbuild: "tag 'package' does not expect a parameter"
(Gabriel Scherer)
- PR#5598: follow-up fix related to PR#6165
(Damien Doligez)
- PR#5820: Fix camlp4 lexer roll back problem
(Hongbo Zhang)
- PR#5851: warn when -r is disabled because no _tags file is present
(Gabriel Scherer)
- PR#5946: CAMLprim taking (void) as argument
(Benoît Vaugon)
- PR#6038: on x86-32, enforce 16-byte stack alignment for compatibility
with recent GCC and Clang. Win32/MSVC keeps 4-byte stack alignment.
(Xavier Leroy)
@ -227,10 +252,14 @@ Bug fixes:
(Jacques Garrigue, report by Leo White)
- PR#6293: Assert_failure with invalid package type
(Jacques Garrigue, report by Elnatan Reisner)
- PR#6300: ocamlbuild -use-ocamlfind conflicts with -ocamlc
(Gabriel Scherer)
- PR#6302: bytecode debug information re-read from filesystem every time
(Jacques-Henri Jourdan)
- PR#6307: Behavior of 'module type of' w.r.t. module aliases
(Jacques Garrigue, report by Alain Frisch)
- PR#6332: Unix.open_process fails to pass empty arguments under Windows
(Damien Doligez, report Virgile Prevosto)
- PR#6346: Build failure with latest version of xcode on OSX
(Jérémie Dimino)
- PR#6348: Unification failure for GADT when original definition is hidden
@ -249,21 +278,33 @@ Bug fixes:
(Alain Frisch and Jacques Garrigue)
- PR#6405: unsound interaction of -rectypes and GADTs
(Jacques Garrigue, report by Gabriel Scherer and Benoît Vaugon)
- PR#6408: Optional arguments given as ~?arg instead of ?arg in message
(Michael O'Connor)
- PR#6418: reimplement parametrized Format tags/indentation with GADTs
(Benoît Vaugon)
- PR#6436: Typos in @deprecated text in stdlib/arrayLabels.mli
(John Whitington)
- PR#6443: ocaml segfault when List.fold_left is traced then executed
(Jacques Garrigue, report by Reventlov)
- PR#6460: runtime assertion failure with large [| e1;...eN |]
float array expressions
(Leo White)
- PR#6482: ocamlbuild fails when _tags file in unhygienic directory
(Gabriel Scherer)
- PR#6505: Missed Type-error leads to a segfault upon record access
(Jacques Garrigue, report by Christoph Höger)
- PR#6509: add -linkall flag to ocamlcommon.cma
(Frédéric Bour)
- PR#6513: Fatal error Ctype.Unify(_) in functor type
(Jacques Garrigue, report by Dario Teixeira)
- fix -dsource printing of "external _pipe = ..."
(Gabriel Scherer)
- bound-checking bug in caml_string_{get,set}{16,32,64}
(Pierre Chambart and Gabriel Scherer, report by Nicolas Trangez)
- sometimes wrong stack alignment at out-of-bounds array access
(Gabriel Scherer and Xavier Leroy, report by Pierre Chambart)
- make ocamldebug -I auto-detection work with ocamlbuild
(Josh Watzman)
Features wishes:
- PR#4243: make the Makefiles parallelizable
@ -285,6 +326,8 @@ Features wishes:
(Jeremy Yallop, review by Gabriel Scherer)
- PR#6071: Add a -noinit option to the toplevel
(David Sheets)
- PR#6087: ocamlbuild, improve _tags parsing of escaped newlines
(Gabriel Scherer, request by Daniel Bünzli)
- PR#6166: document -ocamldoc option of ocamlbuild
(Xavier Clerc)
- PR#6187: ocamlbuild: warn when using -plugin-tag(s) without myocamlbuild.ml
@ -297,6 +340,8 @@ Features wishes:
(Gabriel Scherer, request by François Berenger)
- PR#6406: Expose OCaml version in C headers
(Peter Zotov and Romain Calascibetta)
- PR#5899: a programmer-friendly access to backtrace information
(Jacques-Henri Jourdan and Gabriel Scherer)
- ocamllex: user-definable refill action
(Frédéric Bour, review by Gabriel Scherer and Luc Maranget)
- shorten syntax for functor signatures: "functor (M1:S1) (M2:S2) .. -> .."

6
README.win32
View File

@ -260,6 +260,12 @@ NOTES:
* The replay debugger is partially supported (no reverse execution).
* The default Makefile.mingw passes -static-libgcc to the linker.
For more information on this topic:
http://gcc.gnu.org/onlinedocs/gcc-4.9.1/gcc/Link-Options.html#Link-Options
http://caml.inria.fr/mantis/view.php?id=6411
------------------------------------------------------------------------------
The Cygwin port of OCaml

2
VERSION
View File

@ -1,4 +1,4 @@
4.03.0+dev1-2014-07-21
4.03.0+dev2-2014-08-22
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli

3
asmcomp/CSEgen.mli
View File

@ -33,6 +33,3 @@ class cse_generic : object
method fundecl: Mach.fundecl -> Mach.fundecl
end

1
asmcomp/amd64/CSE.ml
View File

@ -36,4 +36,3 @@ end
let fundecl f =
(new cse)#fundecl f

3
asmcomp/amd64/arch.ml
View File

@ -33,7 +33,8 @@ type addressing_mode =
type specific_operation =
Ilea of addressing_mode (* "lea" gives scaled adds *)
| Istore_int of nativeint * addressing_mode * bool (* Store an integer constant *)
| Istore_int of nativeint * addressing_mode * bool
(* Store an integer constant *)
| Istore_symbol of string * addressing_mode * bool (* Store a symbol *)
| Ioffset_loc of int * addressing_mode (* Add a constant to a location *)
| Ifloatarithmem of float_operation * addressing_mode

8
asmcomp/amd64/proc.ml
View File

@ -118,12 +118,12 @@ let rotate_registers = false
(* Representation of hard registers by pseudo-registers *)
let hard_int_reg =
let v = Array.create 13 Reg.dummy in
let v = Array.make 13 Reg.dummy in
for i = 0 to 12 do v.(i) <- Reg.at_location Int (Reg i) done;
v
let hard_float_reg =
let v = Array.create 16 Reg.dummy in
let v = Array.make 16 Reg.dummy in
for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg (100 + i)) done;
v
@ -150,7 +150,7 @@ let word_addressed = false
let calling_conventions first_int last_int first_float last_float make_stack
arg =
let loc = Array.create (Array.length arg) Reg.dummy in
let loc = Array.make (Array.length arg) Reg.dummy in
let int = ref first_int in
let float = ref first_float in
let ofs = ref 0 in
@ -211,7 +211,7 @@ let win64_float_external_arguments =
[| 100 (*xmm0*); 101 (*xmm1*); 102 (*xmm2*); 103 (*xmm3*) |]
let win64_loc_external_arguments arg =
let loc = Array.create (Array.length arg) Reg.dummy in
let loc = Array.make (Array.length arg) Reg.dummy in
let reg = ref 0
and ofs = ref 32 in
for i = 0 to Array.length arg - 1 do

1
asmcomp/arm/CSE.ml
View File

@ -35,4 +35,3 @@ end
let fundecl f =
(new cse)#fundecl f

2
asmcomp/arm/arch.ml
View File

@ -21,7 +21,7 @@ type fpu = Soft | VFPv2 | VFPv3_D16 | VFPv3
let abi =
match Config.system with
"linux_eabi" -> EABI
"linux_eabi" | "freebsd" -> EABI
| "linux_eabihf" -> EABI_HF
| _ -> assert false

6
asmcomp/arm/proc.ml
View File

@ -82,14 +82,14 @@ let rotate_registers = true
(* Representation of hard registers by pseudo-registers *)
let hard_int_reg =
let v = Array.create 9 Reg.dummy in
let v = Array.make 9 Reg.dummy in
for i = 0 to 8 do
v.(i) <- Reg.at_location Int (Reg i)
done;
v
let hard_float_reg =
let v = Array.create 32 Reg.dummy in
let v = Array.make 32 Reg.dummy in
for i = 0 to 31 do
v.(i) <- Reg.at_location Float (Reg(100 + i))
done;
@ -108,7 +108,7 @@ let stack_slot slot ty =
let calling_conventions
first_int last_int first_float last_float make_stack arg =
let loc = Array.create (Array.length arg) Reg.dummy in
let loc = Array.make (Array.length arg) Reg.dummy in
let int = ref first_int in
let float = ref first_float in
let ofs = ref 0 in

1
asmcomp/arm64/CSE.ml
View File

@ -35,4 +35,3 @@ end
let fundecl f =
(new cse)#fundecl f

6
asmcomp/arm64/proc.ml
View File

@ -76,14 +76,14 @@ let rotate_registers = true
(* Representation of hard registers by pseudo-registers *)
let hard_int_reg =
let v = Array.create 28 Reg.dummy in
let v = Array.make 28 Reg.dummy in
for i = 0 to 27 do
v.(i) <- Reg.at_location Int (Reg i)
done;
v
let hard_float_reg =
let v = Array.create 32 Reg.dummy in
let v = Array.make 32 Reg.dummy in
for i = 0 to 31 do
v.(i) <- Reg.at_location Float (Reg(100 + i))
done;
@ -105,7 +105,7 @@ let stack_slot slot ty =
let calling_conventions
first_int last_int first_float last_float make_stack arg =
let loc = Array.create (Array.length arg) Reg.dummy in
let loc = Array.make (Array.length arg) Reg.dummy in
let int = ref first_int in
let float = ref first_float in
let ofs = ref 0 in

3
asmcomp/asmlink.ml
View File

@ -412,6 +412,3 @@ let reset () =
cmx_required := [];
interfaces := [];
implementations := []

6
asmcomp/closure.ml
View File

@ -1177,7 +1177,7 @@ and close_one_function fenv cenv id funct =
and close_switch arg fenv cenv cases num_keys default =
let ncases = List.length cases in
let index = Array.create num_keys 0
let index = Array.make num_keys 0
and store = Storer.mk_store () in
(* First default case *)
@ -1291,6 +1291,8 @@ let intro size lam =
global_approx := Array.init size (fun i -> Value_global_field (id, i));
Compilenv.set_global_approx(Value_tuple !global_approx);
let (ulam, approx) = close Tbl.empty Tbl.empty lam in
collect_exported_structured_constants (Value_tuple !global_approx);
if !Clflags.opaque
then Compilenv.set_global_approx(Value_unknown)
else collect_exported_structured_constants (Value_tuple !global_approx);
global_approx := [||];
ulam

5
asmcomp/cmmgen.ml
View File

@ -38,7 +38,8 @@ let bind_nonvar name arg fn =
| Cconst_blockheader _ -> fn arg
| _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8 (* cf. byterun/gc.h *)
let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8
(* cf. byterun/gc.h *)
(* Block headers. Meaning of the tag field: see stdlib/obj.ml *)
@ -2409,7 +2410,7 @@ let cache_public_method meths tag cache =
*)
let apply_function_body arity =
let arg = Array.create arity (Ident.create "arg") in
let arg = Array.make arity (Ident.create "arg") in
for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done;
let clos = Ident.create "clos" in
let rec app_fun clos n =

8
asmcomp/coloring.ml
View File

@ -47,7 +47,7 @@ let allocate_registers() =
if reg.spill then begin
(* Preallocate the registers in the stack *)
let nslots = Proc.num_stack_slots.(cl) in
let conflict = Array.create nslots false in
let conflict = Array.make nslots false in
List.iter
(fun r ->
match r.loc with
@ -84,14 +84,14 @@ let allocate_registers() =
(* Where to start the search for a suitable register.
Used to introduce some "randomness" in the choice between registers
with equal scores. This offers more opportunities for scheduling. *)
let start_register = Array.create Proc.num_register_classes 0 in
let start_register = Array.make Proc.num_register_classes 0 in
(* Assign a location to a register, the best we can. *)
let assign_location reg =
let cl = Proc.register_class reg in
let first_reg = Proc.first_available_register.(cl) in
let num_regs = Proc.num_available_registers.(cl) in
let score = Array.create num_regs 0 in
let score = Array.make num_regs 0 in
let best_score = ref (-1000000) and best_reg = ref (-1) in
let start = start_register.(cl) in
if num_regs <> 0 then begin
@ -161,7 +161,7 @@ let allocate_registers() =
end else begin
(* Sorry, we must put the pseudoreg in a stack location *)
let nslots = Proc.num_stack_slots.(cl) in
let score = Array.create nslots 0 in
let score = Array.make nslots 0 in
(* Compute the scores as for registers *)
List.iter
(fun (r, w) ->

1
asmcomp/i386/CSE.ml
View File

@ -45,4 +45,3 @@ end
let fundecl f =
(new cse)#fundecl f

3
asmcomp/i386/arch.ml
View File

@ -31,7 +31,8 @@ type addressing_mode =
type specific_operation =
Ilea of addressing_mode (* Lea gives scaled adds *)
| Istore_int of nativeint * addressing_mode * bool (* Store an integer constant *)
| Istore_int of nativeint * addressing_mode * bool
(* Store an integer constant *)
| Istore_symbol of string * addressing_mode * bool (* Store a symbol *)
| Ioffset_loc of int * addressing_mode (* Add a constant to a location *)
| Ipush (* Push regs on stack *)

4
asmcomp/i386/proc.ml
View File

@ -73,7 +73,7 @@ let rotate_registers = false
(* Representation of hard registers by pseudo-registers *)
let hard_int_reg =
let v = Array.create 7 Reg.dummy in
let v = Array.make 7 Reg.dummy in
for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done;
v
@ -112,7 +112,7 @@ let word_addressed = false
let calling_conventions first_int last_int first_float last_float make_stack
arg =
let loc = Array.create (Array.length arg) Reg.dummy in
let loc = Array.make (Array.length arg) Reg.dummy in
let int = ref first_int in
let float = ref first_float in
let ofs = ref (-64) in

2
asmcomp/linearize.ml
View File

@ -224,7 +224,7 @@ let rec linear i n =
(linear ifso (add_branch lbl_end nelse))
end
| Iswitch(index, cases) ->
let lbl_cases = Array.create (Array.length cases) 0 in
let lbl_cases = Array.make (Array.length cases) 0 in
let (lbl_end, n1) = get_label(linear i.Mach.next n) in
let n2 = ref (discard_dead_code n1) in
for i = Array.length cases - 1 downto 0 do

1
asmcomp/power/CSE.ml
View File

@ -35,4 +35,3 @@ end
let fundecl f =
(new cse)#fundecl f

8
asmcomp/power/proc.ml
View File

@ -83,11 +83,11 @@ let rotate_registers = true
(* Representation of hard registers by pseudo-registers *)
let hard_int_reg =
let v = Array.create 23 Reg.dummy in
let v = Array.make 23 Reg.dummy in
for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; v
let hard_float_reg =
let v = Array.create 31 Reg.dummy in
let v = Array.make 31 Reg.dummy in
for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v
let all_phys_regs =
@ -103,7 +103,7 @@ let stack_slot slot ty =
let calling_conventions
first_int last_int first_float last_float make_stack stack_ofs arg =
let loc = Array.create (Array.length arg) Reg.dummy in
let loc = Array.make (Array.length arg) Reg.dummy in
let int = ref first_int in
let float = ref first_float in
let ofs = ref stack_ofs in
@ -157,7 +157,7 @@ let loc_results res =
let poweropen_external_conventions first_int last_int
first_float last_float arg =
let loc = Array.create (Array.length arg) Reg.dummy in
let loc = Array.make (Array.length arg) Reg.dummy in
let int = ref first_int in
let float = ref first_float in
let ofs = ref (14 * size_addr) in

4
asmcomp/reg.ml
View File

@ -73,13 +73,13 @@ let create ty =
let createv tyv =
let n = Array.length tyv in
let rv = Array.create n dummy in
let rv = Array.make n dummy in
for i = 0 to n-1 do rv.(i) <- create tyv.(i) done;
rv
let createv_like rv =
let n = Array.length rv in
let rv' = Array.create n dummy in
let rv' = Array.make n dummy in
for i = 0 to n-1 do rv'.(i) <- create rv.(i).typ done;
rv'

2
asmcomp/reloadgen.ml
View File

@ -54,7 +54,7 @@ method makereg r =
method private makeregs rv =
let n = Array.length rv in
let newv = Array.create n Reg.dummy in
let newv = Array.make n Reg.dummy in
for i = 0 to n-1 do newv.(i) <- self#makereg rv.(i) done;
newv

4
asmcomp/selectgen.ml
View File

@ -111,7 +111,7 @@ let join opt_r1 seq1 opt_r2 seq2 =
| (Some r1, Some r2) ->
let l1 = Array.length r1 in
assert (l1 = Array.length r2);
let r = Array.create l1 Reg.dummy in
let r = Array.make l1 Reg.dummy in
for i = 0 to l1-1 do
if Reg.anonymous r1.(i) then begin
r.(i) <- r1.(i);
@ -139,7 +139,7 @@ let join_array rs =
None -> None
| Some template ->
let size_res = Array.length template in
let res = Array.create size_res Reg.dummy in
let res = Array.make size_res Reg.dummy in
for i = 0 to size_res - 1 do
res.(i) <- Reg.create template.(i).typ
done;

1
asmcomp/sparc/CSE.ml
View File

@ -28,4 +28,3 @@ end
let fundecl f =
(new cse)#fundecl f

6
asmcomp/sparc/proc.ml
View File

@ -81,12 +81,12 @@ let rotate_registers = true
(* Representation of hard registers by pseudo-registers *)
let hard_int_reg =
let v = Array.create 19 Reg.dummy in
let v = Array.make 19 Reg.dummy in
for i = 0 to 18 do v.(i) <- Reg.at_location Int (Reg i) done;
v
let hard_float_reg =
let v = Array.create 32 Reg.dummy in
let v = Array.make 32 Reg.dummy in
for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done;
v
@ -105,7 +105,7 @@ let stack_slot slot ty =
let calling_conventions first_int last_int first_float last_float make_stack
arg =
let loc = Array.create (Array.length arg) Reg.dummy in
let loc = Array.make (Array.length arg) Reg.dummy in
let int = ref first_int in
let float = ref first_float in
let ofs = ref 0 in

2
asmcomp/spill.ml
View File

@ -64,7 +64,7 @@ let add_superpressure_regs op live_regs res_regs spilled =
let max_pressure = Proc.max_register_pressure op in
let regs = Reg.add_set_array live_regs res_regs in
(* Compute the pressure in each register class *)
let pressure = Array.create Proc.num_register_classes 0 in
let pressure = Array.make Proc.num_register_classes 0 in
Reg.Set.iter
(fun r ->
if Reg.Set.mem r spilled then () else begin

2
asmcomp/split.ml
View File

@ -30,7 +30,7 @@ let subst_regs rv sub =
None -> rv
| Some s ->
let n = Array.length rv in
let nv = Array.create n Reg.dummy in
let nv = Array.make n Reg.dummy in
for i = 0 to n-1 do nv.(i) <- subst_reg rv.(i) s done;
nv

21
asmrun/.depend
View File

@ -98,7 +98,7 @@ hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \
../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \
../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \
../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h
../byterun/minor_gc.h ../byterun/hash.h
intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \
../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \
@ -111,7 +111,7 @@ ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \
../byterun/io.h ../byterun/memory.h ../byterun/gc.h \
../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h
../byterun/misc.h ../byterun/mlvalues.h
io.o: io.c ../byterun/config.h ../byterun/../config/m.h \
../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \
../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \
@ -227,8 +227,7 @@ startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \
../byterun/printexc.h stack.h ../byterun/sys.h
str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \
../byterun/int64_native.h
../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h
sys.o: sys.c ../byterun/config.h ../byterun/../config/m.h \
../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \
../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \
@ -350,7 +349,7 @@ hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \
../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \
../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \
../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h
../byterun/minor_gc.h ../byterun/hash.h
intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \
../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \
@ -363,7 +362,7 @@ ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \
../byterun/io.h ../byterun/memory.h ../byterun/gc.h \
../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h
../byterun/misc.h ../byterun/mlvalues.h
io.d.o: io.c ../byterun/config.h ../byterun/../config/m.h \
../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \
../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \
@ -479,8 +478,7 @@ startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \
../byterun/printexc.h stack.h ../byterun/sys.h
str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \
../byterun/int64_native.h
../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h
sys.d.o: sys.c ../byterun/config.h ../byterun/../config/m.h \
../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \
../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \
@ -602,7 +600,7 @@ hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \
../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \
../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \
../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h
../byterun/minor_gc.h ../byterun/hash.h
intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \
../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \
@ -615,7 +613,7 @@ ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \
../byterun/io.h ../byterun/memory.h ../byterun/gc.h \
../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h
../byterun/misc.h ../byterun/mlvalues.h
io.p.o: io.c ../byterun/config.h ../byterun/../config/m.h \
../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \
../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \
@ -731,8 +729,7 @@ startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \
../byterun/printexc.h stack.h ../byterun/sys.h
str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \
../byterun/int64_native.h
../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h
sys.p.o: sys.c ../byterun/config.h ../byterun/../config/m.h \
../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \
../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \

9
asmrun/arm.S
View File

@ -44,6 +44,15 @@
cmp \reg, #0
beq \lbl
.endm
#elif defined(SYS_freebsd)
.arch armv6
.arm
/* Compatibility macros */
.macro cbz reg, lbl
cmp \reg, #0
beq \lbl
.endm
#endif
trap_ptr .req r8

6
asmrun/backtrace.c
View File

@ -217,7 +217,7 @@ static void extract_location_info(frame_descr * d,
/*out*/ struct loc_info * li)
{
uintnat infoptr;
uint32 info1, info2;
uint32_t info1, info2;
/* If no debugging information available, print nothing.
When everything is compiled with -g, this corresponds to
@ -232,8 +232,8 @@ static void extract_location_info(frame_descr * d,
sizeof(char *) + sizeof(short) + sizeof(short) +
sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
& -sizeof(frame_descr *);
info1 = ((uint32 *)infoptr)[0];
info2 = ((uint32 *)infoptr)[1];
info1 = ((uint32_t *)infoptr)[0];
info2 = ((uint32_t *)infoptr)[1];
/* Format of the two info words:
llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk
44 36 26 2 0

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamldep
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

10
bytecomp/bytegen.ml
View File

@ -717,8 +717,8 @@ let rec comp_expr env exp sz cont =
(* Build indirection vectors *)
let store = Storer.mk_store () in
let act_consts = Array.create sw.sw_numconsts 0
and act_blocks = Array.create sw.sw_numblocks 0 in
let act_consts = Array.make sw.sw_numconsts 0
and act_blocks = Array.make sw.sw_numblocks 0 in
begin match sw.sw_failaction with (* default is index 0 *)
| Some fail -> ignore (store.act_store fail)
| None -> ()
@ -740,7 +740,7 @@ let rec comp_expr env exp sz cont =
| _ -> ())
a ;
*)
let lbls = Array.create (Array.length acts) 0 in
let lbls = Array.make (Array.length acts) 0 in
for i = Array.length acts-1 downto 0 do
let lbl,c1 = label_code (comp_expr env acts.(i) sz (branch :: !c)) in
lbls.(i) <- lbl ;
@ -748,11 +748,11 @@ let rec comp_expr env exp sz cont =
done ;
(* Build label vectors *)
let lbl_blocks = Array.create sw.sw_numblocks 0 in
let lbl_blocks = Array.make sw.sw_numblocks 0 in
for i = sw.sw_numblocks - 1 downto 0 do
lbl_blocks.(i) <- lbls.(act_blocks.(i))
done;
let lbl_consts = Array.create sw.sw_numconsts 0 in
let lbl_consts = Array.make sw.sw_numconsts 0 in
for i = sw.sw_numconsts - 1 downto 0 do
lbl_consts.(i) <- lbls.(act_consts.(i))
done;

9
bytecomp/emitcode.ml
View File

@ -82,7 +82,7 @@ let label_table = ref ([| |] : label_definition array)
let extend_label_table needed =
let new_size = ref(Array.length !label_table) in
while needed >= !new_size do new_size := 2 * !new_size done;
let new_table = Array.create !new_size (Label_undefined []) in
let new_table = Array.make !new_size (Label_undefined []) in
Array.blit !label_table 0 new_table 0 (Array.length !label_table);
label_table := new_table
@ -150,7 +150,7 @@ let record_event ev =
let init () =
out_position := 0;
label_table := Array.create 16 (Label_undefined []);
label_table := Array.make 16 (Label_undefined []);
reloc_info := [];
debug_dirs := StringSet.empty;
events := []
@ -360,7 +360,7 @@ let rec emit = function
(* Emission to a file *)
let to_file outchan unit_name code =
let to_file outchan unit_name objfile code =
init();
output_string outchan cmo_magic_number;
let pos_depl = pos_out outchan in
@ -370,6 +370,9 @@ let to_file outchan unit_name code =
LongString.output outchan !out_buffer 0 !out_position;
let (pos_debug, size_debug) =
if !Clflags.debug then begin
debug_dirs := StringSet.add
(Filename.dirname (Location.absolute_path objfile))
!debug_dirs;
let p = pos_out outchan in
output_value outchan !events;
output_value outchan (StringSet.elements !debug_dirs);

3
bytecomp/emitcode.mli
View File

@ -15,10 +15,11 @@
open Cmo_format
open Instruct
val to_file: out_channel -> string -> instruction list -> unit
val to_file: out_channel -> string -> string -> instruction list -> unit
(* Arguments:
channel on output file
name of compilation unit implemented
path of cmo file being written
list of instructions to emit *)
val to_memory: instruction list -> instruction list ->
bytes * int * (reloc_info * int) list

1
bytecomp/lambda.ml
View File

@ -548,4 +548,3 @@ let lam_of_loc kind loc =
let reset () =
raise_count := 0

7
bytecomp/lambda.mli
View File

@ -247,9 +247,10 @@ val negate_comparison : comparison -> comparison
(* Get a new static failure ident *)
val next_raise_count : unit -> int
val next_negative_raise_count : unit -> int
(* Negative raise counts are used to compile 'match ... with exception x -> ...'.
This disabled some simplifications performed by the Simplif module that assume
that static raises are in tail position in their handler. *)
(* Negative raise counts are used to compile 'match ... with
exception x -> ...'. This disabled some simplifications
performed by the Simplif module that assume that static raises
are in tail position in their handler. *)
val staticfail : lambda (* Anticipated static failure *)

4
bytecomp/matching.ml
View File

@ -1604,7 +1604,7 @@ let divide_tuple arity p ctx pm =
let record_matching_line num_fields lbl_pat_list =
let patv = Array.create num_fields omega in
let patv = Array.make num_fields omega in
List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
Array.to_list patv
@ -1892,7 +1892,7 @@ let rec explode_inter offset i j act k =
k
let max_vals cases acts =
let vals = Array.create (Array.length acts) 0 in
let vals = Array.make (Array.length acts) 0 in
for i=Array.length cases-1 downto 0 do
let l,h,act = cases.(i) in
vals.(act) <- h - l + 1 + vals.(act)

18
bytecomp/switch.ml
View File

@ -248,7 +248,7 @@ let case_append c1 c2 =
let l1,h1,act1 = c1.(Array.length c1-1)
and l2,h2,act2 = c2.(0) in
if act1 = act2 then
let r = Array.create (len1+len2-1) c1.(0) in
let r = Array.make (len1+len2-1) c1.(0) in
for i = 0 to len1-2 do
r.(i) <- c1.(i)
done ;
@ -277,7 +277,7 @@ let case_append c1 c2 =
done ;
r
else if h1 > l1 then
let r = Array.create (len1+len2) c1.(0) in
let r = Array.make (len1+len2) c1.(0) in
for i = 0 to len1-2 do
r.(i) <- c1.(i)
done ;
@ -287,7 +287,7 @@ let case_append c1 c2 =
done ;
r
else if h2 > l2 then
let r = Array.create (len1+len2) c1.(0) in
let r = Array.make (len1+len2) c1.(0) in
for i = 0 to len1-1 do
r.(i) <- c1.(i)
done ;
@ -728,8 +728,8 @@ let dense {cases=cases ; actions=actions} i j =
let comp_clusters ({cases=cases ; actions=actions} as s) =
let len = Array.length cases in
let min_clusters = Array.create len max_int
and k = Array.create len 0 in
let min_clusters = Array.make len max_int
and k = Array.make len 0 in
let get_min i = if i < 0 then 0 else min_clusters.(i) in
for i = 0 to len-1 do
@ -749,7 +749,7 @@ let comp_clusters ({cases=cases ; actions=actions} as s) =
let make_switch {cases=cases ; actions=actions} i j =
let ll,_,_ = cases.(i)
and _,hh,_ = cases.(j) in
let tbl = Array.create (hh-ll+1) 0
let tbl = Array.make (hh-ll+1) 0
and t = Hashtbl.create 17
and index = ref 0 in
let get_index act =
@ -769,7 +769,7 @@ let make_switch {cases=cases ; actions=actions} i j =
tbl.(kk) <- index
done
done ;
let acts = Array.create !index actions.(0) in
let acts = Array.make !index actions.(0) in
Hashtbl.iter
(fun act i -> acts.(i) <- actions.(act))
t ;
@ -784,7 +784,7 @@ let make_switch {cases=cases ; actions=actions} i j =
let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k =
let len = Array.length cases in
let r = Array.create n_clusters (0,0,0)
let r = Array.make n_clusters (0,0,0)
and t = Hashtbl.create 17
and index = ref 0
and bidon = ref (Array.length actions) in
@ -820,7 +820,7 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k =
if i > 0 then zyva (i-1) (ir-1) in
zyva (len-1) (n_clusters-1) ;
let acts = Array.create !index (fun _ -> assert false) in
let acts = Array.make !index (fun _ -> assert false) in
Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ;
{cases = r ; actions = acts}
;;

7
bytecomp/symtable.ml
View File

@ -96,7 +96,7 @@ let require_primitive name =
if name.[0] <> '%' then ignore(num_of_prim name)
let all_primitives () =
let prim = Array.create !c_prim_table.num_cnt "" in
let prim = Array.make !c_prim_table.num_cnt "" in
Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl;
prim
@ -226,7 +226,7 @@ let rec transl_const = function
(* Build the initial table of globals *)
let initial_global_table () =
let glob = Array.create !global_table.num_cnt (Obj.repr 0) in
let glob = Array.make !global_table.num_cnt (Obj.repr 0) in
List.iter
(fun (slot, cst) -> glob.(slot) <- transl_const cst)
!literal_table;
@ -300,7 +300,8 @@ let init_toplevel () =
Dll.init_toplevel dllpath;
(* Recover CRC infos for interfaces *)
let crcintfs =
try (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list)
try
(Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list)
with Not_found -> [] in
(* Done *)
sect.close_reader();

2
bytecomp/translclass.ml
View File

@ -145,7 +145,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
| Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) ->
(inh_init, lsequence (set_inst_var obj id exp) obj_init,
has_init)
| Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _ ->
| Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _->
(inh_init, obj_init, has_init)
| Tcf_initializer _ ->
(inh_init, obj_init, true)

2
bytecomp/translcore.ml
View File

@ -1078,7 +1078,7 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
then begin
(* Allocate new record with given fields (and remaining fields
taken from init_expr if any *)
let lv = Array.create (Array.length all_labels) staticfail in
let lv = Array.make (Array.length all_labels) staticfail in
let init_id = Ident.create "init" in
begin match opt_init_expr with
None -> ()

15
bytecomp/translmod.ml
View File

@ -145,6 +145,19 @@ let rec compose_coercions c1 c2 =
| (_, _) ->
fatal_error "Translmod.compose_coercions"
(*
let apply_coercion a b c =
Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b;
apply_coercion a b c
let compose_coercions c1 c2 =
let c3 = compose_coercions c1 c2 in
let open Includemod in
Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@."
print_coercion c1 print_coercion c2 print_coercion c2;
c3
*)
(* Record the primitive declarations occuring in the module compiled *)
let primitive_declarations = ref ([] : Primitive.description list)
@ -225,7 +238,7 @@ let reorder_rec_bindings bindings =
and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in
let fv = Array.map Lambda.free_variables rhs in
let num_bindings = Array.length id in
let status = Array.create num_bindings Undefined in
let status = Array.make num_bindings Undefined in
let res = ref [] in
let rec emit_binding i =
match status.(i) with

24
byterun/.depend
View File

@ -7,7 +7,7 @@ array.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \
backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h \
compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \
exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
startup.h stacks.h sys.h backtrace.h
startup.h stacks.h sys.h backtrace.h fail.h
callback.o: callback.c callback.h compatibility.h mlvalues.h config.h \
../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \
freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h
@ -55,7 +55,7 @@ globroots.o: globroots.c memory.h compatibility.h config.h ../config/m.h \
roots.h globroots.h
hash.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \
../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \
minor_gc.h hash.h int64_native.h
minor_gc.h hash.h
instrtrace.o: instrtrace.c
intern.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \
@ -66,7 +66,7 @@ interp.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \
memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h
ints.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \
major_gc.h freelist.h minor_gc.h int64_native.h
major_gc.h freelist.h minor_gc.h
io.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \
freelist.h minor_gc.h signals.h sys.h
@ -123,7 +123,7 @@ startup.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \
prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \
version.h
str.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h fail.h int64_native.h
../config/s.h mlvalues.h fail.h
sys.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \
stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h
@ -147,7 +147,7 @@ array.d.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \
backtrace.d.o: backtrace.c config.h ../config/m.h ../config/s.h \
compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \
exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
startup.h stacks.h sys.h backtrace.h
startup.h stacks.h sys.h backtrace.h fail.h
callback.d.o: callback.c callback.h compatibility.h mlvalues.h config.h \
../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \
freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h
@ -195,7 +195,7 @@ globroots.d.o: globroots.c memory.h compatibility.h config.h ../config/m.h \
roots.h globroots.h
hash.d.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \
../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \
minor_gc.h hash.h int64_native.h
minor_gc.h hash.h
instrtrace.d.o: instrtrace.c instruct.h misc.h compatibility.h config.h \
../config/m.h ../config/s.h mlvalues.h opnames.h prims.h stacks.h \
memory.h gc.h major_gc.h freelist.h minor_gc.h
@ -208,7 +208,7 @@ interp.d.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \
memory.h gc.h minor_gc.h prims.h signals.h stacks.h
ints.d.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \
major_gc.h freelist.h minor_gc.h int64_native.h
major_gc.h freelist.h minor_gc.h
io.d.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \
freelist.h minor_gc.h signals.h sys.h
@ -265,7 +265,7 @@ startup.d.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \
prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \
version.h
str.d.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h fail.h int64_native.h
../config/s.h mlvalues.h fail.h
sys.d.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \
stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h
@ -289,7 +289,7 @@ array.pic.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \
backtrace.pic.o: backtrace.c config.h ../config/m.h ../config/s.h \
compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \
exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
startup.h stacks.h sys.h backtrace.h
startup.h stacks.h sys.h backtrace.h fail.h
callback.pic.o: callback.c callback.h compatibility.h mlvalues.h config.h \
../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \
freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h
@ -337,7 +337,7 @@ globroots.pic.o: globroots.c memory.h compatibility.h config.h ../config/m.h \
roots.h globroots.h
hash.pic.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \
../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \
minor_gc.h hash.h int64_native.h
minor_gc.h hash.h
instrtrace.pic.o: instrtrace.c
intern.pic.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \
@ -348,7 +348,7 @@ interp.pic.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \
memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h
ints.pic.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \
major_gc.h freelist.h minor_gc.h int64_native.h
major_gc.h freelist.h minor_gc.h
io.pic.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \
freelist.h minor_gc.h signals.h sys.h
@ -405,7 +405,7 @@ startup.pic.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \
prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \
version.h
str.pic.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h fail.h int64_native.h
../config/s.h mlvalues.h fail.h
sys.pic.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \
stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h

4
byterun/alloc.h
View File

@ -32,8 +32,8 @@ CAMLextern value caml_alloc_string (mlsize_t); /* size in bytes */
CAMLextern value caml_copy_string (char const *);
CAMLextern value caml_copy_string_array (char const **);
CAMLextern value caml_copy_double (double);
CAMLextern value caml_copy_int32 (int32); /* defined in [ints.c] */
CAMLextern value caml_copy_int64 (int64); /* defined in [ints.c] */
CAMLextern value caml_copy_int32 (int32_t); /* defined in [ints.c] */
CAMLextern value caml_copy_int64 (int64_t); /* defined in [ints.c] */
CAMLextern value caml_copy_nativeint (intnat); /* defined in [ints.c] */
CAMLextern value caml_alloc_array (value (*funct) (char const *),
char const ** array);

5
byterun/backtrace.c
View File

@ -229,7 +229,7 @@ static void read_debug_info(void)
int fd;
struct exec_trailer trail;
struct channel * chan;
uint32 num_events, orig, i;
uint32_t num_events, orig, i;
intnat j;
value evl, l, ev_start;
@ -298,7 +298,8 @@ static void read_debug_info(void)
read_debug_info_error = "out of memory";
CAMLreturn0;
}
memcpy(events[j].ev_filename, String_val (Field (ev_start, POS_FNAME)), fnsz);
memcpy(events[j].ev_filename, String_val (Field (ev_start, POS_FNAME)),
fnsz);
events[j].ev_lnum = Int_val (Field (ev_start, POS_LNUM));
events[j].ev_startchr =

35
byterun/config.h
View File

@ -25,24 +25,30 @@
#include "compatibility.h"
#endif
/* Types for 32-bit integers, 64-bit integers,
#ifdef HAS_STDINT_H
#include <stdint.h>
#endif
/* Types for 32-bit integers, 64-bit integers, and
native integers (as wide as a pointer type) */
#ifndef ARCH_INT32_TYPE
#if SIZEOF_INT == 4
typedef int int32;
typedef unsigned int uint32;
#define ARCH_INT32_TYPE int
#define ARCH_UINT32_TYPE unsigned int
#define ARCH_INT32_PRINTF_FORMAT ""
#elif SIZEOF_LONG == 4
typedef long int32;
typedef unsigned long uint32;
#define ARCH_INT32_TYPE long
#define ARCH_UINT32_TYPE unsigned long
#define ARCH_INT32_PRINTF_FORMAT "l"
#elif SIZEOF_SHORT == 4
typedef short int32;
typedef unsigned short uint32;
#define ARCH_INT32_TYPE short
#define ARCH_UINT32_TYPE unsigned short
#define ARCH_INT32_PRINTF_FORMAT ""
#else
#error "No 32-bit integer type available"
#endif
#endif
#ifndef ARCH_INT64_TYPE
#if SIZEOF_LONGLONG == 8
@ -58,8 +64,13 @@ typedef unsigned short uint32;
#endif
#endif
typedef ARCH_INT64_TYPE int64;
typedef ARCH_UINT64_TYPE uint64;
#ifndef HAS_STDINT_H
/* Not a C99 compiler, typically MSVC. Define the C99 types we use. */
typedef ARCH_INT32_TYPE int32_t;
typedef ARCH_UINT32_TYPE uint32_t;
typedef ARCH_INT64_TYPE int64_t;
typedef ARCH_UINT64_TYPE uint64_t;
#endif
#if SIZEOF_PTR == SIZEOF_LONG
/* Standard models: ILP32 or I32LP64 */
@ -72,9 +83,9 @@ typedef int intnat;
typedef unsigned int uintnat;
#define ARCH_INTNAT_PRINTF_FORMAT ""
#elif SIZEOF_PTR == 8
/* Win64 model: IL32LLP64 */
typedef int64 intnat;
typedef uint64 uintnat;
/* Win64 model: IL32P64 */
typedef int64_t intnat;
typedef uint64_t uintnat;
#define ARCH_INTNAT_PRINTF_FORMAT ARCH_INT64_PRINTF_FORMAT
#else
#error "No integer type available to represent pointers"

28
byterun/debugger.h
View File

@ -37,17 +37,17 @@ void caml_debugger_cleanup_fork (void);
/* Requests from the debugger to the runtime system */
enum debugger_request {
REQ_SET_EVENT = 'e', /* uint32 pos */
REQ_SET_EVENT = 'e', /* uint32_t pos */
/* Set an event on the instruction at position pos */
REQ_SET_BREAKPOINT = 'B', /* uint32 pos, (char k) */
REQ_SET_BREAKPOINT = 'B', /* uint32_t pos, (char k) */
/* Set a breakpoint at position pos */
/* In profiling mode, the breakpoint kind is set to k */
REQ_RESET_INSTR = 'i', /* uint32 pos */
REQ_RESET_INSTR = 'i', /* uint32_t pos */
/* Clear an event or breapoint at position pos, restores initial instr. */
REQ_CHECKPOINT = 'c', /* no args */
/* Checkpoint the runtime system by forking a child process.
Reply is pid of child process or -1 if checkpoint failed. */
REQ_GO = 'g', /* uint32 n */
REQ_GO = 'g', /* uint32_t n */
/* Run the program for n events.
Reply is one of debugger_reply described below. */
REQ_STOP = 's', /* no args */
@ -59,38 +59,38 @@ enum debugger_request {
Reply is stack offset and current pc. */
REQ_GET_FRAME = 'f', /* no args */
/* Return current frame location (stack offset + current pc). */
REQ_SET_FRAME = 'S', /* uint32 stack_offset */
REQ_SET_FRAME = 'S', /* uint32_t stack_offset */
/* Set current frame to given stack offset. No reply. */
REQ_UP_FRAME = 'U', /* uint32 n */
REQ_UP_FRAME = 'U', /* uint32_t n */
/* Move one frame up. Argument n is size of current frame (in words).
Reply is stack offset and current pc, or -1 if top of stack reached. */
REQ_SET_TRAP_BARRIER = 'b', /* uint32 offset */
REQ_SET_TRAP_BARRIER = 'b', /* uint32_t offset */
/* Set the trap barrier at the given offset. */
REQ_GET_LOCAL = 'L', /* uint32 slot_number */
REQ_GET_LOCAL = 'L', /* uint32_t slot_number */
/* Return the local variable at the given slot in the current frame.
Reply is one value. */
REQ_GET_ENVIRONMENT = 'E', /* uint32 slot_number */
REQ_GET_ENVIRONMENT = 'E', /* uint32_t slot_number */
/* Return the local variable at the given slot in the heap environment
of the current frame. Reply is one value. */
REQ_GET_GLOBAL = 'G', /* uint32 global_number */
REQ_GET_GLOBAL = 'G', /* uint32_t global_number */
/* Return the specified global variable. Reply is one value. */
REQ_GET_ACCU = 'A', /* no args */
/* Return the current contents of the accumulator. Reply is one value. */
REQ_GET_HEADER = 'H', /* mlvalue v */
/* As REQ_GET_OBJ, but sends only the header. */
REQ_GET_FIELD = 'F', /* mlvalue v, uint32 fieldnum */
REQ_GET_FIELD = 'F', /* mlvalue v, uint32_t fieldnum */
/* As REQ_GET_OBJ, but sends only one field. */
REQ_MARSHAL_OBJ = 'M', /* mlvalue v */
/* Send a copy of the data structure rooted at v, using the same
format as [caml_output_value]. */
REQ_GET_CLOSURE_CODE = 'C', /* mlvalue v */
/* Send the code address of the given closure.
Reply is one uint32. */
REQ_SET_FORK_MODE = 'K' /* uint32 m */
Reply is one uint32_t. */
REQ_SET_FORK_MODE = 'K' /* uint32_t m */
/* Set whether to follow the child (m=0) or the parent on fork. */
};
/* Replies to a REQ_GO request. All replies are followed by three uint32:
/* Replies to a REQ_GO request. All replies are followed by three uint32_t:
- the value of the event counter
- the position of the stack
- the current pc. */

4
byterun/exec.h
View File

@ -39,13 +39,13 @@
struct section_descriptor {
char name[4]; /* Section name */
uint32 len; /* Length of data in bytes */
uint32_t len; /* Length of data in bytes */
};
/* Structure of the trailer. */
struct exec_trailer {
uint32 num_sections; /* Number of sections */
uint32_t num_sections; /* Number of sections */
char magic[12]; /* The magic number */
struct section_descriptor * section; /* Not part of file */
};

4
byterun/extern.c
View File

@ -720,7 +720,7 @@ CAMLexport void caml_serialize_int_2(int i)
extern_ptr += 2;
}
CAMLexport void caml_serialize_int_4(int32 i)
CAMLexport void caml_serialize_int_4(int32_t i)
{
if (extern_ptr + 4 > extern_limit) grow_extern_output(4);
extern_ptr[0] = i >> 24;
@ -730,7 +730,7 @@ CAMLexport void caml_serialize_int_4(int32 i)
extern_ptr += 4;
}
CAMLexport void caml_serialize_int_8(int64 i)
CAMLexport void caml_serialize_int_8(int64_t i)
{
caml_serialize_block_8(&i, 1);
}

8
byterun/fix_code.c
View File

@ -134,12 +134,12 @@ void caml_thread_code (code_t code, asize_t len)
}
*p++ = (opcode_t)(caml_instr_table[instr] - caml_instr_base);
if (instr == SWITCH) {
uint32 sizes = *p++;
uint32 const_size = sizes & 0xFFFF;
uint32 block_size = sizes >> 16;
uint32_t sizes = *p++;
uint32_t const_size = sizes & 0xFFFF;
uint32_t block_size = sizes >> 16;
p += const_size + block_size;
} else if (instr == CLOSUREREC) {
uint32 nfuncs = *p++;
uint32_t nfuncs = *p++;
p++; /* skip nvars */
p += nfuncs;
} else {

6
byterun/floats.c
View File

@ -378,9 +378,9 @@ CAMLprim value caml_log1p_float(value f)
union double_as_two_int32 {
double d;
#if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__))
struct { uint32 h; uint32 l; } i;
struct { uint32_t h; uint32_t l; } i;
#else
struct { uint32 l; uint32 h; } i;
struct { uint32_t l; uint32_t h; } i;
#endif
};
@ -467,7 +467,7 @@ CAMLprim value caml_classify_float(value vd)
}
#else
union double_as_two_int32 u;
uint32 h, l;
uint32_t h, l;
u.d = Double_val(vd);
h = u.i.h; l = u.i.l;

4
byterun/globroots.c
View File

@ -43,11 +43,11 @@ struct global_root_list {
(i.e. 2 * (NUM_LEVELS - 1)). Moreover, the congruential PRNG
is faster and guaranteed to be deterministic (to reproduce bugs). */
static uint32 random_seed = 0;
static uint32_t random_seed = 0;
static int random_level(void)
{
uint32 r;
uint32_t r;
int level = 0;
/* Linear congruence with modulus = 2^32, multiplier = 69069

44
byterun/hash.c
View File

@ -41,7 +41,7 @@
h *= 0xc2b2ae35; \
h ^= h >> 16;
CAMLexport uint32 caml_hash_mix_uint32(uint32 h, uint32 d)
CAMLexport uint32_t caml_hash_mix_uint32(uint32_t h, uint32_t d)
{
MIX(h, d);
return h;
@ -49,17 +49,17 @@ CAMLexport uint32 caml_hash_mix_uint32(uint32 h, uint32 d)
/* Mix a platform-native integer. */
CAMLexport uint32 caml_hash_mix_intnat(uint32 h, intnat d)
CAMLexport uint32_t caml_hash_mix_intnat(uint32_t h, intnat d)
{
uint32 n;
uint32_t n;
#ifdef ARCH_SIXTYFOUR
/* Mix the low 32 bits and the high 32 bits, in a way that preserves
32/64 compatibility: we want n = (uint32) d
32/64 compatibility: we want n = (uint32_t) d
if d is in the range [-2^31, 2^31-1]. */
n = (d >> 32) ^ (d >> 63) ^ d;
/* If 0 <= d < 2^31: d >> 32 = 0 d >> 63 = 0
If -2^31 <= d < 0: d >> 32 = -1 d >> 63 = -1
In both cases, n = (uint32) d. */
In both cases, n = (uint32_t) d. */
#else
n = d;
#endif
@ -69,9 +69,9 @@ CAMLexport uint32 caml_hash_mix_intnat(uint32 h, intnat d)
/* Mix a 64-bit integer. */
CAMLexport uint32 caml_hash_mix_int64(uint32 h, int64 d)
CAMLexport uint32_t caml_hash_mix_int64(uint32_t h, int64_t d)
{
uint32 hi = (uint32) (d >> 32), lo = (uint32) d;
uint32_t hi = (uint32_t) (d >> 32), lo = (uint32_t) d;
MIX(h, lo);
MIX(h, hi);
return h;
@ -82,17 +82,17 @@ CAMLexport uint32 caml_hash_mix_int64(uint32 h, int64 d)
Treats all NaNs identically.
*/
CAMLexport uint32 caml_hash_mix_double(uint32 hash, double d)
CAMLexport uint32_t caml_hash_mix_double(uint32_t hash, double d)
{
union {
double d;
#if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__))
struct { uint32 h; uint32 l; } i;
struct { uint32_t h; uint32_t l; } i;
#else
struct { uint32 l; uint32 h; } i;
struct { uint32_t l; uint32_t h; } i;
#endif
} u;
uint32 h, l;
uint32_t h, l;
/* Convert to two 32-bit halves */
u.d = d;
h = u.i.h; l = u.i.l;
@ -115,14 +115,14 @@ CAMLexport uint32 caml_hash_mix_double(uint32 hash, double d)
Treats all NaNs identically.
*/
CAMLexport uint32 caml_hash_mix_float(uint32 hash, float d)
CAMLexport uint32_t caml_hash_mix_float(uint32_t hash, float d)
{
union {
float f;
uint32 i;
uint32_t i;
} u;
uint32 n;
/* Convert to int32 */
uint32_t n;
/* Convert to int32_t */
u.f = d; n = u.i;
/* Normalize NaNs */
if ((n & 0x7F800000) == 0x7F800000 && (n & 0x007FFFFF) != 0) {
@ -138,11 +138,11 @@ CAMLexport uint32 caml_hash_mix_float(uint32 hash, float d)
/* Mix an OCaml string */
CAMLexport uint32 caml_hash_mix_string(uint32 h, value s)
CAMLexport uint32_t caml_hash_mix_string(uint32_t h, value s)
{
mlsize_t len = caml_string_length(s);
mlsize_t i;
uint32 w;
uint32_t w;
/* Mix by 32-bit blocks (little-endian) */
for (i = 0; i + 4 <= len; i += 4) {
@ -152,7 +152,7 @@ CAMLexport uint32 caml_hash_mix_string(uint32 h, value s)
| (Byte_u(s, i+2) << 16)
| (Byte_u(s, i+3) << 24);
#else
w = *((uint32 *) &Byte_u(s, i));
w = *((uint32_t *) &Byte_u(s, i));
#endif
MIX(h, w);
}
@ -166,7 +166,7 @@ CAMLexport uint32 caml_hash_mix_string(uint32 h, value s)
default: /*skip*/; /* len & 3 == 0, no extra bytes, do nothing */
}
/* Finally, mix in the length. Ignore the upper 32 bits, generally 0. */
h ^= (uint32) len;
h ^= (uint32_t) len;
return h;
}
@ -184,7 +184,7 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj)
intnat wr; /* One past position of last value in queue */
intnat sz; /* Max number of values to put in queue */
intnat num; /* Max number of meaningful values to see */
uint32 h; /* Rolling hash */
uint32_t h; /* Rolling hash */
value v;
mlsize_t i, len;
@ -245,7 +245,7 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj)
/* If no hashing function provided, do nothing. */
/* Only use low 32 bits of custom hash, for 32/64 compatibility */
if (Custom_ops_val(v)->hash != NULL) {
uint32 n = (uint32) Custom_ops_val(v)->hash(v);
uint32_t n = (uint32_t) Custom_ops_val(v)->hash(v);
h = caml_hash_mix_uint32(h, n);
num--;
}
@ -408,5 +408,5 @@ CAMLexport value caml_hash_variant(char const * tag)
#endif
/* Force sign extension of bit 31 for compatibility between 32 and 64-bit
platforms */
return (int32) accu;
return (int32_t) accu;
}

12
byterun/hash.h
View File

@ -18,12 +18,12 @@
#include "mlvalues.h"
CAMLextern uint32 caml_hash_mix_uint32(uint32 h, uint32 d);
CAMLextern uint32 caml_hash_mix_intnat(uint32 h, intnat d);
CAMLextern uint32 caml_hash_mix_int64(uint32 h, int64 d);
CAMLextern uint32 caml_hash_mix_double(uint32 h, double d);
CAMLextern uint32 caml_hash_mix_float(uint32 h, float d);
CAMLextern uint32 caml_hash_mix_string(uint32 h, value s);
CAMLextern uint32_t caml_hash_mix_uint32(uint32_t h, uint32_t d);
CAMLextern uint32_t caml_hash_mix_intnat(uint32_t h, intnat d);
CAMLextern uint32_t caml_hash_mix_int64(uint32_t h, int64_t d);
CAMLextern uint32_t caml_hash_mix_double(uint32_t h, double d);
CAMLextern uint32_t caml_hash_mix_float(uint32_t h, float d);
CAMLextern uint32_t caml_hash_mix_string(uint32_t h, value s);
#endif

114
byterun/int64_emul.h
View File

@ -28,7 +28,7 @@
#define I64_split(x,hi,lo) (hi = (x).h, lo = (x).l)
/* Unsigned comparison */
static int I64_ucompare(uint64 x, uint64 y)
static int I64_ucompare(uint64_t x, uint64_t y)
{
if (x.h > y.h) return 1;
if (x.h < y.h) return -1;
@ -40,19 +40,19 @@ static int I64_ucompare(uint64 x, uint64 y)
#define I64_ult(x, y) (I64_ucompare(x, y) < 0)
/* Signed comparison */
static int I64_compare(int64 x, int64 y)
static int I64_compare(int64_t x, int64_t y)
{
if ((int32)x.h > (int32)y.h) return 1;
if ((int32)x.h < (int32)y.h) return -1;
if ((int32_t)x.h > (int32_t)y.h) return 1;
if ((int32_t)x.h < (int32_t)y.h) return -1;
if (x.l > y.l) return 1;
if (x.l < y.l) return -1;
return 0;
}
/* Negation */
static int64 I64_neg(int64 x)
static int64_t I64_neg(int64_t x)
{
int64 res;
int64_t res;
res.l = -x.l;
res.h = ~x.h;
if (res.l == 0) res.h++;
@ -60,9 +60,9 @@ static int64 I64_neg(int64 x)
}
/* Addition */
static int64 I64_add(int64 x, int64 y)
static int64_t I64_add(int64_t x, int64_t y)
{
int64 res;
int64_t res;
res.l = x.l + y.l;
res.h = x.h + y.h;
if (res.l < x.l) res.h++;
@ -70,9 +70,9 @@ static int64 I64_add(int64 x, int64 y)
}
/* Subtraction */
static int64 I64_sub(int64 x, int64 y)
static int64_t I64_sub(int64_t x, int64_t y)
{
int64 res;
int64_t res;
res.l = x.l - y.l;
res.h = x.h - y.h;
if (x.l < y.l) res.h--;
@ -80,13 +80,13 @@ static int64 I64_sub(int64 x, int64 y)
}
/* Multiplication */
static int64 I64_mul(int64 x, int64 y)
static int64_t I64_mul(int64_t x, int64_t y)
{
int64 res;
uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF);
uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF);
uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16);
uint32 prod11 = (x.l >> 16) * (y.l >> 16);
int64_t res;
uint32_t prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF);
uint32_t prod10 = (x.l >> 16) * (y.l & 0xFFFF);
uint32_t prod01 = (x.l & 0xFFFF) * (y.l >> 16);
uint32_t prod11 = (x.l >> 16) * (y.l >> 16);
res.l = prod00;
res.h = prod11 + (prod01 >> 16) + (prod10 >> 16);
prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++;
@ -96,39 +96,39 @@ static int64 I64_mul(int64 x, int64 y)
}
#define I64_is_zero(x) (((x).l | (x).h) == 0)
#define I64_is_negative(x) ((int32) (x).h < 0)
#define I64_is_negative(x) ((int32_t) (x).h < 0)
#define I64_is_min_int(x) ((x).l == 0 && (x).h == 0x80000000U)
#define I64_is_minus_one(x) (((x).l & (x).h) == 0xFFFFFFFFU)
/* Bitwise operations */
static int64 I64_and(int64 x, int64 y)
static int64_t I64_and(int64_t x, int64_t y)
{
int64 res;
int64_t res;
res.l = x.l & y.l;
res.h = x.h & y.h;
return res;
}
static int64 I64_or(int64 x, int64 y)
static int64_t I64_or(int64_t x, int64_t y)
{
int64 res;
int64_t res;
res.l = x.l | y.l;
res.h = x.h | y.h;
return res;
}
static int64 I64_xor(int64 x, int64 y)
static int64_t I64_xor(int64_t x, int64_t y)
{
int64 res;
int64_t res;
res.l = x.l ^ y.l;
res.h = x.h ^ y.h;
return res;
}
/* Shifts */
static int64 I64_lsl(int64 x, int s)
static int64_t I64_lsl(int64_t x, int s)
{
int64 res;
int64_t res;
s = s & 63;
if (s == 0) return x;
if (s < 32) {
@ -141,9 +141,9 @@ static int64 I64_lsl(int64 x, int s)
return res;
}
static int64 I64_lsr(int64 x, int s)
static int64_t I64_lsr(int64_t x, int s)
{
int64 res;
int64_t res;
s = s & 63;
if (s == 0) return x;
if (s < 32) {
@ -156,17 +156,17 @@ static int64 I64_lsr(int64 x, int s)
return res;
}
static int64 I64_asr(int64 x, int s)
static int64_t I64_asr(int64_t x, int s)
{
int64 res;
int64_t res;
s = s & 63;
if (s == 0) return x;
if (s < 32) {
res.l = (x.l >> s) | (x.h << (32 - s));
res.h = (int32) x.h >> s;
res.h = (int32_t) x.h >> s;
} else {
res.l = (int32) x.h >> (s - 32);
res.h = (int32) x.h >> 31;
res.l = (int32_t) x.h >> (s - 32);
res.h = (int32_t) x.h >> 31;
}
return res;
}
@ -176,15 +176,15 @@ static int64 I64_asr(int64 x, int s)
#define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1
#define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1
static void I64_udivmod(uint64 modulus, uint64 divisor,
uint64 * quo, uint64 * mod)
static void I64_udivmod(uint64_t modulus, uint64_t divisor,
uint64_t * quo, uint64_t * mod)
{
int64 quotient, mask;
int64_t quotient, mask;
int cmp;
quotient.h = 0; quotient.l = 0;
mask.h = 0; mask.l = 1;
while ((int32) divisor.h >= 0) {
while ((int32_t) divisor.h >= 0) {
cmp = I64_ucompare(divisor, modulus);
I64_SHL1(divisor);
I64_SHL1(mask);
@ -202,27 +202,27 @@ static void I64_udivmod(uint64 modulus, uint64 divisor,
*mod = modulus;
}
static int64 I64_div(int64 x, int64 y)
static int64_t I64_div(int64_t x, int64_t y)
{
int64 q, r;
int32 sign;
int64_t q, r;
int32_t sign;
sign = x.h ^ y.h;
if ((int32) x.h < 0) x = I64_neg(x);
if ((int32) y.h < 0) y = I64_neg(y);
if ((int32_t) x.h < 0) x = I64_neg(x);
if ((int32_t) y.h < 0) y = I64_neg(y);
I64_udivmod(x, y, &q, &r);
if (sign < 0) q = I64_neg(q);
return q;
}
static int64 I64_mod(int64 x, int64 y)
static int64_t I64_mod(int64_t x, int64_t y)
{
int64 q, r;
int32 sign;
int64_t q, r;
int32_t sign;
sign = x.h;
if ((int32) x.h < 0) x = I64_neg(x);
if ((int32) y.h < 0) y = I64_neg(y);
if ((int32_t) x.h < 0) x = I64_neg(x);
if ((int32_t) y.h < 0) y = I64_neg(y);
I64_udivmod(x, y, &q, &r);
if (sign < 0) r = I64_neg(r);
return r;
@ -230,49 +230,49 @@ static int64 I64_mod(int64 x, int64 y)
/* Coercions */
static int64 I64_of_int32(int32 x)
static int64_t I64_of_int32(int32_t x)
{
int64 res;
int64_t res;
res.l = x;
res.h = x >> 31;
return res;
}
#define I64_to_int32(x) ((int32) (x).l)
#define I64_to_int32(x) ((int32_t) (x).l)
/* Note: we assume sizeof(intnat) = 4 here, which is true otherwise
autoconfiguration would have selected native 64-bit integers */
#define I64_of_intnat I64_of_int32
#define I64_to_intnat I64_to_int32
static double I64_to_double(int64 x)
static double I64_to_double(int64_t x)
{
double res;
int32 sign = x.h;
int32_t sign = x.h;
if (sign < 0) x = I64_neg(x);
res = ldexp((double) x.h, 32) + x.l;
if (sign < 0) res = -res;
return res;
}
static int64 I64_of_double(double f)
static int64_t I64_of_double(double f)
{
int64 res;
int64_t res;
double frac, integ;
int neg;
neg = (f < 0);
f = fabs(f);
frac = modf(ldexp(f, -32), &integ);
res.h = (uint32) integ;
res.l = (uint32) ldexp(frac, 32);
res.h = (uint32_t) integ;
res.l = (uint32_t) ldexp(frac, 32);
if (neg) res = I64_neg(res);
return res;
}
static int64 I64_bswap(int64 x)
static int64_t I64_bswap(int64_t x)
{
int64 res;
int64_t res;
res.h = (((x.l & 0x000000FF) << 24) |
((x.l & 0x0000FF00) << 8) |
((x.l & 0x00FF0000) >> 8) |

4
byterun/int64_format.h
View File

@ -17,7 +17,7 @@
#ifndef CAML_INT64_FORMAT_H
#define CAML_INT64_FORMAT_H
static void I64_format(char * buffer, char * fmt, int64 x)
static void I64_format(char * buffer, char * fmt, int64_t x)
{
static char conv_lower[] = "0123456789abcdef";
static char conv_upper[] = "0123456789ABCDEF";
@ -26,7 +26,7 @@ static void I64_format(char * buffer, char * fmt, int64 x)
int base, width, sign, i, rawlen;
char * cvtbl;
char * p, * r;
int64 wbase, digit;
int64_t wbase, digit;
/* Parsing of format */
justify = '+';

20
byterun/int64_native.h
View File

@ -18,36 +18,36 @@
#ifndef CAML_INT64_NATIVE_H
#define CAML_INT64_NATIVE_H
#define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo))
#define I64_split(x,hi,lo) (hi = (uint32)((x)>>32), lo = (uint32)(x))
#define I64_literal(hi,lo) ((int64_t)(hi) << 32 | (lo))
#define I64_split(x,hi,lo) (hi = (uint32_t)((x)>>32), lo = (uint32_t)(x))
#define I64_compare(x,y) (((x) > (y)) - ((x) < (y)))
#define I64_ult(x,y) ((uint64)(x) < (uint64)(y))
#define I64_ult(x,y) ((uint64_t)(x) < (uint64_t)(y))
#define I64_neg(x) (-(x))
#define I64_add(x,y) ((x) + (y))
#define I64_sub(x,y) ((x) - (y))
#define I64_mul(x,y) ((x) * (y))
#define I64_is_zero(x) ((x) == 0)
#define I64_is_negative(x) ((x) < 0)
#define I64_is_min_int(x) ((x) == ((int64)1 << 63))
#define I64_is_min_int(x) ((x) == ((int64_t)1 << 63))
#define I64_is_minus_one(x) ((x) == -1)
#define I64_div(x,y) ((x) / (y))
#define I64_mod(x,y) ((x) % (y))
#define I64_udivmod(x,y,quo,rem) \
(*(rem) = (uint64)(x) % (uint64)(y), \
*(quo) = (uint64)(x) / (uint64)(y))
(*(rem) = (uint64_t)(x) % (uint64_t)(y), \
*(quo) = (uint64_t)(x) / (uint64_t)(y))
#define I64_and(x,y) ((x) & (y))
#define I64_or(x,y) ((x) | (y))
#define I64_xor(x,y) ((x) ^ (y))
#define I64_lsl(x,y) ((x) << (y))
#define I64_asr(x,y) ((x) >> (y))
#define I64_lsr(x,y) ((uint64)(x) >> (y))
#define I64_lsr(x,y) ((uint64_t)(x) >> (y))
#define I64_to_intnat(x) ((intnat) (x))
#define I64_of_intnat(x) ((intnat) (x))
#define I64_to_int32(x) ((int32) (x))
#define I64_of_int32(x) ((int64) (x))
#define I64_to_int32(x) ((int32_t) (x))
#define I64_of_int32(x) ((int64_t) (x))
#define I64_to_double(x) ((double)(x))
#define I64_of_double(x) ((int64)(x))
#define I64_of_double(x) ((int64_t)(x))
#define I64_bswap(x) ((((x) & 0x00000000000000FFULL) << 56) | \
(((x) & 0x000000000000FF00ULL) << 40) | \

20
byterun/intern.c
View File

@ -553,7 +553,7 @@ static void intern_add_to_heap(mlsize_t whsize)
value caml_input_val(struct channel *chan)
{
uint32 magic;
uint32_t magic;
mlsize_t block_len, num_objects, whsize;
char * block;
value res;
@ -663,7 +663,7 @@ static value input_val_from_block(void)
CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs)
{
uint32 magic;
uint32_t magic;
value obj;
intern_input = (unsigned char *) data;
@ -681,7 +681,7 @@ CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs)
CAMLexport value caml_input_value_from_block(char * data, intnat len)
{
uint32 magic;
uint32_t magic;
mlsize_t block_len;
value obj;
@ -700,7 +700,7 @@ CAMLexport value caml_input_value_from_block(char * data, intnat len)
CAMLprim value caml_marshal_data_size(value buff, value ofs)
{
uint32 magic;
uint32_t magic;
mlsize_t block_len;
intern_src = &Byte_u(buff, Long_val(ofs));
@ -771,26 +771,26 @@ CAMLexport int caml_deserialize_sint_2(void)
return read16s();
}
CAMLexport uint32 caml_deserialize_uint_4(void)
CAMLexport uint32_t caml_deserialize_uint_4(void)
{
return read32u();
}
CAMLexport int32 caml_deserialize_sint_4(void)
CAMLexport int32_t caml_deserialize_sint_4(void)
{
return read32s();
}
CAMLexport uint64 caml_deserialize_uint_8(void)
CAMLexport uint64_t caml_deserialize_uint_8(void)
{
uint64 i;
uint64_t i;
caml_deserialize_block_8(&i, 1);
return i;
}
CAMLexport int64 caml_deserialize_sint_8(void)
CAMLexport int64_t caml_deserialize_sint_8(void)
{
int64 i;
int64_t i;
caml_deserialize_block_8(&i, 1);
return i;
}

2
byterun/interp.c
View File

@ -793,7 +793,7 @@ value caml_interprete(code_t prog, asize_t prog_size)
if (accu == Val_false) pc += *pc; else pc++;
Next;
Instruct(SWITCH): {
uint32 sizes = *pc++;
uint32_t sizes = *pc++;
if (Is_block(accu)) {
intnat index = Tag_val(accu);
Assert ((uintnat) index < (sizes >> 16));

12
byterun/intext.h
View File

@ -119,8 +119,8 @@ CAMLextern value caml_input_value_from_block(char * data, intnat len);
CAMLextern void caml_serialize_int_1(int i);
CAMLextern void caml_serialize_int_2(int i);
CAMLextern void caml_serialize_int_4(int32 i);
CAMLextern void caml_serialize_int_8(int64 i);
CAMLextern void caml_serialize_int_4(int32_t i);
CAMLextern void caml_serialize_int_8(int64_t i);
CAMLextern void caml_serialize_float_4(float f);
CAMLextern void caml_serialize_float_8(double f);
CAMLextern void caml_serialize_block_1(void * data, intnat len);
@ -133,10 +133,10 @@ CAMLextern int caml_deserialize_uint_1(void);
CAMLextern int caml_deserialize_sint_1(void);
CAMLextern int caml_deserialize_uint_2(void);
CAMLextern int caml_deserialize_sint_2(void);
CAMLextern uint32 caml_deserialize_uint_4(void);
CAMLextern int32 caml_deserialize_sint_4(void);
CAMLextern uint64 caml_deserialize_uint_8(void);
CAMLextern int64 caml_deserialize_sint_8(void);
CAMLextern uint32_t caml_deserialize_uint_4(void);
CAMLextern int32_t caml_deserialize_sint_4(void);
CAMLextern uint64_t caml_deserialize_uint_8(void);
CAMLextern int64_t caml_deserialize_sint_8(void);
CAMLextern float caml_deserialize_float_4(void);
CAMLextern double caml_deserialize_float_8(void);
CAMLextern void caml_deserialize_block_1(void * data, intnat len);

112
byterun/ints.c
View File

@ -172,8 +172,8 @@ CAMLprim value caml_format_int(value fmt, value arg)
static int int32_cmp(value v1, value v2)
{
int32 i1 = Int32_val(v1);
int32 i2 = Int32_val(v2);
int32_t i1 = Int32_val(v1);
int32_t i2 = Int32_val(v2);
return (i1 > i2) - (i1 < i2);
}
@ -191,7 +191,7 @@ static void int32_serialize(value v, uintnat * wsize_32,
static uintnat int32_deserialize(void * dst)
{
*((int32 *) dst) = caml_deserialize_sint_4();
*((int32_t *) dst) = caml_deserialize_sint_4();
return 4;
}
@ -205,7 +205,7 @@ CAMLexport struct custom_operations caml_int32_ops = {
custom_compare_ext_default
};
CAMLexport value caml_copy_int32(int32 i)
CAMLexport value caml_copy_int32(int32_t i)
{
value res = caml_alloc_custom(&caml_int32_ops, 4, 0, 1);
Int32_val(res) = i;
@ -226,8 +226,8 @@ CAMLprim value caml_int32_mul(value v1, value v2)
CAMLprim value caml_int32_div(value v1, value v2)
{
int32 dividend = Int32_val(v1);
int32 divisor = Int32_val(v2);
int32_t dividend = Int32_val(v1);
int32_t divisor = Int32_val(v2);
if (divisor == 0) caml_raise_zero_divide();
/* PR#4740: on some processors, division crashes on overflow.
Implement the same behavior as for type "int". */
@ -237,8 +237,8 @@ CAMLprim value caml_int32_div(value v1, value v2)
CAMLprim value caml_int32_mod(value v1, value v2)
{
int32 dividend = Int32_val(v1);
int32 divisor = Int32_val(v2);
int32_t dividend = Int32_val(v1);
int32_t divisor = Int32_val(v2);
if (divisor == 0) caml_raise_zero_divide();
/* PR#4740: on some processors, modulus crashes if division overflows.
Implement the same behavior as for type "int". */
@ -262,9 +262,9 @@ CAMLprim value caml_int32_shift_right(value v1, value v2)
{ return caml_copy_int32(Int32_val(v1) >> Int_val(v2)); }
CAMLprim value caml_int32_shift_right_unsigned(value v1, value v2)
{ return caml_copy_int32((uint32)Int32_val(v1) >> Int_val(v2)); }
{ return caml_copy_int32((uint32_t)Int32_val(v1) >> Int_val(v2)); }
static int32 caml_swap32(int32 x)
static int32_t caml_swap32(int32_t x)
{
return (((x & 0x000000FF) << 24) |
((x & 0x0000FF00) << 8) |
@ -285,15 +285,15 @@ CAMLprim value caml_int32_to_int(value v)
{ return Val_long(Int32_val(v)); }
CAMLprim value caml_int32_of_float(value v)
{ return caml_copy_int32((int32)(Double_val(v))); }
{ return caml_copy_int32((int32_t)(Double_val(v))); }
CAMLprim value caml_int32_to_float(value v)
{ return caml_copy_double((double)(Int32_val(v))); }
CAMLprim value caml_int32_compare(value v1, value v2)
{
int32 i1 = Int32_val(v1);
int32 i2 = Int32_val(v2);
int32_t i1 = Int32_val(v1);
int32_t i2 = Int32_val(v2);
int res = (i1 > i2) - (i1 < i2);
return Val_int(res);
}
@ -313,14 +313,14 @@ CAMLprim value caml_int32_of_string(value s)
CAMLprim value caml_int32_bits_of_float(value vd)
{
union { float d; int32 i; } u;
union { float d; int32_t i; } u;
u.d = Double_val(vd);
return caml_copy_int32(u.i);
}
CAMLprim value caml_int32_float_of_bits(value vi)
{
union { float d; int32 i; } u;
union { float d; int32_t i; } u;
u.i = Int32_val(vi);
return caml_copy_double(u.d);
}
@ -329,11 +329,11 @@ CAMLprim value caml_int32_float_of_bits(value vi)
#ifdef ARCH_ALIGN_INT64
CAMLexport int64 caml_Int64_val(value v)
CAMLexport int64_t caml_Int64_val(value v)
{
union { int32 i[2]; int64 j; } buffer;
buffer.i[0] = ((int32 *) Data_custom_val(v))[0];
buffer.i[1] = ((int32 *) Data_custom_val(v))[1];
union { int32_t i[2]; int64_t j; } buffer;
buffer.i[0] = ((int32_t *) Data_custom_val(v))[0];
buffer.i[1] = ((int32_t *) Data_custom_val(v))[1];
return buffer.j;
}
@ -341,15 +341,15 @@ CAMLexport int64 caml_Int64_val(value v)
static int int64_cmp(value v1, value v2)
{
int64 i1 = Int64_val(v1);
int64 i2 = Int64_val(v2);
int64_t i1 = Int64_val(v1);
int64_t i2 = Int64_val(v2);
return (i1 > i2) - (i1 < i2);
}
static intnat int64_hash(value v)
{
int64 x = Int64_val(v);
uint32 lo = (uint32) x, hi = (uint32) (x >> 32);
int64_t x = Int64_val(v);
uint32_t lo = (uint32_t) x, hi = (uint32_t) (x >> 32);
return hi ^ lo;
}
@ -363,12 +363,12 @@ static void int64_serialize(value v, uintnat * wsize_32,
static uintnat int64_deserialize(void * dst)
{
#ifndef ARCH_ALIGN_INT64
*((int64 *) dst) = caml_deserialize_sint_8();
*((int64_t *) dst) = caml_deserialize_sint_8();
#else
union { int32 i[2]; int64 j; } buffer;
union { int32_t i[2]; int64_t j; } buffer;
buffer.j = caml_deserialize_sint_8();
((int32 *) dst)[0] = buffer.i[0];
((int32 *) dst)[1] = buffer.i[1];
((int32_t *) dst)[0] = buffer.i[0];
((int32_t *) dst)[1] = buffer.i[1];
#endif
return 8;
}
@ -383,16 +383,16 @@ CAMLexport struct custom_operations caml_int64_ops = {
custom_compare_ext_default
};
CAMLexport value caml_copy_int64(int64 i)
CAMLexport value caml_copy_int64(int64_t i)
{
value res = caml_alloc_custom(&caml_int64_ops, 8, 0, 1);
#ifndef ARCH_ALIGN_INT64
Int64_val(res) = i;
#else
union { int32 i[2]; int64 j; } buffer;
union { int32_t i[2]; int64_t j; } buffer;
buffer.j = i;
((int32 *) Data_custom_val(res))[0] = buffer.i[0];
((int32 *) Data_custom_val(res))[1] = buffer.i[1];
((int32_t *) Data_custom_val(res))[0] = buffer.i[0];
((int32_t *) Data_custom_val(res))[1] = buffer.i[1];
#endif
return res;
}
@ -413,23 +413,23 @@ CAMLprim value caml_int64_mul(value v1, value v2)
CAMLprim value caml_int64_div(value v1, value v2)
{
int64 dividend = Int64_val(v1);
int64 divisor = Int64_val(v2);
int64_t dividend = Int64_val(v1);
int64_t divisor = Int64_val(v2);
if (divisor == 0) caml_raise_zero_divide();
/* PR#4740: on some processors, division crashes on overflow.
Implement the same behavior as for type "int". */
if (dividend == ((int64)1 << 63) && divisor == -1) return v1;
if (dividend == ((int64_t)1 << 63) && divisor == -1) return v1;
return caml_copy_int64(Int64_val(v1) / divisor);
}
CAMLprim value caml_int64_mod(value v1, value v2)
{
int64 dividend = Int64_val(v1);
int64 divisor = Int64_val(v2);
int64_t dividend = Int64_val(v1);
int64_t divisor = Int64_val(v2);
if (divisor == 0) caml_raise_zero_divide();
/* PR#4740: on some processors, division crashes on overflow.
Implement the same behavior as for type "int". */
if (dividend == ((int64)1 << 63) && divisor == -1) return caml_copy_int64(0);
if (dividend == ((int64_t)1 << 63) && divisor == -1) return caml_copy_int64(0);
return caml_copy_int64(Int64_val(v1) % divisor);
}
@ -449,7 +449,7 @@ CAMLprim value caml_int64_shift_right(value v1, value v2)
{ return caml_copy_int64(Int64_val(v1) >> Int_val(v2)); }
CAMLprim value caml_int64_shift_right_unsigned(value v1, value v2)
{ return caml_copy_int64((uint64) (Int64_val(v1)) >> Int_val(v2)); }
{ return caml_copy_int64((uint64_t) (Int64_val(v1)) >> Int_val(v2)); }
#ifdef ARCH_SIXTYFOUR
static value caml_swap64(value x)
@ -470,7 +470,7 @@ value caml_int64_direct_bswap(value v)
CAMLprim value caml_int64_bswap(value v)
{
int64 x = Int64_val(v);
int64_t x = Int64_val(v);
return caml_copy_int64
(((x & 0x00000000000000FFULL) << 56) |
((x & 0x000000000000FF00ULL) << 40) |
@ -483,33 +483,33 @@ CAMLprim value caml_int64_bswap(value v)
}
CAMLprim value caml_int64_of_int(value v)
{ return caml_copy_int64((int64) (Long_val(v))); }
{ return caml_copy_int64((int64_t) (Long_val(v))); }
CAMLprim value caml_int64_to_int(value v)
{ return Val_long((intnat) (Int64_val(v))); }
CAMLprim value caml_int64_of_float(value v)
{ return caml_copy_int64((int64) (Double_val(v))); }
{ return caml_copy_int64((int64_t) (Double_val(v))); }
CAMLprim value caml_int64_to_float(value v)
{ return caml_copy_double((double) (Int64_val(v))); }
CAMLprim value caml_int64_of_int32(value v)
{ return caml_copy_int64((int64) (Int32_val(v))); }
{ return caml_copy_int64((int64_t) (Int32_val(v))); }
CAMLprim value caml_int64_to_int32(value v)
{ return caml_copy_int32((int32) (Int64_val(v))); }
{ return caml_copy_int32((int32_t) (Int64_val(v))); }
CAMLprim value caml_int64_of_nativeint(value v)
{ return caml_copy_int64((int64) (Nativeint_val(v))); }
{ return caml_copy_int64((int64_t) (Nativeint_val(v))); }
CAMLprim value caml_int64_to_nativeint(value v)
{ return caml_copy_nativeint((intnat) (Int64_val(v))); }
CAMLprim value caml_int64_compare(value v1, value v2)
{
int64 i1 = Int64_val(v1);
int64 i2 = Int64_val(v2);
int64_t i1 = Int64_val(v1);
int64_t i2 = Int64_val(v2);
return Val_int((i1 > i2) - (i1 < i2));
}
@ -524,11 +524,11 @@ CAMLprim value caml_int64_format(value fmt, value arg)
CAMLprim value caml_int64_of_string(value s)
{
char * p;
uint64 res, threshold;
uint64_t res, threshold;
int sign, base, d;
p = parse_sign_and_base(String_val(s), &base, &sign);
threshold = ((uint64) -1) / base;
threshold = ((uint64_t) -1) / base;
d = parse_digit(*p);
if (d < 0 || d >= base) caml_failwith("int_of_string");
res = d;
@ -541,7 +541,7 @@ CAMLprim value caml_int64_of_string(value s)
if (res > threshold) caml_failwith("int_of_string");
res = base * res + d;
/* Detect overflow in addition (base * res) + d */
if (res < (uint64) d) caml_failwith("int_of_string");
if (res < (uint64_t) d) caml_failwith("int_of_string");
}
if (p != String_val(s) + caml_string_length(s)){
caml_failwith("int_of_string");
@ -549,9 +549,9 @@ CAMLprim value caml_int64_of_string(value s)
if (base == 10) {
/* Signed representation expected, allow -2^63 to 2^63 - 1 only */
if (sign >= 0) {
if (res >= (uint64)1 << 63) caml_failwith("int_of_string");
if (res >= (uint64_t)1 << 63) caml_failwith("int_of_string");
} else {
if (res > (uint64)1 << 63) caml_failwith("int_of_string");
if (res > (uint64_t)1 << 63) caml_failwith("int_of_string");
}
}
if (sign < 0) res = - res;
@ -560,20 +560,20 @@ CAMLprim value caml_int64_of_string(value s)
CAMLprim value caml_int64_bits_of_float(value vd)
{
union { double d; int64 i; int32 h[2]; } u;
union { double d; int64_t i; int32_t h[2]; } u;
u.d = Double_val(vd);
#if defined(__arm__) && !defined(__ARM_EABI__)
{ int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; }
{ int32_t t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; }
#endif
return caml_copy_int64(u.i);
}
CAMLprim value caml_int64_float_of_bits(value vi)
{
union { double d; int64 i; int32 h[2]; } u;
union { double d; int64_t i; int32_t h[2]; } u;
u.i = Int64_val(vi);
#if defined(__arm__) && !defined(__ARM_EABI__)
{ int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; }
{ int32_t t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; }
#endif
return caml_copy_double(u.d);
}
@ -606,7 +606,7 @@ static void nativeint_serialize(value v, uintnat * wsize_32,
#ifdef ARCH_SIXTYFOUR
if (l >= -((intnat)1 << 31) && l < ((intnat)1 << 31)) {
caml_serialize_int_1(1);
caml_serialize_int_4((int32) l);
caml_serialize_int_4((int32_t) l);
} else {
caml_serialize_int_1(2);
caml_serialize_int_8(l);

6
byterun/io.c
View File

@ -207,7 +207,7 @@ CAMLexport void caml_flush(struct channel *channel)
/* Output data */
CAMLexport void caml_putword(struct channel *channel, uint32 w)
CAMLexport void caml_putword(struct channel *channel, uint32_t w)
{
if (! caml_channel_binary_mode(channel))
caml_failwith("output_binary_int: not a binary channel");
@ -303,10 +303,10 @@ CAMLexport unsigned char caml_refill(struct channel *channel)
return (unsigned char)(channel->buff[0]);
}
CAMLexport uint32 caml_getword(struct channel *channel)
CAMLexport uint32_t caml_getword(struct channel *channel)
{
int i;
uint32 res;
uint32_t res;
if (! caml_channel_binary_mode(channel))
caml_failwith("input_binary_int: not a binary channel");

6
byterun/io.h
View File

@ -78,12 +78,12 @@ CAMLextern value caml_alloc_channel(struct channel *chan);
CAMLextern int caml_flush_partial (struct channel *);
CAMLextern void caml_flush (struct channel *);
CAMLextern void caml_putword (struct channel *, uint32);
CAMLextern void caml_putword (struct channel *, uint32_t);
CAMLextern int caml_putblock (struct channel *, char *, intnat);
CAMLextern void caml_really_putblock (struct channel *, char *, intnat);
CAMLextern unsigned char caml_refill (struct channel *);
CAMLextern uint32 caml_getword (struct channel *);
CAMLextern uint32_t caml_getword (struct channel *);
CAMLextern int caml_getblock (struct channel *, char *, intnat);
CAMLextern int caml_really_getblock (struct channel *, char *, intnat);
@ -107,7 +107,7 @@ CAMLextern struct channel * caml_all_opened_channels;
#define Unlock_exn() \
if (caml_channel_mutex_unlock_exn != NULL) (*caml_channel_mutex_unlock_exn)()
/* Conversion between file_offset and int64 */
/* Conversion between file_offset and int64_t */
#define Val_file_offset(fofs) caml_copy_int64(fofs)
#define File_offset_val(v) ((file_offset) Int64_val(v))

26
byterun/md5.c
View File

@ -97,11 +97,11 @@ CAMLexport void caml_md5_block(unsigned char digest[16],
#else
static void byteReverse(unsigned char * buf, unsigned longs)
{
uint32 t;
uint32_t t;
do {
t = (uint32) ((unsigned) buf[3] << 8 | buf[2]) << 16 |
t = (uint32_t) ((unsigned) buf[3] << 8 | buf[2]) << 16 |
((unsigned) buf[1] << 8 | buf[0]);
*(uint32 *) buf = t;
*(uint32_t *) buf = t;
buf += 4;
} while (--longs);
}
@ -129,12 +129,12 @@ CAMLexport void caml_MD5Init(struct MD5Context *ctx)
CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf,
uintnat len)
{
uint32 t;
uint32_t t;
/* Update bitcount */
t = ctx->bits[0];
if ((ctx->bits[0] = t + ((uint32) len << 3)) < t)
if ((ctx->bits[0] = t + ((uint32_t) len << 3)) < t)
ctx->bits[1]++; /* Carry from low to high */
ctx->bits[1] += len >> 29;
@ -152,7 +152,7 @@ CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf,
}
memcpy(p, buf, t);
byteReverse(ctx->in, 16);
caml_MD5Transform(ctx->buf, (uint32 *) ctx->in);
caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in);
buf += t;
len -= t;
}
@ -161,7 +161,7 @@ CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf,
while (len >= 64) {
memcpy(ctx->in, buf, 64);
byteReverse(ctx->in, 16);
caml_MD5Transform(ctx->buf, (uint32 *) ctx->in);
caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in);
buf += 64;
len -= 64;
}
@ -196,7 +196,7 @@ CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx)
/* Two lots of padding: Pad the first block to 64 bytes */
memset(p, 0, count);
byteReverse(ctx->in, 16);
caml_MD5Transform(ctx->buf, (uint32 *) ctx->in);
caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in);
/* Now fill the next block with 56 bytes */
memset(ctx->in, 0, 56);
@ -207,10 +207,10 @@ CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx)
byteReverse(ctx->in, 14);
/* Append length in bits and transform */
((uint32 *) ctx->in)[14] = ctx->bits[0];
((uint32 *) ctx->in)[15] = ctx->bits[1];
((uint32_t *) ctx->in)[14] = ctx->bits[0];
((uint32_t *) ctx->in)[15] = ctx->bits[1];
caml_MD5Transform(ctx->buf, (uint32 *) ctx->in);
caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in);
byteReverse((unsigned char *) ctx->buf, 4);
memcpy(digest, ctx->buf, 16);
memset(ctx, 0, sizeof(*ctx)); /* In case it's sensitive */
@ -233,9 +233,9 @@ CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx)
* reflect the addition of 16 longwords of new data. caml_MD5Update blocks
* the data and converts bytes into longwords for this routine.
*/
CAMLexport void caml_MD5Transform(uint32 *buf, uint32 *in)
CAMLexport void caml_MD5Transform(uint32_t *buf, uint32_t *in)
{
register uint32 a, b, c, d;
register uint32_t a, b, c, d;
a = buf[0];
b = buf[1];

6
byterun/md5.h
View File

@ -26,8 +26,8 @@ CAMLextern void caml_md5_block(unsigned char digest[16],
void * data, uintnat len);
struct MD5Context {
uint32 buf[4];
uint32 bits[2];
uint32_t buf[4];
uint32_t bits[2];
unsigned char in[64];
};
@ -35,7 +35,7 @@ CAMLextern void caml_MD5Init (struct MD5Context *context);
CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf,
uintnat len);
CAMLextern void caml_MD5Final (unsigned char *digest, struct MD5Context *ctx);
CAMLextern void caml_MD5Transform (uint32 *buf, uint32 *in);
CAMLextern void caml_MD5Transform (uint32_t *buf, uint32_t *in);
#endif /* CAML_MD5_H */

12
byterun/mlvalues.h
View File

@ -38,8 +38,8 @@ extern "C" {
bp: Pointer to the first byte of a block. (a char *)
op: Pointer to the first field of a block. (a value *)
hp: Pointer to the header of a block. (a char *)
int32: Four bytes on all architectures.
int64: Eight bytes on all architectures.
int32_t: Four bytes on all architectures.
int64_t: Eight bytes on all architectures.
Remark: A block size is always a multiple of the word size, and at least
one word plus the header.
@ -161,7 +161,7 @@ bits 63 10 9 8 7 0
/* Fields are numbered from 0. */
#define Field(x, i) (((value *)(x)) [i]) /* Also an l-value. */
typedef int32 opcode_t;
typedef int32_t opcode_t;
typedef opcode_t * code_t;
/* NOTE: [Forward_tag] and [Infix_tag] must be just under
@ -262,12 +262,12 @@ struct custom_operations; /* defined in [custom.h] */
/* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */
#define Int32_val(v) (*((int32 *) Data_custom_val(v)))
#define Int32_val(v) (*((int32_t *) Data_custom_val(v)))
#define Nativeint_val(v) (*((intnat *) Data_custom_val(v)))
#ifndef ARCH_ALIGN_INT64
#define Int64_val(v) (*((int64 *) Data_custom_val(v)))
#define Int64_val(v) (*((int64_t *) Data_custom_val(v)))
#else
CAMLextern int64 caml_Int64_val(value v);
CAMLextern int64_t caml_Int64_val(value v);
#define Int64_val(v) caml_Int64_val(v)
#endif

3
byterun/printexc.c
View File

@ -131,7 +131,8 @@ void caml_fatal_uncaught_exception(value exn)
{
value *handle_uncaught_exception;
handle_uncaught_exception = caml_named_value("Printexc.handle_uncaught_exception");
handle_uncaught_exception =
caml_named_value("Printexc.handle_uncaught_exception");
if (handle_uncaught_exception != NULL)
/* [Printexc.handle_uncaught_exception] does not raise exception. */
caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE));

10
byterun/startup.c
View File

@ -79,7 +79,7 @@ static void init_atoms(void)
/* Read the trailer of a bytecode file */
static void fixup_endianness_trailer(uint32 * p)
static void fixup_endianness_trailer(uint32_t * p)
{
#ifndef ARCH_BIG_ENDIAN
Reverse_32(p, p);
@ -153,7 +153,7 @@ void caml_read_section_descriptors(int fd, struct exec_trailer *trail)
Return the length of the section data in bytes, or -1 if no section
found with that name. */
int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name)
int32_t caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name)
{
long ofs;
int i;
@ -172,9 +172,9 @@ int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name)
/* Position fd at the beginning of the section having the given name.
Return the length of the section data in bytes. */
int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name)
int32_t caml_seek_section(int fd, struct exec_trailer *trail, char *name)
{
int32 len = caml_seek_optional_section(fd, trail, name);
int32_t len = caml_seek_optional_section(fd, trail, name);
if (len == -1)
caml_fatal_error_arg("Fatal_error: section `%s' is missing\n", name);
return len;
@ -185,7 +185,7 @@ int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name)
static char * read_section(int fd, struct exec_trailer *trail, char *name)
{
int32 len;
int32_t len;
char * data;
len = caml_seek_optional_section(fd, trail, name);

4
byterun/startup.h
View File

@ -30,9 +30,9 @@ enum { FILE_NOT_FOUND = -1, BAD_BYTECODE = -2 };
extern int caml_attempt_open(char **name, struct exec_trailer *trail,
int do_open_script);
extern void caml_read_section_descriptors(int fd, struct exec_trailer *trail);
extern int32 caml_seek_optional_section(int fd, struct exec_trailer *trail,
extern int32_t caml_seek_optional_section(int fd, struct exec_trailer *trail,
char *name);
extern int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name);
extern int32_t caml_seek_section(int fd, struct exec_trailer *trail, char *name);
#endif /* CAML_STARTUP_H */

20
byterun/str.c
View File

@ -101,7 +101,7 @@ CAMLprim value caml_string_get32(value str, value index)
CAMLprim value caml_string_get64(value str, value index)
{
uint64 res;
uint64_t res;
unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
intnat idx = Long_val(index);
if (idx < 0 || idx + 7 >= caml_string_length(str)) caml_array_bound_error();
@ -114,15 +114,15 @@ CAMLprim value caml_string_get64(value str, value index)
b7 = Byte_u(str, idx + 6);
b8 = Byte_u(str, idx + 7);
#ifdef ARCH_BIG_ENDIAN
res = (uint64) b1 << 56 | (uint64) b2 << 48
| (uint64) b3 << 40 | (uint64) b4 << 32
| (uint64) b5 << 24 | (uint64) b6 << 16
| (uint64) b7 << 8 | (uint64) b8;
res = (uint64_t) b1 << 56 | (uint64_t) b2 << 48
| (uint64_t) b3 << 40 | (uint64_t) b4 << 32
| (uint64_t) b5 << 24 | (uint64_t) b6 << 16
| (uint64_t) b7 << 8 | (uint64_t) b8;
#else
res = (uint64) b8 << 56 | (uint64) b7 << 48
| (uint64) b6 << 40 | (uint64) b5 << 32
| (uint64) b4 << 24 | (uint64) b3 << 16
| (uint64) b2 << 8 | (uint64) b1;
res = (uint64_t) b8 << 56 | (uint64_t) b7 << 48
| (uint64_t) b6 << 40 | (uint64_t) b5 << 32
| (uint64_t) b4 << 24 | (uint64_t) b3 << 16
| (uint64_t) b2 << 8 | (uint64_t) b1;
#endif
return caml_copy_int64(res);
}
@ -174,7 +174,7 @@ CAMLprim value caml_string_set32(value str, value index, value newval)
CAMLprim value caml_string_set64(value str, value index, value newval)
{
unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
int64 val;
int64_t val;
intnat idx = Long_val(index);
if (idx < 0 || idx + 7 >= caml_string_length(str)) caml_array_bound_error();
val = Int64_val(newval);

2
config/Makefile.mingw
View File

@ -109,7 +109,7 @@ NATIVECCLIBS=-lws2_32
CPP=$(BYTECC) -E
### Flexlink
FLEXLINK=flexlink -chain mingw -stack 16777216
FLEXLINK=flexlink -chain mingw -stack 16777216 -link -static-libgcc
FLEXDIR=$(shell $(FLEXLINK) -where)
IFLEXDIR=-I"$(FLEXDIR)"
MKDLL=$(FLEXLINK)

14
config/auto-aux/int64align.c
View File

@ -17,18 +17,18 @@
#include "m.h"
#if defined(ARCH_INT64_TYPE)
typedef ARCH_INT64_TYPE int64;
typedef ARCH_INT64_TYPE int64_t;
#elif SIZEOF_LONG == 8
typedef long int64;
typedef long int64_t;
#elif SIZEOF_LONGLONG == 8
typedef long long int64;
typedef long long int64_t;
#else
#error "No 64-bit integer type available"
#endif
int64 foo;
int64_t foo;
void access_int64(int64 *p)
void access_int64(int64_t *p)
{
foo = *p;
}
@ -49,8 +49,8 @@ int main(void)
signal(SIGBUS, sig_handler);
#endif
if(setjmp(failure) == 0) {
access_int64((int64 *) n);
access_int64((int64 *) (n+1));
access_int64((int64_t *) n);
access_int64((int64_t *) (n+1));
res = 0;
} else {
res = 1;

3
config/s-nt.h
View File

@ -15,6 +15,9 @@
#define OCAML_OS_TYPE "Win32"
#ifdef __MINGW32__
#define HAS_STDINT_H
#endif
#undef BSD_SIGNALS
#define HAS_STRERROR
#define HAS_SOCKETS

29
configure vendored
View File

@ -615,26 +615,6 @@ case "$target" in
esac
esac
# Check semantics of division and modulus
sh ./runtest divmod.c
case $? in
0) inf "Native division and modulus have round-towards-zero semantics," \
"will use them."
echo "#undef NONSTANDARD_DIV_MOD" >> m.h;;
1) inf "Native division and modulus do not have round-towards-zero"
"semantics, will use software emulation."
echo "#define NONSTANDARD_DIV_MOD" >> m.h;;
*) case $target in
*-*-mingw*) inf "Native division and modulus have round-towards-zero" \
"semantics, will use them."
echo "#undef NONSTANDARD_DIV_MOD" >> m.h;;
*) wrn "Something went wrong while checking native division and modulus"\
"please report it at http://http://caml.inria.fr/mantis/"
echo "#define NONSTANDARD_DIV_MOD" >> m.h;;
esac;;
esac
# Shared library support
shared_libraries_supported=false
@ -768,6 +748,7 @@ if test $with_sharedlibs = "yes"; then
x86_64-*-netbsd*) natdynlink=true;;
i386-*-gnu0.3) natdynlink=true;;
arm*-*-linux*) natdynlink=true;;
arm*-*-freebsd*) natdynlink=true;;
aarch64-*-linux*) natdynlink=true;;
esac
fi
@ -818,6 +799,7 @@ case "$target" in
armv7*-*-linux-gnueabi) arch=arm; model=armv7; system=linux_eabi;;
armv6t2*-*-linux-gnueabi) arch=arm; model=armv6t2; system=linux_eabi;;
armv6*-*-linux-gnueabi) arch=arm; model=armv6; system=linux_eabi;;
armv6*-*-freebsd*) arch=arm; model=armv6; system=freebsd;;
armv5te*-*-linux-gnueabi) arch=arm; model=armv5te; system=linux_eabi;;
armv5*-*-linux-gnueabi) arch=arm; model=armv5; system=linux_eabi;;
arm*-*-linux-gnueabi) arch=arm; system=linux_eabi;;
@ -893,6 +875,8 @@ case "$arch,$system" in
*gcc*) aspp="${TOOLPREF}gcc -c";;
*) aspp="${TOOLPREF}as -P";;
esac;;
arm,freebsd) as="${TOOLPREF}cc -c"
aspp="${TOOLPREF}cc -c";;
*,freebsd) as="${TOOLPREF}as"
aspp="${TOOLPREF}cc -c";;
amd64,*|arm,*|arm64,*|i386,*|power,bsd*|sparc,*)
@ -1075,6 +1059,11 @@ if sh ./hasgot -i sys/types.h -i sys/socket.h -i netinet/in.h \
echo "#define HAS_IPV6" >> s.h
fi
if sh ./hasgot -i stdint.h; then
inf "stdint.h found."
echo "#define HAS_STDINT_H" >> s.h
fi
if sh ./hasgot -i unistd.h; then
inf "unistd.h found."
echo "#define HAS_UNISTD" >> s.h

2
debugger/main.ml
View File

@ -193,7 +193,7 @@ let main () =
(Unix.string_of_inet_addr Unix.inet_addr_loopback)^
":"^
(string_of_int (10000 + ((Unix.getpid ()) mod 10000)))
| _ -> Filename.concat Filename.temp_dir_name
| _ -> Filename.concat (Filename.get_temp_dir_name ())
("camldebug" ^ (string_of_int (Unix.getpid ())))
);
begin try

2
driver/compile.ml
View File

@ -92,7 +92,7 @@ let implementation ppf sourcefile outputprefix =
++ print_if ppf Clflags.dump_lambda Printlambda.lambda
++ Bytegen.compile_implementation modulename
++ print_if ppf Clflags.dump_instr Printinstr.instrlist
++ Emitcode.to_file oc modulename;
++ Emitcode.to_file oc modulename objfile;
Warnings.check_fatal ();
close_out oc;
Stypes.dump (Some (outputprefix ^ ".annot"))

12
driver/main_args.ml
View File

@ -161,7 +161,8 @@ let mk_no_app_funct f =
;;
let mk_no_float_const_prop f =
"-no-float-const-prop", Arg.Unit f, " Deactivate constant propagation for floating-point operations"
"-no-float-const-prop", Arg.Unit f,
" Deactivate constant propagation for floating-point operations"
;;
let mk_noassert f =
@ -446,6 +447,12 @@ let mk_dstartup f =
"-dstartup", Arg.Unit f, " (undocumented)"
;;
let mk_opaque f =
"-opaque", Arg.Unit f,
" Does not generate cross-module optimization information\n\
\ (reduces necessary recompilation on module change)"
;;
let mk__ f =
"-", Arg.String f,
"<file> Treat <file> as a file name (even if it starts with `-')"
@ -515,7 +522,6 @@ module type Compiler_options = sig
val _v : unit -> unit
val _verbose : unit -> unit
val _where : unit -> unit
val _nopervasives : unit -> unit
end
;;
@ -578,6 +584,7 @@ module type Optcomp_options = sig
val _pp : string -> unit
val _S : unit -> unit
val _shared : unit -> unit
val _opaque : unit -> unit
end;;
module type Opttop_options = sig
@ -794,6 +801,7 @@ struct
mk_dscheduling F._dscheduling;
mk_dlinear F._dlinear;
mk_dstartup F._dstartup;
mk_opaque F._opaque;
]
end;;

1
driver/main_args.mli
View File

@ -137,6 +137,7 @@ module type Optcomp_options = sig
val _pp : string -> unit
val _S : unit -> unit
val _shared : unit -> unit
val _opaque : unit -> unit
end;;
module type Opttop_options = sig

1
driver/optmain.ml
View File

@ -149,6 +149,7 @@ module Options = Main_args.Make_optcomp_options (struct
let _dscheduling = set dump_scheduling
let _dlinear = set dump_linear
let _dstartup = set keep_startup_file
let _opaque = set opaque
let anonymous = anonymous
end);;

149
experimental/doligez/check-bounds.diff Normal file
View File

@ -0,0 +1,149 @@
Patch taken from:
https://github.com/mshinwell/ocaml/commits/4.02-block-bounds
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 01eff9c..b498b58 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -22,6 +22,13 @@ open Clambda
open Cmm
open Cmx_format
+let do_check_field_access = true
+(*
+ match try Some (Sys.getenv "BOUNDS") with Not_found -> None with
+ | None | Some "" -> false
+ | Some _ -> true
+*)
+
(* Local binding of complex expressions *)
let bind name arg fn =
@@ -494,6 +501,35 @@ let get_tag ptr =
let get_size ptr =
Cop(Clsr, [header ptr; Cconst_int 10])
+(* Bounds checks upon field access, for debugging the compiler *)
+
+let check_field_access ptr field_index if_success =
+ if not do_check_field_access then
+ if_success
+ else
+ let field_index = Cconst_int field_index in
+ (* If [ptr] points at an infix header, we need to move it back to the "main"
+ [Closure_tag] header. *)
+ let ptr =
+ Cifthenelse (Cop (Ccmpi Cne, [get_tag ptr; Cconst_int Obj.infix_tag]),
+ ptr,
+ Cop (Csuba, [ptr;
+ Cop (Cmuli, [get_size ptr (* == Infix_offset_val(ptr) *);
+ Cconst_int size_addr])]))
+ in
+ let not_too_small = Cop (Ccmpi Cge, [field_index; Cconst_int 0]) in
+ let not_too_big = Cop (Ccmpi Clt, [field_index; get_size ptr]) in
+ let failure =
+ Cop (Cextcall ("caml_field_access_out_of_bounds_error", typ_addr, false,
+ Debuginfo.none),
+ [ptr; field_index])
+ in
+ Cifthenelse (not_too_small,
+ Cifthenelse (not_too_big,
+ if_success,
+ failure),
+ failure)
+
(* Array indexing *)
let log2_size_addr = Misc.log2 size_addr
@@ -1550,13 +1586,18 @@ and transl_prim_1 p arg dbg =
return_unit(remove_unit (transl arg))
(* Heap operations *)
| Pfield n ->
- get_field (transl arg) n
+ let ptr = transl arg in
+ let body = get_field ptr n in
+ check_field_access ptr n body
| Pfloatfield n ->
let ptr = transl arg in
- box_float(
- Cop(Cload Double_u,
- [if n = 0 then ptr
- else Cop(Cadda, [ptr; Cconst_int(n * size_float)])]))
+ let body =
+ box_float(
+ Cop(Cload Double_u,
+ [if n = 0 then ptr
+ else Cop(Cadda, [ptr; Cconst_int(n * size_float)])]))
+ in
+ check_field_access ptr n body
| Pint_as_pointer ->
Cop(Cadda, [transl arg; Cconst_int (-1)])
(* Exceptions *)
@@ -1649,20 +1690,25 @@ and transl_prim_1 p arg dbg =
and transl_prim_2 p arg1 arg2 dbg =
match p with
(* Heap operations *)
- Psetfield(n, ptr) ->
- if ptr then
- return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none),
- [field_address (transl arg1) n; transl arg2]))
- else
- return_unit(set_field (transl arg1) n (transl arg2))
+ Psetfield(n, is_ptr) ->
+ let ptr = transl arg1 in
+ let body =
+ if is_ptr then
+ Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none),
+ [field_address ptr n; transl arg2])
+ else
+ set_field ptr n (transl arg2)
+ in
+ check_field_access ptr n (return_unit body)
| Psetfloatfield n ->
let ptr = transl arg1 in
- return_unit(
+ let body =
Cop(Cstore Double_u,
[if n = 0 then ptr
else Cop(Cadda, [ptr; Cconst_int(n * size_float)]);
- transl_unbox_float arg2]))
-
+ transl_unbox_float arg2])
+ in
+ check_field_access ptr n (return_unit body)
(* Boolean operations *)
| Psequand ->
Cifthenelse(test_bool(transl arg1), transl arg2, Cconst_int 1)
diff --git a/asmrun/fail.c b/asmrun/fail.c
index cb2c1cb..4f67c74 100644
--- a/asmrun/fail.c
+++ b/asmrun/fail.c
@@ -15,6 +15,7 @@
#include <stdio.h>
#include <signal.h>
+#include <assert.h>
#include "alloc.h"
#include "fail.h"
#include "io.h"
@@ -180,3 +181,20 @@ int caml_is_special_exception(value exn) {
|| exn == (value) caml_exn_Assert_failure
|| exn == (value) caml_exn_Undefined_recursive_module;
}
+
+void caml_field_access_out_of_bounds_error(value v_block, intnat index)
+{
+ assert(Is_block(v_block));
+ fprintf(stderr, "Fatal error: out-of-bounds access to field %ld ", index);
+ fprintf(stderr, "of block at %p (%s, size %ld, tag %d)\n",
+ (void*) v_block,
+ Is_young(v_block) ? "in minor heap"
+ : Is_in_heap(v_block) ? "in major heap"
+ : Is_in_value_area(v_block) ? "in static data"
+ : "out-of-heap",
+ (long) Wosize_val(v_block), (int) Tag_val(v_block));
+ fflush(stderr);
+ /* This error may have occurred in places where it is not reasonable to
+ attempt to continue. */
+ abort();
+}

28
lex/compact.ml
View File

@ -92,13 +92,13 @@ type t_compact =
mutable c_last_used : int ; }
let create_compact () =
{ c_trans = Array.create 1024 0 ;
c_check = Array.create 1024 (-1) ;
{ c_trans = Array.make 1024 0 ;
c_check = Array.make 1024 (-1) ;
c_last_used = 0 ; }
let reset_compact c =
c.c_trans <- Array.create 1024 0 ;
c.c_check <- Array.create 1024 (-1) ;
c.c_trans <- Array.make 1024 0 ;
c.c_check <- Array.make 1024 (-1) ;
c.c_last_used <- 0
(* One compacted table for transitions, one other for memory actions *)
@ -110,9 +110,9 @@ let grow_compact c =
let old_trans = c.c_trans
and old_check = c.c_check in
let n = Array.length old_trans in
c.c_trans <- Array.create (2*n) 0;
c.c_trans <- Array.make (2*n) 0;
Array.blit old_trans 0 c.c_trans 0 c.c_last_used;
c.c_check <- Array.create (2*n) (-1);
c.c_check <- Array.make (2*n) (-1);
Array.blit old_check 0 c.c_check 0 c.c_last_used
let do_pack state_num orig compact =
@ -142,8 +142,8 @@ let do_pack state_num orig compact =
(base, default)
let pack_moves state_num move_t =
let move_v = Array.create 257 0
and move_m = Array.create 257 0 in
let move_v = Array.make 257 0
and move_m = Array.make 257 0 in
for i = 0 to 256 do
let act,c = move_t.(i) in
move_v.(i) <- (match act with Backtrack -> -1 | Goto n -> n) ;
@ -175,12 +175,12 @@ type lex_tables =
let compact_tables state_v =
let n = Array.length state_v in
let base = Array.create n 0
and backtrk = Array.create n (-1)
and default = Array.create n 0
and base_code = Array.create n 0
and backtrk_code = Array.create n 0
and default_code = Array.create n 0 in
let base = Array.make n 0
and backtrk = Array.make n (-1)
and default = Array.make n 0
and base_code = Array.make n 0
and backtrk_code = Array.make n 0
and default_code = Array.make n 0 in
for i = 0 to n - 1 do
match state_v.(i) with
| Perform (n,c) ->

2
lex/cset.ml
View File

@ -81,7 +81,7 @@ let complement s = diff all_chars s
let env_to_array env = match env with
| [] -> assert false
| (_,x)::rem ->
let res = Array.create 257 x in
let res = Array.make 257 x in
List.iter
(fun (c,y) ->
List.iter

6
lex/lexgen.ml
View File

@ -589,7 +589,7 @@ let rec firstpos = function
(* Berry-sethi followpos *)
let followpos size entry_list =
let v = Array.create size TransSet.empty in
let v = Array.make size TransSet.empty in
let rec fill s = function
| Empty|Action _|Tag _ -> ()
| Chars (n,_) -> v.(n) <- s
@ -1132,7 +1132,7 @@ let make_tag_entry id start act a r = match a with
| _ -> r
let extract_tags l =
let envs = Array.create (List.length l) TagMap.empty in
let envs = Array.make (List.length l) TagMap.empty in
List.iter
(fun (act,m,_) ->
envs.(act) <-
@ -1186,7 +1186,7 @@ let make_dfa lexdef =
done ;
eprintf "%d states\n" !next_state_num ;
*)
let actions = Array.create !next_state_num (Perform (0,[])) in
let actions = Array.make !next_state_num (Perform (0,[])) in
List.iter (fun (act, i) -> actions.(i) <- act) states;
(* Useless state reset, so as to restrict GC roots *)
reset_state () ;

2
lex/output.ml
View File

@ -77,7 +77,7 @@ let output_entry sourcefile ic oc has_refill oci e =
output_args e.auto_args
(fun oc x ->
if x > 0 then
fprintf oc "lexbuf.Lexing.lex_mem <- Array.create %d (-1) ; " x)
fprintf oc "lexbuf.Lexing.lex_mem <- Array.make %d (-1) ; " x)
e.auto_mem_size
(output_memory_actions " ") init_moves
e.auto_name

2
lex/outputbis.ml
View File

@ -20,7 +20,7 @@ let output_auto_defs oc has_refill =
output_string oc
"let __ocaml_lex_init_lexbuf lexbuf mem_size =\
\n let pos = lexbuf.Lexing.lex_curr_pos in\
\n lexbuf.Lexing.lex_mem <- Array.create mem_size (-1) ;\
\n lexbuf.Lexing.lex_mem <- Array.make mem_size (-1) ;\
\n lexbuf.Lexing.lex_start_pos <- pos ;\
\n lexbuf.Lexing.lex_last_pos <- pos ;\
\n lexbuf.Lexing.lex_last_action <- -1\

4
lex/table.ml
View File

@ -15,12 +15,12 @@ type 'a t = {mutable next : int ; mutable data : 'a array}
let default_size = 32
;;
let create x = {next = 0 ; data = Array.create default_size x}
let create x = {next = 0 ; data = Array.make default_size x}
and reset t = t.next <- 0
;;
let incr_table table new_size =
let t = Array.create new_size table.data.(0) in
let t = Array.make new_size table.data.(0) in
Array.blit table.data 0 t 0 (Array.length table.data) ;
table.data <- t

6
man/ocamldoc.m
View File

@ -181,7 +181,7 @@ Several
.B -load
options can be given.
.TP
.BI \-m flags
.BI \-m \ flags
Specify merge options between interfaces and implementations.
.I flags
can be one or several of the following characters:
@ -442,11 +442,11 @@ option:
Generate man pages only for modules, module types, classes and class types,
instead of pages for all elements.
.TP
.BI \-man\-suffix suffix
.BI \-man\-suffix \ suffix
Set the suffix used for generated man filenames. Default is o, as in
.IR List.o .
.TP
.BI \-man\-section section
.BI \-man\-section \ section
Set the section number used for generated man filenames. Default is 3.

10
man/ocamlopt.m
View File

@ -682,17 +682,13 @@ Disable Thumb/Thumb-2 code generation
.P
The default values for target architecture, floating-point hardware
and thumb usage were selected at configure-time when building
.BR ocamlopt
.B ocamlopt
itself. This configuration can be inspected using
.BR ocamlopt
.BR \-config .
.BR ocamlopt\ \-config .
Target architecture depends on the "model" setting, while
floating-point hardware and thumb support are determined from the ABI
setting in "system" (
.BR linux_eabi
or
.BR linux_eabihf
).
.BR linux_eabi or linux_eabihf ).
.SH SEE ALSO
.BR ocamlc (1).

55
ocamlbuild/.depend
View File

@ -1,6 +1,6 @@
bool.cmi :
command.cmi : tags.cmi signatures.cmi
configuration.cmi : tags.cmi pathname.cmi
configuration.cmi : tags.cmi pathname.cmi loc.cmi
digest_cache.cmi :
discard_printf.cmi :
display.cmi : tags.cmi
@ -27,10 +27,10 @@ ocaml_tools.cmi : tags.cmi rule.cmi pathname.cmi command.cmi
ocaml_utils.cmi : tags.cmi pathname.cmi command.cmi
ocamlbuild.cmi :
ocamlbuild_executor.cmi :
ocamlbuild_plugin.cmi : ocamlbuild_pack.cmi
ocamlbuild_unix_plugin.cmi : ocamlbuild_pack.cmi
ocamlbuild_plugin.cmi :
ocamlbuild_unix_plugin.cmi :
ocamlbuild_where.cmi :
ocamlbuildlight.cmi : ocamlbuild_pack.cmi
ocamlbuildlight.cmi :
options.cmi : slurp.cmi signatures.cmi command.cmi
param_tags.cmi : tags.cmi loc.cmi
pathname.cmi : signatures.cmi
@ -48,13 +48,15 @@ tools.cmi : tags.cmi pathname.cmi
bool.cmo : bool.cmi
bool.cmx : bool.cmi
command.cmo : tags.cmi shell.cmi param_tags.cmi my_unix.cmi my_std.cmi \
log.cmi lexers.cmi command.cmi
log.cmi lexers.cmi const.cmo command.cmi
command.cmx : tags.cmx shell.cmx param_tags.cmx my_unix.cmx my_std.cmx \
log.cmx lexers.cmx command.cmi
log.cmx lexers.cmx const.cmx command.cmi
configuration.cmo : tags.cmi param_tags.cmi my_std.cmi log.cmi loc.cmi \
lexers.cmi glob.cmi configuration.cmi
lexers.cmi glob.cmi const.cmo configuration.cmi
configuration.cmx : tags.cmx param_tags.cmx my_std.cmx log.cmx loc.cmx \
lexers.cmx glob.cmx configuration.cmi
lexers.cmx glob.cmx const.cmx configuration.cmi
const.cmo :
const.cmx :
digest_cache.cmo : shell.cmi pathname.cmi options.cmi my_unix.cmi my_std.cmi \
digest_cache.cmi
digest_cache.cmx : shell.cmx pathname.cmx options.cmx my_unix.cmx my_std.cmx \
@ -67,8 +69,10 @@ exit_codes.cmo : exit_codes.cmi
exit_codes.cmx : exit_codes.cmi
fda.cmo : pathname.cmi options.cmi log.cmi hygiene.cmi fda.cmi
fda.cmx : pathname.cmx options.cmx log.cmx hygiene.cmx fda.cmi
findlib.cmo : my_unix.cmi my_std.cmi lexers.cmi command.cmi findlib.cmi
findlib.cmx : my_unix.cmx my_std.cmx lexers.cmx command.cmx findlib.cmi
findlib.cmo : my_unix.cmi my_std.cmi lexers.cmi const.cmo command.cmi \
findlib.cmi
findlib.cmx : my_unix.cmx my_std.cmx lexers.cmx const.cmx command.cmx \
findlib.cmi
flags.cmo : tags.cmi param_tags.cmi log.cmi command.cmi bool.cmi flags.cmi
flags.cmx : tags.cmx param_tags.cmx log.cmx command.cmx bool.cmx flags.cmi
glob.cmo : my_std.cmi glob_lexer.cmi glob_ast.cmi bool.cmi glob.cmi
@ -93,14 +97,14 @@ main.cmo : tools.cmi tags.cmi solver.cmi slurp.cmi shell.cmi rule.cmi \
resource.cmi report.cmi plugin.cmi pathname.cmi param_tags.cmi \
options.cmi ocaml_utils.cmi ocaml_specific.cmi ocaml_dependencies.cmi \
my_unix.cmi my_std.cmi log.cmi loc.cmi lexers.cmi hooks.cmi flags.cmi \
fda.cmi exit_codes.cmi digest_cache.cmi configuration.cmi command.cmi \
main.cmi
fda.cmi exit_codes.cmi digest_cache.cmi const.cmo configuration.cmi \
command.cmi main.cmi
main.cmx : tools.cmx tags.cmx solver.cmx slurp.cmx shell.cmx rule.cmx \
resource.cmx report.cmx plugin.cmx pathname.cmx param_tags.cmx \
options.cmx ocaml_utils.cmx ocaml_specific.cmx ocaml_dependencies.cmx \
my_unix.cmx my_std.cmx log.cmx loc.cmx lexers.cmx hooks.cmx flags.cmx \
fda.cmx exit_codes.cmx digest_cache.cmx configuration.cmx command.cmx \
main.cmi
fda.cmx exit_codes.cmx digest_cache.cmx const.cmx configuration.cmx \
command.cmx main.cmi
my_std.cmo : my_std.cmi
my_std.cmx : my_std.cmi
my_unix.cmo : my_std.cmi my_unix.cmi
@ -132,18 +136,19 @@ ocaml_tools.cmx : tools.cmx tags.cmx rule.cmx pathname.cmx options.cmx \
ocaml_utils.cmx ocaml_compiler.cmx my_std.cmx flags.cmx command.cmx \
ocaml_tools.cmi
ocaml_utils.cmo : tools.cmi tags.cmi pathname.cmi param_tags.cmi options.cmi \
my_std.cmi log.cmi lexers.cmi flags.cmi command.cmi ocaml_utils.cmi
my_std.cmi log.cmi lexers.cmi flags.cmi const.cmo command.cmi \
ocaml_utils.cmi
ocaml_utils.cmx : tools.cmx tags.cmx pathname.cmx param_tags.cmx options.cmx \
my_std.cmx log.cmx lexers.cmx flags.cmx command.cmx ocaml_utils.cmi
my_std.cmx log.cmx lexers.cmx flags.cmx const.cmx command.cmx \
ocaml_utils.cmi
ocamlbuild.cmo : ocamlbuild_unix_plugin.cmi ocamlbuild.cmi
ocamlbuild.cmx : ocamlbuild_unix_plugin.cmx ocamlbuild.cmi
ocamlbuild_config.cmo :
ocamlbuild_config.cmx :
ocamlbuild_executor.cmo : ocamlbuild_executor.cmi
ocamlbuild_executor.cmx : ocamlbuild_executor.cmi
ocamlbuild_pack.cmo : ocamlbuild_pack.cmi
ocamlbuild_plugin.cmo : ocamlbuild_plugin.cmi ocamlbuild_pack.cmo
ocamlbuild_plugin.cmx : ocamlbuild_plugin.cmi ocamlbuild_pack.cmx
ocamlbuild_plugin.cmo : ocamlbuild_plugin.cmi
ocamlbuild_plugin.cmx : ocamlbuild_plugin.cmi
ocamlbuild_unix_plugin.cmo : ocamlbuild_executor.cmi my_unix.cmi my_std.cmi \
exit_codes.cmi ocamlbuild_unix_plugin.cmi
ocamlbuild_unix_plugin.cmx : ocamlbuild_executor.cmx my_unix.cmx my_std.cmx \
@ -153,9 +158,9 @@ ocamlbuild_where.cmx : ocamlbuild_config.cmx ocamlbuild_where.cmi
ocamlbuildlight.cmo : ocamlbuildlight.cmi
ocamlbuildlight.cmx : ocamlbuildlight.cmi
options.cmo : shell.cmi ocamlbuild_where.cmi ocamlbuild_config.cmo \
my_std.cmi log.cmi lexers.cmi command.cmi options.cmi
my_std.cmi log.cmi lexers.cmi const.cmo command.cmi options.cmi
options.cmx : shell.cmx ocamlbuild_where.cmx ocamlbuild_config.cmx \
my_std.cmx log.cmx lexers.cmx command.cmx options.cmi
my_std.cmx log.cmx lexers.cmx const.cmx command.cmx options.cmi
param_tags.cmo : tags.cmi my_std.cmi log.cmi loc.cmi lexers.cmi \
param_tags.cmi
param_tags.cmx : tags.cmx my_std.cmx log.cmx loc.cmx lexers.cmx \
@ -166,10 +171,10 @@ pathname.cmx : shell.cmx options.cmx my_unix.cmx my_std.cmx log.cmx glob.cmx \
pathname.cmi
plugin.cmo : tools.cmi tags.cmi shell.cmi rule.cmi pathname.cmi \
param_tags.cmi options.cmi ocamlbuild_where.cmi my_unix.cmi my_std.cmi \
log.cmi command.cmi plugin.cmi
log.cmi const.cmo command.cmi plugin.cmi
plugin.cmx : tools.cmx tags.cmx shell.cmx rule.cmx pathname.cmx \
param_tags.cmx options.cmx ocamlbuild_where.cmx my_unix.cmx my_std.cmx \
log.cmx command.cmx plugin.cmi
log.cmx const.cmx command.cmx plugin.cmi
ppcache.cmo : shell.cmi pathname.cmi my_std.cmi log.cmi command.cmi \
ppcache.cmi
ppcache.cmx : shell.cmx pathname.cmx my_std.cmx log.cmx command.cmx \
@ -178,10 +183,10 @@ report.cmo : solver.cmi resource.cmi my_std.cmi log.cmi glob.cmi report.cmi
report.cmx : solver.cmx resource.cmx my_std.cmx log.cmx glob.cmx report.cmi
resource.cmo : slurp.cmi shell.cmi pathname.cmi options.cmi my_unix.cmi \
my_std.cmi log.cmi lexers.cmi glob_ast.cmi glob.cmi digest_cache.cmi \
command.cmi resource.cmi
const.cmo command.cmi resource.cmi
resource.cmx : slurp.cmx shell.cmx pathname.cmx options.cmx my_unix.cmx \
my_std.cmx log.cmx lexers.cmx glob_ast.cmx glob.cmx digest_cache.cmx \
command.cmx resource.cmi
const.cmx command.cmx resource.cmi
rule.cmo : shell.cmi resource.cmi pathname.cmi options.cmi my_std.cmi \
log.cmi digest_cache.cmi command.cmi rule.cmi
rule.cmx : shell.cmx resource.cmx pathname.cmx options.cmx my_std.cmx \

1
ocamlbuild/Makefile
View File

@ -23,6 +23,7 @@ COMPFLAGS= -warn-error A -w L -w R -w Z -I ../otherlibs/$(UNIXLIB) -safe-string
LINKFLAGS= -I ../otherlibs/$(UNIXLIB)
PACK_CMO=\
const.cmo \
loc.cmo \
discard_printf.cmo \
signatures.cmi \

5
ocamlbuild/command.ml
View File

@ -99,10 +99,7 @@ let env_path = lazy begin
Lexers.parse_environment_path
in
let paths =
try
parse_path (Lexing.from_string path_var)
with Lexers.Error (msg,pos) -> raise (Lexers.Error ("$PATH: " ^ msg, pos))
in
parse_path Const.Source.path (Lexing.from_string path_var) in
let norm_current_dir_name path =
if path = "" then Filename.current_dir_name else path
in

26
ocamlbuild/configuration.ml
View File

@ -18,31 +18,35 @@ open Lexers
type t = Lexers.conf
let acknowledge_config config =
let ack (tag, loc) = Param_tags.acknowledge (Some loc) tag in
let acknowledge_config source config =
let ack (tag, loc) = Param_tags.acknowledge source (Some loc) tag in
List.iter (fun (_, config) -> List.iter ack config.plus_tags) config
let cache = Hashtbl.create 107
let (configs, add_config) =
let configs = ref [] in
(fun () -> !configs),
(fun config ->
acknowledge_config config;
(fun source config ->
acknowledge_config source config;
configs := config :: !configs;
Hashtbl.clear cache)
let parse_lexbuf ?dir source lexbuf =
lexbuf.Lexing.lex_curr_p <-
{ lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = source };
let conf = Lexers.conf_lines dir lexbuf in
add_config conf
let conf = Lexers.conf_lines dir source lexbuf in
add_config source conf
let parse_string s =
parse_lexbuf (Printf.sprintf "STRING(%s)" s) (Lexing.from_string s)
let parse_string ?source s =
let source = match source with
| Some source -> source
| None -> Const.Source.configuration
in
parse_lexbuf source (lexbuf_of_string s)
let parse_file ?dir file =
with_input_file file begin fun ic ->
parse_lexbuf ?dir file (Lexing.from_channel ic)
let lexbuf = Lexing.from_channel ic in
set_lexbuf_fname file lexbuf;
parse_lexbuf ?dir Const.Source.file lexbuf
end
let key_match = Glob.eval

2
ocamlbuild/configuration.mli
View File

@ -18,7 +18,7 @@
(** Incorporate a newline-separated configuration string into the current configuration.
Will usually raising an [Invalid_arg] with an appropriately explicit message in case of error. *)
val parse_string : string -> unit
val parse_string : ?source:Loc.source -> string -> unit
(** [parse_file ?dir fn] incorporates the configuration file named [fn], prefixing its glob patterns
with [dir] if given. *)

11
ocamlbuild/const.ml Normal file
View File

@ -0,0 +1,11 @@
module Source = struct
let file = "file"
let command_line = "command-line"
let path = "path"
let ocamlfind_query = "ocamlfind query"
let ocamldep = "ocamldep"
let target_pattern = "target pattern"
let builtin = "builtin configuration"
let configuration = "configuration"
let plugin_tag = "plugin tag"
end

10
ocamlbuild/findlib.ml
View File

@ -74,15 +74,19 @@ let rec query name =
with Not_found ->
try
let n, d, v, a_byte, lo, l =
run_and_parse Lexers.ocamlfind_query
run_and_parse
(Lexers.ocamlfind_query Const.Source.ocamlfind_query)
"%s query -l -predicates byte %s" ocamlfind name
in
let a_native =
run_and_parse Lexers.trim_blanks
run_and_parse
(Lexers.trim_blanks Const.Source.ocamlfind_query)
"%s query -a-format -predicates native %s" ocamlfind name
in
let deps =
run_and_parse Lexers.blank_sep_strings "%s query -r -p-format %s" ocamlfind name
run_and_parse
(Lexers.blank_sep_strings Const.Source.ocamlfind_query)
"%s query -r -p-format %s" ocamlfind name
in
let deps = List.filter ((<>) n) deps in
let deps =

Some files were not shown because too many files have changed in this diff Show More