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

fusion des changements 3.09.1 -> 3.09.2 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@7382 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Damien Doligez 2006-04-16 23:28:22 +00:00
parent 8604fbe7f3
commit 1279ab4b76
50 changed files with 496 additions and 289 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
.depend
View File

@ -747,22 +747,24 @@ toplevel/topdirs.cmx: utils/warnings.cmx typing/types.cmx toplevel/trace.cmx \
bytecomp/emitcode.cmx bytecomp/dll.cmx typing/ctype.cmx \
utils/consistbl.cmx utils/config.cmx utils/clflags.cmx \
toplevel/topdirs.cmi
toplevel/toploop.cmo: utils/warnings.cmi typing/types.cmi typing/typemod.cmi \
typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
bytecomp/symtable.cmi bytecomp/simplif.cmi typing/printtyp.cmi \
bytecomp/printlambda.cmi bytecomp/printinstr.cmi parsing/printast.cmi \
typing/predef.cmi typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \
toplevel/toploop.cmo: utils/warnings.cmi typing/unused_var.cmi \
typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \
typing/typecore.cmi bytecomp/translmod.cmi bytecomp/symtable.cmi \
bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
bytecomp/printinstr.cmi parsing/printast.cmi typing/predef.cmi \
typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \
typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi \
parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \
typing/ident.cmi toplevel/genprintval.cmi driver/errors.cmi \
typing/env.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \
utils/config.cmi driver/compile.cmi utils/clflags.cmi \
bytecomp/bytegen.cmi typing/btype.cmi toplevel/toploop.cmi
toplevel/toploop.cmx: utils/warnings.cmx typing/types.cmx typing/typemod.cmx \
typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
bytecomp/symtable.cmx bytecomp/simplif.cmx typing/printtyp.cmx \
bytecomp/printlambda.cmx bytecomp/printinstr.cmx parsing/printast.cmx \
typing/predef.cmx typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \
toplevel/toploop.cmx: utils/warnings.cmx typing/unused_var.cmx \
typing/types.cmx typing/typemod.cmx typing/typedtree.cmx \
typing/typecore.cmx bytecomp/translmod.cmx bytecomp/symtable.cmx \
bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
bytecomp/printinstr.cmx parsing/printast.cmx typing/predef.cmx \
typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \
typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx \
parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \
typing/ident.cmx toplevel/genprintval.cmx driver/errors.cmx \

82
Changes
View File

@ -7,6 +7,36 @@ Language features:
definition replaces the old one, rather than creating a new
variable.
Objective Caml 3.09.2:
----------------------
Bug fixes:
- Makefile: problem with "make world.opt" PR#3954
- compilers: problem compiling several modules with one command line PR#3979
- compilers,ocamldoc: error message that Emacs cannot parse
- compilers: crash when printing type error PR#3968
- compilers: -dtypes wrong for monomorphic type variables PR#3894
- compilers: wrong warning on optional arguments PR#3980
- compilers: crash when wrong use of type constructor in let rec PR#3976
- compilers: better wording of "statement never returns" warning PR#3889
- runtime: inefficiency of signal handling PR#3990
- runtime: crashes with I/O in multithread programs PR#3906
- camlp4: empty file name in error messages PR#3886
- camlp4: stack overflow PR#3948
- otherlibs/labltk: ocamlbrowser ignores its command line options PR#3961
- otherlibs/unix: Unix.times wrong under Mac OS X PR#3960
- otherlibs/unix: wrong doc for execvp and execvpe PR#3973
- otherlibs/win32unix: random crash in Unix.stat PR#3998
- stdlib: update_mod not found under Windows PR#3847
- stdlib: Filename.dirname/basename wrong on Win32 PR#3933
- stdlib: incomplete documentation of Pervasives.abs PR#3967
- stdlib: Printf bugs PR#3902, PR#3955
- tools/checkstack.c missing include
- yacc: crash when given argument "-" PR#3956
New features:
- ported to MacOS X on Intel PR#3985
- configure: added support for GNU Hurd PR#3991
Objective Caml 3.09.1:
----------------------
@ -16,7 +46,7 @@ Bug fixes:
- compilers: assert failure in typeclass.cml PR#3856
- compilers: assert failure in typing/ctype.ml PR#3909
- compilers: fatal error exception Ctype.Unify PR#3918
- compilers: spurious warning Y PR#3868
- compilers: spurious warning Y in objects PR#3868
- compilers: spurious warning Z on loop index PR#3907
- compilers: error message that emacs cannot parse
- ocamlopt: problems with -for-pack/-pack PR#3825, PR#3826, PR#3919
@ -70,7 +100,7 @@ Both compilers:
Native-code compiler (ocamlopt):
* Revised implementation of the -pack option (packing of several compilation
units into one). The .cmx files that are to be packed with
units into one). The .cmx files that are to be packed with
"ocamlopt -pack -o P.cmx" must be compiled with "ocamlopt -for-pack P".
In exchange for this additional constraint, ocamlopt -pack is now
available on all platforms (no need for binutils).
@ -290,7 +320,7 @@ Both compilers:
.cmi / .cmo / .cmx files.
Bytecode compiler:
- Option -output-obj is now compatible with Dynlink and
- Option -output-obj is now compatible with Dynlink and
with embedded toplevels.
Native-code compiler:
@ -373,7 +403,7 @@ Language features:
(written with an 'l', 'n' or 'L' suffix respectively).
Type-checking:
- Allow polymorphic generalization of covariant parts of expansive
- Allow polymorphic generalization of covariant parts of expansive
expressions. For instance, if f: unit -> 'a list, "let x = f ()"
gives "x" the generalized type forall 'a. 'a list, instead of '_a list
as before.
@ -432,7 +462,7 @@ Native-code compiler:
Small performance tweaks for the Pentium 4.
Fixed illegal "imul" instruction generated by reloading phase.
- Sparc port:
Enhanced code generation for Sparc V8 (option -march=v8) and
Enhanced code generation for Sparc V8 (option -march=v8) and
Sparc V9 (option -march=v9).
Profiling support added for Solaris.
- PowerPC port:
@ -590,7 +620,7 @@ Run-time system:
- Better support for lazy data in the garbage collector.
- Fixed issues with the heap compactor.
- Fixed issues with finalized Caml values.
- The type "int64" is now supported on all platforms: we use software
- The type "int64" is now supported on all platforms: we use software
emulation if the C compiler doesn't support 64-bit integers.
- Support for float formats that are neither big-endian nor little-endian
(one known example: the ARM).
@ -636,12 +666,12 @@ Standard library:
Other libraries:
- Bigarray:
support for bigarrays of complex numbers;
support for bigarrays of complex numbers;
added functions Genarray.dims,
{Genarray,Array1,Array2,Array3}.{kind,layout}.
- Dynlink: fixed bug with loading of mixed-mode Caml/C libraries.
- LablTK:
now supports also the CamlTK API (no labels);
now supports also the CamlTK API (no labels);
support for Activate and Deactivate events;
support for virtual events;
added UTF conversion;
@ -672,7 +702,7 @@ Windows port:
- Graphics library: fixed several bugs in event handling.
- Threads library: fixed preemption bug.
- Unix library: better handling of the underlying differences between
sockets and regular file descriptors;
sockets and regular file descriptors;
added Unix.lockf and a better Unix.rename (thanks to Tracy Camp).
- LablTk library: fixed a bug in Fileinput
@ -718,15 +748,15 @@ Standard library:
- Pervasives.float_of_string: now raises Failure on ill-formed input.
- Pervasives: added useful float constants max_float, min_float, epsilon_float.
- printf functions in Printf and Format: added % formats for int32, nativeint,
int64; "*" in width and precision specifications now supported
int64; "*" in width and precision specifications now supported
(contributed by Thorsten Ohl).
- Added Hashtbl.copy, Stack.copy.
- Hashtbl: revised resizing strategy to avoid quadratic behavior
- Hashtbl: revised resizing strategy to avoid quadratic behavior
on Hashtbl.add.
- New module MoreLabels providing labelized versions of modules
Hashtbl, Map and Set.
- Pervasives.output_value and Marshal.to_* : improved hashing strategy
for internal data structures, avoid excessive slowness on
for internal data structures, avoid excessive slowness on
quasi-linearly-allocated inputs.
Other libraries:
@ -839,7 +869,7 @@ Byte-code compiler:
variables.
Native-code compiler:
- Removed re-sharing of string literals, causes too many surprises with
- Removed re-sharing of string literals, causes too many surprises with
in-place string modifications.
- Corrected wrong compilation of toplevel "include" statements.
- Fixed bug in runtime function "callbackN_exn".
@ -908,11 +938,11 @@ New ports:
- Cygwin under MS Windows. This port is an alternative to the earlier
Windows port of OCaml, which relied on MS compilers; the Cygwin
Windows port does not need MS Visual C++ nor MASM, runs faster
in bytecode, and has a better implementation of the Unix library,
in bytecode, and has a better implementation of the Unix library,
but currently lacks threads and COM component support.
Type-checking:
- Relaxed "monomorphic restriction" on type constructors in a
- Relaxed "monomorphic restriction" on type constructors in a
mutually-recursive type definition, e.g. the following is again allowed
type u = C of int t | D of string t and 'a t = ...
- Fixed name-capture bug in "include SIG" and "SIG with ..." constructs.
@ -926,7 +956,7 @@ Type-checking:
Both compilers:
- Revised compilation of pattern matching.
- Option -I +<subdir> to search a subdirectory <subdir> of the standard
library directory (i.e. write "ocamlc -I +labltk" instead of
library directory (i.e. write "ocamlc -I +labltk" instead of
"ocamlc -I /usr/local/lib/ocaml/labltk").
- Option -warn-error to turn warnings into errors.
- Option -where to print the location of the standard library directory.
@ -970,7 +1000,7 @@ Standard library:
- Module Hashtbl: added Hashtbl.replace.
- Module Int64: added bits_of_float, float_of_bits (access to IEEE 754
representation of floats).
- Module List: List.partition now tail-rec;
- Module List: List.partition now tail-rec;
improved memory behavior of List.stable_sort.
- Module Nativeint: added Nativeint.size (number of bits in a nativeint).
- Module Obj: fixed incorrect resizing of float arrays in Obj.resize.
@ -1107,7 +1137,7 @@ Other libraries:
- Dbm: fixed bug with Dbm.iter on empty database.
New or updated ports:
- Alpha/Digital Unix: lifted 256M limitation on total memory space
- Alpha/Digital Unix: lifted 256M limitation on total memory space
induced by -taso
- Port to AIX 4.3 on PowerPC
- Port to HPUX 10 on HPPA
@ -1150,8 +1180,8 @@ Syntax:
the equivalent "# LINENO" is still supported.
Typing:
- When an incomplete pattern-matching is detected, report also a
value or value template that is not covered by the cases of
- When an incomplete pattern-matching is detected, report also a
value or value template that is not covered by the cases of
the pattern-matching.
- Several bugs in class type matching and in type error reporting fixed.
- Added an option -rectypes to support general recursive types,
@ -1520,7 +1550,7 @@ Objective Caml 1.06:
in class type declared in module signature).
- Objects can be compared using generic comparison functions.
- Fixed compilation of partial application of object constructors.
* Type system:
- Occur-check now more strict (all recursions must traverse an object).
- A few bugs fixed.
@ -1635,7 +1665,7 @@ Objective Caml 1.04:
- At toplevel, allow several phrases without intermediate ";;".
* Typing:
- Allow constraints on datatype parameters, e.g.
- Allow constraints on datatype parameters, e.g.
type 'a foo = ... constraint 'a = 'b * 'c.
- Fixed bug in signature matching in presence of free type variables '_a.
- Extensive cleanup of internals of type inference.
@ -1737,7 +1767,7 @@ Objective Caml 1.03:
Objective Caml 1.02:
--------------------
* Typing:
* Typing:
- fixed bug with type names escaping their scope via unification
with non-generalized type variables '_a;
- keep #class abbreviations longer;
@ -1781,7 +1811,7 @@ Objective Caml 1.02:
- added -thread option to select a thread-safe version of the
standard library, the ThreadIO module is no longer needed.
* The "graph" library: avoid invalid pixmaps when doing
* The "graph" library: avoid invalid pixmaps when doing
open_graph/close_graph several times.
* The "dynlink" library: support for "private" (no re-export) dynamic loading.
@ -1794,7 +1824,7 @@ Objective Caml 1.02:
Objective Caml 1.01:
--------------------
* Typing: better report of type incompatibilities;
* Typing: better report of type incompatibilities;
non-generalizable type variables in a struct...end no longer flagged
immediately as an error;
name clashes during "open" avoided.
@ -2001,7 +2031,7 @@ Caml Special Light 1.07:
* Syntax: optional ;; allowed in compilation units and structures
(back by popular demand)
* cslopt:
* cslopt:
generic handling of float arrays fixed
direct function application when the function expr is not a path fixed
compilation of "let rec" over values fixed

