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

passage aux labels stricts 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3696 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Garrigue 2001-09-06 08:52:32 +00:00
parent bc8ff705be
commit ea299bbbc1
122 changed files with 3068 additions and 610 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Makefile
View File

@ -108,7 +108,8 @@ EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \
PERVASIVES=arg array buffer callback char digest filename format gc hashtbl \
lexing list map obj parsing pervasives printexc printf queue random \
set sort stack string stream sys oo genlex topdirs toploop weak lazy \
marshal int32 int64 nativeint outcometree
marshal int32 int64 nativeint outcometree \
arrayLabels listLabels stringLabels stdLabels
# Recompile the system using the bootstrap compiler
all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \
@ -277,7 +278,7 @@ utils/config.ml: utils/config.mlp config/Makefile
@rm -f utils/config.ml
sed -e 's|%%LIBDIR%%|$(LIBDIR)|' \
-e 's|%%BYTERUN%%|$(BINDIR)/ocamlrun|' \
-e 's|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS)|' \
-e 's|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)|' \
-e 's|%%BYTELINK%%|$(BYTECC) $(BYTECCLINKOPTS)|' \
-e 's|%%BYTECCRPATH%%|$(BYTECCRPATH)|' \
-e 's|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|' \

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

9
bytecomp/dll.ml
View File

@ -23,7 +23,14 @@ external dll_sym: dll_handle -> string -> dll_address = "dynlink_lookup_symbol"
external add_primitive: dll_address -> int = "dynlink_add_primitive"
external get_current_dlls: unit -> dll_handle array
= "dynlink_get_current_libs"
(*
external dll_open: string -> dll_handle = "%identity"
external dll_close: dll_handle -> unit = "%identity"
external dll_sym: dll_handle -> string -> dll_address = "%equal"
external add_primitive: dll_address -> int = "%identity"
external get_current_dlls: unit -> dll_handle array
= "%identity"
*)
(* Current search path for DLLs *)
let search_path = ref ([] : string list)

4
config/auto-aux/runtest
View File

@ -1,6 +1,8 @@
#!/bin/sh
if test "$verbose" = yes; then
echo "runtest: $cc -o tst $* $cclibs" >&2
fi
$cc -o tst $* $cclibs || exit 100
else
$cc -o tst $* $cclibs 2> /dev/null || exit 100
fi
exec ./tst

25
configure vendored
View File

@ -996,26 +996,32 @@ fi
# Look for tcl/tk
echo "Configuring LablTk..."
if test "$ostype" != "Cygwin" && \
(test "$x11_include" = "not found" || test "$x11_link" = "not found")
then
if test "$ostype" = "Cygwin"; then
has_tk=true
elif test "$x11_include" = "not found" || test "$x11_link" = "not found"; then
echo "X11 not found."
has_tk=false
else
tk_x11_include="$x11_include"
tk_x11_libs="$x11_libs -lX11"
has_tk=true
fi
if test $has_tk = true; then
tcl_version=''
tcl_version=`sh ./runtest $tk_defs tclversion.c 2> /dev/null`
tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
if test -z "$tcl_version" && test -z "$tk_defs"; then
tk_defs=-I/usr/local/include
tcl_version=`sh ./runtest $tk_defs tclversion.c 2> /dev/null`
tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
fi
if test -z "$tcl_version"; then
tk_defs="-I/usr/include/tcl8.2 -I/usr/include/tk8.2"
tcl_version=`sh ./runtest $tk_defs tclversion.c 2> /dev/null`
tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
fi
if test -z "$tcl_version"; then
tk_defs="-I/usr/include/tcl8.3 -I/usr/include/tk8.3"
tcl_version=`sh ./runtest $tk_defs tclversion.c 2> /dev/null`
tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
fi
if test -n "$tcl_version"; then
echo "tcl.h version $tcl_version found."
@ -1034,11 +1040,6 @@ else
fi
fi
if test $has_tk = true && test "$ostype" != "Cygwin"; then
tk_x11_include=$x11_include
tk_x11_libs="$x11_libs -lX11"
fi
if test $has_tk = true; then
if sh ./hasgot $tk_x11_include $tk_defs -i tk.h; then
echo "tk.h found."

1
driver/main.ml
View File

@ -86,6 +86,7 @@ module Options = Main_args.Make_options (struct
let _make_runtime () =
custom_runtime := true; make_runtime := true; link_everything := true
let _noassert = set noassert
let _nolabels = set classic
let _noautolink = set no_auto_link
let _o s = exec_name := s; archive_name := s; object_name := s
let _output_obj () = output_c_object := true; custom_runtime := true

3
driver/main_args.ml
View File

@ -32,6 +32,7 @@ module Make_options (F :
val _make_runtime : unit -> unit
val _noassert : unit -> unit
val _noautolink : unit -> unit
val _nolabels : unit -> unit
val _o : string -> unit
val _output_obj : unit -> unit
val _pp : string -> unit
@ -84,6 +85,7 @@ struct
"-noassert", Arg.Unit F._noassert, " Don't compile assertion checks";
"-noautolink", Arg.Unit F._noautolink,
" Don't automatically link C libraries specified in .cma files";
"-nolabels", Arg.Unit F._nolabels, " Ignore non-optional labels in types";
"-o", Arg.String F._o, "<file> Set output file name to <file>";
"-output-obj", Arg.Unit F._output_obj,
" Output a C object file instead of an executable";
@ -104,6 +106,7 @@ struct
\032 A/a enable/disable all warnings\n\
\032 C/c enable/disable suspicious comment\n\
\032 F/f enable/disable partially applied function\n\
\032 L/l enable/disable labels omitted in application\n\
\032 M/m enable/disable overriden method\n\
\032 P/p enable/disable partial match\n\
\032 S/s enable/disable non-unit statement\n\

1
driver/main_args.mli
View File

@ -32,6 +32,7 @@ module Make_options (F :
val _make_runtime : unit -> unit
val _noassert : unit -> unit
val _noautolink : unit -> unit
val _nolabels : unit -> unit
val _o : string -> unit
val _output_obj : unit -> unit
val _pp : string -> unit

3
driver/optmain.ml
View File

@ -91,10 +91,10 @@ let main () =
"-labels", Arg.Clear classic, " Use commuting label mode";
"-linkall", Arg.Set link_everything,
" Link all modules, even unused ones";
"-modern", Arg.Clear classic, " (deprecated) same as -labels";
"-noassert", Arg.Set noassert, " Don't compile assertion checks";
"-noautolink", Arg.Set no_auto_link,
" Don't automatically link C libraries specified in .cma files";
"-nolabels", Arg.Set classic, " Ignore non-optional labels in types";
"-o", Arg.String(fun s -> exec_name := s;
archive_name := s;
object_name := s),
@ -119,6 +119,7 @@ let main () =
\032 A/a enable/disable all warnings\n\
\032 C/c enable/disable suspicious comment\n\
\032 F/f enable/disable partially applied function\n\
\032 L/l enable/disable labels omitted in application\n\
\032 M/m enable/disable overriden methods\n\
\032 P/p enable/disable partial match\n\
\032 S/s enable/disable non-unit statement\n\

4
emacs/caml-font.el
View File

@ -65,9 +65,9 @@
'font-lock-reference-face)
'("\\<raise\\>" . font-lock-comment-face)
;labels (and open)
'("\\(\\([~?]\\|\\<\\)[a-z][a-z0-9_']*:\\)[^:=]" 1
'("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" 1
font-lock-variable-name-face)
'("\\<\\(assert\\|open\\|include\\)\\>\\|[~?][ (]*[a-z][a-z0-9_']*"
'("\\<\\(assert\\|open\\|include\\)\\>\\|[~?][ (]*[a-z][a-zA-Z0-9_']*"
. font-lock-variable-name-face)))
(defconst inferior-caml-font-lock-keywords

4
emacs/caml-hilit.el
View File

@ -16,8 +16,8 @@
nil
'string)
;labels
'("\\(\\([~?]\\|\\<\\)[a-z][a-z0-9_']*:\\)[^:=]" 1 brown)
'("[~?][ (]*[a-z][a-z0-9_']*" nil brown)
'("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" 1 brown)
'("[~?][ (]*[a-z][a-zA-Z0-9_']*" nil brown)
;modules
'("\\<\\(assert\\|open\\|include\\)\\>" nil brown)
'("`?\\<[A-Z][A-Za-z0-9_\']*\\>" nil MidnightBlue)

2
otherlibs/bigarray/bigarray.ml
View File