4
Makefile
View File

@ -226,8 +226,8 @@ opt-core:runtimeopt ocamlopt libraryopt
opt: runtimeopt ocamlopt libraryopt otherlibrariesopt camlp4opt
# Native-code versions of the tools
opt.opt: checkstack core ocaml opt-core ocamlc.opt otherlibraries camlp4out \
$(DEBUGGER) ocamldoc ocamlopt.opt otherlibrariesopt \
opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \
camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt otherlibrariesopt \
camlp4opt ocamllex.opt ocamltoolsopt.opt camlp4optopt ocamldoc.opt
# Installation

2
asmcomp/alpha/emit.mlp
View File

@ -281,7 +281,7 @@ let emit_call_gc gc =
let rdata_section =
match Config.system with
"digital" -> ".rdata"
| "linux" | "openbsd" | "netbsd" | "freebsd" -> ".section .rodata"
| "linux" | "openbsd" | "netbsd" | "freebsd" | "gnu" -> ".section .rodata"
| _ -> assert false
(* Names of various instructions *)

16
asmcomp/amd64/emit.mlp
View File

@ -65,11 +65,11 @@ let emit_label lbl =
let emit_align n =
` .align {emit_int n}\n`
let emit_Llabel fallthrough lbl =
if not fallthrough && !fastcode_flag then emit_align 4;
emit_label lbl
(* Output a pseudo-register *)
let emit_reg = function
@ -84,13 +84,13 @@ let emit_reg = function
(* Output a reference to the lower 8, 16 or 32 bits of a register *)
let reg_low_8_name =
[| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b";
[| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b";
"%r10b"; "%r11b"; "%bpl"; "%r12b"; "%r13b" |]
let reg_low_16_name =
[| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w";
[| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w";
"%r10w"; "%r11w"; "%bp"; "%r12w"; "%r13w" |]
let reg_low_32_name =
[| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d";
[| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d";
"%r10d"; "%r11d"; "%ebp"; "%r12d"; "%r13d" |]
let emit_subreg tbl r =
@ -217,7 +217,7 @@ let name_for_cond_branch = function
| Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne"
| Iunsigned Cle -> "be" | Iunsigned Cgt -> "a"
| Iunsigned Clt -> "b" | Iunsigned Cge -> "ae"
(* Output an = 0 or <> 0 test. *)
let output_test_zero arg =
@ -578,11 +578,11 @@ let emit_float_constant (lbl, cst) =
let emit_profile () =
match Config.system with
| "linux" ->
| "linux" | "gnu" ->
(* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly
and rbx, rbp, r12-r15 like all C functions.
We need to preserve r10 and r11 ourselves, since Caml can
use them for argument passing. *)
use them for argument passing. *)
` pushq %r10\n`;
` movq %rsp, %rbp\n`;
` pushq %r11\n`;

1
asmcomp/cmmgen.ml
View File

@ -1684,6 +1684,7 @@ let emit_all_constants cont =
(fun (lbl, cst) -> c := Cdata(emit_constant lbl cst []) :: !c)
!structured_constants;
structured_constants := [];
Hashtbl.clear immstrings; (* PR#3979 *)
List.iter
(fun (symb, fundecls) ->
c := Cdata(emit_constant_closure symb fundecls []) :: !c)

2
asmcomp/hppa/emit.mlp
View File

@ -922,7 +922,7 @@ let fundecl fundecl =
else
` .callinfo frame={emit_int n}, no_calls\n`;
` .entry\n`
| "linux" ->
| "linux" | "gnu" ->
` .text\n`;
` .align 8\n`;
` .globl {emit_symbol fundecl.fun_name}\n`;

7
asmcomp/i386/arch.ml
View File

@ -145,3 +145,10 @@ let print_specific_operation printreg op ppf arg =
printreg ppf arg.(i)
done
(* Stack alignment constraints *)
let stack_alignment =
match Config.system with
| "macosx" -> 16
| _ -> 4

76
asmcomp/i386/emit.mlp
View File

@ -14,6 +14,8 @@
(* Emission of Intel 386 assembly code *)
module StringSet = Set.Make(struct type t = string let compare = compare end)
open Location
open Misc
open Cmm
@ -33,7 +35,9 @@ let stack_offset = ref 0
(* Layout of the stack frame *)
let frame_size () = (* includes return address *)
!stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4
let sz =
!stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4
in Misc.align sz stack_alignment
let slot_offset loc cl =
match loc with
@ -48,6 +52,8 @@ let slot_offset loc cl =
assert (n >= 0);
n
let trap_frame_size = Misc.align 8 stack_alignment
(* Prefixing of symbols with "_" *)
let symbol_prefix =
@ -56,6 +62,7 @@ let symbol_prefix =
| "bsd_elf" -> ""
| "solaris" -> ""
| "beos" -> ""
| "gnu" -> ""
| _ -> "_"
let emit_symbol s =
@ -69,6 +76,7 @@ let label_prefix =
| "bsd_elf" -> ".L"
| "solaris" -> ".L"
| "beos" -> ".L"
| "gnu" -> ".L"
| _ -> "L"
let emit_label lbl =
@ -90,13 +98,21 @@ let use_ascii_dir =
"solaris" -> false
| _ -> true
(* MacOSX has its own way to reference symbols potentially defined in
shared objects *)
let macosx =
match Config.system with
| "macosx" -> true
| _ -> false
(* Output a .align directive.
The numerical argument to .align is log2 of alignment size, except
under ELF, where it is the alignment size... *)
let emit_align =
match Config.system with
"linux_elf" | "bsd_elf" | "solaris" | "beos" | "cygwin" | "mingw" ->
"linux_elf" | "bsd_elf" | "solaris" | "beos" | "cygwin" | "mingw" | "gnu" ->
(fun n -> ` .align {emit_int n}\n`)
| _ ->
(fun n -> ` .align {emit_int(Misc.log2 n)}\n`)
@ -378,6 +394,9 @@ let tailrec_entry_point = ref 0
let range_check_trap = ref 0
(* Record float literals to be emitted later *)
let float_constants = ref ([] : (int * string) list)
(* Record references to external C functions (for MacOSX) *)
let external_symbols_direct = ref StringSet.empty
let external_symbols_indirect = ref StringSet.empty
let emit_instr fallthrough i =
match i.desc with
@ -439,11 +458,23 @@ let emit_instr fallthrough i =
end
| Lop(Iextcall(s, alloc)) ->
if alloc then begin
` movl ${emit_symbol s}, %eax\n`;
if not macosx then
` movl ${emit_symbol s}, %eax\n`
else begin
external_symbols_indirect :=
StringSet.add s !external_symbols_indirect;
` movl L{emit_symbol s}$non_lazy_ptr, %eax\n`
end;
` call {emit_symbol "caml_c_call"}\n`;
record_frame i.live
end else begin
` call {emit_symbol s}\n`
if not macosx then
` call {emit_symbol s}\n`
else begin
external_symbols_direct :=
StringSet.add s !external_symbols_direct;
` call L{emit_symbol s}$stub\n`
end
end
| Lop(Istackoffset n) ->
if n < 0
@ -734,16 +765,20 @@ let emit_instr fallthrough i =
| Lsetuptrap lbl ->
` call {emit_label lbl}\n`
| Lpushtrap ->
if trap_frame_size > 8 then
` subl ${emit_int (trap_frame_size - 8)}, %esp\n`;
` pushl {emit_symbol "caml_exception_pointer"}\n`;
` movl %esp, {emit_symbol "caml_exception_pointer"}\n`;
stack_offset := !stack_offset + 8
stack_offset := !stack_offset + trap_frame_size
| Lpoptrap ->
` popl {emit_symbol "caml_exception_pointer"}\n`;
` addl $4, %esp\n`;
stack_offset := !stack_offset - 8
` addl ${emit_int (trap_frame_size - 4)}, %esp\n`;
stack_offset := !stack_offset - trap_frame_size
| Lraise ->
` movl {emit_symbol "caml_exception_pointer"}, %esp\n`;
` popl {emit_symbol "caml_exception_pointer"}\n`;
if trap_frame_size > 8 then
` addl ${emit_int (trap_frame_size - 8)}, %esp\n`;
` ret\n`
let rec emit_all fallthrough i =
@ -762,11 +797,31 @@ let emit_float_constant (lbl, cst) =
` .data\n`;
`{emit_label lbl}: .double {emit_string cst}\n`
(* Emission of external symbol references (for MacOSX) *)
let emit_external_symbol_direct s =
`L{emit_symbol s}$stub:\n`;
` .indirect_symbol {emit_symbol s}\n`;
` hlt ; hlt ; hlt ; hlt ; hlt\n`
let emit_external_symbol_indirect s =
`L{emit_symbol s}$non_lazy_ptr:\n`;
` .indirect_symbol {emit_symbol s}\n`;
` .long 0\n`
let emit_external_symbols () =
` .section __IMPORT,__pointers,non_lazy_symbol_pointers\n`;
StringSet.iter emit_external_symbol_indirect !external_symbols_indirect;
external_symbols_indirect := StringSet.empty;
` .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5\n`;
StringSet.iter emit_external_symbol_direct !external_symbols_direct;
external_symbols_direct := StringSet.empty
(* Emission of the profiling prelude *)
let emit_profile () =
match Config.system with
"linux_elf" ->
"linux_elf" | "gnu" ->
` pushl %eax\n`;
` movl %esp, %ebp\n`;
` pushl %ecx\n`;
@ -791,7 +846,7 @@ let emit_profile () =
let declare_function_symbol name =
` .globl {emit_symbol name}\n`;
match Config.system with
"linux_elf" | "bsd_elf" ->
"linux_elf" | "bsd_elf" | "gnu" ->
` .type {emit_symbol name},@function\n`
| _ -> ()
@ -886,4 +941,5 @@ let end_assembly() =
`{emit_symbol lbl}:\n`;
` .long {emit_int (List.length !frame_descriptors)}\n`;
List.iter emit_frame !frame_descriptors;
frame_descriptors := []
frame_descriptors := [];
if macosx then emit_external_symbols ()

32
asmcomp/i386/selection.ml
View File

@ -159,6 +159,15 @@ inherit Selectgen.selector_generic as super
method is_immediate (n : int) = true
method is_simple_expr e =
match e with
| Cop(Cextcall(fn, _, alloc), args)
when !fast_math && List.mem fn inline_float_ops ->
(* inlined float ops are simple if their arguments are *)
List.for_all self#is_simple_expr args
| _ ->
super#is_simple_expr e
method select_addressing exp =
match select_addr exp with
(Asymbol s, d) ->
@ -291,18 +300,23 @@ method select_push exp =
| _ -> (Ispecific(Ipush), exp)
method emit_extcall_args env args =
let rec size_pushes = function
| [] -> 0
| e :: el -> Selectgen.size_expr env e + size_pushes el in
let sz1 = size_pushes args in
let sz2 = Misc.align sz1 stack_alignment in
let rec emit_pushes = function
[] -> 0
| [] ->
if sz2 > sz1 then
self#insert (Iop (Istackoffset (sz2 - sz1))) [||] [||]
| e :: el ->
let ofs = emit_pushes el in
emit_pushes el;
let (op, arg) = self#select_push e in
begin match self#emit_expr env arg with
None -> ofs
| Some r ->
self#insert (Iop op) r [||];
ofs + Selectgen.size_expr env e
end
in ([||], emit_pushes args)
match self#emit_expr env arg with
| None -> ()
| Some r -> self#insert (Iop op) r [||] in
emit_pushes args;
([||], sz2)
end

70
asmcomp/selectgen.ml
View File

@ -76,46 +76,6 @@ let size_expr env exp =
fatal_error "Selection.size_expr"
in size Tbl.empty exp
(* These are C library functions that are known to be pure
(no side effects at all) and worth not pre-computing. *)
let pure_external_functions =
["acos"; "asin"; "atan"; "atan2"; "cos"; "exp"; "log";
"log10"; "sin"; "sqrt"; "tan"]
(* Says if an expression is "simple". A "simple" expression has no
side-effects and its execution can be delayed until its value
is really needed. In the case of e.g. an [alloc] instruction,
the non-simple arguments are computed in right-to-left order
first, then the block is allocated, then the simple arguments are
evaluated and stored. *)
let rec is_simple_expr = function
Cconst_int _ -> true
| Cconst_natint _ -> true
| Cconst_float _ -> true
| Cconst_symbol _ -> true
| Cconst_pointer _ -> true
| Cconst_natpointer _ -> true
| Cvar _ -> true
| Ctuple el -> List.for_all is_simple_expr el
| Clet(id, arg, body) -> is_simple_expr arg && is_simple_expr body
| Csequence(e1, e2) -> is_simple_expr e1 && is_simple_expr e2
| Cop(op, args) ->
begin match op with
(* The following may have side effects *)
| Capply _ | Calloc | Cstore _ | Craise -> false
(* External C functions normally have side effects, unless known *)
| Cextcall(fn, _, alloc) ->
not alloc &&
List.mem fn pure_external_functions &&
List.for_all is_simple_expr args
(* The remaining operations are simple if their args are *)
| _ ->
List.for_all is_simple_expr args
end
| _ -> false
(* Swap the two arguments of an integer comparison *)
let swap_intcomp = function
@ -201,6 +161,34 @@ let current_function_name = ref ""
class virtual selector_generic = object (self)
(* Says if an expression is "simple". A "simple" expression has no
side-effects and its execution can be delayed until its value
is really needed. In the case of e.g. an [alloc] instruction,
the non-simple arguments are computed in right-to-left order
first, then the block is allocated, then the simple arguments are
evaluated and stored. *)
method is_simple_expr = function
Cconst_int _ -> true
| Cconst_natint _ -> true
| Cconst_float _ -> true
| Cconst_symbol _ -> true
| Cconst_pointer _ -> true
| Cconst_natpointer _ -> true
| Cvar _ -> true
| Ctuple el -> List.for_all self#is_simple_expr el
| Clet(id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body
| Csequence(e1, e2) -> self#is_simple_expr e1 && self#is_simple_expr e2
| Cop(op, args) ->
begin match op with
(* The following may have side effects *)
| Capply _ | Cextcall(_, _, _) | Calloc | Cstore _ | Craise -> false
(* The remaining operations are simple if their args are *)
| _ ->
List.for_all self#is_simple_expr args
end
| _ -> false
(* Says whether an integer constant is a suitable immediate argument *)
method virtual is_immediate : int -> bool
@ -591,7 +579,7 @@ method private bind_let env v r1 =
end
method private emit_parts env exp =
if is_simple_expr exp then
if self#is_simple_expr exp then
Some (exp, env)
else begin
match self#emit_expr env exp with

2
asmcomp/selectgen.mli
View File

@ -28,6 +28,8 @@ class virtual selector_generic : object
method virtual select_addressing :
Cmm.expression -> Arch.addressing_mode * Cmm.expression
(* Must be defined to select addressing modes *)
method is_simple_expr: Cmm.expression -> bool
(* Can be overriden to reflect special extcalls known to be pure *)
method select_operation :
Cmm.operation ->
Cmm.expression list -> Mach.operation * Cmm.expression list

3
asmcomp/sparc/emit.mlp
View File

@ -76,7 +76,8 @@ let emit_size lbl =
` .size {emit_symbol lbl},.-{emit_symbol lbl}\n`
let rodata () =
if Config.system = "solaris" (* || Config.system = "linux" *) then
if Config.system = "solaris" (* || Config.system = "linux" *)
(* || Config.system = "gnu" *) then
` .section \".rodata\"\n`
else
` .data\n`

4
asmrun/hppa.S
View File

@ -30,7 +30,7 @@
#define LOWLABEL(x) RR%x
#endif
#ifdef SYS_linux
#if defined(SYS_linux) || defined(SYS_gnu)
#define G(x) x
#define CODESPACE .text
#define CODE_ALIGN 8
@ -69,7 +69,7 @@ caml_exception_pointer .comm 8
caml_required_size .comm 8
#endif
#ifdef SYS_linux
#if defined(SYS_linux) || defined(SYS_gnu)
.align 8
.comm G(young_limit), 4
.comm G(young_ptr), 4

19
asmrun/i386.S
View File

@ -26,7 +26,7 @@
#endif
#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \
|| defined(SYS_solaris) || defined(SYS_beos)
|| defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_gnu)
#define G(x) x
#define LBL(x) CONCAT(.L,x)
#else
@ -36,14 +36,14 @@
#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \
|| defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_cygwin) \
|| defined(SYS_mingw)
|| defined(SYS_mingw) || defined(SYS_gnu)
#define FUNCTION_ALIGN 4
#else
#define FUNCTION_ALIGN 2
#endif
#if defined(PROFILING)
#if defined(SYS_linux_elf)
#if defined(SYS_linux_elf) || defined(SYS_gnu)
#define PROFILE_CAML \
pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \
call mcount; \
@ -208,8 +208,12 @@ LBL(106):
pushl G(caml_gc_regs)
pushl G(caml_last_return_address)
pushl G(caml_bottom_of_stack)
/* Note: 16-alignment preserved on MacOSX at this point */
/* Build an exception handler */
pushl $ LBL(108)
#ifdef SYS_macosx
subl $8, %esp /* 16-alignment */
#endif
pushl G(caml_exception_pointer)
movl %esp, G(caml_exception_pointer)
/* Call the Caml code */
@ -217,7 +221,11 @@ LBL(106):
LBL(107):
/* Pop the exception handler */
popl G(caml_exception_pointer)
popl %esi /* dummy register */
#ifdef SYS_macosx
addl $12, %esp
#else
addl $4, %esp
#endif
LBL(109):
/* Pop the callback link, restoring the global variables */
popl G(caml_bottom_of_stack)
@ -245,6 +253,9 @@ G(caml_raise_exception):
movl 4(%esp), %eax
movl G(caml_exception_pointer), %esp
popl G(caml_exception_pointer)
#ifdef SYS_macosx
addl $8, %esp
#endif
ret
/* Callback from C to Caml */

32
asmrun/signals.c
View File

@ -52,18 +52,23 @@ extern char * caml_code_area_start, * caml_code_area_end;
((char *)(pc) >= caml_code_area_start && \
(char *)(pc) <= caml_code_area_end)
intnat volatile caml_signals_are_pending = 0;
volatile intnat caml_pending_signals[NSIG];
volatile int caml_force_major_slice = 0;
value caml_signal_handlers = 0;
static void caml_process_pending_signals(void)
{
int signal_num;
intnat signal_state;
int i;
for (signal_num = 0; signal_num < NSIG; signal_num++) {
Read_and_clear(signal_state, caml_pending_signals[signal_num]);
if (signal_state) caml_execute_signal(signal_num, 0);
if (caml_signals_are_pending) {
caml_signals_are_pending = 0;
for (i = 0; i < NSIG; i++) {
if (caml_pending_signals[i]) {
caml_pending_signals[i] = 0;
caml_execute_signal(i, 0);
}
}
}
}
@ -132,6 +137,7 @@ void caml_execute_signal(int signal_number, int in_signal_handler)
void caml_record_signal(int signal_number)
{
caml_pending_signals[signal_number] = 1;
caml_signals_are_pending = 1;
caml_young_limit = caml_young_end;
}
@ -153,10 +159,7 @@ void caml_garbage_collection(void)
if (caml_young_ptr < caml_young_start || caml_force_major_slice) {
caml_minor_collection();
}
for (signal_number = 0; signal_number < NSIG; signal_number++) {
Read_and_clear(signal_state, caml_pending_signals[signal_number]);
if (signal_state) caml_execute_signal(signal_number, 0);
}
caml_process_pending_signals();
}
/* Trigger a garbage collection as soon as possible */
@ -173,18 +176,13 @@ void caml_urge_major_slice (void)
void caml_enter_blocking_section(void)
{
int i;
intnat pending;
while (1){
/* Process all pending signals now */
caml_process_pending_signals();
caml_enter_blocking_section_hook ();
/* Check again for pending signals. */
pending = 0;
for (i = 0; i < NSIG; i++) pending |= caml_pending_signals[i];
/* If none, done; otherwise, try again */
if (!pending) break;
/* Check again for pending signals.
If none, done; otherwise, try again */
if (! caml_signals_are_pending) break;
caml_leave_blocking_section_hook ();
}
}

4
asmrun/stack.h
View File

@ -34,8 +34,12 @@
#ifdef TARGET_i386
#define Saved_return_address(sp) *((intnat *)((sp) - 4))
#ifdef SYS_macosx
#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
#else
#define Callback_link(sp) ((struct caml_context *)((sp) + 8))
#endif
#endif
#ifdef TARGET_mips
#define Saved_return_address(sp) *((intnat *)((sp) - 4))

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

37
bytecomp/translclass.ml
View File

@ -107,7 +107,7 @@ let create_object cl obj init =
Lsequence(obj_init,
if not has_init then Lvar obj' else
Lapply (oo_prim "run_initializers_opt",
[obj; Lvar obj'; Lvar cl]))))
[obj; Lvar obj'; Lvar cl]))))
end
let rec build_object_init cl_table obj params inh_init obj_init cl =
@ -198,7 +198,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
let ((_,inh_init), obj_init) =
build_object_init cl_table obj params (envs,[]) (copy_env env) cl in
let obj_init =
if ids = [] then obj_init else lfunction [self] obj_init in
if ids = [] then obj_init else lfunction [self] obj_init in
(inh_init, lfunction [env] (subst_env env inh_init obj_init))
@ -251,11 +251,11 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
Tclass_ident path ->
begin match inh_init with
(obj_init, path')::inh_init ->
let lpath = transl_path path in
let lpath = transl_path path in
(inh_init,
Llet (Strict, obj_init,
Llet (Strict, obj_init,
Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
if top then [Lprim(Pfield 3, [lpath])] else []),
if top then [Lprim(Pfield 3, [lpath])] else []),
bind_super cla super cl_init))
| _ ->
assert false
@ -323,15 +323,15 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
let concr_meths = Concr.elements concr_meths in
let narrow_args =
[Lvar cla;
[Lvar cla;
transl_meth_list vals;
transl_meth_list virt_meths;
transl_meth_list concr_meths] in
let cl = ignore_cstrs cl in
begin match cl.cl_desc, inh_init with
Tclass_ident path, (obj_init, path')::inh_init ->
assert (Path.same path path');
let lpath = transl_path path in
Tclass_ident path, (obj_init, path')::inh_init ->
assert (Path.same path path');
let lpath = transl_path path in
let inh = Ident.create "inh"
and ofs = List.length vals + 1
and valids, methids = super in
@ -347,15 +347,15 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
Llet(StrictOpt, id, lfield inh (index nm vals + 1), init))
cl_init valids in
(inh_init,
Llet (Strict, inh,
Lapply(oo_prim "inherits", narrow_args @
[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
Llet (Strict, inh,
Lapply(oo_prim "inherits", narrow_args @
[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
Llet(StrictOpt, obj_init, lfield inh 0, cl_init)))
| _ ->
let core cl_init =
let core cl_init =
build_class_init cla true super inh_init cl_init msubst top cl
in
if cstr then core cl_init else
in
if cstr then core cl_init else
let (inh_init, cl_init) =
core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
in
@ -625,6 +625,7 @@ let transl_class ids cl_id arity pub_meths cl vflag =
begin try
(* Doesn't seem to improve size for bytecode *)
(* if not !Clflags.native_code then raise Not_found; *)
if !Clflags.debug then raise Not_found;
builtin_meths arr [self] env env2 (lfunction args body')
with Not_found ->
[lfunction (self :: args)
@ -695,7 +696,7 @@ let transl_class ids cl_id arity pub_meths cl vflag =
and lbody fv =
if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
Lapply (oo_prim "make_class",[transl_meth_list pub_meths;
Lvar class_init])
Lvar class_init])
else
ltable table (
Llet(
@ -703,8 +704,8 @@ let transl_class ids cl_id arity pub_meths cl vflag =
Lsequence(
Lapply (oo_prim "init_class", [Lvar table]),
Lprim(Pmakeblock(0, Immutable),
[Lapply(Lvar env_init, [lambda_unit]);
Lvar class_init; Lvar env_init; lambda_unit]))))
[Lapply(Lvar env_init, [lambda_unit]);
Lvar class_init; Lvar env_init; lambda_unit]))))
and lbody_virt lenvs =
Lprim(Pmakeblock(0, Immutable),
[lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs])

43
byterun/io.c
View File

@ -230,7 +230,7 @@ CAMLexport int caml_putblock(struct channel *channel, char *p, intnat len)
}
}
CAMLexport void caml_really_putblock(struct channel *channel,
CAMLexport void caml_really_putblock(struct channel *channel,
char *p, intnat len)
{
int written;
@ -450,7 +450,7 @@ CAMLprim value caml_ml_out_channels_list (value unit)
res = Val_emptylist;
for (channel = caml_all_opened_channels;
channel != NULL;
channel = channel->next)
channel = channel->next)
/* Testing channel->fd >= 0 looks unnecessary, as
caml_ml_close_channel changes max when setting fd to -1. */
if (channel->max == NULL) {
@ -530,6 +530,7 @@ CAMLprim value caml_ml_set_binary_mode(value vchannel, value mode)
CAMLprim value caml_ml_flush_partial(value vchannel)
{
CAMLparam1 (vchannel);
struct channel * channel = Channel(vchannel);
int res;
@ -537,36 +538,41 @@ CAMLprim value caml_ml_flush_partial(value vchannel)
Lock(channel);
res = caml_flush_partial(channel);
Unlock(channel);
return Val_bool(res);
CAMLreturn (Val_bool(res));
}
CAMLprim value caml_ml_flush(value vchannel)
{
CAMLparam1 (vchannel);
struct channel * channel = Channel(vchannel);
if (channel->fd == -1) return Val_unit;
Lock(channel);
caml_flush(channel);
Unlock(channel);
return Val_unit;
CAMLreturn (Val_unit);
}
CAMLprim value caml_ml_output_char(value vchannel, value ch)
{
CAMLparam2 (vchannel, ch);
struct channel * channel = Channel(vchannel);
Lock(channel);
putch(channel, Long_val(ch));
Unlock(channel);
return Val_unit;
CAMLreturn (Val_unit);
}
CAMLprim value caml_ml_output_int(value vchannel, value w)
{
CAMLparam2 (vchannel, w);
struct channel * channel = Channel(vchannel);
Lock(channel);
caml_putword(channel, Long_val(w));
Unlock(channel);
return Val_unit;
CAMLreturn (Val_unit);
}
CAMLprim value caml_ml_output_partial(value vchannel, value buff, value start,
@ -602,20 +608,24 @@ CAMLprim value caml_ml_output(value vchannel, value buff, value start,
CAMLprim value caml_ml_seek_out(value vchannel, value pos)
{
CAMLparam2 (vchannel, pos);
struct channel * channel = Channel(vchannel);
Lock(channel);
caml_seek_out(channel, Long_val(pos));
Unlock(channel);
return Val_unit;
CAMLreturn (Val_unit);
}
CAMLprim value caml_ml_seek_out_64(value vchannel, value pos)
{
CAMLparam2 (vchannel, pos);
struct channel * channel = Channel(vchannel);
Lock(channel);
caml_seek_out(channel, File_offset_val(pos));
Unlock(channel);
return Val_unit;
CAMLreturn (Val_unit);
}
CAMLprim value caml_ml_pos_out(value vchannel)
@ -632,17 +642,19 @@ CAMLprim value caml_ml_pos_out_64(value vchannel)
CAMLprim value caml_ml_input_char(value vchannel)
{
CAMLparam1 (vchannel);
struct channel * channel = Channel(vchannel);
unsigned char c;
Lock(channel);
c = getch(channel);
Unlock(channel);
return Val_long(c);
CAMLreturn (Val_long(c));
}
CAMLprim value caml_ml_input_int(value vchannel)
{
CAMLparam1 (vchannel);
struct channel * channel = Channel(vchannel);
intnat i;
@ -652,7 +664,7 @@ CAMLprim value caml_ml_input_int(value vchannel)
#ifdef ARCH_SIXTYFOUR
i = (i << 32) >> 32; /* Force sign extension */
#endif
return Val_long(i);
CAMLreturn (Val_long(i));
}
CAMLprim value caml_ml_input(value vchannel, value buff, value vstart,
@ -692,20 +704,24 @@ CAMLprim value caml_ml_input(value vchannel, value buff, value vstart,
CAMLprim value caml_ml_seek_in(value vchannel, value pos)
{
CAMLparam2 (vchannel, pos);
struct channel * channel = Channel(vchannel);
Lock(channel);
caml_seek_in(channel, Long_val(pos));
Unlock(channel);
return Val_unit;
CAMLreturn (Val_unit);
}
CAMLprim value caml_ml_seek_in_64(value vchannel, value pos)
{
CAMLparam2 (vchannel, pos);
struct channel * channel = Channel(vchannel);
Lock(channel);
caml_seek_in(channel, File_offset_val(pos));
Unlock(channel);
return Val_unit;
CAMLreturn (Val_unit);
}
CAMLprim value caml_ml_pos_in(value vchannel)
@ -722,13 +738,14 @@ CAMLprim value caml_ml_pos_in_64(value vchannel)
CAMLprim value caml_ml_input_scan_line(value vchannel)
{
CAMLparam1 (vchannel);
struct channel * channel = Channel(vchannel);
intnat res;
Lock(channel);
res = caml_input_scan_line(channel);
Unlock(channel);
return Val_long(res);
CAMLreturn (Val_long(res));
}
/* Conversion between file_offset and int64 */

6
byterun/md5.c
View File

@ -17,6 +17,7 @@
#include "alloc.h"
#include "fail.h"
#include "md5.h"
#include "memory.h"
#include "mlvalues.h"
#include "io.h"
#include "reverse.h"
@ -36,6 +37,7 @@ CAMLprim value caml_md5_string(value str, value ofs, value len)
CAMLprim value caml_md5_chan(value vchan, value len)
{
CAMLparam2 (vchan, len);
struct channel * chan = Channel(vchan);
struct MD5Context ctx;
value res;
@ -63,7 +65,7 @@ CAMLprim value caml_md5_chan(value vchan, value len)
res = caml_alloc_string(16);
caml_MD5Final(&Byte_u(res, 0), &ctx);
Unlock(chan);
return res;
CAMLreturn (res);
}
/*
@ -163,7 +165,7 @@ CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf,
}
/*
* Final wrapup - pad to 64-byte boundary with the bit pattern
* Final wrapup - pad to 64-byte boundary with the bit pattern
* 1 0* (64-bit count of bits processed, MSB-first)
*/
CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx)

34
byterun/signals.c
View File

@ -36,6 +36,7 @@ extern sighandler caml_win32_signal(int sig, sighandler action);
#define signal(sig,act) caml_win32_signal(sig,act)
#endif
CAMLexport intnat volatile caml_signals_are_pending = 0;
CAMLexport intnat volatile caml_pending_signals[NSIG];
CAMLexport int volatile caml_something_to_do = 0;
int volatile caml_force_major_slice = 0;
@ -44,12 +45,16 @@ CAMLexport void (* volatile caml_async_action_hook)(void) = NULL;
static void caml_process_pending_signals(void)
{
int signal_num;
intnat signal_state;
int i;
for (signal_num = 0; signal_num < NSIG; signal_num++) {
Read_and_clear(signal_state, caml_pending_signals[signal_num]);
if (signal_state) caml_execute_signal(signal_num, 0);
if (caml_signals_are_pending) {
caml_signals_are_pending = 0;
for (i = 0; i < NSIG; i++) {
if (caml_pending_signals[i]) {
caml_pending_signals[i] = 0;
caml_execute_signal(i, 0);
}
}
}
}
@ -60,8 +65,11 @@ void caml_process_event(void)
if (caml_force_major_slice) caml_minor_collection ();
/* FIXME should be [caml_check_urgent_gc] */
caml_process_pending_signals();
Read_and_clear(async_action, caml_async_action_hook);
if (async_action != NULL) (*async_action)();
async_action = caml_async_action_hook;
if (async_action != NULL) {
caml_async_action_hook = NULL;
(*async_action)();
}
}
static intnat volatile caml_async_signal_mode = 0;
@ -129,6 +137,7 @@ void caml_execute_signal(int signal_number, int in_signal_handler)
void caml_record_signal(int signal_number)
{
caml_pending_signals[signal_number] = 1;
caml_signals_are_pending = 1;
caml_something_to_do = 1;
}
@ -154,18 +163,13 @@ void caml_urge_major_slice (void)
CAMLexport void caml_enter_blocking_section(void)
{
int i;
intnat pending;
while (1){
/* Process all pending signals now */
caml_process_pending_signals();
caml_enter_blocking_section_hook ();
/* Check again for pending signals. */
pending = 0;
for (i = 0; i < NSIG; i++) pending |= caml_pending_signals[i];
/* If none, done; otherwise, try again */
if (!pending) break;
/* Check again for pending signals.
If none, done; otherwise, try again */
if (! caml_signals_are_pending) break;
caml_leave_blocking_section_hook ();
}
}

1
byterun/signals.h
View File

@ -24,6 +24,7 @@
/* <private> */
extern value caml_signal_handlers;
CAMLextern intnat volatile caml_signals_are_pending;
CAMLextern intnat volatile caml_pending_signals[];
CAMLextern int volatile caml_something_to_do;
extern int volatile caml_force_major_slice;

4
camlp4/etc/pr_o.ml
View File

@ -1408,8 +1408,8 @@ pr_expr.pr_levels :=
<:expr< while $_$ do { $list:_$ } >> | <:expr< ($list: _$) >> |
<:expr< let $opt:_$ $list:_$ in $_$ >> |
<:expr< let module $_$ = $_$ in $_$ >> |
(* Note: `new' is treated differently in pa_o and in pa_r,
and should not occur at this level *)
(* Note: `new' is treated differently in pa_o and in pa_r,
and should not occur at this level *)
<:expr< assert $_$ >> | <:expr< lazy $_$ >> as e ->
fun curr next dg k ->
[: `S LO "("; `expr e "" [: `HVbox [: `S RO ")"; k :] :] :]

26
configure vendored
View File

@ -42,7 +42,7 @@ gcc_warnings="-Wall"
# Try to turn internationalization off, can cause config.guess to malfunction!
unset LANG
unset LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME
unset LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME
# Turn off some MacOS X debugging stuff, same reason
unset RC_TRACE_ARCHIVES RC_TRACE_DYLIBS RC_TRACE_PREBINDING_DISABLED
@ -408,7 +408,7 @@ case "$host" in
# alignment is not reliable (PR#1521), hence force it.
# Same goes for hppa.
# But there's a knack (PR#2572):
# if we're in 64-bit mode (sizeof(long) == 8),
# if we're in 64-bit mode (sizeof(long) == 8),
# we must not doubleword-align floats...
if test $2 = 8; then
echo "Doubles can be word-aligned."
@ -483,7 +483,7 @@ mksharedlibrpath=''
if test $withsharedlibs = "yes"; then
case "$host" in
*-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*)
*-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-gnu*)
sharedcccompopts="-fPIC"
mksharedlib="$bytecc -shared -o"
bytecclinkopts="$bytecclinkopts -Wl,-E"
@ -562,6 +562,7 @@ system=unknown
case "$host" in
alpha*-*-osf*) arch=alpha; system=digital;;
alpha*-*-linux*) arch=alpha; system=linux;;
alpha*-*-gnu*) arch=alpha; system=gnu;;
alpha*-*-freebsd*) arch=alpha; system=freebsd;;
alpha*-*-netbsd*) arch=alpha; system=netbsd;;
alpha*-*-openbsd*) arch=alpha; system=openbsd;;
@ -569,24 +570,31 @@ case "$host" in
sparc*-*-solaris2.*) arch=sparc; system=solaris;;
sparc*-*-*bsd*) arch=sparc; system=bsd;;
sparc*-*-linux*) arch=sparc; system=linux;;
sparc*-*-gnu*) arch=sparc; system=gnu;;
i[3456]86-*-linux*) arch=i386; system=linux_`sh ./runtest elf.c`;;
i[3456]86-*-*bsd*) arch=i386; system=bsd_`sh ./runtest elf.c`;;
i[3456]86-*-nextstep*) arch=i386; system=nextstep;;
i[3456]86-*-solaris*) arch=i386; system=solaris;;
i[3456]86-*-beos*) arch=i386; system=beos;;
i[3456]86-*-cygwin*) arch=i386; system=cygwin;;
i[3456]86-*-darwin*) arch=i386; system=macosx;;
i[3456]86-*-gnu*) arch=i386; system=gnu;;
mips-*-irix6*) arch=mips; system=irix;;
hppa1.1-*-hpux*) arch=hppa; system=hpux;;
hppa2.0*-*-hpux*) arch=hppa; system=hpux;;
hppa*-*-linux*) arch=hppa; system=linux;;
hppa*-*-linux*) arch=hppa; system=linux;;
hppa*-*-gnu*) arch=hppa; system=gnu;;
powerpc-*-linux*) arch=power; model=ppc; system=elf;;
powerpc-*-netbsd*) arch=power; model=ppc; system=bsd;;
powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;;
powerpc-*-darwin*) arch=power; model=ppc; system=rhapsody;;
arm*-*-linux*) arch=arm; system=linux;;
arm*-*-gnu*) arch=arm; system=gnu;;
ia64-*-linux*) arch=ia64; system=linux;;
ia64-*-gnu*) arch=ia64; system=gnu;;
ia64-*-freebsd*) arch=ia64; system=freebsd;;
x86_64-*-linux*) arch=amd64; system=linux;;
x86_64-*-gnu*) arch=amd64; system=gnu;;
x86_64-*-freebsd*) arch=amd64; system=freebsd;;
x86_64-*-netbsd*) arch=amd64; system=netbsd;;
x86_64-*-openbsd*) arch=amd64; system=openbsd;;
@ -629,12 +637,14 @@ case "$arch,$model,$system" in
alpha,*,digital) asflags='-O2'; asppflags='-O2 -DSYS_$(SYSTEM)';
asppprofflags='-pg -DPROFILING';;
alpha,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
alpha,*,gnu) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
alpha,*,freebsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
alpha,*,netbsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
alpha,*,openbsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
mips,*,irix) asflags='-n32 -O2'; asppflags="$asflags";;
sparc,*,bsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
sparc,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
sparc,*,gnu) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
sparc,*,*) case "$cc" in
gcc*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
*) asppflags='-P -DSYS_$(SYSTEM)';;
@ -646,6 +656,7 @@ case "$arch,$model,$system" in
power,*,bsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
power,*,rhapsody) ;;
arm,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
arm,*,gnu) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
ia64,*,*) asflags=-xexplicit
aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM) -Wa,-xexplicit';;
amd64,*,*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
@ -655,11 +666,13 @@ cc_profile='-pg'
case "$arch,$model,$system" in
alpha,*,digital) profiling='prof';;
i386,*,linux_elf) profiling='prof';;
i386,*,gnu) profiling='prof';;
i386,*,bsd_elf) profiling='prof';;
sparc,*,solaris)
profiling='prof'
case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;;
amd64,*,linux) profiling='prof';;
amd64,*,gnu) profiling='prof';;
*) profiling='noprof';;
esac
@ -1242,7 +1255,7 @@ for dir in /usr/include /usr/include/db1 /usr/include/gdbm; do
elif sh ./hasgot -lgdbm dbm_open; then
dbm_link="-lgdbm"
elif sh ./hasgot -lgdbm_compat -lgdbm dbm_open; then
dbm_link="-lgdbm_compat -lgdbm"
dbm_link="-lgdbm_compat -lgdbm"
fi
break
fi
@ -1252,7 +1265,7 @@ for dir in /usr/include /usr/include/db1 /usr/include/gdbm; do
if sh ./hasgot -lgdbm_compat -lgdbm dbm_open; then
dbm_link="-lgdbm_compat -lgdbm"
fi
break
break
fi
done
if test "$dbm_include" = "not found" || test "$dbm_link" = "not found"; then
@ -1523,4 +1536,3 @@ fi
echo
echo "** Objective Caml configuration completed successfully **"
echo