@ -82,7 +82,7 @@ module Genarray = struct
= "bigarray_blit"
external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
external map_file: Unix.file_descr -> ('a, 'b) kind -> 'c layout ->
shared:bool -> dims:int array -> ('a, 'b, 'c) t
bool -> int array -> ('a, 'b, 'c) t
= "bigarray_map_file"
end

108
otherlibs/bigarray/bigarray.mli
View File

@ -156,8 +156,7 @@ module Genarray: sig
in Fortran layout; reads and writes in this array use the
Caml type [float]. *)
external create:
kind:('a, 'b) kind -> layout:'c layout -> dims:int array -> ('a, 'b, 'c) t
external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t
= "bigarray_create"
(* [Genarray.create kind layout dimensions] returns a new big array
whose element kind is determined by the parameter [kind] (one of
@ -223,8 +222,7 @@ module Genarray: sig
(The syntax [a.{...} <- v] with one, two or three coordinates is
reserved for updating one-, two- and three-dimensional arrays
as described below.) *)
external sub_left:
('a, 'b, c_layout) t -> pos:int -> len:int -> ('a, 'b, c_layout) t
external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
= "bigarray_sub"
(* Extract a sub-array of the given big array by restricting the
first (left-most) dimension. [Genarray.sub_left a ofs len]
@ -243,8 +241,7 @@ module Genarray: sig
a valid sub-array of [a], that is, if [ofs < 0], or [len < 0],
or [ofs + len > Genarray.nth_dim a 0]. *)
external sub_right:
('a, 'b, fortran_layout) t ->
pos:int -> len:int -> ('a, 'b, fortran_layout) t
('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
= "bigarray_sub"
(* Extract a sub-array of the given big array by restricting the
last (right-most) dimension. [Genarray.sub_right a ofs len]
@ -296,7 +293,7 @@ module Genarray: sig
[Genarray.slice_right] applies only to big arrays in Fortran layout.
Raise [Invalid_arg] if [M >= N], or if [[|i1; ... ; iM|]]
is outside the bounds of [a]. *)
external blit: src:('a, 'b, 'c) t -> dst:('a, 'b, 'c) t -> unit
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
= "bigarray_blit"
(* Copy all elements of a big array in another big array.
[Genarray.blit src dst] copies all elements of [src] into
@ -311,8 +308,8 @@ module Genarray: sig
can be achieved by applying [Genarray.fill] to a sub-array
or a slice of [a]. *)
external map_file:
Unix.file_descr -> kind:('a, 'b) kind -> layout:'c layout ->
shared:bool -> dims:int array -> ('a, 'b, 'c) t = "bigarray_map_file"
Unix.file_descr -> ('a, 'b) kind -> 'c layout ->
bool -> int array -> ('a, 'b, 'c) t = "bigarray_map_file"
(* Memory mapping of a file as a big array.
[Genarray.map_file fd kind layout shared dims]
returns a big array of kind [kind], layout [layout],
@ -360,8 +357,7 @@ module Array1: sig
type ('a, 'b, 'c) t
(* The type of one-dimensional big arrays whose elements have
Caml type ['a], representation kind ['b], and memory layout ['c]. *)
val create:
kind:('a, 'b) kind -> layout:'c layout -> dim:int -> ('a, 'b, 'c) t
val create: ('a, 'b) kind -> 'c layout -> int -> ('a, 'b, 'c) t
(* [Array1.create kind layout dim] returns a new bigarray of
one dimension, whose size is [dim]. [kind] and [layout]
determine the array element kind and the array layout
@ -381,23 +377,22 @@ module Array1: sig
stores the value [v] at index [x] in [a].
[x] must be inside the bounds of [a] as described in [Array1.get];
otherwise, [Invalid_arg] is raised. *)
external sub: ('a, 'b, 'c) t -> pos:int -> len:int -> ('a, 'b, 'c) t
external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t
= "bigarray_sub"
(* Extract a sub-array of the given one-dimensional big array.
See [Genarray.sub_left] for more details. *)
external blit: src:('a, 'b, 'c) t -> dst:('a, 'b, 'c) t -> unit
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
= "bigarray_blit"
(* Copy the first big array to the second big array.
See [Genarray.blit] for more details. *)
external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
(* Fill the given big array with the given value.
See [Genarray.fill] for more details. *)
val of_array:
kind:('a, 'b) kind -> layout:'c layout -> 'a array -> ('a, 'b, 'c) t
val of_array: ('a, 'b) kind -> 'c layout -> 'a array -> ('a, 'b, 'c) t
(* Build a one-dimensional big array initialized from the
given array. *)
val map_file: Unix.file_descr -> kind:('a, 'b) kind -> layout:'c layout ->
shared:bool -> dim:int -> ('a, 'b, 'c) t
val map_file: Unix.file_descr -> ('a, 'b) kind -> 'c layout ->
bool -> int -> ('a, 'b, 'c) t
(* Memory mapping of a file as a one-dimensional big array.
See [Genarray.map_file] for more details. *)
end
@ -411,9 +406,7 @@ module Array2: sig
type ('a, 'b, 'c) t
(* The type of two-dimensional big arrays whose elements have
Caml type ['a], representation kind ['b], and memory layout ['c]. *)
val create:
kind:('a, 'b) kind ->
layout:'c layout -> dim1:int -> dim2:int -> ('a, 'b, 'c) t
val create: ('a, 'b) kind -> 'c layout -> int -> int -> ('a, 'b, 'c) t
(* [Array2.create kind layout dim1 dim2] returns a new bigarray of
two dimension, whose size is [dim1] in the first dimension
and [dim2] in the second dimension. [kind] and [layout]
@ -437,46 +430,43 @@ module Array2: sig
[x] and [y] must be within the bounds of [a],
as described for [Genarray.set];
otherwise, [Invalid_arg] is raised. *)
external sub_left:
('a, 'b, c_layout) t -> pos:int -> len:int -> ('a, 'b, c_layout) t
external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
= "bigarray_sub"
(* Extract a two-dimensional sub-array of the given two-dimensional
big array by restricting the first dimension.
See [Genarray.sub_left] for more details. [Array2.sub_left]
applies only to arrays with C layout. *)
external sub_right:
('a, 'b, fortran_layout) t ->
pos:int -> len:int -> ('a, 'b, fortran_layout) t = "bigarray_sub"
('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
= "bigarray_sub"
(* Extract a two-dimensional sub-array of the given two-dimensional
big array by restricting the second dimension.
See [Genarray.sub_right] for more details. [Array2.sub_right]
applies only to arrays with Fortran layout. *)
val slice_left:
('a, 'b, c_layout) t -> x:int -> ('a, 'b, c_layout) Array1.t
val slice_left: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array1.t
(* Extract a row (one-dimensional slice) of the given two-dimensional
big array. The integer parameter is the index of the row to
extract. See [Genarray.slice_left] for more details.
[Array2.slice_left] applies only to arrays with C layout. *)
val slice_right:
('a, 'b, fortran_layout) t -> y:int -> ('a, 'b, fortran_layout) Array1.t
('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array1.t
(* Extract a column (one-dimensional slice) of the given
two-dimensional big array. The integer parameter is the
index of the column to extract. See [Genarray.slice_right] for
more details. [Array2.slice_right] applies only to arrays
with Fortran layout. *)
external blit: src:('a, 'b, 'c) t -> dst:('a, 'b, 'c) t -> unit
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
= "bigarray_blit"
(* Copy the first big array to the second big array.
See [Genarray.blit] for more details. *)
external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
(* Fill the given big array with the given value.
See [Genarray.fill] for more details. *)
val of_array:
kind:('a, 'b) kind -> layout:'c layout -> 'a array array -> ('a, 'b, 'c) t
val of_array: ('a, 'b) kind -> 'c layout -> 'a array array -> ('a, 'b, 'c) t
(* Build a two-dimensional big array initialized from the
given array of arrays. *)
val map_file: Unix.file_descr -> kind:('a, 'b) kind -> layout:'c layout ->
shared:bool -> dim1:int -> dim2:int -> ('a, 'b, 'c) t
val map_file: Unix.file_descr -> ('a, 'b) kind -> 'c layout ->
bool -> int -> int -> ('a, 'b, 'c) t
(* Memory mapping of a file as a two-dimensional big array.
See [Genarray.map_file] for more details. *)
end
@ -490,9 +480,7 @@ module Array3: sig
type ('a, 'b, 'c) t
(* The type of three-dimensional big arrays whose elements have
Caml type ['a], representation kind ['b], and memory layout ['c]. *)
val create:
kind:('a, 'b) kind -> layout:'c layout ->
dim1:int -> dim2:int -> dim3:int -> ('a, 'b, 'c) t
val create: ('a, 'b) kind -> 'c layout -> int -> int -> int -> ('a, 'b, 'c) t
(* [Array3.create kind layout dim1 dim2 dim3] returns a new bigarray of
three dimension, whose size is [dim1] in the first dimension,
[dim2] in the second dimension, and [dim3] in the third.
@ -513,59 +501,57 @@ module Array3: sig
[x], [y] and [z] must be within the bounds of [a],
as described for [Genarray.get]; otherwise, [Invalid_arg]
is raised. *)
external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%bigarray_set_3"
external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
= "%bigarray_set_3"
(* [Array3.set a x y v], or alternatively [a.{x,y,z} <- v],
stores the value [v] at coordinates ([x], [y], [z]) in [a].
[x], [y] and [z] must be within the bounds of [a],
as described for [Genarray.set];
otherwise, [Invalid_arg] is raised. *)
external sub_left:
('a, 'b, c_layout) t -> pos:int -> len:int -> ('a, 'b, c_layout) t
external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
= "bigarray_sub"
(* Extract a three-dimensional sub-array of the given
three-dimensional big array by restricting the first dimension.
See [Genarray.sub_left] for more details. [Array3.sub_left]
applies only to arrays with C layout. *)
external sub_right:
('a, 'b, fortran_layout) t ->
pos:int -> len:int -> ('a, 'b, fortran_layout) t
('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
= "bigarray_sub"
(* Extract a three-dimensional sub-array of the given
three-dimensional big array by restricting the second dimension.
See [Genarray.sub_right] for more details. [Array3.sub_right]
applies only to arrays with Fortran layout. *)
val slice_left_1:
('a, 'b, c_layout) t -> x:int -> y:int -> ('a, 'b, c_layout) Array1.t
('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) Array1.t
(* Extract a one-dimensional slice of the given three-dimensional
big array by fixing the first two coordinates.
The integer parameters are the coordinates of the slice to
extract. See [Genarray.slice_left] for more details.
[Array3.slice_left_1] applies only to arrays with C layout. *)
val slice_right_1:
('a, 'b, fortran_layout) t -> y:int -> z:int ->
('a, 'b, fortran_layout) Array1.t
('a, 'b, fortran_layout) t ->
int -> int -> ('a, 'b, fortran_layout) Array1.t
(* Extract a one-dimensional slice of the given three-dimensional
big array by fixing the last two coordinates.
The integer parameters are the coordinates of the slice to
extract. See [Genarray.slice_right] for more details.
[Array3.slice_right_1] applies only to arrays with Fortran
layout. *)
val slice_left_2:
('a, 'b, c_layout) t -> x:int -> ('a, 'b, c_layout) Array2.t
val slice_left_2: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array2.t
(* Extract a two-dimensional slice of the given three-dimensional
big array by fixing the first coordinate.
The integer parameter is the first coordinate of the slice to
extract. See [Genarray.slice_left] for more details.
[Array3.slice_left_2] applies only to arrays with C layout. *)
val slice_right_2:
('a, 'b, fortran_layout) t -> z:int -> ('a, 'b, fortran_layout) Array2.t
('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array2.t
(* Extract a two-dimensional slice of the given
three-dimensional big array by fixing the last coordinate.
The integer parameter is the coordinate of the slice
to extract. See [Genarray.slice_right] for more details.
[Array3.slice_right_2] applies only to arrays with Fortran
layout. *)
external blit: src:('a, 'b, 'c) t -> dst:('a, 'b, 'c) t -> unit
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
= "bigarray_blit"
(* Copy the first big array to the second big array.
See [Genarray.blit] for more details. *)
@ -573,21 +559,23 @@ module Array3: sig
(* Fill the given big array with the given value.
See [Genarray.fill] for more details. *)
val of_array:
kind:('a, 'b) kind -> layout:'c layout ->
'a array array array -> ('a, 'b, 'c) t
('a, 'b) kind -> 'c layout -> 'a array array array -> ('a, 'b, 'c) t
(* Build a three-dimensional big array initialized from the
given array of arrays of arrays. *)
val map_file: Unix.file_descr -> kind:('a, 'b) kind -> layout:'c layout ->
shared:bool -> dim1:int -> dim2:int -> dim3:int -> ('a, 'b, 'c) t
val map_file: Unix.file_descr -> ('a, 'b) kind -> 'c layout ->
bool -> int -> int -> int -> ('a, 'b, 'c) t
(* Memory mapping of a file as a three-dimensional big array.
See [Genarray.map_file] for more details. *)
end
(*** Coercions between generic big arrays and fixed-dimension big arrays *)
external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t = "%identity"
external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t = "%identity"
external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t = "%identity"
external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t
= "%identity"
external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t
= "%identity"
external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t
= "%identity"
(* Return the generic big array corresponding to the given
one-dimensional, two-dimensional or three-dimensional big array. *)
val array1_of_genarray: ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array1.t
@ -605,8 +593,7 @@ val array3_of_genarray: ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array3.t
(*** Re-shaping big arrays *)
val reshape:
('a, 'b, 'c) Genarray.t -> dims:int array -> ('a, 'b, 'c) Genarray.t
val reshape: ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t
(* [reshape b [|d1;...;dN|]] converts the big array [b] to a
[N]-dimensional array of dimensions [d1]...[dN]. The returned
array and the original array [b] share their data
@ -621,16 +608,13 @@ val reshape:
elements as the original big array [b]. That is, the product
of the dimensions of [b] must be equal to [i1 * ... * iN].
Otherwise, [Invalid_arg] is raised. *)
val reshape_1:
('a, 'b, 'c) Genarray.t -> dim:int -> ('a, 'b, 'c) Array1.t
val reshape_1: ('a, 'b, 'c) Genarray.t -> int -> ('a, 'b, 'c) Array1.t
(* Specialized version of [reshape] for reshaping to one-dimensional
arrays. *)
val reshape_2:
('a, 'b, 'c) Genarray.t -> dim1:int -> dim2:int -> ('a, 'b, 'c) Array2.t
val reshape_2: ('a, 'b, 'c) Genarray.t -> int -> int -> ('a, 'b, 'c) Array2.t
(* Specialized version of [reshape] for reshaping to two-dimensional
arrays. *)
val reshape_3:
('a, 'b, 'c) Genarray.t -> dim1:int -> dim2:int -> dim3:int ->
('a, 'b, 'c) Array3.t
('a, 'b, 'c) Genarray.t -> int -> int -> int -> ('a, 'b, 'c) Array3.t
(* Specialized version of [reshape] for reshaping to three-dimensional
arrays. *)

12
otherlibs/db/db.mli
View File

@ -48,7 +48,7 @@ type t
(* Raw access *)
external dbopen :
string -> mode:open_flag list -> perm:file_perm -> btree_flag list -> t
string -> open_flag list -> file_perm -> btree_flag list -> t
= "caml_db_open"
(* [dbopen file flags mode] *)
@ -56,25 +56,25 @@ external dbopen :
external close : t -> unit
= "caml_db_close"
external del : t -> key -> mode:routine_flag list -> unit
external del : t -> key -> routine_flag list -> unit
= "caml_db_del"
(* raise Not_found if the key was not in the file *)
external get : t -> key -> mode:routine_flag list -> data
external get : t -> key -> routine_flag list -> data
= "caml_db_get"
(* raise Not_found if the key was not in the file *)
external put : t -> key -> data:data -> mode:routine_flag list -> unit
external put : t -> key -> data -> routine_flag list -> unit
= "caml_db_put"
external seq : t -> key -> mode:routine_flag list -> (key * data)
external seq : t -> key -> routine_flag list -> (key * data)
= "caml_db_seq"
external sync : t -> unit
= "caml_db_sync"
val add : t -> key:key -> data:data -> unit
val add : t -> key -> data -> unit
val find : t -> key -> data
val find_all : t -> key -> data list
val remove : t -> key -> unit

8
otherlibs/dbm/dbm.mli
View File

@ -24,7 +24,7 @@ type open_flag =
exception Dbm_error of string
(* Raised by the following functions when an error is encountered. *)
val opendbm : string -> mode:open_flag list -> perm:int -> t
val opendbm : string -> open_flag list -> int -> t
(* Open a descriptor on an NDBM database. The first argument is
the name of the database (without the [.dir] and [.pag] suffixes).
The second argument is a list of flags: [Dbm_rdonly] opens
@ -39,11 +39,11 @@ external find : t -> string -> string = "caml_dbm_fetch"
(* [find db key] returns the data associated with the given
[key] in the database opened for the descriptor [db].
Raise [Not_found] if the [key] has no associated data. *)
external add : t -> key:string -> data:string -> unit = "caml_dbm_insert"
external add : t -> string -> string -> unit = "caml_dbm_insert"
(* [add db key data] inserts the pair ([key], [data]) in
the database [db]. If the database already contains data
associated with [key], raise [Dbm_error "Entry already exists"]. *)
external replace : t -> key:string -> data:string -> unit = "caml_dbm_replace"
external replace : t -> string -> string -> unit = "caml_dbm_replace"
(* [replace db key data] inserts the pair ([key], [data]) in
the database [db]. If the database already contains data
associated with [key], that data is discarded and silently
@ -58,7 +58,7 @@ external nextkey : t -> string = "caml_dbm_nextkey"
[firstkey db] returns the first key, and repeated calls
to [nextkey db] return the remaining keys. [Not_found] is raised
when all keys have been enumerated. *)
val iter : f:(key:string -> data:string -> 'a) -> t -> unit
val iter : (string -> string -> 'a) -> t -> unit
(* [iter f db] applies [f] to each ([key], [data]) pair in
the database [db]. [f] receives [key] as first argument
and [data] as second argument. *)

2
otherlibs/dynlink/dynlink.mli
View File

@ -26,7 +26,7 @@ val loadfile : string -> unit
val loadfile_private : string -> unit
(* Same as [loadfile], except that the module loaded is not
made available to other modules dynamically loaded afterwards. *)
val add_interfaces : units:string list -> paths:string list -> unit
val add_interfaces : string list -> string list -> unit
(* [add_interfaces units path] grants dynamically-linked object
files access to the compilation units named in list [units].
The interfaces ([.cmi] files) for these units are searched in

38
otherlibs/graph/graphics.mli
View File

@ -77,16 +77,16 @@ val foreground: color
(*** Point and line drawing *)
external plot : x:int -> y:int -> unit = "gr_plot"
external plot : int -> int -> unit = "gr_plot"
(* Plot the given point with the current drawing color. *)
val plots : (int * int) array -> unit
(* Plot the given points with the current drawing color. *)
external point_color : x:int -> y:int -> color = "gr_point_color"
external point_color : int -> int -> color = "gr_point_color"
(* Return the color of the given point in the backing store
(see "Double buffering" below). *)
external moveto : x:int -> y:int -> unit = "gr_moveto"
external moveto : int -> int -> unit = "gr_moveto"
(* Position the current point. *)
val rmoveto : dx:int -> dy:int -> unit
val rmoveto : int -> int -> unit
(* [rmoveto dx dy] translates the current point by the given vector. *)
external current_x : unit -> int = "gr_current_x"
(* Return the abscissa of the current point. *)
@ -94,10 +94,10 @@ external current_y : unit -> int = "gr_current_y"
(* Return the ordinate of the current point. *)
val current_point : unit -> int * int
(* Return the position of the current point. *)
external lineto : x:int -> y:int -> unit = "gr_lineto"
external lineto : int -> int -> unit = "gr_lineto"
(* Draw a line with endpoints the current point and the given point,
and move the current point to the given point. *)
val rlineto : dx:int -> dy:int -> unit
val rlineto : int -> int -> unit
(* Draw a line with endpoints the current point and the
current point translated of the given vector,
and move the current point to this point. *)
@ -105,7 +105,7 @@ val curveto : int * int -> int * int -> int * int -> unit
(* [curveto b c d] draws a cubic Bezier curve starting from
the current point to point [d], with control points [b] and
[c], and moves the current point to [d]. *)
external draw_rect : x:int -> y:int -> w:int -> h:int -> unit = "gr_draw_rect"
external draw_rect : int -> int -> int -> int -> unit = "gr_draw_rect"
(* [draw_rect x y w h] draws the rectangle with lower left corner
at [x,y], width [w] and height [h].
The current point is unchanged. *)
@ -127,16 +127,16 @@ val draw_segments : (int * int * int * int) array -> unit
the coordinates of the end points of the segment.
The current point is unchanged. *)
external draw_arc :
x:int -> y:int -> rx:int -> ry:int -> start:int -> stop:int -> unit
int -> int -> int -> int -> int -> int -> unit
= "gr_draw_arc" "gr_draw_arc_nat"
(* [draw_arc x y rx ry a1 a2] draws an elliptical arc with center
[x,y], horizontal radius [rx], vertical radius [ry], from angle
[a1] to angle [a2] (in degrees). The current point is unchanged. *)
val draw_ellipse : x:int -> y:int -> rx:int -> ry:int -> unit
val draw_ellipse : int -> int -> int -> int -> unit
(* [draw_ellipse x y rx ry] draws an ellipse with center
[x,y], horizontal radius [rx] and vertical radius [ry].
The current point is unchanged. *)
val draw_circle : x:int -> y:int -> r:int -> unit
val draw_circle : int -> int -> int -> unit
(* [draw_circle x y r] draws a circle with center [x,y] and
radius [r]. The current point is unchanged. *)
external set_line_width : int -> unit = "gr_set_line_width"
@ -163,21 +163,21 @@ external text_size : string -> int * int = "gr_text_size"
(*** Filling *)
external fill_rect : x:int -> y:int -> w:int -> h:int -> unit = "gr_fill_rect"
external fill_rect : int -> int -> int -> int -> unit = "gr_fill_rect"
(* [fill_rect x y w h] fills the rectangle with lower left corner
at [x,y], width [w] and height [h], with the current color. *)
external fill_poly : (int * int) array -> unit = "gr_fill_poly"
(* Fill the given polygon with the current color. The array
contains the coordinates of the vertices of the polygon. *)
external fill_arc :
x:int -> y:int -> rx:int -> ry:int -> start:int -> stop:int -> unit
int -> int -> int -> int -> int -> int -> unit
= "gr_fill_arc" "gr_fill_arc_nat"
(* Fill an elliptical pie slice with the current color. The
parameters are the same as for [draw_arc]. *)
val fill_ellipse : x:int -> y:int -> rx:int -> ry:int -> unit
val fill_ellipse : int -> int -> int -> int -> unit
(* Fill an ellipse with the current color. The
parameters are the same as for [draw_ellipse]. *)
val fill_circle : x:int -> y:int -> r:int -> unit
val fill_circle : int -> int -> int -> unit
(* Fill a circle with the current color. The
parameters are the same as for [draw_circle]. *)
@ -202,17 +202,17 @@ external make_image : color array array -> image = "gr_make_image"
is raised. *)
external dump_image : image -> color array array = "gr_dump_image"
(* Convert an image to a color matrix. *)
external draw_image : image -> x:int -> y:int -> unit = "gr_draw_image"
external draw_image : image -> int -> int -> unit = "gr_draw_image"
(* Draw the given image with lower left corner at the given point. *)
val get_image : x:int -> y:int -> w:int -> h:int -> image
val get_image : int -> int -> int -> int -> image
(* Capture the contents of a rectangle on the screen as an image.
The parameters are the same as for [fill_rect]. *)
external create_image : w:int -> h:int -> image = "gr_create_image"
external create_image : int -> int -> image = "gr_create_image"
(* [create_image w h] returns a new image [w] pixels wide and [h]
pixels tall, to be used in conjunction with [blit_image].
The initial image contents are random, except that no point
is transparent. *)
external blit_image : image -> x:int -> y:int -> unit = "gr_blit_image"
external blit_image : image -> int -> int -> unit = "gr_blit_image"
(* [blit_image img x y] copies screen pixels into the image [img],
modifying [img] in-place. The pixels copied are those inside the
rectangle with lower left corner at [x,y], and width and height
@ -265,7 +265,7 @@ val key_pressed : unit -> bool
(*** Sound *)
external sound : freq:int -> ms:int -> unit = "gr_sound"
external sound : int -> int -> unit = "gr_sound"
(* [sound freq dur] plays a sound at frequency [freq] (in hertz)
for a duration [dur] (in milliseconds). *)

24
otherlibs/labltk/browser/editor.ml
View File

@ -13,6 +13,7 @@
(* $Id$ *)
open StdLabels
open Tk
open Parsetree
open Location
@ -38,7 +39,7 @@ let compiler_preferences () =
~f:(fun (text, ref, invert) -> mk_chkbutton ~text ~ref ~invert)
[ "No pervasives", Clflags.nopervasives, false;
"No warnings", Typecheck.nowarnings, false;
"Labels commute", Clflags.classic, true;
"No labels", Clflags.classic, false;
"Recursive types", Clflags.recursive_types, false;
"Lex on load", lex_on_load, false;
"Type on load", type_on_load, false ])
@ -99,7 +100,7 @@ let goto_line tw =
let select_shell txt =
let shells = Shell.get_all () in
let shells = Sort.list shells ~order:(fun (x,_) (y,_) -> x <= y) in
let shells = List.sort shells ~cmp:compare in
let tl = Jg_toplevel.titled "Select Shell" in
Jg_bind.escape_destroy tl;
Wm.transient_set tl ~master:(Winfo.toplevel txt.tw);
@ -112,7 +113,7 @@ let select_shell txt =
begin fun () ->
try
let name = Listbox.get box ~index:`Active in
txt.shell <- Some (name, List.assoc name shells);
txt.shell <- Some (name, List.assoc name ~map:shells);
destroy tl
with Not_found -> txt.shell <- None; destroy tl
end
@ -145,7 +146,7 @@ let send_phrase txt =
let i1,i2 = Text.tag_nextrange txt.tw ~tag:"sel" ~start:tstart in
let phrase = Text.get txt.tw ~start:(i1,[]) ~stop:(i2,[]) in
sh#send phrase;
if Str.string_match phrase ~pat:(Str.regexp ";;") ~pos:0
if Str.string_match (Str.regexp ";;") phrase 0
then sh#send "\n" else sh#send ";;\n"
with Not_found | Protocol.TkError _ ->
let text = Text.get txt.tw ~start:tstart ~stop:tend in
@ -250,7 +251,7 @@ let indent_line =
fun tw ->
let `Linechar(l,c) = Text.index tw ~index:(ins,[])
and line = Text.get tw ~start:(ins,[`Linestart]) ~stop:(ins,[`Lineend]) in
ignore (Str.string_match ~pat:reg line ~pos:0);
ignore (Str.string_match reg line 0);
let len = Str.match_end () in
if len < c then Text.insert tw ~index:(ins,[]) ~text:"\t" else
let width = string_width (Str.matched_string line) in
@ -260,7 +261,7 @@ let indent_line =
let previous =
Text.get tw ~start:(ins,[`Line(-1);`Linestart])
~stop:(ins,[`Line(-1);`Lineend]) in
ignore (Str.string_match ~pat:reg previous ~pos:0);
ignore (Str.string_match reg previous 0);
let previous = Str.matched_string previous in
let width_previous = string_width previous in
if width_previous <= width then 2 else width_previous - width
@ -288,8 +289,9 @@ class editor ~top ~menus = object (self)
method reset_window_menu =
Menu.delete window_menu#menu ~first:(`Num 0) ~last:`End;
List.iter
(Sort.list windows ~order:
(fun w1 w2 -> Filename.basename w1.name < Filename.basename w2.name))
(List.sort windows ~cmp:
(fun w1 w2 ->
compare (Filename.basename w1.name) (Filename.basename w2.name)))
~f:
begin fun txt ->
Menu.add_radiobutton window_menu#menu
@ -340,7 +342,7 @@ class editor ~top ~menus = object (self)
~action:(fun _ ->
let text =
Text.get tw ~start:(`Mark"insert",[]) ~stop:(`Mark"insert",[`Lineend])
in ignore (Str.string_match ~pat:(Str.regexp "[ \t]*") text ~pos:0);
in ignore (Str.string_match (Str.regexp "[ \t]*") text 0);
if Str.match_end () <> String.length text then begin
Clipboard.clear ();
Clipboard.append ~data:text ()
@ -390,7 +392,7 @@ class editor ~top ~menus = object (self)
try
if Sys.file_exists name then
if txt.name = name then
Sys.rename ~src:name ~dst:(name ^ "~")
Sys.rename name (name ^ "~")
else begin match
Jg_message.ask ~master:top ~title:"Save"
("File `" ^ name ^ "' exists. Overwrite it?")
@ -432,7 +434,7 @@ class editor ~top ~menus = object (self)
and buf = String.create 4096 in
Text.delete tw ~start:tstart ~stop:tend;
while
len := input file ~buf ~pos:0 ~len:4096;
len := input file buf 0 4096;
!len > 0
do
Jg_text.output tw ~buf ~pos:0 ~len:!len

35
otherlibs/labltk/browser/fileselect.ml
View File

@ -15,6 +15,7 @@
(* file selection box *)
open StdLabels
open Useunix
open Str
open Filename
@ -30,24 +31,24 @@ let (~!) = Jg_memo.fast ~f:Str.regexp
(* Convert Windows-style directory separator '\' to caml-style '/' *)
let caml_dir path =
if Sys.os_type = "Win32" then
global_replace ~pat:(regexp "\\\\") ~templ:"/" path
global_replace ~!"\\\\" "/" path
else path
let parse_filter s =
let s = caml_dir s in
(* replace // by / *)
let s = global_replace ~pat:~!"/+" ~templ:"/" s in
let s = global_replace ~!"/+" "/" s in
(* replace /./ by / *)
let s = global_replace ~pat:~!"/\./" ~templ:"/" s in
let s = global_replace ~!"/\./" "/" s in
(* replace hoge/../ by "" *)
let s = global_replace s
~pat:~!"\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\./" ~templ:"" in
let s = global_replace ~!"\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\./"
"" s in
(* replace hoge/..$ by *)
let s = global_replace s
~pat:~!"\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\.$" ~templ:"" in
let s = global_replace ~!"\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\.$"
"" s in
(* replace ^/hoge/../ by / *)
let s = global_replace ~pat:~!"^\(/\.\.\)+/" ~templ:"/" s in
if string_match s ~pat:~!"^\([^\*?[]*[/:]\)\(.*\)" ~pos:0 then
let s = global_replace ~!"^\(/\.\.\)+/" "/" s in
if string_match ~!"^\([^\*?[]*[/:]\)\(.*\)" s 0 then
let dirs = matched_group 1 s
and ptrn = matched_group 2 s
in
@ -59,18 +60,18 @@ let rec fixpoint ~f v =
if v = v' then v else fixpoint ~f v'
let unix_regexp s =
let s = Str.global_replace ~pat:~!"[$^.+]" ~templ:"\\\\\\0" s in
let s = Str.global_replace ~pat:~!"\\*" ~templ:".*" s in
let s = Str.global_replace ~pat:~!"\\?" ~templ:".?" s in
let s = Str.global_replace ~!"[$^.+]" "\\\\\\0" s in
let s = Str.global_replace ~!"\\*" ".*" s in
let s = Str.global_replace ~!"\\?" ".?" s in
let s =
fixpoint s
~f:(Str.replace_first ~pat:~!"\\({.*\\),\\(.*}\\)" ~templ:"\\1\\|\\2") in
~f:(Str.replace_first ~!"\\({.*\\),\\(.*}\\)" "\\1\\|\\2") in
let s =
Str.global_replace ~pat:~!"{\\(.*\\)}" ~templ:"\\(\\1\\)" s in
Str.global_replace ~!"{\\(.*\\)}" "\\(\\1\\)" s in
Str.regexp s
let exact_match s ~pat =
Str.string_match ~pat s ~pos:0 && Str.match_end () = String.length s
let exact_match ~pat s =
Str.string_match pat s 0 && Str.match_end () = String.length s
let ls ~dir ~pattern =
let files = get_files_in_directory dir in
@ -130,7 +131,7 @@ let f ~title ~action:proc ?(dir = Unix.getcwd ())
List.fold_left !Config.load_path ~init:[] ~f:
begin fun acc dir ->
let files = ls ~dir ~pattern in
Sort.merge ~order:(<) files
Sort.merge (<) files
(List.fold_left files ~init:acc
~f:(fun acc name -> List2.exclude name acc))
end

1
otherlibs/labltk/browser/jg_config.ml
View File

@ -13,6 +13,7 @@
(* $Id$ *)
open StdLabels
open Jg_tk
let fixed = if wingui then "{Courier New} 8" else "fixed"

6
otherlibs/labltk/browser/jg_message.ml
View File

@ -13,6 +13,7 @@
(* $Id$ *)
open StdLabels
open Tk
open Jg_tk
@ -59,11 +60,12 @@ let formatted ~title ?on ?(ppf = Format.std_formatter)
Format.pp_set_margin ppf (width - 2);
let fof,fff = Format.pp_get_formatter_output_functions ppf () in
Format.pp_set_formatter_output_functions ppf
~out:(Jg_text.output tw) ~flush:(fun () -> ());
(fun buf pos len -> Jg_text.output tw ~buf ~pos ~len)
ignore;
tl, tw,
begin fun () ->
Format.pp_print_flush ppf ();
Format.pp_set_formatter_output_functions ppf ~out:fof ~flush:fff;
Format.pp_set_formatter_output_functions ppf fof fff;
let `Linechar (l, _) = Text.index tw ~index:(tposend 1) in
Text.configure tw ~height:(max minheight (min l maxheight));
if l > 5 then

2
otherlibs/labltk/browser/jg_multibox.ml
View File

@ -13,6 +13,8 @@
(* $Id$ *)
open StdLabels
let rec gen_list ~f:f ~len =
if len = 0 then [] else f () :: gen_list ~f:f ~len:(len - 1)

1
otherlibs/labltk/browser/jg_text.ml
View File

@ -13,6 +13,7 @@
(* $Id$ *)
open StdLabels
open Tk
open Jg_tk

1
otherlibs/labltk/browser/lexical.ml
View File

@ -13,6 +13,7 @@
(* $Id$ *)
open StdLabels
open Tk
open Jg_tk
open Parser

2
otherlibs/labltk/browser/list2.ml
View File

@ -13,6 +13,8 @@
(* $Id$ *)
open StdLabels
let exclude x l = List.filter l ~f:((<>) x)
let rec flat_map ~f = function

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

@ -13,37 +13,41 @@
(* $Id$ *)
open StdLabels
module Unix = UnixLabels
open Tk
let _ =
let path = ref [] in
let st = ref false in
Arg.parse
~keywords:["-I", Arg.String (fun s -> path := s :: !path),
"<dir> Add <dir> to the list of include directories";
"-labels", Arg.Clear Clflags.classic,
" Use commuting label syntax";
"-rectypes", Arg.Set Clflags.recursive_types,
" Allow arbitrary recursive types";
"-st", Arg.Set st, " Smalltalk-like one-box browsing";
"-w", Arg.String (fun s -> Shell.warnings := s),
"<flags> Enable or disable warnings according to <flags>:\n\
\032 A/a enable/disable all warnings\n\
\032 C/c enable/disable suspicious comment\n\
\032 F/f enable/disable partially applied function\n\
\032 M/m enable/disable overriden method\n\
\032 P/p enable/disable partial match\n\
\032 S/s enable/disable non-unit statement\n\
\032 U/u enable/disable unused match case\n\
\032 V/v enable/disable hidden instance variable\n\
\032 X/x enable/disable all other warnings\n\
\032 default setting is A (all warnings enabled)"]
~others:(fun name -> raise(Arg.Bad("don't know what to do with " ^ name)))
~errmsg:"ocamlbrowser :";
[ "-I", Arg.String (fun s -> path := s :: !path),
"<dir> Add <dir> to the list of include directories";
"-labels", Arg.Clear Clflags.classic, " <obsolete>";
"-nolabels", Arg.Set Clflags.classic,
" Ignore non-optional labels in types";
"-rectypes", Arg.Set Clflags.recursive_types,
" Allow arbitrary recursive types";
"-st", Arg.Set st, " Smalltalk-like one-box browsing";
"-w", Arg.String (fun s -> Shell.warnings := s),
"<flags> Enable or disable warnings according to <flags>:\n\
\032 A/a enable/disable all warnings\n\
\032 C/c enable/disable suspicious comment\n\
\032 F/f enable/disable partially applied function\n\
\032 L/l enable/disable labels omitted in application\n\
\032 M/m enable/disable overriden method\n\
\032 P/p enable/disable partial match\n\
\032 S/s enable/disable non-unit statement\n\
\032 U/u enable/disable unused match case\n\
\032 V/v enable/disable hidden instance variable\n\
\032 X/x enable/disable all other warnings\n\
\032 default setting is A (all warnings enabled)" ]
(fun name -> raise(Arg.Bad("don't know what to do with " ^ name)))
"ocamlbrowser :";
Config.load_path :=
List.rev_map ~f:(Misc.expand_directory Config.standard_library) !path
@ [Config.standard_library];
Warnings.parse_options ~iserror:false !Shell.warnings;
Warnings.parse_options false !Shell.warnings;
Unix.putenv "TERM" "noterminal";
begin
try Searchid.start_env := Env.open_pers_signature "Pervasives" Env.initial

1
otherlibs/labltk/browser/searchid.ml
View File

@ -13,6 +13,7 @@
(* $Id$ *)
open StdLabels
open Location
open Longident
open Path

26
otherlibs/labltk/browser/searchpos.ml
View File

@ -13,6 +13,8 @@
(* $Id$ *)
open StdLabels
open Support
open Tk
open Jg_tk
open Parsetree
@ -69,7 +71,7 @@ let rec list_of_path = function
class buffer ~size = object
val buffer = Buffer.create size
method out ~buf = Buffer.add_substring buffer buf
method out buf = Buffer.add_substring buffer buf
method get = Buffer.contents buffer
end
@ -228,13 +230,13 @@ type module_widgets =
let shown_modules = Hashtbl.create 17
let default_frame = ref None
let filter_modules () =
Hashtbl.iter shown_modules ~f:
begin fun ~key ~data ->
Hashtbl.iter
(fun key data ->
if not (Winfo.exists data.mw_frame) then
Hashtbl.remove shown_modules key
end
Hashtbl.remove shown_modules key)
shown_modules
let add_shown_module path ~widgets =
Hashtbl.add shown_modules ~key:path ~data:widgets
Hashtbl'.add shown_modules ~key:path ~data:widgets
let find_shown_module path =
try
filter_modules ();
@ -474,7 +476,7 @@ and view_decl_menu lid ~kind ~env ~parent =
let buf = new buffer ~size:60 in
let (fo,ff) = Format.get_formatter_output_functions ()
and margin = Format.get_margin () in
Format.set_formatter_output_functions ~out:buf#out ~flush:(fun () -> ());
Format.set_formatter_output_functions buf#out (fun () -> ());
Format.set_margin 60;
Format.open_hbox ();
if kind = `Type then
@ -488,9 +490,9 @@ and view_decl_menu lid ~kind ~env ~parent =
Format.std_formatter
(find_modtype path env);
Format.close_box (); Format.print_flush ();
Format.set_formatter_output_functions ~out:fo ~flush:ff;
Format.set_formatter_output_functions fo ff;
Format.set_margin margin;
let l = Str.split ~sep:~!"\n" buf#get in
let l = Str.split ~!"\n" buf#get in
let font =
let font =
Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in
@ -573,16 +575,16 @@ let view_type_menu kind ~env ~parent =
let buf = new buffer ~size:60 in
let (fo,ff) = Format.get_formatter_output_functions ()
and margin = Format.get_margin () in
Format.set_formatter_output_functions ~out:buf#out ~flush:(fun () -> ());
Format.set_formatter_output_functions buf#out ignore;
Format.set_margin 60;
Format.open_hbox ();
Printtyp.reset ();
Printtyp.mark_loops ty;
Printtyp.type_expr Format.std_formatter ty;
Format.close_box (); Format.print_flush ();
Format.set_formatter_output_functions ~out:fo ~flush:ff;
Format.set_formatter_output_functions fo ff;
Format.set_margin margin;
let l = Str.split ~sep:~!"\n" buf#get in
let l = Str.split ~!"\n" buf#get in
let font =
let font =
Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in

1
otherlibs/labltk/browser/setpath.ml
View File

@ -13,6 +13,7 @@
(* $Id$ *)
open StdLabels
open Tk
(* Listboxes *)

12
otherlibs/labltk/browser/shell.ml
View File

@ -13,6 +13,8 @@
(* $Id$ *)
open StdLabels
module Unix = UnixLabels
open Tk
open Jg_tk
open Dummy
@ -196,7 +198,7 @@ object (self)
let len = ref 0 in
try while len := ThreadUnix.read fd ~buf ~pos:0 ~len:1024; !len > 0 do
Mutex.lock imutex;
Buffer.add_substring ibuffer buf ~pos:0 ~len:!len;
Buffer.add_substring ibuffer buf 0 !len;
Mutex.unlock imutex
done with Unix.Unix_error _ -> ()
in
@ -204,7 +206,7 @@ object (self)
let rec read_buffer () =
Mutex.lock imutex;
if Buffer.length ibuffer > 0 then begin
self#insert (Str.global_replace ~pat:~!"\r\n" ~templ:"\n"
self#insert (Str.global_replace ~!"\r\n" "\n"
(Buffer.contents ibuffer));
Buffer.reset ibuffer;
Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)])
@ -254,12 +256,12 @@ let warnings = ref "A"
let f ~prog ~title =
let progargs =
List.filter ~f:((<>) "") (Str.split ~sep:~!" " prog) in
List.filter ~f:((<>) "") (Str.split ~!" " prog) in
if progargs = [] then () else
let prog = List.hd progargs in
let path =
try Sys.getenv "PATH" with Not_found -> "/bin" ^ path_sep ^ "/usr/bin" in
let exec_path = Str.split ~sep:~!path_sep path in
let exec_path = Str.split ~!path_sep path in
let exists =
if not (Filename.is_implicit prog) then may_exec prog else
List.exists exec_path
@ -280,7 +282,7 @@ let f ~prog ~title =
pack [frame] ~fill:`Both ~expand:true;
let env = Array.map (Unix.environment ()) ~f:
begin fun s ->
if Str.string_match ~pat:~!"TERM=" s ~pos:0 then "TERM=dumb" else s
if Str.string_match ~!"TERM=" s 0 then "TERM=dumb" else s
end in
let load_path =
List2.flat_map !Config.load_path ~f:(fun dir -> ["-I"; dir]) in

1
otherlibs/labltk/browser/typecheck.ml
View File

@ -13,6 +13,7 @@
(* $Id$ *)
open StdLabels
open Tk
open Parsetree
open Location

5
otherlibs/labltk/browser/useunix.ml
View File

@ -13,7 +13,8 @@
(* $Id$ *)
open Unix
open StdLabels
open UnixLabels
let get_files_in_directory dir =
match
@ -30,7 +31,7 @@ let get_files_in_directory dir =
| None ->
closedir dirh; l
in
Sort.list ~order:(<=) (get_them [])
List.sort ~cmp:compare (get_them [])
let is_directory name =
try

16
otherlibs/labltk/browser/viewer.ml
View File

@ -13,6 +13,7 @@
(* $Id$ *)
open StdLabels
open Tk
open Jg_tk
open Mytypes
@ -42,7 +43,7 @@ let list_modules ~path =
let reset_modules box =
Listbox.delete box ~first:(`Num 0) ~last:`End;
module_list := Sort.list ~order:(Jg_completion.lt_string ~nocase:true)
module_list := Sort.list (Jg_completion.lt_string ~nocase:true)
(list_modules ~path:!Config.load_path);
Listbox.insert box ~index:`End ~texts:!module_list;
Jg_box.recenter box ~index:(`Num 0)
@ -99,10 +100,7 @@ let choose_symbol ~title ~env ?signature ?path l =
and detach = Button.create buttons ~text:"Detach"
and edit = Button.create buttons ~text:"Impl"
and intf = Button.create buttons ~text:"Intf" in
let l = Sort.list l ~order:
(fun (li1, _) (li2,_) ->
string_of_longident li1 < string_of_longident li2)
in
let l = List.sort l ~cmp:(fun (li1, _) (li2,_) -> compare li1 li2) in
let nl = List.map l ~f:
begin fun (li, k) ->
string_of_longident li ^ " (" ^ string_of_kind k ^ ")"
@ -164,7 +162,7 @@ let search_which = ref "itself"
let search_symbol () =
if !module_list = [] then
module_list := Sort.list ~order:(<) (list_modules ~path:!Config.load_path);
module_list := List.sort ~cmp:compare (list_modules ~path:!Config.load_path);
let tl = Jg_toplevel.titled "Search symbol" in
Jg_bind.escape_destroy tl;
let ew = Entry.create tl ~width:30 in
@ -505,11 +503,7 @@ object (self)
match path with None -> 1
| Some path -> self#get_box ~path
in
let l = Sort.list l ~order:
(fun (li1, _) (li2,_) ->
string_of_longident li1 < string_of_longident li2)
in
let l = List.sort l ~cmp:(fun (li1, _) (li2,_) -> compare li1 li2) in
let nl = List.map l ~f:
begin fun (li, k) ->
string_of_longident li ^ " (" ^ string_of_kind k ^ ")"

8
otherlibs/labltk/compiler/Makefile
View File

@ -1,7 +1,7 @@
include ../support/Makefile.common
OBJS=tsort.cmo tables.cmo printer.cmo lexer.cmo parser.cmo \
compile.cmo intf.cmo maincompile.cmo
OBJS= ../support/support.cmo tsort.cmo tables.cmo printer.cmo lexer.cmo \
parser.cmo compile.cmo intf.cmo maincompile.cmo
tkcompiler : $(OBJS)
$(LABLC) $(LINKFLAGS) -o tkcompiler $(OBJS)
@ -25,10 +25,10 @@ install:
.SUFFIXES : .mli .ml .cmi .cmo .mlp
.mli.cmi:
$(LABLCOMP) $(COMPFLAGS) $<
$(LABLCOMP) $(COMPFLAGS) -I ../support $<
.ml.cmo:
$(LABLCOMP) $(COMPFLAGS) $<
$(LABLCOMP) $(COMPFLAGS) -I ../support $<
depend: parser.ml parser.mli lexer.ml
$(LABLDEP) *.mli *.ml > .depend

7
otherlibs/labltk/compiler/compile.ml
View File

@ -15,6 +15,7 @@
(* $Id$ *)
open StdLabels
open Tables
(* CONFIGURE *)
@ -51,7 +52,7 @@ let gettklabel fc =
else s
in begin
if List.mem s forbidden then
try List.assoc s nicknames
try List.assoc s ~map:nicknames
with Not_found -> small fc.var_name
else s
end
@ -96,7 +97,7 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
begin
try
let typdef = Hashtbl.find types_table sup in
let fcl = List.assoc sub typdef.subtypes in
let fcl = List.assoc sub ~map:typdef.subtypes in
let tklabels = List.map ~f:gettklabel fcl in
let l = List.map fcl ~f:
begin fun fc ->
@ -498,7 +499,7 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template =
StringArg s -> "TkToken \"" ^ s ^ "\""
| TypeArg (_, List (Subtype (sup, sub) as ty)) ->
let typdef = Hashtbl.find types_table sup in
let classdef = List.assoc sub typdef.subtypes in
let classdef = List.assoc sub ~map:typdef.subtypes in
let lbl = gettklabel (List.hd classdef) in
catch_opts := (sub ^ "_" ^ sup, lbl);
newvar := newvar2;

4
otherlibs/labltk/compiler/intf.ml
View File

@ -15,6 +15,8 @@
(* $Id$ *)
open StdLabels
(* Write .mli for widgets *)
open Tables
@ -25,7 +27,7 @@ let write_create_p ~w wname =
begin
try
let option = Hashtbl.find types_table "options" in
let classdefs = List.assoc wname option.subtypes in
let classdefs = List.assoc wname ~map:option.subtypes in
let tklabels = List.map ~f:gettklabel classdefs in
let l = List.map classdefs ~f:
begin fun fc ->

4
otherlibs/labltk/compiler/lexer.mll
View File

@ -16,8 +16,10 @@
(* $Id$ *)
{
open StdLabels
open Lexing
open Parser
open Support
exception Lexical_error of string
let current_line = ref 1
@ -28,7 +30,7 @@ let current_line = ref 1
let keyword_table = (Hashtbl.create 149 : (string, token) Hashtbl.t)
let _ = List.iter
~f:(fun (str,tok) -> Hashtbl.add keyword_table ~key:str ~data:tok)
~f:(fun (str,tok) -> Hashtbl'.add keyword_table ~key:str ~data:tok)
[
"int", TYINT;
"float", TYFLOAT;

83
otherlibs/labltk/compiler/maincompile.ml
View File

@ -15,6 +15,8 @@
(* $Id$ *)
open StdLabels
open Support
open Tables
open Printer
open Compile
@ -84,7 +86,7 @@ let parse_file filename =
in an hash table. *)
let elements t =
let elems = ref [] in
Hashtbl.iter ~f:(fun ~key:_ ~data:d -> elems := d :: !elems) t;
Hashtbl.iter (fun _ d -> elems := d :: !elems) t;
!elems;;
(* Verifies that duplicated clauses are semantically equivalent and
@ -117,7 +119,7 @@ let uniq_clauses = function
let c = constr.var_name in
if Hashtbl.mem t c
then (check_constr constr (Hashtbl.find t c))
else Hashtbl.add t ~key:c ~data:constr);
else Hashtbl'.add t ~key:c ~data:constr);
elements t;;
let option_hack oc =
@ -198,8 +200,7 @@ let compile () =
~f:(write_function_type ~w:(output_string oc));
close_out oc;
verbose_endline "Creating other ml, mli ...";
Hashtbl.iter module_table ~f:
begin fun ~key:wname ~data:wdef ->
let write_module wname wdef =
verbose_endline (" "^wname);
let modname = wname in
let oc = open_out_bin (destfile (modname ^ ".ml"))
@ -210,11 +211,11 @@ let compile () =
end;
output_string oc "open Protocol\n";
List.iter ~f:(fun s -> output_string oc s; output_string oc' s)
[ "open Tk\n";
"open Tkintf\n";
"open Widget\n";
"open Textvariable\n"
];
[ "open StdLabels\n";
"open Tk\n";
"open Tkintf\n";
"open Widget\n";
"open Textvariable\n" ];
begin match wdef.module_type with
Widget ->
write_create ~w:(output_string oc) wname;
@ -231,46 +232,48 @@ let compile () =
(sort_components wdef.externals);
close_out oc;
close_out oc'
end;
in Hashtbl.iter write_module module_table;
(* write the module list for the Makefile *)
(* and hack to death until it works *)
let oc = open_out_bin (destfile "modules") in
output_string oc "WIDGETOBJS=";
Hashtbl.iter module_table
~f:(fun ~key:name ~data:_ ->
output_string oc name;
output_string oc ".cmo ");
output_string oc "\n";
Hashtbl.iter module_table
~f:(fun ~key:name ~data:_ ->
output_string oc name;
output_string oc ".ml ");
output_string oc ": tkgen.ml\n\n";
Hashtbl.iter module_table ~f:
begin fun ~key:name ~data:_ ->
output_string oc name;
output_string oc ".cmo : ";
output_string oc name;
output_string oc ".ml\n";
output_string oc name;
output_string oc ".cmi : ";
output_string oc name;
output_string oc ".mli\n"
end;
close_out oc
output_string oc "WIDGETOBJS=";
Hashtbl.iter
(fun name _ ->
output_string oc name;
output_string oc ".cmo ")
module_table;
output_string oc "\n";
Hashtbl.iter
(fun name _ ->
output_string oc name;
output_string oc ".ml ")
module_table;
output_string oc ": tkgen.ml\n\n";
Hashtbl.iter
(fun name _ ->
output_string oc name;
output_string oc ".cmo : ";
output_string oc name;
output_string oc ".ml\n";
output_string oc name;
output_string oc ".cmi : ";
output_string oc name;
output_string oc ".mli\n")
module_table;
close_out oc
let main () =
Arg.parse
~keywords:[ "-verbose", Arg.Unit (fun () -> flag_verbose := true),
"Make output verbose" ]
~others:(fun filename -> input_name := filename)
~errmsg:"Usage: tkcompiler <source file>" ;
[ "-verbose", Arg.Unit (fun () -> flag_verbose := true),
"Make output verbose" ]
(fun filename -> input_name := filename)
"Usage: tkcompiler <source file>" ;
try
verbose_string "Parsing... ";
verbose_endline "Parsing...";
parse_file !input_name;
verbose_string "Compiling... ";
verbose_endline "Compiling...";
compile ();
verbose_string "Finished";
verbose_endline "Finished";
exit 0
with
| Lexer.Lexical_error s ->

26
otherlibs/labltk/compiler/tables.ml
View File

@ -15,6 +15,9 @@
(* $Id$ *)
open StdLabels
open Support
(* Internal compiler errors *)
exception Compiler_Error of string
@ -60,7 +63,7 @@ type fullcomponent = {
}
let sort_components =
Sort.list ~order:(fun c1 c2 -> c1.ml_name < c2.ml_name)
List.sort ~cmp:(fun c1 c2 -> compare c1.ml_name c2.ml_name)
(* components are given either in full or abbreviated *)
@ -153,7 +156,7 @@ let new_type typname arity =
subtypes = [];
requires_widget_context = false;
variant = false} in
Hashtbl.add types_table ~key:typname ~data:typdef;
Hashtbl'.add types_table ~key:typname ~data:typdef;
typdef
@ -178,7 +181,7 @@ let declared_type_parser_arity s =
(Hashtbl.find types_table s).parser_arity
with
Not_found ->
try List.assoc s !types_external
try List.assoc s ~map:!types_external
with
Not_found ->
prerr_string "Type "; prerr_string s;
@ -344,8 +347,8 @@ let enter_subtype typ arity subtyp constructors =
in
(* TODO: duplicate def in subtype are not checked *)
typdef.subtypes <-
(subtyp , Sort.list real_constructors
~order:(fun c1 c2 -> c1.var_name <= c2.var_name)) ::
(subtyp , List.sort real_constructors
~cmp:(fun c1 c2 -> compare c1.var_name c2.var_name)) ::
typdef.subtypes
end
@ -385,13 +388,13 @@ let enter_widget name components =
| External, _ -> ()
end;
let commands =
try List.assoc Command sorted_components
try List.assoc Command ~map:sorted_components
with Not_found -> []
and externals =
try List.assoc External sorted_components
try List.assoc External ~map:sorted_components
with Not_found -> []
in
Hashtbl.add module_table ~key:name
Hashtbl'.add module_table ~key:name
~data:{module_type = Widget; commands = commands; externals = externals}
(******************** Functions ********************)
@ -412,12 +415,11 @@ let enter_module name components =
| External, _ -> ()
end;
let commands =
try List.assoc Command sorted_components
try List.assoc Command ~map:sorted_components
with Not_found -> []
and externals =
try List.assoc External sorted_components
try List.assoc External ~map:sorted_components
with Not_found -> []
in
Hashtbl.add module_table ~key:name
Hashtbl'.add module_table ~key:name
~data:{module_type = Family; commands = commands; externals = externals}

2
otherlibs/labltk/compiler/tsort.ml
View File

@ -15,6 +15,8 @@
(* $Id$ *)
open StdLabels
(* Topological Sort.list *)
(* d'apres More Programming Pearls *)

1
otherlibs/labltk/example/calc.ml
View File

@ -22,6 +22,7 @@
makes things a little bit awkward.
*)
open StdLabels
open Tk
let mem_string ~elt:c s =

40
otherlibs/labltk/example/clock.ml
View File

@ -46,37 +46,36 @@ class clock ~parent = object (self)
initializer
(* Create the oval border *)
Canvas.create_oval ~x1:1 ~y1:1 ~x2:(width - 2) ~y2:(height - 2)
~tags:["cadran"] ~width:3 ~outline:`Yellow ~fill:`White
canvas;
Canvas.create_oval canvas ~tags:["cadran"]
~x1:1 ~y1:1 ~x2:(width - 2) ~y2:(height - 2)
~width:3 ~outline:`Yellow ~fill:`White;
(* Draw the figures *)
self#draw_figures;
(* Create the arrows with dummy position *)
Canvas.create_line ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
~tags:["hours"] ~fill:`Red
canvas;
Canvas.create_line ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
~tags:["minutes"] ~fill:`Blue
canvas;
Canvas.create_line ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
~tags:["seconds"] ~fill:`Black
canvas;
Canvas.create_line canvas
~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
~tags:["hours"] ~fill:`Red;
Canvas.create_line canvas
~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
~tags:["minutes"] ~fill:`Blue;
Canvas.create_line canvas
~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.]
~tags:["seconds"] ~fill:`Black;
(* Setup a timer every second *)
let rec timer () =
self#draw_arrows (Unix.localtime (Unix.time ()));
Timer.add ~ms:1000 ~callback:timer; ()
in timer ();
(* Redraw when configured (changes size) *)
bind ~events:[`Configure]
~action:(fun _ ->
bind canvas ~events:[`Configure] ~action:
begin fun _ ->
width <- Winfo.width canvas;
height <- Winfo.height canvas;
self#redraw)
canvas;
self#redraw
end;
(* Change direction with right button *)
bind ~events:[`ButtonPressDetail 3]
~action:(fun _ -> rflag <- -rflag; self#redraw)
canvas;
bind canvas ~events:[`ButtonPressDetail 3]
~action:(fun _ -> rflag <- -rflag; self#redraw);
(* Pack, expanding in both directions *)
pack ~fill:`Both ~expand:true [canvas]
@ -92,12 +91,11 @@ class clock ~parent = object (self)
Canvas.delete canvas [`Tag "figures"];
for i = 1 to 12 do
let angle = float (rflag * i - 3) *. pi /. 6. in
Canvas.create_text
Canvas.create_text canvas
~x:(self#x (0.8 *. cos angle)) ~y:(self#y (0.8 *. sin angle))
~tags:["figures"]
~text:(string_of_int i) ~font:"variable"
~anchor:`Center
canvas
done
(* Resize and reposition the arrows *)

1
otherlibs/labltk/example/demo.ml
View File

@ -17,6 +17,7 @@
(* Some CamlTk4 Demonstration by JPF *)
(* First, open these modules for convenience *)
open StdLabels
open Tk
(* Dummy let *)

9
otherlibs/labltk/example/tetris.ml
View File

@ -17,6 +17,7 @@
(* A Tetris game for LablTk *)
(* written by Jun P. Furuse *)
open StdLabels
open Tk
exception Done
@ -643,21 +644,21 @@ let _ =
| "h" ->
let m = copy_block current in
m.x <- m.x - 1;
try_to_move m; ()
ignore (try_to_move m)
| "j" ->
let m = copy_block current in
m.d <- m.d + 1;
if m.d = List.length m.pattern then m.d <- 0;
try_to_move m; ()
ignore (try_to_move m)
| "k" ->
let m = copy_block current in
m.d <- m.d - 1;
if m.d < 0 then m.d <- List.length m.pattern - 1;
try_to_move m; ()
ignore (try_to_move m)
| "l" ->
let m = copy_block current in
m.x <- m.x + 1;
try_to_move m; ()
ignore (try_to_move m)
| "m" ->
remove_timer ();
loop ()

5
otherlibs/labltk/jpf/balloon.ml
View File

@ -13,11 +13,14 @@
(* $Id$ *)
open StdLabels
(* easy balloon help facility *)
open Tk
open Widget
open Protocol
open Support
(* switch -- if you do not want balloons, set false *)
let flag = ref true
@ -90,7 +93,7 @@ let init () =
begin fun w ->
try Hashtbl.find t w.ev_Widget
with Not_found ->
Hashtbl.add t ~key:w.ev_Widget ~data: ();
Hashtbl'.add t ~key:w.ev_Widget ~data: ();
let x = Option.get w.ev_Widget ~name: "balloon" ~clas: "Balloon" in
if x <> "" then put ~on: w.ev_Widget ~ms: 1000 x
end

29
otherlibs/labltk/jpf/fileselect.ml
View File

@ -15,7 +15,8 @@
(* file selection box *)
open Unix
open StdLabels
open UnixLabels
open Str
open Filename
@ -72,20 +73,22 @@ let dirget = regexp "^\([^\*?[]*/\)\(.*\)"
let parse_filter src =
(* replace // by / *)
let s = global_replace ~pat:(regexp "/+") ~templ:"/" src in
let s = global_replace (regexp "/+") "/" src in
(* replace /./ by / *)
let s = global_replace ~pat:(regexp "/\./") ~templ:"/" s in
let s = global_replace (regexp "/\./") "/" s in
(* replace ????/../ by "" *)
let s = global_replace s
~pat:(regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\./")
~templ:"" in
let s = global_replace
(regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\./")
""
s in
(* replace ????/..$ by "" *)
let s = global_replace s
~pat:(regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\.$")
~templ:"" in
let s = global_replace
(regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\.$")
""
s in
(* replace ^/../../ by / *)
let s = global_replace ~pat:(regexp "^\(/\.\.\)+/") ~templ:"/" s in
if string_match ~pat:dirget s ~pos:0 then
let s = global_replace (regexp "^\(/\.\.\)+/") "/" s in
if string_match dirget s 0 then
let dirs = matched_group 1 s
and ptrn = matched_group 2 s
in
@ -108,7 +111,7 @@ let get_files_in_directory dir =
| Some x ->
get_them (x::l)
in
Sort.list ~order:(<=) (get_them [])
List.sort ~cmp:compare (get_them [])
let rec get_directories_in_files path =
List.filter
@ -218,7 +221,7 @@ let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync =
(* OLDER let curdir = getcwd () in *)
(* Printf.eprintf "CURDIR %s\n" curdir; *)
let filter =
if string_match ~pat:(regexp "^/.*") filter ~pos:0 then filter
if string_match (regexp "^/.*") filter 0 then filter
else
if filter = "" then !global_dir ^ "/*"
else !global_dir ^ "/" ^ filter in

3
otherlibs/labltk/lib/Makefile.gen
View File

@ -8,7 +8,8 @@ tkgen.ml: ../Widgets.src ../compiler/tkcompiler
# dependencies are broken: wouldn't work with gmake 3.77
tk.ml .depend: tkgen.ml ../builtin/report.ml #../builtin/builtin_*.ml
(echo 'open Widget'; \
(echo 'open StdLabels'; \
echo 'open Widget'; \
echo 'open Protocol'; \
echo 'open Support'; \
echo 'open Textvariable'; \

20
otherlibs/labltk/support/.depend
View File

@ -1,16 +1,16 @@
protocol.cmi: widget.cmi
textvariable.cmi: protocol.cmi widget.cmi
fileevent.cmo: protocol.cmi fileevent.cmi
fileevent.cmx: protocol.cmx fileevent.cmi
protocol.cmo: widget.cmi protocol.cmi
protocol.cmx: widget.cmx protocol.cmi
fileevent.cmo: protocol.cmi support.cmi fileevent.cmi
fileevent.cmx: protocol.cmx support.cmx fileevent.cmi
protocol.cmo: support.cmi widget.cmi protocol.cmi
protocol.cmx: support.cmx widget.cmx protocol.cmi
slave.cmo: widget.cmi
slave.cmx: widget.cmx
support.cmo: support.cmi
support.cmx: support.cmi
textvariable.cmo: protocol.cmi widget.cmi textvariable.cmi
textvariable.cmx: protocol.cmx widget.cmx textvariable.cmi
timer.cmo: protocol.cmi timer.cmi
timer.cmx: protocol.cmx timer.cmi
widget.cmo: widget.cmi
widget.cmx: widget.cmi
textvariable.cmo: protocol.cmi support.cmi widget.cmi textvariable.cmi
textvariable.cmx: protocol.cmx support.cmx widget.cmx textvariable.cmi
timer.cmo: protocol.cmi support.cmi timer.cmi
timer.cmx: protocol.cmx support.cmx timer.cmi
widget.cmo: support.cmi widget.cmi
widget.cmx: support.cmx widget.cmi

2
otherlibs/labltk/support/Makefile.common
View File

@ -12,7 +12,7 @@ LABLTKDIR=$(LIBDIR)/labltk
CAMLRUN=$(TOPDIR)/boot/ocamlrun
LABLC=$(CAMLRUN) $(TOPDIR)/ocamlc -I $(TOPDIR)/stdlib
LABLCOMP=$(LABLC) -labels -c
LABLCOMP=$(LABLC) -c
LABLYACC=$(TOPDIR)/boot/ocamlyacc -v
LABLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex
LABLLIBR=$(LABLC) -a

9
otherlibs/labltk/support/fileevent.ml
View File

@ -16,6 +16,7 @@
(* $Id$ *)
open Unix
open Support
open Protocol
external add_file_input : file_descr -> cbid -> unit
@ -33,8 +34,8 @@ let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *)
let add_fileinput ~fd ~callback:f =
let id = new_function_id () in
Hashtbl.add callback_naming_table ~key:id ~data:(fun _ -> f());
Hashtbl.add fd_table ~key:(fd, 'r') ~data:id;
Hashtbl'.add callback_naming_table ~key:id ~data:(fun _ -> f());
Hashtbl'.add fd_table ~key:(fd, 'r') ~data:id;
if !Protocol.debug then begin
Protocol.prerr_cbid id; prerr_endline " for fileinput"
end;
@ -56,8 +57,8 @@ let remove_fileinput ~fd =
let add_fileoutput ~fd ~callback:f =
let id = new_function_id () in
Hashtbl.add callback_naming_table ~key:id ~data:(fun _ -> f());
Hashtbl.add fd_table ~key:(fd, 'w') ~data:id;
Hashtbl'.add callback_naming_table ~key:id ~data:(fun _ -> f());
Hashtbl'.add fd_table ~key:(fd, 'w') ~data:id;
if !Protocol.debug then begin
Protocol.prerr_cbid id; prerr_endline " for fileoutput"
end;

8
otherlibs/labltk/support/protocol.ml
View File

@ -15,6 +15,8 @@
(* $Id$ *)
open StdLabels
open Support
open Widget
type callback_buffer = string list
@ -107,9 +109,9 @@ let string_of_cbid = string_of_int
(* The callback should be cleared when w is destroyed *)
let register_callback w ~callback:f =
let id = new_function_id () in
Hashtbl.add callback_naming_table ~key:id ~data:f;
Hashtbl'.add callback_naming_table ~key:id ~data:f;
if (forget_type w) <> (forget_type Widget.dummy) then
Hashtbl.add callback_memo_table ~key:(forget_type w) ~data:id;
Hashtbl'.add callback_memo_table ~key:(forget_type w) ~data:id;
(string_of_cbid id)
let clear_callback id =
@ -143,7 +145,7 @@ let install_cleanup () =
List.iter ~f:(fun f -> f w) !destroy_hooks
| _ -> raise (TkError "bad cleanup callback") in
let fid = new_function_id () in
Hashtbl.add callback_naming_table ~key:fid ~data:call_destroy_hooks;
Hashtbl'.add callback_naming_table ~key:fid ~data:call_destroy_hooks;
(* setup general destroy callback *)
tcl_command ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}")

6
otherlibs/labltk/support/support.ml
View File

@ -15,6 +15,8 @@
(* $Id$ *)
open StdLabels
(* Parsing results of Tcl *)
(* List.split a string according to char_sep predicate *)
let split_str ~pred:char_sep str =
@ -45,3 +47,7 @@ let maycons f x l =
match x with
Some x -> f x :: l
| None -> l
(* Get some labels on Hashtbl.add *)
module Hashtbl' =
struct let add tbl ~key ~data = Hashtbl.add tbl key data end

2
otherlibs/labltk/support/support.mli
View File

@ -18,3 +18,5 @@
val split_str : pred:(char -> bool) -> string -> string list
val may : ('a -> 'b) -> 'a option -> 'b option
val maycons : ('a -> 'b) -> 'a option -> 'b list -> 'b list
module Hashtbl' :
sig val add : ('a, 'b) Hashtbl.t -> key:'a -> data:'b -> unit end

10
otherlibs/labltk/support/textvariable.ml
View File

@ -15,6 +15,8 @@
(* $Id$ *)
open StdLabels
open Support
open Protocol
external internal_tracevar : string -> cbid -> unit
@ -36,7 +38,7 @@ let add_handle var cbid =
r := cbid :: !r
with
Not_found ->
Hashtbl.add handles ~key:var ~data:(ref [cbid])
Hashtbl'.add handles var (ref [cbid])
let exceptq x =
let rec ex acc = function
@ -74,7 +76,7 @@ let handle vname ~callback:f =
clear_callback id;
rem_handle vname id;
f() in
Hashtbl.add callback_naming_table ~key:id ~data:wrapped;
Hashtbl'.add callback_naming_table ~key:id ~data:wrapped;
add_handle vname id;
if !Protocol.debug then begin
prerr_cbid id; prerr_string " for variable "; prerr_endline vname
@ -95,7 +97,7 @@ let add w v =
with
Not_found ->
let r = ref StringSet.empty in
Hashtbl.add memo ~key:w ~data:r;
Hashtbl'.add memo ~key:w ~data:r;
r in
r := StringSet.add v !r
@ -108,7 +110,7 @@ let free v =
let freew w =
try
let r = Hashtbl.find memo w in
StringSet.iter ~f:free !r;
StringSet.iter free !r;
Hashtbl.remove memo w
with
Not_found -> ()

3
otherlibs/labltk/support/timer.ml
View File

@ -16,6 +16,7 @@
(* $Id$ *)
(* Timers *)
open Support
open Protocol
type tkTimer = int
@ -33,7 +34,7 @@ let add ~ms ~callback =
let wrapped _ =
clear_callback id; (* do it first in case f raises exception *)
callback() in
Hashtbl.add callback_naming_table ~key:id ~data:wrapped;
Hashtbl'.add callback_naming_table ~key:id ~data:wrapped;
if !Protocol.debug then begin
prerr_cbid id; prerr_endline " for timer"
end;

9
otherlibs/labltk/support/widget.ml
View File

@ -15,6 +15,9 @@
(* $Id$ *)
open StdLabels
open Support
(*
* Widgets
*)
@ -66,7 +69,7 @@ let known_class = function
let default_toplevel =
let wname = "." in
let w = Typed (wname, "toplevel") in
Hashtbl.add table ~key:wname ~data:w;
Hashtbl'.add table ~key:wname ~data:w;
w
(* Dummy widget to which global callbacks are associated *)
@ -123,7 +126,7 @@ and widget_toplevel_table = [ "toplevel" ]
let new_suffix clas n =
try
(List.assoc clas naming_scheme) ^ (string_of_int n)
(List.assoc clas ~map:naming_scheme) ^ (string_of_int n)
with
Not_found -> "w" ^ (string_of_int n)
@ -145,7 +148,7 @@ let new_atom ~parent ?name:nom clas =
else parentpath ^ "." ^ name
in
let w = Typed(path,clas) in
Hashtbl.add table ~key:path ~data:w;
Hashtbl'.add table ~key:path ~data:w;
w
(* Just create a path. Only to check existence of widgets *)

34
otherlibs/str/str.mli
View File

@ -56,23 +56,23 @@ val regexp_string_case_fold: string -> regexp
(*** String matching and searching *)
external string_match: pat:regexp -> string -> pos:int -> bool
external string_match: regexp -> string -> int -> bool
= "str_string_match"
(* [string_match r s start] tests whether the characters in [s]
starting at position [start] match the regular expression [r].
The first character of a string has position [0], as usual. *)
external search_forward: pat:regexp -> string -> pos:int -> int
external search_forward: regexp -> string -> int -> int
= "str_search_forward"
(* [search_forward r s start] searchs the string [s] for a substring
matching the regular expression [r]. The search starts at position
[start] and proceeds towards the end of the string.
Return the position of the first character of the matched
substring, or raise [Not_found] if no substring matches. *)
external search_backward: pat:regexp -> string -> pos:int -> int
external search_backward: regexp -> string -> int -> int
= "str_search_backward"
(* Same as [search_forward], but the search proceeds towards the
beginning of the string. *)
external string_partial_match: pat:regexp -> string -> pos:int -> bool
external string_partial_match: regexp -> string -> int -> bool
= "str_string_partial_match"
(* Similar to [string_match], but succeeds whenever the argument
string is a prefix of a string that matches. This includes
@ -114,28 +114,28 @@ val group_end: int -> int
(*** Replacement *)
val global_replace: pat:regexp -> templ:string -> string -> string
val global_replace: regexp -> string -> string -> string
(* [global_replace regexp templ s] returns a string identical to [s],
except that all substrings of [s] that match [regexp] have been
replaced by [templ]. The replacement template [templ] can contain
[\1], [\2], etc; these sequences will be replaced by the text
matched by the corresponding group in the regular expression.
[\0] stands for the text matched by the whole regular expression. *)
val replace_first: pat:regexp -> templ:string -> string -> string
val replace_first: regexp -> string -> string -> string
(* Same as [global_replace], except that only the first substring
matching the regular expression is replaced. *)
val global_substitute:
pat:regexp -> subst:(string -> string) -> string -> string
regexp -> (string -> string) -> string -> string
(* [global_substitute regexp subst s] returns a string identical
to [s], except that all substrings of [s] that match [regexp]
have been replaced by the result of function [subst]. The
function [subst] is called once for each matching substring,
and receives [s] (the whole text) as argument. *)
val substitute_first:
pat:regexp -> subst:(string -> string) -> string -> string
regexp -> (string -> string) -> string -> string
(* Same as [global_substitute], except that only the first substring
matching the regular expression is replaced. *)
val replace_matched : templ:string -> string -> string
val replace_matched : string -> string -> string
(* [replace_matched repl s] returns the replacement text [repl]
in which [\1], [\2], etc. have been replaced by the text
matched by the corresponding groups in the most recent matching
@ -144,18 +144,18 @@ val replace_matched : templ:string -> string -> string
(*** Splitting *)
val split: sep:regexp -> string -> string list
val split: regexp -> string -> string list
(* [split r s] splits [s] into substrings, taking as delimiters
the substrings that match [r], and returns the list of substrings.
For instance, [split (regexp "[ \t]+") s] splits [s] into
blank-separated words. An occurrence of the delimiter at the
beginning and at the end of the string is ignored. *)
val bounded_split: sep:regexp -> string -> max:int -> string list
val bounded_split: regexp -> string -> int -> string list
(* Same as [split], but splits into at most [n] substrings,
where [n] is the extra integer parameter. *)
val split_delim: sep:regexp -> string -> string list
val bounded_split_delim: sep:regexp -> string -> max:int -> string list
val split_delim: regexp -> string -> string list
val bounded_split_delim: regexp -> string -> int -> string list
(* Same as [split] and [bounded_split], but occurrences of the
delimiter at the beginning and at the end of the string are
recognized and returned as empty strings in the result.
@ -165,8 +165,8 @@ val bounded_split_delim: sep:regexp -> string -> max:int -> string list
type split_result = Text of string | Delim of string
val full_split: sep:regexp -> string -> split_result list
val bounded_full_split: sep:regexp -> string -> int -> split_result list
val full_split: regexp -> string -> split_result list
val bounded_full_split: regexp -> string -> int -> split_result list
(* Same as [split_delim] and [bounded_split_delim], but returns
the delimiters as well as the substrings contained between
delimiters. The former are tagged [Delim] in the result list;
@ -184,8 +184,8 @@ val string_after: string -> int -> string
(* [string_after s n] returns the substring of all characters of [s]
that follow position [n] (including the character at
position [n]). *)
val first_chars: string -> len:int -> string
val first_chars: string -> int -> string
(* [first_chars s n] returns the first [n] characters of [s].
This is the same function as [string_before]. *)
val last_chars: string -> len:int -> string
val last_chars: string -> int -> string
(* [last_chars s n] returns the last [n] characters of [s]. *)

2
otherlibs/systhreads/condition.mli
View File

@ -35,7 +35,7 @@ type t
(* The type of condition variables. *)
val create: unit -> t
(* Return a new condition variable. *)
val wait: t -> locking:Mutex.t -> unit
val wait: t -> Mutex.t -> unit
(* [wait c m] atomically unlocks the mutex [m] and suspends the
calling process on the condition variable [c]. The process will
restart after the condition variable [c] has been signalled.

4
otherlibs/systhreads/event.mli
View File

@ -39,11 +39,11 @@ val always: 'a -> 'a event
val choose: 'a event list -> 'a event
(* [choose evl] returns the event that is the alternative of
all the events in the list [evl]. *)
val wrap: 'a event -> f:('a -> 'b) -> 'b event
val wrap: 'a event -> ('a -> 'b) -> 'b event
(* [wrap ev fn] returns the event that performs the same communications
as [ev], then applies the post-processing function [fn]
on the return value. *)
val wrap_abort: 'a event -> f:(unit -> unit) -> 'a event
val wrap_abort: 'a event -> (unit -> unit) -> 'a event
(* [wrap_abort ev fn] returns the event that performs
the same communications as [ev], but if it is not selected
the function [fn] is called after the synchronization. *)

8
otherlibs/systhreads/thread.mli
View File

@ -54,8 +54,8 @@ external join : t -> unit = "caml_thread_join"
val wait_read : Unix.file_descr -> unit
val wait_write : Unix.file_descr -> unit
(* These functions do nothing in this implementation. *)
val wait_timed_read : Unix.file_descr -> timeout:float -> bool
val wait_timed_write : Unix.file_descr -> timeout:float -> bool
val wait_timed_read : Unix.file_descr -> float -> bool
val wait_timed_write : Unix.file_descr -> float -> bool
(* Suspend the execution of the calling thread until at least
one character is available for reading ([wait_read]) or
one character can be written without blocking ([wait_write])
@ -66,8 +66,8 @@ val wait_timed_write : Unix.file_descr -> timeout:float -> bool
(* These functions return immediately [true] in the Win32
implementation. *)
val select :
read:Unix.file_descr list -> write:Unix.file_descr list ->
exn:Unix.file_descr list -> timeout:float ->
Unix.file_descr list -> Unix.file_descr list ->
Unix.file_descr list -> float ->
Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
(* Suspend the execution of the calling thead until input/output
becomes possible on the given Unix file descriptors.

42
otherlibs/systhreads/threadUnix.mli
View File

@ -22,26 +22,26 @@
(*** Process handling *)
val execv : prog:string -> args:string array -> unit
val execve : prog:string -> args:string array -> env:string array -> unit
val execvp : prog:string -> args:string array -> unit
val execv : string -> string array -> unit
val execve : string -> string array -> string array -> unit
val execvp : string -> string array -> unit
val wait : unit -> int * Unix.process_status
val waitpid : mode:Unix.wait_flag list -> int -> int * Unix.process_status
val waitpid : Unix.wait_flag list -> int -> int * Unix.process_status
val system : string -> Unix.process_status
(*** Basic input/output *)
val read : Unix.file_descr -> buf:string -> pos:int -> len:int -> int
val write : Unix.file_descr -> buf:string -> pos:int -> len:int -> int
val read : Unix.file_descr -> string -> int -> int -> int
val write : Unix.file_descr -> string -> int -> int -> int
(*** Input/output with timeout *)
val timed_read :
Unix.file_descr ->
buf:string -> pos:int -> len:int -> timeout:float -> int
string -> int -> int -> float -> int
val timed_write :
Unix.file_descr ->
buf:string -> pos:int -> len:int -> timeout:float -> int
string -> int -> int -> float -> int
(* Behave as [read] and [write], except that
[Unix_error(ETIMEDOUT,_,_)] is raised if no data is
available for reading or ready for writing after [d] seconds.
@ -50,8 +50,8 @@ val timed_write :
(*** Polling *)
val select :
read:Unix.file_descr list -> write:Unix.file_descr list ->
except:Unix.file_descr list -> timeout:float ->
Unix.file_descr list -> Unix.file_descr list ->
Unix.file_descr list -> float ->
Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
(*** Pipes and redirections *)
@ -67,16 +67,16 @@ val sleep : int -> unit
(*** Sockets *)
val socket : domain:Unix.socket_domain ->
kind:Unix.socket_type -> protocol:int -> Unix.file_descr
val socket : Unix.socket_domain ->
Unix.socket_type -> int -> Unix.file_descr
val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr
val connect : Unix.file_descr -> addr:Unix.sockaddr -> unit
val recv : Unix.file_descr -> buf:string ->
pos:int -> len:int -> mode:Unix.msg_flag list -> int
val recvfrom : Unix.file_descr -> buf:string -> pos:int -> len:int ->
mode:Unix.msg_flag list -> int * Unix.sockaddr
val send : Unix.file_descr -> buf:string -> pos:int -> len:int ->
mode:Unix.msg_flag list -> int
val sendto : Unix.file_descr -> buf:string -> pos:int -> len:int ->
mode:Unix.msg_flag list -> addr:Unix.sockaddr -> int
val connect : Unix.file_descr -> Unix.sockaddr -> unit
val recv : Unix.file_descr -> string ->
int -> int -> Unix.msg_flag list -> int
val recvfrom : Unix.file_descr -> string -> int -> int ->
Unix.msg_flag list -> int * Unix.sockaddr
val send : Unix.file_descr -> string -> int -> int ->
Unix.msg_flag list -> int
val sendto : Unix.file_descr -> string -> int -> int ->
Unix.msg_flag list -> Unix.sockaddr -> int
val open_connection : Unix.sockaddr -> in_channel * out_channel

4
otherlibs/threads/Makefile
View File

@ -36,7 +36,9 @@ LIB_OBJS=pervasives.cmo \
$(LIB)/printexc.cmo $(LIB)/gc.cmo $(LIB)/digest.cmo $(LIB)/random.cmo \
$(LIB)/oo.cmo $(LIB)/genlex.cmo $(LIB)/callback.cmo $(LIB)/weak.cmo \
$(LIB)/lazy.cmo $(LIB)/filename.cmo $(LIB)/int32.cmo $(LIB)/int64.cmo \
$(LIB)/nativeint.cmo
$(LIB)/nativeint.cmo \
$(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo $(LIB)/stringLabels.cmo \
$(LIB)/stdLabels.cmo
UNIXLIB=../unix

2
otherlibs/threads/condition.mli
View File

@ -35,7 +35,7 @@ type t
(* The type of condition variables. *)
val create: unit -> t
(* Return a new condition variable. *)
val wait: t -> locking:Mutex.t -> unit
val wait: t -> Mutex.t -> unit
(* [wait c m] atomically unlocks the mutex [m] and suspends the
calling process on the condition variable [c]. The process will
restart after the condition variable [c] has been signalled.

4
otherlibs/threads/event.mli
View File

@ -39,11 +39,11 @@ val always: 'a -> 'a event
val choose: 'a event list -> 'a event
(* [choose evl] returns the event that is the alternative of
all the events in the list [evl]. *)
val wrap: 'a event -> f:('a -> 'b) -> 'b event
val wrap: 'a event -> ('a -> 'b) -> 'b event
(* [wrap ev fn] returns the event that performs the same communications
as [ev], then applies the post-processing function [fn]
on the return value. *)
val wrap_abort: 'a event -> f:(unit -> unit) -> 'a event
val wrap_abort: 'a event -> (unit -> unit) -> 'a event
(* [wrap_abort ev fn] returns the event that performs
the same communications as [ev], but if it is not selected
the function [fn] is called after the synchronization. *)

2
otherlibs/threads/marshal.ml
View File

@ -31,6 +31,8 @@ let to_buffer buff ofs len v flags =
then invalid_arg "Marshal.to_buffer: substring out of bounds"
else to_buffer_unsafe buff ofs len v flags
let to_buffer' ~buf ~pos ~len v ~mode = to_buffer buf pos len v mode
external from_string_unsafe: string -> int -> 'a = "input_value_from_string"
external data_size_unsafe: string -> int -> int = "marshal_data_size"

4
otherlibs/threads/pervasives.ml
View File

@ -287,6 +287,8 @@ let output oc s ofs len =
then invalid_arg "output"
else unsafe_output oc s ofs len
let output' oc ~buf ~pos ~len = output oc buf pos len
let rec output_byte oc b =
try
output_byte_blocking oc b
@ -350,6 +352,8 @@ let input ic s ofs len =
then invalid_arg "input"
else unsafe_input ic s ofs len
let input' ic ~buf ~pos ~len = input ic buf pos len
let rec unsafe_really_input ic s ofs len =
if len <= 0 then () else begin
let r = unsafe_input ic s ofs len in

8
otherlibs/threads/thread.mli
View File

@ -58,15 +58,15 @@ val wait_write : Unix.file_descr -> unit
one character is available for reading ([wait_read]) or
one character can be written without blocking ([wait_write])
on the given Unix file descriptor. *)
val wait_timed_read : Unix.file_descr -> timeout:float -> bool
val wait_timed_write : Unix.file_descr -> timeout:float -> bool
val wait_timed_read : Unix.file_descr -> float -> bool
val wait_timed_write : Unix.file_descr -> float -> bool
(* Same as [wait_read] and [wait_write], but wait for at most
the amount of time given as second argument (in seconds).
Return [true] if the file descriptor is ready for input/output
and [false] if the timeout expired. *)
val select :
read:Unix.file_descr list -> write:Unix.file_descr list ->
exn:Unix.file_descr list -> timeout:float ->
Unix.file_descr list -> Unix.file_descr list ->
Unix.file_descr list -> float ->
Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
(* Suspend the execution of the calling thead until input/output
becomes possible on the given Unix file descriptors.

50
otherlibs/threads/threadUnix.mli
View File

@ -22,26 +22,26 @@
(*** Process handling *)
val execv : prog:string -> args:string array -> unit
val execve : prog:string -> args:string array -> env:string array -> unit
val execvp : prog:string -> args:string array -> unit
val execv : string -> string array -> unit
val execve : string -> string array -> string array -> unit
val execvp : string -> string array -> unit
val wait : unit -> int * Unix.process_status
val waitpid : mode:Unix.wait_flag list -> int -> int * Unix.process_status
val waitpid : Unix.wait_flag list -> int -> int * Unix.process_status
val system : string -> Unix.process_status
(*** Basic input/output *)
val read : Unix.file_descr -> buf:string -> pos:int -> len:int -> int
val write : Unix.file_descr -> buf:string -> pos:int -> len:int -> int
val read : Unix.file_descr -> string -> int -> int -> int
val write : Unix.file_descr -> string -> int -> int -> int
(*** Input/output with timeout *)
val timed_read :
Unix.file_descr ->
buf:string -> pos:int -> len:int -> timeout:float -> int
string -> int -> int -> float -> int
val timed_write :
Unix.file_descr ->
buf:string -> pos:int -> len:int -> timeout:float -> int
string -> int -> int -> float -> int
(* Behave as [read] and [write], except that
[Unix_error(ETIMEDOUT,_,_)] is raised if no data is
available for reading or ready for writing after [d] seconds.
@ -50,8 +50,8 @@ val timed_write :
(*** Polling *)
val select :
read:Unix.file_descr list -> write:Unix.file_descr list ->
except:Unix.file_descr list -> timeout:float ->
Unix.file_descr list -> Unix.file_descr list ->
Unix.file_descr list -> float ->
Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
(*** Pipes and redirections *)
@ -61,7 +61,7 @@ val open_process_in: string -> in_channel
val open_process_out: string -> out_channel
val open_process: string -> in_channel * out_channel
val open_process_full:
string -> env:string array -> in_channel * out_channel * in_channel
string -> string array -> in_channel * out_channel * in_channel
(*** Time *)
@ -69,21 +69,21 @@ val sleep : int -> unit
(*** Sockets *)
val socket : domain:Unix.socket_domain ->
kind:Unix.socket_type -> protocol:int -> Unix.file_descr
val socketpair : domain:Unix.socket_domain -> kind:Unix.socket_type ->
protocol:int -> Unix.file_descr * Unix.file_descr
val socket : Unix.socket_domain ->
Unix.socket_type -> int -> Unix.file_descr
val socketpair : Unix.socket_domain -> Unix.socket_type ->
int -> Unix.file_descr * Unix.file_descr
val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr
val connect : Unix.file_descr -> addr:Unix.sockaddr -> unit
val recv : Unix.file_descr -> buf:string ->
pos:int -> len:int -> mode:Unix.msg_flag list -> int
val recvfrom : Unix.file_descr -> buf:string -> pos:int -> len:int ->
mode:Unix.msg_flag list -> int * Unix.sockaddr
val send : Unix.file_descr -> buf:string -> pos:int -> len:int ->
mode:Unix.msg_flag list -> int
val sendto : Unix.file_descr -> buf:string -> pos:int -> len:int ->
mode:Unix.msg_flag list -> addr:Unix.sockaddr -> int
val connect : Unix.file_descr -> Unix.sockaddr -> unit
val recv : Unix.file_descr -> string ->
int -> int -> Unix.msg_flag list -> int
val recvfrom : Unix.file_descr -> string -> int -> int ->
Unix.msg_flag list -> int * Unix.sockaddr
val send : Unix.file_descr -> string -> int -> int ->
Unix.msg_flag list -> int
val sendto : Unix.file_descr -> string -> int -> int ->
Unix.msg_flag list -> Unix.sockaddr -> int
val open_connection : Unix.sockaddr -> in_channel * out_channel
val establish_server :
(in_channel -> out_channel -> unit) ->
addr:Unix.sockaddr -> unit
Unix.sockaddr -> unit

2
otherlibs/unix/.depend
View File

@ -90,3 +90,5 @@ wait.o: wait.c unixsupport.h
write.o: write.c unixsupport.h
unix.cmo: unix.cmi
unix.cmx: unix.cmi
unixLabels.cmo: unix.cmi unixLabels.cmi
unixLabels.cmx: unix.cmx unixLabels.cmi

22
otherlibs/unix/Makefile
View File

@ -39,18 +39,20 @@ OBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \
time.o times.o truncate.o umask.o unixsupport.o unlink.o \
utimes.o wait.o write.o
all: libunix.a unix.cmi unix.cma
MLOBJS=unix.cmo unixLabels.cmo
allopt: libunix.a unix.cmi unix.cmxa
all: libunix.a unix.cma
allopt: libunix.a unix.cmxa
libunix.a: $(OBJS)
$(MKLIB) -o unix $(OBJS)
unix.cma: unix.cmo
$(MKLIB) -o unix -ocamlc '$(CAMLC)' -linkall unix.cmo
unix.cma: $(MLOBJS)
$(MKLIB) -o unix -ocamlc '$(CAMLC)' -linkall $(MLOBJS)
unix.cmxa: unix.cmx
$(MKLIB) -o unix -ocamlopt '$(CAMLOPT)' -linkall unix.cmx
unix.cmxa: $(MLOBJS:.cmo=.cmx)
$(MKLIB) -o unix -ocamlopt '$(CAMLOPT)' -linkall $(MLOBJS:.cmo=.cmx)
unix.cmx: ../../ocamlopt
@ -64,10 +66,10 @@ install:
test -f libunix.so && cp libunix.so $(LIBDIR)/libunix.so
cp libunix.a $(LIBDIR)/libunix.a
cd $(LIBDIR); $(RANLIB) libunix.a
cp unix.cmi unix.cma unix.mli $(LIBDIR)
cp unix.cma $(MLOBJS:.cmo=.cmi) $(MLOBJS:.cmo=.mli) $(LIBDIR)
installopt:
cp unix.cmx unix.cmxa unix.a $(LIBDIR)
cp $(MLOBJS:.cmo=.cmx) unix.cmxa unix.a $(LIBDIR)
cd $(LIBDIR); $(RANLIB) unix.a
.SUFFIXES: .ml .mli .cmo .cmi .cmx
@ -76,10 +78,10 @@ installopt:
$(CAMLC) -c $(COMPFLAGS) $<
.ml.cmo:
$(CAMLC) -c $(COMPFLAGS) $<
$(CAMLC) -c $(COMPFLAGS) -nolabels $<
.ml.cmx:
$(CAMLOPT) -c $(COMPFLAGS) $<
$(CAMLOPT) -c $(COMPFLAGS) -nolabels $<
depend:
gcc -MM $(CFLAGS) *.c > .depend

108
otherlibs/unix/unix.mli
View File

@ -145,14 +145,14 @@ type wait_flag =
[WUNTRACED] means report also the children that receive stop
signals. *)
val execv : prog:string -> args:string array -> unit
val execv : string -> string array -> unit
(* [execv prog args] execute the program in file [prog], with
the arguments [args], and the current process environment. *)
val execve : prog:string -> args:string array -> env:string array -> unit
val execve : string -> string array -> string array -> unit
(* Same as [execv], except that the third argument provides the
environment to the program executed. *)
val execvp : prog:string -> args:string array -> unit
val execvpe : prog:string -> args:string array -> env:string array -> unit
val execvp : string -> string array -> unit
val execvpe : string -> string array -> string array -> unit
(* Same as [execv] and [execvp] respectively, except that
the program is searched in the path. *)
val fork : unit -> int
@ -161,7 +161,7 @@ val fork : unit -> int
val wait : unit -> int * process_status
(* Wait until one of the children processes die, and return its pid
and termination status. *)
val waitpid : mode:wait_flag list -> int -> int * process_status
val waitpid : wait_flag list -> int -> int * process_status
(* Same as [wait], but waits for the process whose pid is given.
A pid of [-1] means wait for any child.
A pid of [0] means wait for any child in the same process group
@ -211,17 +211,17 @@ type open_flag =
type file_perm = int
(* The type of file access rights. *)
val openfile : string -> mode:open_flag list -> perm:file_perm -> file_descr
val openfile : string -> open_flag list -> file_perm -> file_descr
(* Open the named file with the given flags. Third argument is
the permissions to give to the file if it is created. Return
a file descriptor on the named file. *)
val close : file_descr -> unit
(* Close a file descriptor. *)
val read : file_descr -> buf:string -> pos:int -> len:int -> int
val read : file_descr -> string -> int -> int -> int
(* [read fd buff ofs len] reads [len] characters from descriptor
[fd], storing them in string [buff], starting at position [ofs]
in string [buff]. Return the number of characters actually read. *)
val write : file_descr -> buf:string -> pos:int -> len:int -> int
val write : file_descr -> string -> int -> int -> int
(* [write fd buff ofs len] writes [len] characters to descriptor
[fd], taking them from string [buff], starting at position [ofs]
in string [buff]. Return the number of characters actually
@ -256,11 +256,11 @@ type seek_command =
the current position, [SEEK_END] relative to the end of the
file. *)
val lseek : file_descr -> int -> mode:seek_command -> int
val lseek : file_descr -> int -> seek_command -> int
(* Set the current position for a file descriptor *)
val truncate : string -> len:int -> unit
val truncate : string -> int -> unit
(* Truncates the named file to the given size. *)
val ftruncate : file_descr -> len:int -> unit
val ftruncate : file_descr -> int -> unit
(* Truncates the file corresponding to the given descriptor
to the given size. *)
@ -306,9 +306,9 @@ val fstat : file_descr -> stats
val unlink : string -> unit
(* Removes the named file *)
val rename : src:string -> dst:string -> unit
val rename : string -> string -> unit
(* [rename old new] changes the name of a file from [old] to [new]. *)
val link : src:string -> dst:string -> unit
val link : string -> string -> unit
(* [link source dest] creates a hard link named [dest] to the file
named [new]. *)
@ -323,17 +323,17 @@ type access_permission =
(* Flags for the [access] call. *)
val chmod : string -> perm:file_perm -> unit
val chmod : string -> file_perm -> unit
(* Change the permissions of the named file. *)
val fchmod : file_descr -> perm:file_perm -> unit
val fchmod : file_descr -> file_perm -> unit
(* Change the permissions of an opened file. *)
val chown : string -> uid:int -> gid:int -> unit
val chown : string -> int -> int -> unit
(* Change the owner uid and owner gid of the named file. *)
val fchown : file_descr -> uid:int -> gid:int -> unit
val fchown : file_descr -> int -> int -> unit
(* Change the owner uid and owner gid of an opened file. *)
val umask : int -> int
(* Set the process creation mask, and return the previous mask. *)
val access : string -> perm:access_permission list -> unit
val access : string -> access_permission list -> unit
(* Check that the process has the given permissions over the named
file. Raise [Unix_error] otherwise. *)
@ -343,7 +343,7 @@ val access : string -> perm:access_permission list -> unit
val dup : file_descr -> file_descr
(* Return a new file descriptor referencing the same file as
the given descriptor. *)
val dup2 : src:file_descr -> dst:file_descr -> unit
val dup2 : file_descr -> file_descr -> unit
(* [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already
opened. *)
val set_nonblock : file_descr -> unit
@ -364,7 +364,7 @@ val clear_close_on_exec : file_descr -> unit
(*** Directories *)
val mkdir : string -> perm:file_perm -> unit
val mkdir : string -> file_perm -> unit
(* Create a directory with the given permissions. *)
val rmdir : string -> unit
(* Remove an empty directory. *)
@ -399,15 +399,15 @@ val pipe : unit -> file_descr * file_descr
for reading, that's the exit to the pipe. The second component is
opened for writing, that's the entrance to the pipe. *)
val mkfifo : string -> perm:file_perm -> unit
val mkfifo : string -> file_perm -> unit
(* Create a named pipe with the given permissions. *)
(*** High-level process and redirection management *)
val create_process :
prog:string -> args:string array ->
stdin:file_descr -> stdout:file_descr -> stderr:file_descr -> int
string -> string array ->
file_descr -> file_descr -> file_descr -> int
(* [create_process prog args new_stdin new_stdout new_stderr]
forks a new process that executes the program
in file [prog], with arguments [args]. The pid of the new
@ -425,8 +425,8 @@ val create_process :
outputs. *)
val create_process_env :
prog:string -> args:string array -> env:string array ->
stdin:file_descr -> stdout:file_descr -> stderr:file_descr -> int
string -> string array -> string array ->
file_descr -> file_descr -> file_descr -> int
(* [create_process_env prog args env new_stdin new_stdout new_stderr]
works as [create_process], except that the extra argument
[env] specifies the environment passed to the program. *)
@ -442,7 +442,7 @@ val open_process: string -> in_channel * out_channel
are buffered, hence be careful to call [flush] at the right times
to ensure correct synchronization. *)
val open_process_full:
string -> env:string array -> in_channel * out_channel * in_channel
string -> string array -> in_channel * out_channel * in_channel
(* Similar to [open_process], but the second argument specifies
the environment passed to the command. The result is a triple
of channels connected to the standard output, standard input,
@ -458,7 +458,7 @@ val close_process_full: in_channel * out_channel * in_channel -> process_status
(*** Symbolic links *)
val symlink : src:string -> dst:string -> unit
val symlink : string -> string -> unit
(* [symlink source dest] creates the file [dest] as a symbolic link
to the file [source]. *)
val readlink : string -> string
@ -468,8 +468,8 @@ val readlink : string -> string
(*** Polling *)
val select :
read:file_descr list -> write:file_descr list -> except:file_descr list ->
timeout:float ->
file_descr list -> file_descr list -> file_descr list ->
float ->
file_descr list * file_descr list * file_descr list
(* Wait until some input/output operations become possible on
some channels. The three list arguments are, respectively, a set
@ -494,7 +494,7 @@ type lock_command =
(* Commands for [lockf]. *)
val lockf : file_descr -> mode:lock_command -> len:int -> unit
val lockf : file_descr -> lock_command -> int -> unit
(* [lockf fd cmd size] puts a lock on a region of the file opened
as [fd]. The region starts at the current read/write position for
@ -512,13 +512,13 @@ val lockf : file_descr -> mode:lock_command -> len:int -> unit
(* Note: installation of signal handlers is performed via
the functions [signal] and [set_signal] of module [Sys]. *)
val kill : pid:int -> signal:int -> unit
val kill : int -> int -> unit
(* [kill pid sig] sends signal number [sig] to the process
with id [pid]. *)
type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK
val sigprocmask: mode:sigprocmask_command -> int list -> int list
val sigprocmask: sigprocmask_command -> int list -> int list
(* [sigprocmask cmd sigs] changes the set of blocked signals.
If [cmd] is [SIG_SETMASK], blocked signals are set to those in
the list [sigs].
@ -585,7 +585,7 @@ val sleep : int -> unit
(* Stop execution for the given number of seconds. *)
val times : unit -> process_times
(* Return the execution times of the process. *)
val utimes : string -> access:float -> modif:float -> unit
val utimes : string -> float -> float -> unit
(* Set the last access time (second arg) and last modification time
(third arg) for a file. Times are expressed in seconds from
00:00:00 GMT, Jan. 1, 1970. *)
@ -716,23 +716,23 @@ type sockaddr =
[port] is the port number. *)
val socket :
domain:socket_domain -> kind:socket_type -> protocol:int -> file_descr
socket_domain -> socket_type -> int -> file_descr
(* Create a new socket in the given domain, and with the
given kind. The third argument is the protocol type; 0 selects
the default protocol for that kind of sockets. *)
val socketpair :
domain:socket_domain -> kind:socket_type -> protocol:int ->
socket_domain -> socket_type -> int ->
file_descr * file_descr
(* Create a pair of unnamed sockets, connected together. *)
val accept : file_descr -> file_descr * sockaddr
(* Accept connections on the given socket. The returned descriptor
is a socket connected to the client; the returned address is
the address of the connecting client. *)
val bind : file_descr -> addr:sockaddr -> unit
val bind : file_descr -> sockaddr -> unit
(* Bind a socket to an address. *)
val connect : file_descr -> addr:sockaddr -> unit
val connect : file_descr -> sockaddr -> unit
(* Connect a socket to an address. *)
val listen : file_descr -> max:int -> unit
val listen : file_descr -> int -> unit
(* Set up a socket for receiving connection requests. The integer
argument is the maximal number of pending requests. *)
@ -742,7 +742,7 @@ type shutdown_command =
| SHUTDOWN_ALL (* Close both *)
(* The type of commands for [shutdown]. *)
val shutdown : file_descr -> mode:shutdown_command -> unit
val shutdown : file_descr -> shutdown_command -> unit
(* Shutdown a socket connection. [SHUTDOWN_SEND] as second argument
causes reads on the other end of the connection to return
an end-of-file condition.
@ -761,17 +761,17 @@ type msg_flag =
(* The flags for [recv], [recvfrom], [send] and [sendto]. *)
val recv :
file_descr -> buf:string -> pos:int -> len:int
-> mode:msg_flag list -> int
file_descr -> string -> int -> int
-> msg_flag list -> int
val recvfrom :
file_descr -> buf:string -> pos:int -> len:int
-> mode:msg_flag list -> int * sockaddr
file_descr -> string -> int -> int
-> msg_flag list -> int * sockaddr
(* Receive data from an unconnected socket. *)
val send : file_descr -> buf:string -> pos:int -> len:int
-> mode:msg_flag list -> int
val send : file_descr -> string -> int -> int
-> msg_flag list -> int
val sendto :
file_descr -> buf:string -> pos:int -> len:int
-> mode:msg_flag list -> addr:sockaddr -> int
file_descr -> string -> int -> int
-> msg_flag list -> sockaddr -> int
(* Send data over an unconnected socket. *)
(*** Socket options *)
@ -848,7 +848,7 @@ val shutdown_connection : in_channel -> unit
that is, transmit an end-of-file condition to the server reading
on the other side of the connection. *)
val establish_server : (in_channel -> out_channel -> unit) ->
addr:sockaddr -> unit
sockaddr -> unit
(* Establish a server on the given address.
The function given as first argument is called for each connection
with two buffered channels connected to the client. A new process
@ -892,10 +892,10 @@ val getprotobyname : string -> protocol_entry
val getprotobynumber : int -> protocol_entry
(* Find an entry in [protocols] with the given protocol number,
or raise [Not_found]. *)
val getservbyname : string -> protocol:string -> service_entry
val getservbyname : string -> string -> service_entry
(* Find an entry in [services] with the given name, or raise
[Not_found]. *)
val getservbyport : int -> protocol:string -> service_entry
val getservbyport : int -> string -> service_entry
(* Find an entry in [services] with the given service number,
or raise [Not_found]. *)
@ -961,7 +961,7 @@ val tcgetattr: file_descr -> terminal_io
type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH
val tcsetattr: file_descr -> mode:setattr_when -> terminal_io -> unit
val tcsetattr: file_descr -> setattr_when -> terminal_io -> unit
(* Set the status of the terminal referred to by the given
file descriptor. The second argument indicates when the
status change takes place: immediately ([TCSANOW]),
@ -971,7 +971,7 @@ val tcsetattr: file_descr -> mode:setattr_when -> terminal_io -> unit
the output parameters; [TCSAFLUSH], when changing the input
parameters. *)
val tcsendbreak: file_descr -> duration:int -> unit
val tcsendbreak: file_descr -> int -> unit
(* Send a break condition on the given file descriptor.
The second argument is the duration of the break, in 0.1s units;
0 means standard duration (0.25s). *)
@ -982,7 +982,7 @@ val tcdrain: file_descr -> unit
type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH
val tcflush: file_descr -> mode:flush_queue -> unit
val tcflush: file_descr -> flush_queue -> unit
(* Discard data written on the given file descriptor but not yet
transmitted, or data received but not yet read, depending on the
second argument: [TCIFLUSH] flushes data received but not read,
@ -991,7 +991,7 @@ val tcflush: file_descr -> mode:flush_queue -> unit
type flow_action = TCOOFF | TCOON | TCIOFF | TCION
val tcflow: file_descr -> mode:flow_action -> unit
val tcflow: file_descr -> flow_action -> unit
(* Suspend or restart reception or transmission of data on
the given file descriptor, depending on the second argument:
[TCOOFF] suspends output, [TCOON] restarts output,

17
otherlibs/unix/unixLabels.ml Normal file
View File

@ -0,0 +1,17 @@
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Jacques Garrigue, Kyoto University RIMS *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the GNU Library General Public License. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Module [UnixLabels]: labelled Unix module *)
include Unix

1007
otherlibs/unix/unixLabels.mli Normal file
View File

File diff suppressed because it is too large Load Diff

1
stdlib/.cvsignore
View File

@ -1,2 +1,3 @@
camlheader
camlheader_ur
labelled-*

8
stdlib/.depend
View File

@ -6,6 +6,8 @@ arg.cmo: array.cmi list.cmi printf.cmi string.cmi sys.cmi arg.cmi
arg.cmx: array.cmx list.cmx printf.cmx string.cmx sys.cmx arg.cmi
array.cmo: array.cmi
array.cmx: array.cmi
arrayLabels.cmo: array.cmi arrayLabels.cmi
arrayLabels.cmx: array.cmx arrayLabels.cmi
buffer.cmo: string.cmi sys.cmi buffer.cmi
buffer.cmx: string.cmx sys.cmx buffer.cmi
callback.cmo: obj.cmi callback.cmi
@ -34,6 +36,8 @@ lexing.cmo: string.cmi lexing.cmi
lexing.cmx: string.cmx lexing.cmi
list.cmo: array.cmi list.cmi
list.cmx: array.cmx list.cmi
listLabels.cmo: list.cmi listLabels.cmi
listLabels.cmx: list.cmx listLabels.cmi
map.cmo: map.cmi
map.cmx: map.cmi
marshal.cmo: string.cmi marshal.cmi
@ -64,10 +68,14 @@ sort.cmo: array.cmi sort.cmi
sort.cmx: array.cmx sort.cmi
stack.cmo: list.cmi stack.cmi
stack.cmx: list.cmx stack.cmi
stdLabels.cmo: arrayLabels.cmi listLabels.cmi stringLabels.cmi stdLabels.cmi
stdLabels.cmx: arrayLabels.cmx listLabels.cmx stringLabels.cmx stdLabels.cmi
stream.cmo: list.cmi obj.cmi string.cmi stream.cmi
stream.cmx: list.cmx obj.cmx string.cmx stream.cmi
string.cmo: char.cmi list.cmi string.cmi
string.cmx: char.cmx list.cmx string.cmi
stringLabels.cmo: string.cmi stringLabels.cmi
stringLabels.cmx: string.cmx stringLabels.cmi
sys.cmo: sys.cmi
sys.cmx: sys.cmi
weak.cmo: obj.cmi weak.cmi

40
stdlib/Makefile
View File

@ -23,13 +23,17 @@ CAMLOPT=$(RUNTIME) $(OPTCOMPILER)
OPTCOMPFLAGS=
CAMLDEP=../boot/ocamlrun ../tools/ocamldep
OBJS=pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
BASIC=pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
hashtbl.cmo sort.cmo marshal.cmo obj.cmo \
lexing.cmo parsing.cmo \
set.cmo map.cmo stack.cmo queue.cmo stream.cmo \
buffer.cmo printf.cmo format.cmo arg.cmo printexc.cmo gc.cmo \
digest.cmo random.cmo oo.cmo genlex.cmo callback.cmo weak.cmo \
lazy.cmo filename.cmo int32.cmo int64.cmo nativeint.cmo
LABELLED=arrayLabels.ml listLabels.ml stringLabels.ml
OBJS=$(BASIC) labelled.cmo stdLabels.cmo
ALLOBJS=$(BASIC) $(LABELLED:.ml=.cmo) stdLabels.cmo
all: stdlib.cma std_exit.cmo camlheader camlheader_ur
@ -59,13 +63,13 @@ installopt-prof:
cd $(LIBDIR); $(RANLIB) stdlib.p.a
stdlib.cma: $(OBJS)
$(CAMLC) -a -o stdlib.cma $(OBJS)
$(CAMLC) -a -o stdlib.cma $(ALLOBJS)
stdlib.cmxa: $(OBJS:.cmo=.cmx)
$(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx)
$(CAMLOPT) -a -o stdlib.cmxa $(ALLOBJS:.cmo=.cmx)
stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx)
$(CAMLOPT) -a -o stdlib.p.cmxa $(OBJS:.cmo=.p.cmx)
$(CAMLOPT) -a -o stdlib.p.cmxa $(ALLOBJS:.cmo=.p.cmx)
camlheader camlheader_ur: header.c ../config/Makefile
if $(SHARPBANGSCRIPTS); then \
@ -103,30 +107,42 @@ pervasives.p.cmx: pervasives.ml
oo.cmi: oo.mli
$(CAMLC) $(COMPFLAGS) -nopervasives -c oo.mli
# labelled modules require the -nolabels flag
labelled.cmo:
$(MAKE) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.cmo)
touch $@
labelled.cmx:
$(MAKE) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.cmx)
touch $@
labelled.p.cmx:
$(MAKE) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.p.cmx)
touch $@
.SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx
.mli.cmi:
$(CAMLC) $(COMPFLAGS) -c $<
$(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
.ml.cmo:
$(CAMLC) $(COMPFLAGS) -c $<
$(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
.ml.cmx:
$(CAMLOPT) $(OPTCOMPFLAGS) -c $<
$(CAMLOPT) $(OPTCOMPFLAGS) $(EXTRAFLAGS) -c $<
.ml.p.cmx:
@if test -f $*.cmx; then mv $*.cmx $*.n.cmx; else :; fi
@if test -f $*.o; then mv $*.o $*.n.o; else :; fi
$(CAMLOPT) $(OPTCOMPFLAGS) -p -c $<
$(CAMLOPT) $(OPTCOMPFLAGS) $(EXTRAFLAGS) -p -c $<
mv $*.cmx $*.p.cmx
mv $*.o $*.p.o
@if test -f $*.n.cmx; then mv $*.n.cmx $*.cmx; else :; fi
@if test -f $*.n.o; then mv $*.n.o $*.o; else :; fi
$(OBJS) std_exit.cmo: pervasives.cmi $(COMPILER)
$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi $(OPTCOMPILER)
$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi $(OPTCOMPILER)
$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
$(ALLOBJS) labelled.cmo std_exit.cmo: pervasives.cmi $(COMPILER)
$(ALLOBJS:.cmo=.cmx) labelled.cmx std_exit.cmx: pervasives.cmi $(OPTCOMPILER)
$(ALLOBJS:.cmo=.p.cmx) labelled.p.cmx std_exit.p.cmx: pervasives.cmi $(OPTCOMPILER)
$(ALLOBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
labelled.cmo labelled.cmx labelled.p.cmx: $(LABELLED) $(LABELLED:.ml=.mli)
clean::
rm -f *.cm* *.o *.a

6
stdlib/arg.mli
View File

@ -51,8 +51,8 @@ type spec =
(* The concrete type describing the behavior associated
with a keyword. *)
val parse : keywords:(string * spec * string) list ->
others:(string -> unit) -> errmsg:string -> unit
val parse : (string * spec * string) list ->
(string -> unit) -> string -> unit
(*
[Arg.parse speclist anonfun usage_msg] parses the command line.
[speclist] is a list of triples [(key, spec, doc)].
@ -85,7 +85,7 @@ exception Bad of string
message to reject invalid arguments.
*)
val usage : keywords:(string * spec * string) list -> errmsg:string -> unit
val usage : (string * spec * string) list -> string -> unit
(*
[Arg.usage speclist usage_msg] prints an error message including
the list of valid options. This is the same message that

29
stdlib/array.mli
View File

@ -42,13 +42,13 @@ external create: int -> 'a -> 'a array = "make_vect"
If the value of [x] is a floating-point number, then the maximum
size is only [Sys.max_array_length / 2].
[Array.create] is a deprecated alias for [Array.make]. *)
val init: int -> f:(int -> 'a) -> 'a array
val init: int -> (int -> 'a) -> 'a array
(* [Array.init n f] returns a fresh array of length [n],
with element number [i] initialized to the result of [f i].
In other terms, [Array.init n f] tabulates the results of [f]
applied to the integers [0] to [n-1]. *)
val make_matrix: dimx:int -> dimy:int -> 'a -> 'a array array
val create_matrix: dimx:int -> dimy:int -> 'a -> 'a array array
val make_matrix: int -> int -> 'a -> 'a array array
val create_matrix: int -> int -> 'a -> 'a array array
(* [Array.make_matrix dimx dimy e] returns a two-dimensional array
(an array of arrays) with first dimension [dimx] and
second dimension [dimy]. All the elements of this new matrix
@ -66,7 +66,7 @@ val append: 'a array -> 'a array -> 'a array
concatenation of the arrays [v1] and [v2]. *)
val concat: 'a array list -> 'a array
(* Same as [Array.append], but catenates a list of arrays. *)
val sub: 'a array -> pos:int -> len:int -> 'a array
val sub: 'a array -> int -> int -> 'a array
(* [Array.sub a start len] returns a fresh array of length [len],
containing the elements number [start] to [start + len - 1]
of array [a].
@ -76,13 +76,12 @@ val sub: 'a array -> pos:int -> len:int -> 'a array
val copy: 'a array -> 'a array
(* [Array.copy a] returns a copy of [a], that is, a fresh array
containing the same elements as [a]. *)
val fill: 'a array -> pos:int -> len:int -> 'a -> unit
val fill: 'a array -> int -> int -> 'a -> unit
(* [Array.fill a ofs len x] modifies the array [a] in place,
storing [x] in elements number [ofs] to [ofs + len - 1].
Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not
designate a valid subarray of [a]. *)
val blit: src:'a array -> src_pos:int ->
dst:'a array -> dst_pos:int -> len:int -> unit
val blit: 'a array -> int -> 'a array -> int -> int -> unit
(* [Array.blit v1 o1 v2 o2 len] copies [len] elements
from array [v1], starting at element number [o1], to array [v2],
starting at element number [o2]. It works correctly even if
@ -96,30 +95,30 @@ val to_list: 'a array -> 'a list
val of_list: 'a list -> 'a array
(* [Array.of_list l] returns a fresh array containing the elements
of [l]. *)
val iter: f:('a -> unit) -> 'a array -> unit
val iter: ('a -> unit) -> 'a array -> unit
(* [Array.iter f a] applies function [f] in turn to all
the elements of [a]. It is equivalent to
[f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *)
val map: f:('a -> 'b) -> 'a array -> 'b array
val map: ('a -> 'b) -> 'a array -> 'b array
(* [Array.map f a] applies function [f] to all the elements of [a],
and builds an array with the results returned by [f]:
[[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *)
val iteri: f:(int -> 'a -> unit) -> 'a array -> unit
val mapi: f:(int -> 'a -> 'b) -> 'a array -> 'b array
val iteri: (int -> 'a -> unit) -> 'a array -> unit
val mapi: (int -> 'a -> 'b) -> 'a array -> 'b array
(* Same as [Array.iter] and [Array.map] respectively, but the
function is applied to the index of the element as first argument,
and the element itself as second argument. *)
val fold_left: f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a
val fold_left: ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
(* [Array.fold_left f x a] computes
[f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)],
where [n] is the length of the array [a]. *)
val fold_right: f:('b -> 'a -> 'a) -> 'b array -> init:'a -> 'a
val fold_right: ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a
(* [Array.fold_right f a x] computes
[f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))],
where [n] is the length of the array [a]. *)
(** Sorting *)
val sort : cmp:('a -> 'a -> int) -> 'a array -> unit;;
val sort : ('a -> 'a -> int) -> 'a array -> unit;;
(* Sort an array in increasing order according to a comparison
function. The comparison function must return 0 if its arguments
compare as equal, a positive integer if the first is greater,
@ -134,7 +133,7 @@ val sort : cmp:('a -> 'a -> int) -> 'a array -> unit;;
stack space.
*)
val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit;;
val stable_sort : ('a -> 'a -> int) -> 'a array -> unit;;
(* Same as [Array.sort], but the sorting algorithm is stable and
not guaranteed to use a fixed amount of heap memory.
The current implementation is Merge Sort. It uses [n/2]

17
stdlib/arrayLabels.ml Normal file
View File

@ -0,0 +1,17 @@
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Jacques Garrigue, Kyoto University RIMS *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the GNU Library General Public License. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Module [ArrayLabels]: labelled Array module *)
include Array

148
stdlib/arrayLabels.mli Normal file
View File

@ -0,0 +1,148 @@
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the GNU Library General Public License. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Module [Array]: array operations *)
external length : 'a array -> int = "%array_length"
(* Return the length (number of elements) of the given array. *)
external get: 'a array -> int -> 'a = "%array_safe_get"
(* [Array.get a n] returns the element number [n] of array [a].
The first element has number 0.
The last element has number [Array.length a - 1].
Raise [Invalid_argument "Array.get"] if [n] is outside the range
0 to [(Array.length a - 1)].
You can also write [a.(n)] instead of [Array.get a n]. *)
external set: 'a array -> int -> 'a -> unit = "%array_safe_set"
(* [Array.set a n x] modifies array [a] in place, replacing
element number [n] with [x].
Raise [Invalid_argument "Array.set"] if [n] is outside the range
0 to [Array.length a - 1].
You can also write [a.(n) <- x] instead of [Array.set a n x]. *)
external make: int -> 'a -> 'a array = "make_vect"
external create: int -> 'a -> 'a array = "make_vect"
(* [Array.make n x] returns a fresh array of length [n],
initialized with [x].
All the elements of this new array are initially
physically equal to [x] (in the sense of the [==] predicate).
Consequently, if [x] is mutable, it is shared among all elements
of the array, and modifying [x] through one of the array entries
will modify all other entries at the same time.
Raise [Invalid_argument] if [n <= 0] or [n > Sys.max_array_length].
If the value of [x] is a floating-point number, then the maximum
size is only [Sys.max_array_length / 2].
[Array.create] is a deprecated alias for [Array.make]. *)
val init: int -> f:(int -> 'a) -> 'a array
(* [Array.init n f] returns a fresh array of length [n],
with element number [i] initialized to the result of [f i].
In other terms, [Array.init n f] tabulates the results of [f]
applied to the integers [0] to [n-1]. *)
val make_matrix: dimx:int -> dimy:int -> 'a -> 'a array array
val create_matrix: dimx:int -> dimy:int -> 'a -> 'a array array
(* [Array.make_matrix dimx dimy e] returns a two-dimensional array
(an array of arrays) with first dimension [dimx] and
second dimension [dimy]. All the elements of this new matrix
are initially physically equal to [e].
The element ([x,y]) of a matrix [m] is accessed
with the notation [m.(x).(y)].
Raise [Invalid_argument] if [dimx] or [dimy] is less than 1 or
greater than [Sys.max_array_length].
If the value of [e] is a floating-point number, then the maximum
size is only [Sys.max_array_length / 2].
[Array.create_matrix] is a deprecated alias for [Array.make_matrix].
*)
val append: 'a array -> 'a array -> 'a array
(* [Array.append v1 v2] returns a fresh array containing the
concatenation of the arrays [v1] and [v2]. *)
val concat: 'a array list -> 'a array
(* Same as [Array.append], but catenates a list of arrays. *)
val sub: 'a array -> pos:int -> len:int -> 'a array
(* [Array.sub a start len] returns a fresh array of length [len],
containing the elements number [start] to [start + len - 1]
of array [a].
Raise [Invalid_argument "Array.sub"] if [start] and [len] do not
designate a valid subarray of [a]; that is, if
[start < 0], or [len < 0], or [start + len > Array.length a]. *)
val copy: 'a array -> 'a array
(* [Array.copy a] returns a copy of [a], that is, a fresh array
containing the same elements as [a]. *)
val fill: 'a array -> pos:int -> len:int -> 'a -> unit
(* [Array.fill a ofs len x] modifies the array [a] in place,
storing [x] in elements number [ofs] to [ofs + len - 1].
Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not
designate a valid subarray of [a]. *)
val blit: src:'a array -> src_pos:int ->
dst:'a array -> dst_pos:int -> len:int -> unit
(* [Array.blit v1 o1 v2 o2 len] copies [len] elements
from array [v1], starting at element number [o1], to array [v2],
starting at element number [o2]. It works correctly even if
[v1] and [v2] are the same array, and the source and
destination chunks overlap.
Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not
designate a valid subarray of [v1], or if [o2] and [len] do not
designate a valid subarray of [v2]. *)
val to_list: 'a array -> 'a list
(* [Array.to_list a] returns the list of all the elements of [a]. *)
val of_list: 'a list -> 'a array
(* [Array.of_list l] returns a fresh array containing the elements
of [l]. *)
val iter: f:('a -> unit) -> 'a array -> unit
(* [Array.iter f a] applies function [f] in turn to all
the elements of [a]. It is equivalent to
[f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *)
val map: f:('a -> 'b) -> 'a array -> 'b array
(* [Array.map f a] applies function [f] to all the elements of [a],
and builds an array with the results returned by [f]:
[[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *)
val iteri: f:(int -> 'a -> unit) -> 'a array -> unit
val mapi: f:(int -> 'a -> 'b) -> 'a array -> 'b array
(* Same as [Array.iter] and [Array.map] respectively, but the
function is applied to the index of the element as first argument,
and the element itself as second argument. *)
val fold_left: f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a
(* [Array.fold_left f x a] computes
[f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)],
where [n] is the length of the array [a]. *)
val fold_right: f:('b -> 'a -> 'a) -> 'b array -> init:'a -> 'a
(* [Array.fold_right f a x] computes
[f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))],
where [n] is the length of the array [a]. *)
(** Sorting *)
val sort : cmp:('a -> 'a -> int) -> 'a array -> unit;;
(* Sort an array in increasing order according to a comparison
function. The comparison function must return 0 if its arguments
compare as equal, a positive integer if the first is greater,
and a negative integer if the first is smaller. For example,
the [compare] function is a suitable comparison function.
After calling [Array.sort], the array is sorted in place in
increasing order.
[Array.sort] is guaranteed to run in constant heap space
and logarithmic stack space.
The current implementation uses Heap Sort. It runs in constant
stack space.
*)
val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit;;
(* Same as [Array.sort], but the sorting algorithm is stable and
not guaranteed to use a fixed amount of heap memory.
The current implementation is Merge Sort. It uses [n/2]
words of heap space, where [n] is the length of the array.
It is faster than the current implementation of [Array.sort].
*)
(*--*)
external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get"
external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set"

6
stdlib/buffer.mli
View File

@ -52,13 +52,13 @@ val add_char : t -> char -> unit
val add_string : t -> string -> unit
(* [add_string b s] appends the string [s] at the end of
the buffer [b]. *)
val add_substring : t -> string -> pos:int -> len:int -> unit
val add_substring : t -> string -> int -> int -> unit
(* [add_substring b s ofs len] takes [len] characters from offset
[ofs] in string [s] and appends them at the end of the buffer [b]. *)
val add_buffer : t -> src:t -> unit
val add_buffer : t -> t -> unit
(* [add_buffer b1 b2] appends the current contents of buffer [b2]
at the end of buffer [b1]. [b2] is not modified. *)
val add_channel : t -> in_channel -> len:int -> unit
val add_channel : t -> in_channel -> int -> unit
(* [add_channel b ic n] reads exactly [n] character from the
input channel [ic] and stores them at the end of buffer [b].
Raise [End_of_file] if the channel contains fewer than [n]

4
stdlib/digest.mli
View File

@ -23,11 +23,11 @@ type t = string
(* The type of digests: 16-character strings. *)
val string: string -> t
(* Return the digest of the given string. *)
val substring: string -> pos:int -> len:int -> t
val substring: string -> int -> int -> t
(* [Digest.substring s ofs len] returns the digest of the substring
of [s] starting at character number [ofs] and containing [len]
characters. *)
external channel: in_channel -> len:int -> t = "md5_chan"
external channel: in_channel -> int -> t = "md5_chan"
(* [Digest.channel ic len] reads [len] characters from channel [ic]
and returns their digest. *)
val file: string -> t

2
stdlib/filename.mli
View File

@ -52,7 +52,7 @@ val dirname : string -> string
current directory to [dirname name] (with [Sys.chdir]),
references to [basename name] (which is a relative file name)
designate the same file as [name] before the call to [Sys.chdir]. *)
val temp_file : prefix:string -> suffix:string -> string
val temp_file : string -> string -> string
(* [temp_file prefix suffix] returns the name of a
fresh temporary file in the temporary directory.
The base name of the temporary file is formed by concatenating

3
stdlib/format.ml
View File

@ -566,7 +566,8 @@ let pp_set_formatter_output_functions state f g =
let pp_get_formatter_output_functions state () =
(state.pp_output_function, state.pp_flush_function);;
let pp_set_all_formatter_output_functions state f g h i =
let pp_set_all_formatter_output_functions state
~out:f ~flush:g ~newline:h ~spaces:i =
pp_set_formatter_output_functions state f g;
state.pp_output_newline <- (function _ -> function () -> h ());
state.pp_output_spaces <- (function _ -> function n -> i n);;

27
stdlib/format.mli
View File

@ -234,8 +234,7 @@ val set_formatter_out_channel : out_channel -> unit;;
(*** Changing the meaning of printing material *)
val set_formatter_output_functions :
out:(buf:string -> pos:int -> len:int -> unit) ->
flush:(unit -> unit) -> unit;;
(string -> int -> int -> unit) -> (unit -> unit) -> unit;;
(* [set_formatter_output_functions out flush] redirects the
pretty-printer output to the functions [out] and [flush].
The [out] function performs the pretty-printer output.
@ -245,14 +244,13 @@ val set_formatter_output_functions :
called whenever the pretty-printer is flushed using
[print_flush] or [print_newline]. *)
val get_formatter_output_functions :
unit -> (buf:string -> pos:int -> len:int -> unit) * (unit -> unit);;
unit -> (string -> int -> int -> unit) * (unit -> unit);;
(* Return the current output functions of the pretty-printer. *)
(*** Changing the meaning of pretty printing (indentation, line breaking, and printing material) *)
val set_all_formatter_output_functions :
out:(buf:string -> pos:int -> len:int -> unit) ->
flush:(unit -> unit) ->
newline:(unit -> unit) -> space:(int -> unit) -> unit;;
out:(string -> int -> int -> unit) -> flush:(unit -> unit) ->
newline:(unit -> unit) -> spaces:(int -> unit) -> unit;;
(* [set_all_formatter_output_functions out flush outnewline outspace]
redirects the pretty-printer output to the functions
[out] and [flush] as described in
@ -269,7 +267,7 @@ val set_all_formatter_output_functions :
[outspace] and [outnewline] are [out (String.make n ' ') 0 n]
and [out "\n" 0 1]. *)
val get_all_formatter_output_functions : unit ->
(buf:string -> pos:int -> len:int -> unit) * (unit -> unit) *
(string -> int -> int -> unit) * (unit -> unit) *
(unit -> unit) * (int -> unit);;
(* Return the current output functions of the pretty-printer,
including line breaking and indentation functions. *)
@ -323,8 +321,7 @@ val flush_str_formatter : unit -> string;;
[str_formatter] is defined as [formatter_of_buffer stdbuf]. *)
val make_formatter :
out:(buf:string -> pos:int -> len:int -> unit) ->
flush:(unit -> unit) -> formatter;;
(string -> int -> int -> unit) -> (unit -> unit) -> formatter;;
(* [make_formatter out flush] returns a new formatter that
writes according to the output function [out], and the flushing
function [flush]. Hence, a formatter to out channel [oc]
@ -365,16 +362,14 @@ val pp_set_ellipsis_text : formatter -> string -> unit;;
val pp_get_ellipsis_text : formatter -> unit -> string;;
val pp_set_formatter_out_channel : formatter -> out_channel -> unit;;
val pp_set_formatter_output_functions : formatter ->
out:(buf:string -> pos:int -> len:int -> unit) ->
flush:(unit -> unit) -> unit;;
(string -> int -> int -> unit) -> (unit -> unit) -> unit;;
val pp_get_formatter_output_functions : formatter -> unit ->
(buf:string -> pos:int -> len:int -> unit) * (unit -> unit);;
(string -> int -> int -> unit) * (unit -> unit);;
val pp_set_all_formatter_output_functions : formatter ->
out:(buf:string -> pos:int -> len:int -> unit) ->
flush:(unit -> unit) ->
newline:(unit -> unit) -> space:(int -> unit) -> unit;;
out:(string -> int -> int -> unit) -> flush:(unit -> unit) ->
newline:(unit -> unit) -> spaces:(int -> unit) -> unit;;
val pp_get_all_formatter_output_functions : formatter -> unit ->
(buf:string -> pos:int -> len:int -> unit) * (unit -> unit) *
(string -> int -> int -> unit) * (unit -> unit) *
(unit -> unit) * (int -> unit);;
(* The basic functions to use with formatters.
These functions are the basic ones: usual functions

2
stdlib/hashtbl.ml
View File

@ -177,7 +177,7 @@ module type S =
val replace : 'a t -> key -> 'a -> unit
val mem : 'a t -> key -> bool
val iter: (key -> 'a -> unit) -> 'a t -> unit
val fold: f:(key:key -> data:'a -> 'b -> 'b) -> 'a t -> init:'b -> 'b
val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
end
module Make(H: HashedType): (S with type key = H.t) =

16
stdlib/hashtbl.mli
View File

@ -31,7 +31,7 @@ val create : int -> ('a,'b) t
val clear : ('a, 'b) t -> unit
(* Empty a hash table. *)
val add : ('a, 'b) t -> key:'a -> data:'b -> unit
val add : ('a, 'b) t -> 'a -> 'b -> unit
(* [Hashtbl.add tbl x y] adds a binding of [x] to [y] in table [tbl].
Previous bindings for [x] are not removed, but simply
hidden. That is, after performing [Hashtbl.remove tbl x],
@ -56,21 +56,21 @@ val remove : ('a, 'b) t -> 'a -> unit
restoring the previous binding if it exists.
It does nothing if [x] is not bound in [tbl]. *)
val replace : ('a, 'b) t -> key:'a -> data:'b -> unit
val replace : ('a, 'b) t -> 'a -> 'b -> unit
(* [Hashtbl.replace tbl x y] replaces the current binding of [x]
in [tbl] by a binding of [x] to [y]. If [x] is unbound in [tbl],
a binding of [x] to [y] is added to [tbl].
This is functionally equivalent to [Hashtbl.remove tbl x]
followed by [Hashtbl.add tbl x y]. *)
val iter : f:(key:'a -> data:'b -> unit) -> ('a, 'b) t -> unit
val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit
(* [Hashtbl.iter f tbl] applies [f] to all bindings in table [tbl].
[f] receives the key as first argument, and the associated value
as second argument. The order in which the bindings are passed to
[f] is unspecified. Each binding is presented exactly once
to [f]. *)
val fold : f:(key:'a -> data:'b -> 'c -> 'c) -> ('a, 'b) t -> init:'c -> 'c
val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
(* [Hashtbl.fold f tbl init] computes
[(f kN dN ... (f k1 d1 init)...)],
where [k1 ... kN] are the keys of all bindings in [tbl],
@ -106,14 +106,14 @@ module type S =
type 'a t
val create: int -> 'a t
val clear: 'a t -> unit
val add: 'a t -> key:key -> data:'a -> unit
val add: 'a t -> key -> 'a -> unit
val remove: 'a t -> key -> unit
val find: 'a t -> key -> 'a
val find_all: 'a t -> key -> 'a list
val replace : 'a t -> key:key -> data:'a -> unit
val replace: 'a t -> key -> 'a -> unit
val mem: 'a t -> key -> bool
val iter: f:(key:key -> data:'a -> unit) -> 'a t -> unit
val fold: f:(key:key -> data:'a -> 'b -> 'b) -> 'a t -> init:'b -> 'b
val iter: (key -> 'a -> unit) -> 'a t -> unit
val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
end
module Make(H: HashedType): (S with type key = H.t)

2
stdlib/lexing.mli
View File

@ -40,7 +40,7 @@ val from_string : string -> lexbuf
the given string. Reading starts from the first character in
the string. An end-of-input condition is generated when the
end of the string is reached. *)
val from_function : (buf:string -> len:int -> int) -> lexbuf
val from_function : (string -> int -> int) -> lexbuf
(* Create a lexer buffer with the given function as its reading method.
When the scanner needs more characters, it will call the given
function, giving it a character string [s] and a character

40
stdlib/list.mli
View File

@ -54,49 +54,49 @@ val flatten : 'a list list -> 'a list
(** Iterators *)
val iter : f:('a -> unit) -> 'a list -> unit
val iter : ('a -> unit) -> 'a list -> unit
(* [List.iter f [a1; ...; an]] applies function [f] in turn to
[a1; ...; an]. It is equivalent to
[begin f a1; f a2; ...; f an; () end]. *)
val map : f:('a -> 'b) -> 'a list -> 'b list
val map : ('a -> 'b) -> 'a list -> 'b list
(* [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
and builds the list [[f a1; ...; f an]]
with the results returned by [f]. Not tail-recursive. *)
val rev_map : f:('a -> 'b) -> 'a list -> 'b list
val rev_map : ('a -> 'b) -> 'a list -> 'b list
(* [List.rev_map f l] gives the same result as
[List.rev (List.map f l)], but is tail-recursive and
more efficient. *)
val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a
val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
(* [List.fold_left f a [b1; ...; bn]] is
[f (... (f (f a b1) b2) ...) bn]. *)
val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b
val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
(* [List.fold_right f [a1; ...; an] b] is
[f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *)
(** Iterators on two lists *)
val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit
val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
(* [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn
[f a1 b1; ...; f an bn].
Raise [Invalid_argument] if the two lists have
different lengths. *)
val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
(* [List.map2 f [a1; ...; an] [b1; ...; bn]] is
[[f a1 b1; ...; f an bn]].
Raise [Invalid_argument] if the two lists have
different lengths. Not tail-recursive. *)
val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
(* [List.rev_map2 f l] gives the same result as
[List.rev (List.map2 f l)], but is tail-recursive and
more efficient. *)
val fold_left2 :
f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a
('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
(* [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is
[f (... (f (f a b1 c1) b2 c2) ...) bn cn].
Raise [Invalid_argument] if the two lists have
different lengths. *)
val fold_right2 :
f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c
('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
(* [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is
[f a1 b1 (f a2 b2 (... (f an bn c) ...))].
Raise [Invalid_argument] if the two lists have
@ -104,16 +104,16 @@ val fold_right2 :
(** List scanning *)
val for_all : f:('a -> bool) -> 'a list -> bool
val for_all : ('a -> bool) -> 'a list -> bool
(* [for_all p [a1; ...; an]] checks if all elements of the list
satisfy the predicate [p]. That is, it returns
[(p a1) && (p a2) && ... && (p an)]. *)
val exists : f:('a -> bool) -> 'a list -> bool
val exists : ('a -> bool) -> 'a list -> bool
(* [exists p [a1; ...; an]] checks if at least one element of
the list satisfies the predicate [p]. That is, it returns
[(p a1) || (p a2) || ... || (p an)]. *)
val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
(* Same as [for_all] and [exists], but for a two-argument predicate.
Raise [Invalid_argument] if the two lists have
different lengths. *)
@ -126,20 +126,20 @@ val memq : 'a -> 'a list -> bool
(** List searching *)
val find : f:('a -> bool) -> 'a list -> 'a
val find : ('a -> bool) -> 'a list -> 'a
(* [find p l] returns the first element of the list [l]
that satisfies the predicate [p].
Raise [Not_found] if there is no value that satisfies [p] in the
list [l]. *)
val filter : f:('a -> bool) -> 'a list -> 'a list
val find_all : f:('a -> bool) -> 'a list -> 'a list
val filter : ('a -> bool) -> 'a list -> 'a list
val find_all : ('a -> bool) -> 'a list -> 'a list
(* [filter p l] returns all the elements of the list [l]
that satisfy the predicate [p]. The order of the elements
in the input list is preserved. [find_all] is another name
for [filter]. *)
val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list
val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
(* [partition p l] returns a pair of lists [(l1, l2)], where
[l1] is the list of all the elements of [l] that
satisfy the predicate [p], and [l2] is the list of all the
@ -190,7 +190,7 @@ val combine : 'a list -> 'b list -> ('a * 'b) list
have different lengths. Not tail-recursive. *)
(** Sorting *)
val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list;;
val sort : ('a -> 'a -> int) -> 'a list -> 'a list;;
(* Sort a list in increasing order according to a comparison
function. The comparison function must return 0 if it arguments
compare as equal, a positive integer if the first is greater,
@ -204,7 +204,7 @@ val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list;;
The current implementation uses Merge Sort and is the same as
[List.stable_sort].
*)
val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list;;
val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list;;
(* Same as [List.sort], but the sorting algorithm is stable.
The current implementation is Merge Sort. It runs in constant

17
stdlib/listLabels.ml Normal file
View File

@ -0,0 +1,17 @@
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Jacques Garrigue, Kyoto University RIMS *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the GNU Library General Public License. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Module [ListLabels]: labelled List module *)
include List

212
stdlib/listLabels.mli Normal file
View File

@ -0,0 +1,212 @@
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the GNU Library General Public License. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Module [List]: list operations *)
(* Some functions are flagged as not tail-recursive. A tail-recursive
function uses constant stack space, while a non-tail-recursive function
uses stack space proportional to the length of its list argument, which
can be a problem with very long lists. When the function takes several
list arguments, an approximate formula giving stack usage (in some
unspecified constant unit) is shown in parentheses.
The above considerations can usually be ignored if your lists are not
longer than about 10000 elements.
*)
val length : 'a list -> int
(* Return the length (number of elements) of the given list. *)
val hd : 'a list -> 'a
(* Return the first element of the given list. Raise
[Failure "hd"] if the list is empty. *)
val tl : 'a list -> 'a list
(* Return the given list without its first element. Raise
[Failure "tl"] if the list is empty. *)
val nth : 'a list -> int -> 'a
(* Return the n-th element of the given list.
The first element (head of the list) is at position 0.
Raise [Failure "nth"] if the list is too short. *)
val rev : 'a list -> 'a list
(* List reversal. *)
val append : 'a list -> 'a list -> 'a list
(* Catenate two lists. Same function as the infix operator [@].
Not tail-recursive (length of the first argument). The [@]
operator is not tail-recursive either. *)
val rev_append : 'a list -> 'a list -> 'a list
(* [List.rev_append l1 l2] reverses [l1] and catenates it to [l2].
This is equivalent to [List.rev l1 @ l2], but [rev_append] is
tail-recursive and more efficient. *)
val concat : 'a list list -> 'a list
val flatten : 'a list list -> 'a list
(* Catenate (flatten) a list of lists. Not tail-recursive
(length of the argument + length of the longest sub-list). *)
(** Iterators *)
val iter : f:('a -> unit) -> 'a list -> unit
(* [List.iter f [a1; ...; an]] applies function [f] in turn to
[a1; ...; an]. It is equivalent to
[begin f a1; f a2; ...; f an; () end]. *)
val map : f:('a -> 'b) -> 'a list -> 'b list
(* [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
and builds the list [[f a1; ...; f an]]
with the results returned by [f]. Not tail-recursive. *)
val rev_map : f:('a -> 'b) -> 'a list -> 'b list
(* [List.rev_map f l] gives the same result as
[List.rev (List.map f l)], but is tail-recursive and
more efficient. *)
val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a
(* [List.fold_left f a [b1; ...; bn]] is
[f (... (f (f a b1) b2) ...) bn]. *)
val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b
(* [List.fold_right f [a1; ...; an] b] is
[f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *)
(** Iterators on two lists *)
val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit
(* [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn
[f a1 b1; ...; f an bn].
Raise [Invalid_argument] if the two lists have
different lengths. *)
val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
(* [List.map2 f [a1; ...; an] [b1; ...; bn]] is
[[f a1 b1; ...; f an bn]].
Raise [Invalid_argument] if the two lists have
different lengths. Not tail-recursive. *)
val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
(* [List.rev_map2 f l] gives the same result as
[List.rev (List.map2 f l)], but is tail-recursive and
more efficient. *)
val fold_left2 :
f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a
(* [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is
[f (... (f (f a b1 c1) b2 c2) ...) bn cn].
Raise [Invalid_argument] if the two lists have
different lengths. *)
val fold_right2 :
f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c
(* [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is
[f a1 b1 (f a2 b2 (... (f an bn c) ...))].
Raise [Invalid_argument] if the two lists have
different lengths. Not tail-recursive. *)
(** List scanning *)
val for_all : f:('a -> bool) -> 'a list -> bool
(* [for_all p [a1; ...; an]] checks if all elements of the list
satisfy the predicate [p]. That is, it returns
[(p a1) && (p a2) && ... && (p an)]. *)
val exists : f:('a -> bool) -> 'a list -> bool
(* [exists p [a1; ...; an]] checks if at least one element of
the list satisfies the predicate [p]. That is, it returns
[(p a1) || (p a2) || ... || (p an)]. *)
val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
(* Same as [for_all] and [exists], but for a two-argument predicate.
Raise [Invalid_argument] if the two lists have
different lengths. *)
val mem : 'a -> set:'a list -> bool
(* [mem a l] is true if and only if [a] is equal
to an element of [l]. *)
val memq : 'a -> set:'a list -> bool
(* Same as [mem], but uses physical equality instead of structural
equality to compare list elements. *)
(** List searching *)
val find : f:('a -> bool) -> 'a list -> 'a
(* [find p l] returns the first element of the list [l]
that satisfies the predicate [p].
Raise [Not_found] if there is no value that satisfies [p] in the
list [l]. *)
val filter : f:('a -> bool) -> 'a list -> 'a list
val find_all : f:('a -> bool) -> 'a list -> 'a list
(* [filter p l] returns all the elements of the list [l]
that satisfy the predicate [p]. The order of the elements
in the input list is preserved. [find_all] is another name
for [filter]. *)
val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list
(* [partition p l] returns a pair of lists [(l1, l2)], where
[l1] is the list of all the elements of [l] that
satisfy the predicate [p], and [l2] is the list of all the
elements of [l] that do not satisfy [p].
The order of the elements in the input list is preserved. *)
(** Association lists *)
val assoc : 'a -> map:('a * 'b) list -> 'b
(* [assoc a l] returns the value associated with key [a] in the list of
pairs [l]. That is,
[assoc a [ ...; (a,b); ...] = b]
if [(a,b)] is the leftmost binding of [a] in list [l].
Raise [Not_found] if there is no value associated with [a] in the
list [l]. *)
val assq : 'a -> map:('a * 'b) list -> 'b
(* Same as [assoc], but uses physical equality instead of structural
equality to compare keys. *)
val mem_assoc : 'a -> map:('a * 'b) list -> bool
(* Same as [assoc], but simply return true if a binding exists,
and false if no bindings exist for the given key. *)
val mem_assq : 'a -> map:('a * 'b) list -> bool
(* Same as [mem_assoc], but uses physical equality instead of
structural equality to compare keys. *)
val remove_assoc : 'a -> map:('a * 'b) list -> ('a * 'b) list
(* [remove_assoc a l] returns the list of
pairs [l] without the first pair with key [a], if any.
Not tail-recursive. *)
val remove_assq : 'a -> map:('a * 'b) list -> ('a * 'b) list
(* Same as [remove_assq], but uses physical equality instead
of structural equality to compare keys. Not tail-recursive. *)
(** Lists of pairs *)
val split : ('a * 'b) list -> 'a list * 'b list
(* Transform a list of pairs into a pair of lists:
[split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])].
Not tail-recursive.
*)
val combine : 'a list -> 'b list -> ('a * 'b) list
(* Transform a pair of lists into a list of pairs:
[combine ([a1; ...; an], [b1; ...; bn])] is
[[(a1,b1); ...; (an,bn)]].
Raise [Invalid_argument] if the two lists
have different lengths. Not tail-recursive. *)
(** Sorting *)
val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list;;
(* Sort a list in increasing order according to a comparison
function. The comparison function must return 0 if it arguments
compare as equal, a positive integer if the first is greater,
and a negative integer if the first is smaller. For example,
the [compare] function is a suitable comparison function.
The resulting list is sorted in increasing order.
[List.sort] is guaranteed to run in constant heap space
(in addition to the size of the result list) and logarithmic
stack space.
The current implementation uses Merge Sort and is the same as
[List.stable_sort].
*)
val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list;;
(* Same as [List.sort], but the sorting algorithm is stable.
The current implementation is Merge Sort. It runs in constant
heap space and logarithmic stack space.
*)

10
stdlib/map.mli
View File

@ -44,7 +44,7 @@ module type S =
(* The type of maps from type [key] to type ['a]. *)
val empty: 'a t
(* The empty map. *)
val add: key:key -> data:'a -> 'a t -> 'a t
val add: key -> 'a -> 'a t -> 'a t
(* [add x y m] returns a map containing the same bindings as
[m], plus a binding of [x] to [y]. If [x] was already bound
in [m], its previous binding disappears. *)
@ -57,22 +57,22 @@ module type S =
val mem: key -> 'a t -> bool
(* [mem x m] returns [true] if [m] contains a binding for [x],
and [false] otherwise. *)
val iter: f:(key:key -> data:'a -> unit) -> 'a t -> unit
val iter: (key -> 'a -> unit) -> 'a t -> unit
(* [iter f m] applies [f] to all bindings in map [m].
[f] receives the key as first argument, and the associated value
as second argument. The order in which the bindings are passed to
[f] is unspecified. Only current bindings are presented to [f]:
bindings hidden by more recent bindings are not passed to [f]. *)
val map: f:('a -> 'b) -> 'a t -> 'b t
val map: ('a -> 'b) -> 'a t -> 'b t
(* [map f m] returns a map with same domain as [m], where the
associated value [a] of all bindings of [m] has been
replaced by the result of the application of [f] to [a].
The order in which the associated values are passed to [f]
is unspecified. *)
val mapi: f:(key -> 'a -> 'b) -> 'a t -> 'b t
val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
(* Same as [map], but the function receives as arguments both the
key and the associated value for each binding of the map. *)
val fold: f:(key:key -> data:'a -> 'b -> 'b) -> 'a t -> init:'b -> 'b
val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
(* [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
where [k1 ... kN] are the keys of all bindings in [m],
and [d1 ... dN] are the associated data.

13
stdlib/marshal.mli
View File

@ -47,7 +47,7 @@ type extern_flags =
| Closures (* Send function closures *)
(* The flags to the [Marshal.to_*] functions below. *)
val to_channel: out_channel -> 'a -> mode:extern_flags list -> unit
val to_channel: out_channel -> 'a -> extern_flags list -> unit
(* [Marshal.to_channel chan v flags] writes the representation
of [v] on channel [chan]. The [flags] argument is a
possibly empty list of flags that governs the marshaling
@ -77,15 +77,14 @@ val to_channel: out_channel -> 'a -> mode:extern_flags list -> unit
at un-marshaling time, using an MD5 digest of the code
transmitted along with the code position.) *)
external to_string: 'a -> mode:extern_flags list -> string
external to_string: 'a -> extern_flags list -> string
= "output_value_to_string"
(* [Marshal.to_string v flags] returns a string containing
the representation of [v] as a sequence of bytes.
The [flags] argument has the same meaning as for
[Marshal.to_channel]. *)
val to_buffer: string -> pos:int -> len:int ->
'a -> mode:extern_flags list -> int
val to_buffer: string -> int -> int -> 'a -> extern_flags list -> int
(* [Marshal.to_buffer buff ofs len v flags] marshals the value [v],
storing its byte representation in the string [buff],
starting at character number [ofs], and writing at most
@ -100,15 +99,15 @@ val from_channel: in_channel -> 'a
one of the [Marshal.to_*] functions, and reconstructs and
returns the corresponding value.*)
val from_string: string -> pos:int -> 'a
val from_string: string -> int -> 'a
(* [Marshal.from_string buff ofs] unmarshals a structured value
like [Marshal.from_channel] does, except that the byte
representation is not read from a channel, but taken from
the string [buff], starting at position [ofs]. *)
val header_size : int
val data_size : string -> pos:int -> int
val total_size : string -> pos:int -> int
val data_size : string -> int -> int
val total_size : string -> int -> int
(* The bytes representing a marshaled value are composed of
a fixed-size header and a variable-sized data part,
whose size can be determined from the header.

4
stdlib/obj.mli
View File

@ -27,9 +27,9 @@ external tag : t -> int = "obj_tag"
external size : t -> int = "%obj_size"
external field : t -> int -> t = "%obj_field"
external set_field : t -> int -> t -> unit = "%obj_set_field"
external new_block : int -> len:int -> t = "obj_block"
external new_block : int -> int -> t = "obj_block"
external dup : t -> t = "obj_dup"
external truncate : t -> len:int -> unit = "obj_truncate"
external truncate : t -> int -> unit = "obj_truncate"
val no_scan_tag : int
val closure_tag : int

10
stdlib/pervasives.mli
View File

@ -472,7 +472,7 @@ val open_out_bin : string -> out_channel
so that no translation takes place during writes. On operating
systems that do not distinguish between text mode and binary
mode, this function behaves like [open_out]. *)
val open_out_gen : mode:open_flag list -> perm:int -> string -> out_channel
val open_out_gen : open_flag list -> int -> string -> out_channel
(* Open the named file for writing, as above. The extra argument [mode]
specify the opening mode. The extra argument [perm] specifies
the file permissions, in case the file must be created.
@ -486,7 +486,7 @@ val output_char : out_channel -> char -> unit
(* Write the character on the given output channel. *)
val output_string : out_channel -> string -> unit
(* Write the string on the given output channel. *)
val output : out_channel -> buf:string -> pos:int -> len:int -> unit
val output : out_channel -> string -> int -> int -> unit
(* Write [len] characters from string [buf], starting at offset
[pos], to the given output channel.
Raise [Invalid_argument "output"] if [pos] and [len] do not
@ -543,7 +543,7 @@ val open_in_bin : string -> in_channel
so that no translation takes place during reads. On operating
systems that do not distinguish between text mode and binary
mode, this function behaves like [open_in]. *)
val open_in_gen : mode:open_flag list -> perm:int -> string -> in_channel
val open_in_gen : open_flag list -> int -> string -> in_channel
(* Open the named file for reading, as above. The extra arguments
[mode] and [perm] specify the opening mode and file permissions.
[open_in] and [open_in_bin] are special cases of this function. *)
@ -556,7 +556,7 @@ val input_line : in_channel -> string
all characters read, without the newline character at the end.
Raise [End_of_file] if the end of the file is reached
at the beginning of line. *)
val input : in_channel -> buf:string -> pos:int -> len:int -> int
val input : in_channel -> string -> int -> int -> int
(* Read up to [len] characters from the given channel,
storing them in string [buf], starting at character number [pos].
It returns the actual number of characters read, between 0 and
@ -571,7 +571,7 @@ val input : in_channel -> buf:string -> pos:int -> len:int -> int
exactly [len] characters.)
Exception [Invalid_argument "input"] is raised if [pos] and [len]
do not designate a valid substring of [buf]. *)
val really_input : in_channel -> buf:string -> pos:int -> len:int -> unit
val really_input : in_channel -> string -> int -> int -> unit
(* Read [len] characters from the given channel, storing them in
string [buf], starting at character number [pos].
Raise [End_of_file] if the end of file is reached before [len]

4
stdlib/queue.mli
View File

@ -32,11 +32,11 @@ val take: 'a t -> 'a
val peek: 'a t -> 'a
(* [peek q] returns the first element in queue [q], without removing
it from the queue, or raises [Empty] if the queue is empty. *)
val clear : 'a t -> unit
val clear: 'a t -> unit
(* Discard all elements from a queue. *)
val length: 'a t -> int
(* Return the number of elements in a queue. *)
val iter: f:('a -> unit) -> 'a t -> unit
val iter: ('a -> unit) -> 'a t -> unit
(* [iter f q] applies [f] in turn to all elements of [q],
from the least recently entered to the most recently entered.
The queue itself is unchanged. *)

12
stdlib/set.mli
View File

@ -69,25 +69,25 @@ module type S =
val subset: t -> t -> bool
(* [subset s1 s2] tests whether the set [s1] is a subset of
the set [s2]. *)
val iter: f:(elt -> unit) -> t -> unit
val iter: (elt -> unit) -> t -> unit
(* [iter f s] applies [f] in turn to all elements of [s].
The order in which the elements of [s] are presented to [f]
is unspecified. *)
val fold: f:(elt -> 'a -> 'a) -> t -> init:'a -> 'a
val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
(* [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
where [x1 ... xN] are the elements of [s].
The order in which elements of [s] are presented to [f] is
unspecified. *)
val for_all: f:(elt -> bool) -> t -> bool
val for_all: (elt -> bool) -> t -> bool
(* [for_all p s] checks if all elements of the set
satisfy the predicate [p]. *)
val exists: f:(elt -> bool) -> t -> bool
val exists: (elt -> bool) -> t -> bool
(* [exists p s] checks if at least one element of
the set satisfies the predicate [p]. *)
val filter: f:(elt -> bool) -> t -> t
val filter: (elt -> bool) -> t -> t
(* [filter p s] returns the set of all elements in [s]
that satisfy predicate [p]. *)
val partition: f:(elt -> bool) -> t -> t * t
val partition: (elt -> bool) -> t -> t * t
(* [partition p s] returns a pair of sets [(s1, s2)], where
[s1] is the set of all the elements of [s] that satisfy the
predicate [p], and [s2] is the set of all the elements of

6
stdlib/sort.mli
View File

@ -19,19 +19,19 @@
The new functions are faster and use less memory.
*)
val list : order:('a -> 'a -> bool) -> 'a list -> 'a list
val list : ('a -> 'a -> bool) -> 'a list -> 'a list
(* Sort a list in increasing order according to an ordering predicate.
The predicate should return [true] if its first argument is
less than or equal to its second argument. *)
val array : order:('a -> 'a -> bool) -> 'a array -> unit
val array : ('a -> 'a -> bool) -> 'a array -> unit
(* Sort an array in increasing order according to an
ordering predicate.
The predicate should return [true] if its first argument is
less than or equal to its second argument.
The array is sorted in place. *)
val merge : order:('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
(* Merge two lists according to the given predicate.
Assuming the two argument lists are sorted according to the
predicate, [merge] returns a sorted list containing the elements

4
stdlib/stack.mli
View File

@ -32,11 +32,11 @@ val pop: 'a t -> 'a
val top: 'a t -> 'a
(* [top s] returns the topmost element in stack [s],
or raises [Empty] if the stack is empty. *)
val clear : 'a t -> unit
val clear: 'a t -> unit
(* Discard all elements from a stack. *)
val length: 'a t -> int
(* Return the number of elements in a stack. *)
val iter: f:('a -> unit) -> 'a t -> unit
val iter: ('a -> unit) -> 'a t -> unit
(* [iter f s] applies [f] in turn to all elements of [s],
from the element at the top of the stack to the element at the
bottom of the stack. The stack itself is unchanged. *)

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