2
driver/opterrors.ml
View File

@ -65,7 +65,7 @@ let report_error ppf exn =
| Sys_error msg ->
fprintf ppf "I/O error: %s" msg
| Warnings.Errors (n) ->
fprintf ppf "@.Error: %d error-enabled warnings occurred." n
fprintf ppf "@.Error: error-enabled warnings (%d occurrences)" n
| x -> fprintf ppf "@]"; raise x in
fprintf ppf "@[%a@]@." report exn

4
ocamldoc/odoc_analyse.ml
View File

@ -186,7 +186,7 @@ let process_error exn =
| Translclass.Error(loc, err) ->
Location.print ppf loc; Translclass.report_error ppf err
| Warnings.Errors (n) ->
fprintf ppf "@.Error: %d error-enabled warnings occurred." n
fprintf ppf "@.Error: error-enabled warnings (%d occurrences)" n
| x ->
fprintf ppf "@]";
fprintf ppf "Compilation error. Use the OCaml compiler to get more details."
@ -290,7 +290,7 @@ let process_file ppf sourcefile =
Odoc_module.m_top_deps = [] ;
Odoc_module.m_code = None ;
Odoc_module.m_code_intf = None ;
Odoc_module.m_text_only = true ;
Odoc_module.m_text_only = true ;
}
in
Some m

4
otherlibs/labltk/browser/main.ml
View File

@ -117,7 +117,7 @@ let _ =
"points to the Objective Caml library."
Config.standard_library)
end;
Searchpos.view_defined_ref := (fun s ~env -> Viewer.view_defined s ~env);
Searchpos.editor_ref := Editor.f;
@ -126,7 +126,7 @@ let _ =
(* bind top ~events:[`Destroy] ~action:(fun _ -> exit 0); *)
at_exit Shell.kill_all;
if !st then Viewer.st_viewer ~on:top ()
else Viewer.f ~on:top ();

3
otherlibs/systhreads/posix.c
View File

@ -305,7 +305,8 @@ static void * caml_thread_tick(void * arg)
select(0, NULL, NULL, NULL, &timeout);
/* This signal should never cause a callback, so don't go through
handle_signal(), tweak the global variable directly. */
pending_signals[SIGVTALRM] = 1;
caml_pending_signals[SIGVTALRM] = 1;
caml_signals_are_pending = 1;
#ifdef NATIVE_CODE
young_limit = young_end;
#else

3
otherlibs/systhreads/win32.c
View File

@ -256,7 +256,8 @@ static DWORD WINAPI caml_thread_tick(void * arg)
{
while(1) {
Sleep(Thread_timeout);
pending_signals[SIGTIMER] = 1;
caml_pending_signals[SIGTIMER] = 1;
caml_signals_are_pending = 1;
#ifdef NATIVE_CODE
young_limit = young_end;
#else

23
otherlibs/unix/times.c
View File

@ -20,6 +20,10 @@
#include <time.h>
#include <sys/types.h>
#include <sys/times.h>
#ifdef HAS_GETRUSAGE
#include <sys/time.h>
#include <sys/resource.h>
#endif
#ifndef CLK_TCK
#ifdef HZ
@ -31,6 +35,23 @@
CAMLprim value unix_times(value unit)
{
#ifdef HAS_GETRUSAGE
value res;
struct rusage ru;
res = alloc_small(4 * Double_wosize, Double_array_tag);
getrusage (RUSAGE_SELF, &ru);
Store_double_field (res, 0, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6);
Store_double_field (res, 1, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6);
getrusage (RUSAGE_CHILDREN, &ru);
Store_double_field (res, 2, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6);
Store_double_field (res, 3, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6);
return res;
#else
value res;
struct tms buffer;
@ -41,4 +62,6 @@ CAMLprim value unix_times(value unit)
Store_double_field(res, 2, (double) buffer.tms_cutime / CLK_TCK);
Store_double_field(res, 3, (double) buffer.tms_cstime / CLK_TCK);
return res;
#endif
}

4
otherlibs/unix/unix.mli
View File

@ -165,11 +165,11 @@ val execve : string -> string array -> string array -> 'a
environment to the program executed. *)
val execvp : string -> string array -> 'a
(** Same as {!Unix.execv} respectively, except that
(** Same as {!Unix.execv}, except that
the program is searched in the path. *)
val execvpe : string -> string array -> string array -> 'a
(** Same as {!Unix.execvp} respectively, except that
(** Same as {!Unix.execve}, except that
the program is searched in the path. *)
val fork : unit -> int

41
otherlibs/win32unix/stat.c
View File

@ -42,30 +42,25 @@ static int file_kind_table[] = {
static value stat_aux(int use_64, struct _stati64 *buf)
{
value v;
value atime = Val_unit, mtime = Val_unit, ctime = Val_unit;
CAMLparam0 ();
CAMLlocal1 (v);
Begin_roots3(atime,mtime,ctime)
atime = copy_double((double) buf->st_atime);
mtime = copy_double((double) buf->st_mtime);
ctime = copy_double((double) buf->st_ctime);
v = alloc_small(12, 0);
Field (v, 0) = Val_int (buf->st_dev);
Field (v, 1) = Val_int (buf->st_ino);
Field (v, 2) = cst_to_constr(buf->st_mode & S_IFMT, file_kind_table,
sizeof(file_kind_table) / sizeof(int), 0);
Field (v, 3) = Val_int(buf->st_mode & 07777);
Field (v, 4) = Val_int (buf->st_nlink);
Field (v, 5) = Val_int (buf->st_uid);
Field (v, 6) = Val_int (buf->st_gid);
Field (v, 7) = Val_int (buf->st_rdev);
Field (v, 8) =
use_64 ? copy_int64(buf->st_size) : Val_int (buf->st_size);
Field (v, 9) = atime;
Field (v, 10) = mtime;
Field (v, 11) = ctime;
End_roots();
return v;
v = caml_alloc (12, 0);
Store_field (v, 0, Val_int (buf->st_dev));
Store_field (v, 1, Val_int (buf->st_ino));
Store_field (v, 2, cst_to_constr (buf->st_mode & S_IFMT, file_kind_table,
sizeof(file_kind_table) / sizeof(int), 0));
Store_field (v, 3, Val_int(buf->st_mode & 07777));
Store_field (v, 4, Val_int (buf->st_nlink));
Store_field (v, 5, Val_int (buf->st_uid));
Store_field (v, 6, Val_int (buf->st_gid));
Store_field (v, 7, Val_int (buf->st_rdev));
Store_field (v, 8,
use_64 ? copy_int64(buf->st_size) : Val_int (buf->st_size));
Store_field (v, 9, copy_double((double) buf->st_atime));
Store_field (v, 10, copy_double((double) buf->st_mtime));
Store_field (v, 11, copy_double((double) buf->st_ctime));
CAMLreturn (v);
}
CAMLprim value unix_stat(value path)

2
parsing/.cvsignore
View File

@ -5,3 +5,5 @@ lexer_tmp.mll
lexer_tmp.ml
linenum.ml
parser.output
parser.automaton
parser.conflicts

6
parsing/parser.mly
View File

@ -180,7 +180,7 @@ let bigarray_set arr arg newval =
["", arr; "", c1; "", c2; "", c3; "", newval]))
| coords ->
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")),
["", arr;
["", arr;
"", ghexp(Pexp_array coords);
"", newval]))
%}
@ -1308,6 +1308,10 @@ simple_core_type2:
{ mktyp(Ptyp_class($5, List.rev $2, $6)) }
| LBRACKET tag_field RBRACKET
{ mktyp(Ptyp_variant([$2], true, None)) }
/* PR#3835: this is not LR(1), would need lookahead=2
| LBRACKET simple_core_type2 RBRACKET
{ mktyp(Ptyp_variant([$2], true, None)) }
*/
| LBRACKET BAR row_field_list RBRACKET
{ mktyp(Ptyp_variant(List.rev $3, true, None)) }
| LBRACKET row_field BAR row_field_list RBRACKET

3
stdlib/Makefile.nt
View File

@ -32,7 +32,8 @@ OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \
set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \
printf.cmo format.cmo scanf.cmo \
arg.cmo printexc.cmo gc.cmo \
digest.cmo random.cmo callback.cmo camlinternalOO.cmo oo.cmo \
digest.cmo random.cmo callback.cmo \
camlinternalOO.cmo oo.cmo camlinternalMod.cmo \
genlex.cmo weak.cmo \
lazy.cmo filename.cmo complex.cmo \
arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo

68
stdlib/filename.ml
View File

@ -25,6 +25,24 @@ let generic_quote quotequote s =
Buffer.add_char b '\'';
Buffer.contents b
let generic_basename rindex_dir_sep current_dir_name name =
let raw_name =
try
let p = rindex_dir_sep name + 1 in
String.sub name p (String.length name - p)
with Not_found ->
name
in
if raw_name = "" then current_dir_name else raw_name
let generic_dirname rindex_dir_sep current_dir_name dir_sep name =
try
match rindex_dir_sep name with
0 -> dir_sep
| n -> String.sub name 0 n
with Not_found ->
current_dir_name
module Unix = struct
let current_dir_name = "."
let parent_dir_name = ".."
@ -43,6 +61,8 @@ module Unix = struct
let temp_dir_name =
try Sys.getenv "TMPDIR" with Not_found -> "/tmp"
let quote = generic_quote "'\\''"
let basename = generic_basename rindex_dir_sep current_dir_name
let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep
end
module Win32 = struct
@ -53,7 +73,7 @@ module Win32 = struct
let rindex_dir_sep s =
let rec pos i =
if i < 0 then raise Not_found
else if (let c = s.[i] in c = '/' || c = '\\' || c = ':') then i
else if is_dir_sep s i then i
else pos (i - 1)
in pos (String.length s - 1)
let is_relative n =
@ -87,6 +107,23 @@ module Win32 = struct
done;
Buffer.add_char b '\"';
Buffer.contents b
let has_drive s =
let is_letter = function
| 'A' .. 'Z' | 'a' .. 'z' -> true
| _ -> false
in
String.length s >= 2 && is_letter s.[0] && s.[1] = ':'
let drive_and_path s =
if has_drive s
then (String.sub s 0 2, String.sub s 2 (String.length s - 2))
else ("", s)
let dirname s =
let (drive, path) = drive_and_path s in
let dir = generic_dirname rindex_dir_sep current_dir_name dir_sep path in
drive ^ dir
let basename s =
let (drive, path) = drive_and_path s in
generic_basename rindex_dir_sep current_dir_name path
end
module Cygwin = struct
@ -100,26 +137,29 @@ module Cygwin = struct
let check_suffix = Win32.check_suffix
let temp_dir_name = Unix.temp_dir_name
let quote = Unix.quote
let basename = generic_basename rindex_dir_sep current_dir_name
let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep
end
let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep, rindex_dir_sep,
is_relative, is_implicit, check_suffix, temp_dir_name, quote) =
is_relative, is_implicit, check_suffix, temp_dir_name, quote, basename,
dirname) =
match Sys.os_type with
"Unix" ->
(Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
Unix.is_dir_sep, Unix.rindex_dir_sep,
Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
Unix.temp_dir_name, Unix.quote)
Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname)
| "Win32" ->
(Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep,
Win32.is_dir_sep, Win32.rindex_dir_sep,
Win32.is_relative, Win32.is_implicit, Win32.check_suffix,
Win32.temp_dir_name, Win32.quote)
Win32.temp_dir_name, Win32.quote, Win32.basename, Win32.dirname)
| "Cygwin" ->
(Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep,
Cygwin.is_dir_sep, Cygwin.rindex_dir_sep,
Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix,
Cygwin.temp_dir_name, Cygwin.quote)
Cygwin.temp_dir_name, Cygwin.quote, Cygwin.basename, Cygwin.dirname)
| _ -> assert false
let concat dirname filename =
@ -128,24 +168,6 @@ let concat dirname filename =
then dirname ^ filename
else dirname ^ dir_sep ^ filename
let basename name =
let raw_name =
try
let p = rindex_dir_sep name + 1 in
String.sub name p (String.length name - p)
with Not_found ->
name
in
if raw_name = "" then current_dir_name else raw_name
let dirname name =
try
match rindex_dir_sep name with
0 -> dir_sep
| n -> String.sub name 0 n
with Not_found ->
current_dir_name
let chop_suffix name suff =
let n = String.length name - String.length suff in
if n < 0 then invalid_arg "Filename.chop_suffix" else String.sub name 0 n

6
stdlib/pervasives.mli
View File

@ -172,10 +172,12 @@ external ( mod ) : int -> int -> int = "%modint"
[x = (x / y) * y + x mod y] and
[abs(x mod y) <= abs(y)-1].
If [y = 0], [x mod y] raises [Division_by_zero].
Notice that [x mod y] is negative if and only if [x < 0]. *)
Notice that [x mod y] is nonpositive if and only if [x < 0].
Raise [Division_by_zero] if [y] is zero. *)
val abs : int -> int
(** Return the absolute value of the argument. *)
(** Return the absolute value of the argument. Note that this may be
negative if the argument is [min_int]. *)
val max_int : int
(** The greatest representable integer. *)

2
stdlib/printf.ml
View File

@ -296,7 +296,7 @@ let kapr kpr fmt =
else Obj.magic (fun x -> loop (succ i) (x :: args)) in
loop 0 [];;
type param_spec = Spec_none | Spec_index of index;;
type param_spec = Spec_none | Spec_index of index;;
(* To scan an optional positional parameter specification,
i.e. an integer followed by a $.

2
stdlib/sys.ml
View File

@ -78,4 +78,4 @@ let catch_break on =
(* OCaml version string, must be in the format described in sys.mli. *)
let ocaml_version = "3.10+dev6 (2006-04-05)";;
let ocaml_version = "3.10+dev7 (2006-04-17)";;

1
tools/checkstack.c
View File

@ -14,6 +14,7 @@
/* $Id$ */
#include <stdio.h>
#include <stdlib.h>
#include <sys/types.h>
#include <sys/time.h>
#include <sys/resource.h>

18
typing/printtyp.ml
View File

@ -130,7 +130,7 @@ and raw_type_desc ppf = function
fprintf ppf "@[<hov1>Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f
(safe_kind_repr [] k)
raw_type t1 raw_type t2
| Tnil -> fprintf ppf "Tnil"
| Tnil -> fprintf ppf "Tnil"
| Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
| Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t
| Tunivar -> fprintf ppf "Tunivar"
@ -180,7 +180,7 @@ let reset_names () = names := []; name_counter := 0
let new_name () =
let name =
if !name_counter < 26
then String.make 1 (Char.chr(97 + !name_counter))
then String.make 1 (Char.chr(97 + !name_counter))
else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
string_of_int(!name_counter / 26) in
incr name_counter;
@ -195,7 +195,7 @@ let name_of_type t =
let check_name_of_type t = ignore(name_of_type t)
let non_gen_mark sch ty =
if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else ""
if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else ""
let print_name_of_type sch ppf t =
fprintf ppf "'%s%s" (non_gen_mark sch t) (name_of_type t)
@ -456,7 +456,7 @@ and type_sch ppf ty = typexp true 0 ppf ty
and type_scheme ppf ty = reset_and_mark_loops ty; typexp true 0 ppf ty
(* Maxence *)
let type_scheme_max ?(b_reset_names=true) ppf ty =
let type_scheme_max ?(b_reset_names=true) ppf ty =
if b_reset_names then reset_names () ;
typexp true 0 ppf ty
(* Fin Maxence *)
@ -515,7 +515,7 @@ let rec tree_of_type_decl id decl =
in
mark_loops ty;
Some ty
in
in
begin match decl.type_kind with
| Type_abstract -> ()
| Type_variant ([], _) -> ()
@ -564,7 +564,7 @@ let rec tree_of_type_decl id decl =
begin match ty_manifest with
| None -> (Otyp_abstract, Public)
| Some ty ->
tree_of_typexp false ty,
tree_of_typexp false ty,
(if has_constr_row ty then Private else Public)
end
| Type_variant(cstrs, priv) ->
@ -589,7 +589,7 @@ let type_declaration id ppf decl =
(* Print an exception declaration *)
let tree_of_exception_declaration id decl =
reset_and_mark_loops_list decl;
reset_and_mark_loops_list decl;
let tyl = tree_of_typlist false decl in
Osig_exception (Ident.name id, tyl)
@ -820,7 +820,7 @@ and tree_of_modtype_declaration id decl =
in
Osig_modtype (Ident.name id, mty)
let tree_of_module id mty rs =
let tree_of_module id mty rs =
Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs)
let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty)
@ -839,7 +839,7 @@ let signature ppf sg =
let type_expansion t ppf t' =
if t == t' then type_expr ppf t else
let t' = if proxy t = proxy t' then unalias t' else t' in
let t' = if proxy t == proxy t' then unalias t' else t' in
fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t'
let rec trace fst txt ppf = function

1
typing/printtyp.mli
View File

@ -29,6 +29,7 @@ val reset_and_mark_loops: type_expr -> unit
val reset_and_mark_loops_list: type_expr list -> unit
val type_expr: formatter -> type_expr -> unit
val tree_of_type_scheme: type_expr -> out_type
val type_sch : formatter -> type_expr -> unit
val type_scheme: formatter -> type_expr -> unit
(* Maxence *)
val reset_names: unit -> unit

2
typing/stypes.ml
View File

@ -107,7 +107,7 @@ let print_info pp ti =
fprintf pp "@.type(@. ";
printtyp_reset_maybe loc;
Printtyp.mark_loops typ;
Printtyp.type_expr pp typ;
Printtyp.type_sch pp typ;
fprintf pp "@.)@.";
;;

45
typing/typeclass.ml
View File

@ -57,7 +57,7 @@ exception Error of Location.t * error
(**********************)
(* Useful constants *)
(**********************)
(*
Self type have a dummy private method, thus preventing it to become
@ -75,7 +75,7 @@ let unbound_class = Path.Pident (Ident.create "")
(************************************)
(* Some operations on class types *)
(************************************)
(* Fully expand the head of a class type *)
let rec scrape_class_type =
@ -190,7 +190,7 @@ let rc node =
(***********************************)
(* Primitives for typing classes *)
(***********************************)
(* Enter a value in the method environment only *)
let enter_met_env lab kind ty val_env met_env par_env =
@ -294,7 +294,7 @@ let make_method cl_num expr =
(*******************************)
let add_val env loc lab (mut, virt, ty) val_sig =
let add_val env loc lab (mut, virt, ty) val_sig =
let virt =
try
let (mut', virt', ty') = Vars.find lab val_sig in
@ -339,7 +339,7 @@ let rec class_type_field env self_type meths (val_sig, concr_meths, inher) =
and class_signature env sty sign =
let meths = ref Meths.empty in
let self_type = transl_simple_type env false sty in
(* Check that the binder is a correct type, and introduce a dummy
method preventing self type from being closed. *)
let dummy_obj = Ctype.newvar () in
@ -350,14 +350,14 @@ and class_signature env sty sign =
with Ctype.Unify _ ->
raise(Error(sty.ptyp_loc, Pattern_type_clash self_type))
end;
(* Class type fields *)
let (val_sig, concr_meths, inher) =
List.fold_left (class_type_field env self_type meths)
(Vars.empty, Concr.empty, [])
sign
in
{cty_self = self_type;
cty_vars = val_sig;
cty_concr = concr_meths;
@ -389,7 +389,7 @@ and class_type env scty =
| Pcty_signature (sty, sign) ->
Tcty_signature (class_signature env sty sign)
| Pcty_fun (l, sty, scty) ->
let ty = transl_simple_type env false sty in
let cty = class_type env scty in
@ -441,11 +441,11 @@ let rec class_field cl_num self_type meths vars
cl_sig.cty_vars (val_env, met_env, par_env, [], warn_vals)
in
(* Inherited concrete methods *)
let inh_meths =
let inh_meths =
Concr.fold (fun lab rem -> (lab, Ident.create lab)::rem)
cl_sig.cty_concr []
in
(* Super *)
(* Super *)
let (val_env, met_env, par_env) =
match super with
None ->
@ -731,7 +731,7 @@ and class_expr cl_num val_env met_env scl =
try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
raise(Error(loc, Parameter_mismatch trace)))
tyl params;
let cl =
let cl =
rc {cl_desc = Tclass_ident path;
cl_loc = scl.pcl_loc;
cl_type = clty';
@ -790,9 +790,8 @@ and class_expr cl_num val_env met_env scl =
pexp_loc = Location.none}))
pv
in
let rec all_labeled = function
Tcty_fun ("", _, _) -> false
| Tcty_fun (l, _, ty_fun) -> l.[0] <> '?' && all_labeled ty_fun
let rec not_function = function
Tcty_fun _ -> false
| _ -> true
in
let partial =
@ -805,7 +804,7 @@ and class_expr cl_num val_env met_env scl =
Ctype.raise_nongen_level ();
let cl = class_expr cl_num val_env met_env scl' in
Ctype.end_def ();
if Btype.is_optional l && all_labeled cl.cl_type then
if Btype.is_optional l && not_function cl.cl_type then
Location.prerr_warning pat.pat_loc
Warnings.Unerasable_optional_argument;
rc {cl_desc = Tclass_fun (pat, pv, cl, partial);
@ -1012,7 +1011,7 @@ let rec initial_env define_class approx
let arity = List.length (fst cl.pci_params) in
let (obj_params, obj_ty, env) = temp_abbrev env obj_id arity in
let (cl_params, cl_ty, env) = temp_abbrev env cl_id arity in
(* Temporary type for the class constructor *)
let constr_type = approx cl.pci_expr in
if !Clflags.principal then Ctype.generalize_spine constr_type;
@ -1059,7 +1058,7 @@ let class_infos define_class kind
reset_type_variables ();
Ctype.begin_class_def ();
(* Introduce class parameters *)
let params =
try
@ -1071,7 +1070,7 @@ let class_infos define_class kind
(* Allow self coercions (only for class declarations) *)
let coercion_locs = ref [] in
(* Type the class expression *)
let (expr, typ) =
try
@ -1083,9 +1082,9 @@ let class_infos define_class kind
with exn ->
Typecore.self_coercion := []; raise exn
in
Ctype.end_def ();
let sty = Ctype.self_type typ in
(* Generalize the row variable *)
@ -1115,7 +1114,7 @@ let class_infos define_class kind
Abbrev_type_clash (constr, ty, Ctype.expand_head env constr)))
end
end;
(* Check the other temporary abbreviation (#-type) *)
begin
let (cl_params', cl_type) = Ctype.instance_class params typ in
@ -1190,7 +1189,7 @@ let class_infos define_class kind
in
List.map (function (lab, _, _) -> lab) fields
in
(* Final definitions *)
let (params', typ') = Ctype.instance_class params typ in
let cltydef =
@ -1421,7 +1420,7 @@ let approx_class sdecl =
let self' =
{ ptyp_desc = Ptyp_any; ptyp_loc = Location.none } in
let clty' =
{ pcty_desc = Pcty_signature(self', []);
{ pcty_desc = Pcty_signature(self', []);
pcty_loc = sdecl.pci_expr.pcty_loc } in
{ sdecl with pci_expr = clty' }

11
typing/typecore.ml
View File

@ -782,8 +782,9 @@ let rec approx_type env sty =
newty (Ttuple (List.map (approx_type env) args))
| Ptyp_constr (lid, ctl) ->
begin try
let (path, decl) = Env.lookup_type lid env in
if List.length ctl <> decl.type_arity then raise Not_found;
let tyl = List.map (approx_type env) ctl in
let (path, _) = Env.lookup_type lid env in
newconstr path tyl
with Not_found -> newvar ()
end
@ -1628,7 +1629,7 @@ and type_application env funct sargs =
else begin
may_warn sarg0.pexp_loc
(Warnings.Not_principal "using an optional argument here");
Some (fun () -> option_some (type_argument env sarg0
Some (fun () -> option_some (type_argument env sarg0
(extract_option_type env ty)))
end
with Not_found ->
@ -1796,11 +1797,11 @@ and type_expect ?in_function env sexp ty_expected =
let cases, partial =
type_cases ~in_function:(loc,ty_fun) env ty_arg ty_res
(Some sexp.pexp_loc) caselist in
let all_labeled ty =
let not_function ty =
let ls, tvar = list_labels env ty in
not (tvar || List.exists (fun l -> l = "" || l.[0] = '?') ls)
ls = [] && not tvar
in
if is_optional l && all_labeled ty_res then
if is_optional l && not_function ty_res then
Location.prerr_warning (fst (List.hd cases)).pat_loc
Warnings.Unerasable_optional_argument;
re {

3
utils/warnings.ml
View File

@ -147,7 +147,8 @@ let message = function
| Not_principal s -> s^" is not principal."
| Without_principality s -> s^" without principality."
| Unused_argument -> "this argument will not be used by the function."
| Nonreturning_statement -> "this statement never returns."
| Nonreturning_statement ->
"this statement never returns (or has an unsound type.)"
| Camlp4 s -> s
| All_clauses_guarded ->
"bad style, all clauses in this pattern-matching are guarded."

1
yacc/.cvsignore
View File

@ -2,3 +2,4 @@ ocamlyacc
*.c.x
ocamlyacc.xcoff
version.h
.gdb_history

1
yacc/main.c
View File

@ -157,6 +157,7 @@ void getargs(int argc, char **argv)
{
case '\0':
input_file = stdin;
file_prefix = "stdin";
if (i + 1 < argc) usage();
return;