diff options
122 files changed, 3068 insertions, 610 deletions
@@ -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)|' \ diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 7efc9f64e3..38f030683c 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 6ad31bf31b..f772df90fe 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index 8149278548..fe9a1dd476 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -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) diff --git a/config/auto-aux/runtest b/config/auto-aux/runtest index 421223875d..ce65bd07f1 100755 --- a/config/auto-aux/runtest +++ b/config/auto-aux/runtest @@ -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 @@ -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." diff --git a/driver/main.ml b/driver/main.ml index e38f7f383c..4d97a070ed 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -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 diff --git a/driver/main_args.ml b/driver/main_args.ml index 7a5f2049fb..70c622c5a7 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -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\ diff --git a/driver/main_args.mli b/driver/main_args.mli index 4b352143dc..f8d270f0d5 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -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 diff --git a/driver/optmain.ml b/driver/optmain.ml index 4f55fd93a9..572ce7dfaa 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -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\ diff --git a/emacs/caml-font.el b/emacs/caml-font.el index 7cf780aec8..5c9ae356cd 100644 --- a/emacs/caml-font.el +++ b/emacs/caml-font.el @@ -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 diff --git a/emacs/caml-hilit.el b/emacs/caml-hilit.el index 72cc81482d..21a5870ff8 100644 --- a/emacs/caml-hilit.el +++ b/emacs/caml-hilit.el @@ -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) diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml index f2a52e6056..2234b934f0 100644 --- a/otherlibs/bigarray/bigarray.ml +++ b/otherlibs/bigarray/bigarray.ml @@ -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 diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli index 11840a9c11..0563713f6f 100644 --- a/otherlibs/bigarray/bigarray.mli +++ b/otherlibs/bigarray/bigarray.mli @@ -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. *) diff --git a/otherlibs/db/db.mli b/otherlibs/db/db.mli index c22e337e99..3aa4244f79 100644 --- a/otherlibs/db/db.mli +++ b/otherlibs/db/db.mli @@ -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 diff --git a/otherlibs/dbm/dbm.mli b/otherlibs/dbm/dbm.mli index 9bb975642f..a228b28d16 100644 --- a/otherlibs/dbm/dbm.mli +++ b/otherlibs/dbm/dbm.mli @@ -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. *) diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli index e63e106802..63e70cf816 100644 --- a/otherlibs/dynlink/dynlink.mli +++ b/otherlibs/dynlink/dynlink.mli @@ -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 diff --git a/otherlibs/graph/graphics.mli b/otherlibs/graph/graphics.mli index cc8893615d..774fbd91f5 100644 --- a/otherlibs/graph/graphics.mli +++ b/otherlibs/graph/graphics.mli @@ -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). *) diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml index 5174493a3d..279098d3da 100644 --- a/otherlibs/labltk/browser/editor.ml +++ b/otherlibs/labltk/browser/editor.ml @@ -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 diff --git a/otherlibs/labltk/browser/fileselect.ml b/otherlibs/labltk/browser/fileselect.ml index 0b513584f4..9987505b3a 100644 --- a/otherlibs/labltk/browser/fileselect.ml +++ b/otherlibs/labltk/browser/fileselect.ml @@ -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 diff --git a/otherlibs/labltk/browser/jg_config.ml b/otherlibs/labltk/browser/jg_config.ml index 41e8e9cd17..547aab2ddb 100644 --- a/otherlibs/labltk/browser/jg_config.ml +++ b/otherlibs/labltk/browser/jg_config.ml @@ -13,6 +13,7 @@ (* $Id$ *) +open StdLabels open Jg_tk let fixed = if wingui then "{Courier New} 8" else "fixed" diff --git a/otherlibs/labltk/browser/jg_message.ml b/otherlibs/labltk/browser/jg_message.ml index 97a90bf9f3..6e15a4992f 100644 --- a/otherlibs/labltk/browser/jg_message.ml +++ b/otherlibs/labltk/browser/jg_message.ml @@ -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 diff --git a/otherlibs/labltk/browser/jg_multibox.ml b/otherlibs/labltk/browser/jg_multibox.ml index 5fb90b4947..5e5adb190e 100644 --- a/otherlibs/labltk/browser/jg_multibox.ml +++ b/otherlibs/labltk/browser/jg_multibox.ml @@ -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) diff --git a/otherlibs/labltk/browser/jg_text.ml b/otherlibs/labltk/browser/jg_text.ml index 97e071a6e4..0d239316fd 100644 --- a/otherlibs/labltk/browser/jg_text.ml +++ b/otherlibs/labltk/browser/jg_text.ml @@ -13,6 +13,7 @@ (* $Id$ *) +open StdLabels open Tk open Jg_tk diff --git a/otherlibs/labltk/browser/lexical.ml b/otherlibs/labltk/browser/lexical.ml index 38dcb8f81c..cb664043c2 100644 --- a/otherlibs/labltk/browser/lexical.ml +++ b/otherlibs/labltk/browser/lexical.ml @@ -13,6 +13,7 @@ (* $Id$ *) +open StdLabels open Tk open Jg_tk open Parser diff --git a/otherlibs/labltk/browser/list2.ml b/otherlibs/labltk/browser/list2.ml index 8ba876f25b..ece69a0a8e 100644 --- a/otherlibs/labltk/browser/list2.ml +++ b/otherlibs/labltk/browser/list2.ml @@ -13,6 +13,8 @@ (* $Id$ *) +open StdLabels + let exclude x l = List.filter l ~f:((<>) x) let rec flat_map ~f = function diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml index ef1e18ba34..e6f325f179 100644 --- a/otherlibs/labltk/browser/main.ml +++ b/otherlibs/labltk/browser/main.ml @@ -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 diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml index f25b9a3781..a3112761ec 100644 --- a/otherlibs/labltk/browser/searchid.ml +++ b/otherlibs/labltk/browser/searchid.ml @@ -13,6 +13,7 @@ (* $Id$ *) +open StdLabels open Location open Longident open Path diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 72dbf701dd..e5c222d6da 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -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 diff --git a/otherlibs/labltk/browser/setpath.ml b/otherlibs/labltk/browser/setpath.ml index a69c8fdc8f..cae5d046c1 100644 --- a/otherlibs/labltk/browser/setpath.ml +++ b/otherlibs/labltk/browser/setpath.ml @@ -13,6 +13,7 @@ (* $Id$ *) +open StdLabels open Tk (* Listboxes *) diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml index 30870cf98a..a0dcf2a055 100644 --- a/otherlibs/labltk/browser/shell.ml +++ b/otherlibs/labltk/browser/shell.ml @@ -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 diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml index 87a68a8c52..a7a1847952 100644 --- a/otherlibs/labltk/browser/typecheck.ml +++ b/otherlibs/labltk/browser/typecheck.ml @@ -13,6 +13,7 @@ (* $Id$ *) +open StdLabels open Tk open Parsetree open Location diff --git a/otherlibs/labltk/browser/useunix.ml b/otherlibs/labltk/browser/useunix.ml index b17911091c..3b6361878d 100644 --- a/otherlibs/labltk/browser/useunix.ml +++ b/otherlibs/labltk/browser/useunix.ml @@ -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 diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml index 7ae91e6e79..4a540dadc3 100644 --- a/otherlibs/labltk/browser/viewer.ml +++ b/otherlibs/labltk/browser/viewer.ml @@ -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 ^ ")" diff --git a/otherlibs/labltk/compiler/Makefile b/otherlibs/labltk/compiler/Makefile index 6b215dcbfd..302ad25880 100644 --- a/otherlibs/labltk/compiler/Makefile +++ b/otherlibs/labltk/compiler/Makefile @@ -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 diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml index 25cf3be814..66cfcf7a7d 100644 --- a/otherlibs/labltk/compiler/compile.ml +++ b/otherlibs/labltk/compiler/compile.ml @@ -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; diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml index 634e0a315e..fdeac2edbb 100644 --- a/otherlibs/labltk/compiler/intf.ml +++ b/otherlibs/labltk/compiler/intf.ml @@ -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 -> diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll index 89d62417a2..8de3956810 100644 --- a/otherlibs/labltk/compiler/lexer.mll +++ b/otherlibs/labltk/compiler/lexer.mll @@ -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; diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml index c546b173d7..65535df790 100644 --- a/otherlibs/labltk/compiler/maincompile.ml +++ b/otherlibs/labltk/compiler/maincompile.ml @@ -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 -> diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml index f5fc1435c6..85029b7726 100644 --- a/otherlibs/labltk/compiler/tables.ml +++ b/otherlibs/labltk/compiler/tables.ml @@ -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} - diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml index c4d7f62242..993ed0f4ad 100644 --- a/otherlibs/labltk/compiler/tsort.ml +++ b/otherlibs/labltk/compiler/tsort.ml @@ -15,6 +15,8 @@ (* $Id$ *) +open StdLabels + (* Topological Sort.list *) (* d'apres More Programming Pearls *) diff --git a/otherlibs/labltk/example/calc.ml b/otherlibs/labltk/example/calc.ml index be8f557e3f..c9373d0b74 100644 --- a/otherlibs/labltk/example/calc.ml +++ b/otherlibs/labltk/example/calc.ml @@ -22,6 +22,7 @@ makes things a little bit awkward. *) +open StdLabels open Tk let mem_string ~elt:c s = diff --git a/otherlibs/labltk/example/clock.ml b/otherlibs/labltk/example/clock.ml index ae5ef3e10c..3105b03c88 100644 --- a/otherlibs/labltk/example/clock.ml +++ b/otherlibs/labltk/example/clock.ml @@ -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 *) diff --git a/otherlibs/labltk/example/demo.ml b/otherlibs/labltk/example/demo.ml index bf35fa6a38..4fcd0e02af 100644 --- a/otherlibs/labltk/example/demo.ml +++ b/otherlibs/labltk/example/demo.ml @@ -17,6 +17,7 @@ (* Some CamlTk4 Demonstration by JPF *) (* First, open these modules for convenience *) +open StdLabels open Tk (* Dummy let *) diff --git a/otherlibs/labltk/example/tetris.ml b/otherlibs/labltk/example/tetris.ml index e2d4277a7f..28cc880d5d 100644 --- a/otherlibs/labltk/example/tetris.ml +++ b/otherlibs/labltk/example/tetris.ml @@ -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 () diff --git a/otherlibs/labltk/jpf/balloon.ml b/otherlibs/labltk/jpf/balloon.ml index 971d1e2d9d..7b2f2e074f 100644 --- a/otherlibs/labltk/jpf/balloon.ml +++ b/otherlibs/labltk/jpf/balloon.ml @@ -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 diff --git a/otherlibs/labltk/jpf/fileselect.ml b/otherlibs/labltk/jpf/fileselect.ml index 6dabf5a0da..6e565bb793 100644 --- a/otherlibs/labltk/jpf/fileselect.ml +++ b/otherlibs/labltk/jpf/fileselect.ml @@ -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 diff --git a/otherlibs/labltk/lib/Makefile.gen b/otherlibs/labltk/lib/Makefile.gen index e44dc35dc5..756e704b9c 100644 --- a/otherlibs/labltk/lib/Makefile.gen +++ b/otherlibs/labltk/lib/Makefile.gen @@ -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'; \ diff --git a/otherlibs/labltk/support/.depend b/otherlibs/labltk/support/.depend index 8c7b959bf6..c10b37a920 100644 --- a/otherlibs/labltk/support/.depend +++ b/otherlibs/labltk/support/.depend @@ -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 diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common index d929e45ca1..0abd3b6732 100644 --- a/otherlibs/labltk/support/Makefile.common +++ b/otherlibs/labltk/support/Makefile.common @@ -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 diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml index 4598c1d429..1e907c7684 100644 --- a/otherlibs/labltk/support/fileevent.ml +++ b/otherlibs/labltk/support/fileevent.ml @@ -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; diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml index 368ae7afbc..7ad8b317e6 100644 --- a/otherlibs/labltk/support/protocol.ml +++ b/otherlibs/labltk/support/protocol.ml @@ -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}") diff --git a/otherlibs/labltk/support/support.ml b/otherlibs/labltk/support/support.ml index 72941b6565..b6cd5e8c32 100644 --- a/otherlibs/labltk/support/support.ml +++ b/otherlibs/labltk/support/support.ml @@ -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 diff --git a/otherlibs/labltk/support/support.mli b/otherlibs/labltk/support/support.mli index 78007e4eff..2eaf9b5e52 100644 --- a/otherlibs/labltk/support/support.mli +++ b/otherlibs/labltk/support/support.mli @@ -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 diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml index 1bf919bab4..df4c3b92dc 100644 --- a/otherlibs/labltk/support/textvariable.ml +++ b/otherlibs/labltk/support/textvariable.ml @@ -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 -> () diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml index 197dfac014..349bf6a2e3 100644 --- a/otherlibs/labltk/support/timer.ml +++ b/otherlibs/labltk/support/timer.ml @@ -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; diff --git a/otherlibs/labltk/support/widget.ml b/otherlibs/labltk/support/widget.ml index aa3c177e79..6cc7c74743 100644 --- a/otherlibs/labltk/support/widget.ml +++ b/otherlibs/labltk/support/widget.ml @@ -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 *) diff --git a/otherlibs/str/str.mli b/otherlibs/str/str.mli index 06051db709..567d016c10 100644 --- a/otherlibs/str/str.mli +++ b/otherlibs/str/str.mli @@ -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]. *) diff --git a/otherlibs/systhreads/condition.mli b/otherlibs/systhreads/condition.mli index efd92569a3..007d024b72 100644 --- a/otherlibs/systhreads/condition.mli +++ b/otherlibs/systhreads/condition.mli @@ -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. diff --git a/otherlibs/systhreads/event.mli b/otherlibs/systhreads/event.mli index 2214117b41..ede7f9bc43 100644 --- a/otherlibs/systhreads/event.mli +++ b/otherlibs/systhreads/event.mli @@ -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. *) diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli index 6a2135a2a3..9218233f20 100644 --- a/otherlibs/systhreads/thread.mli +++ b/otherlibs/systhreads/thread.mli @@ -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. diff --git a/otherlibs/systhreads/threadUnix.mli b/otherlibs/systhreads/threadUnix.mli index 08bf48fba4..14ab54796e 100644 --- a/otherlibs/systhreads/threadUnix.mli +++ b/otherlibs/systhreads/threadUnix.mli @@ -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 diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index 8ddbd8287c..0825905636 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -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 diff --git a/otherlibs/threads/condition.mli b/otherlibs/threads/condition.mli index efd92569a3..007d024b72 100644 --- a/otherlibs/threads/condition.mli +++ b/otherlibs/threads/condition.mli @@ -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. diff --git a/otherlibs/threads/event.mli b/otherlibs/threads/event.mli index 2214117b41..ede7f9bc43 100644 --- a/otherlibs/threads/event.mli +++ b/otherlibs/threads/event.mli @@ -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. *) diff --git a/otherlibs/threads/marshal.ml b/otherlibs/threads/marshal.ml index a0fe8d2bf0..1173643881 100644 --- a/otherlibs/threads/marshal.ml +++ b/otherlibs/threads/marshal.ml @@ -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" diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml index 327be3ca80..afd30fb930 100644 --- a/otherlibs/threads/pervasives.ml +++ b/otherlibs/threads/pervasives.ml @@ -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 diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli index 4fda3afa5b..d49aca1804 100644 --- a/otherlibs/threads/thread.mli +++ b/otherlibs/threads/thread.mli @@ -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. diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli index 7d816e9fc6..b94dc78f0a 100644 --- a/otherlibs/threads/threadUnix.mli +++ b/otherlibs/threads/threadUnix.mli @@ -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 diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend index 081555a1a5..94aa152da0 100644 --- a/otherlibs/unix/.depend +++ b/otherlibs/unix/.depend @@ -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 diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile index 17288e3ab5..c58f5cf157 100644 --- a/otherlibs/unix/Makefile +++ b/otherlibs/unix/Makefile @@ -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 diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index ce95614c5a..c3b7a281c6 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -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, diff --git a/otherlibs/unix/unixLabels.ml b/otherlibs/unix/unixLabels.ml new file mode 100644 index 0000000000..1de1a7a8c1 --- /dev/null +++ b/otherlibs/unix/unixLabels.ml @@ -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 diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli new file mode 100644 index 0000000000..20de566f47 --- /dev/null +++ b/otherlibs/unix/unixLabels.mli @@ -0,0 +1,1007 @@ +(***********************************************************************) +(* *) +(* 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 [UnixLabels]: interface to the Unix system *) + +(* To use as replacement to default [Unix] module, *) +(* add [module Unix = UnixLabels] in your implementation *) + +(*** Error report *) + +type error = Unix.error = + (* Errors defined in the POSIX standard *) + E2BIG (* Argument list too long *) + | EACCES (* Permission denied *) + | EAGAIN (* Resource temporarily unavailable; try again *) + | EBADF (* Bad file descriptor *) + | EBUSY (* Resource unavailable *) + | ECHILD (* No child process *) + | EDEADLK (* Resource deadlock would occur *) + | EDOM (* Domain error for math functions, etc. *) + | EEXIST (* File exists *) + | EFAULT (* Bad address *) + | EFBIG (* File too large *) + | EINTR (* Function interrupted by signal *) + | EINVAL (* Invalid argument *) + | EIO (* Hardware I/O error *) + | EISDIR (* Is a directory *) + | EMFILE (* Too many open files by the process *) + | EMLINK (* Too many links *) + | ENAMETOOLONG (* Filename too long *) + | ENFILE (* Too many open files in the system *) + | ENODEV (* No such device *) + | ENOENT (* No such file or directory *) + | ENOEXEC (* Not an executable file *) + | ENOLCK (* No locks available *) + | ENOMEM (* Not enough memory *) + | ENOSPC (* No space left on device *) + | ENOSYS (* Function not supported *) + | ENOTDIR (* Not a directory *) + | ENOTEMPTY (* Directory not empty *) + | ENOTTY (* Inappropriate I/O control operation *) + | ENXIO (* No such device or address *) + | EPERM (* Operation not permitted *) + | EPIPE (* Broken pipe *) + | ERANGE (* Result too large *) + | EROFS (* Read-only file system *) + | ESPIPE (* Invalid seek e.g. on a pipe *) + | ESRCH (* No such process *) + | EXDEV (* Invalid link *) + (* Additional errors, mostly BSD *) + | EWOULDBLOCK (* Operation would block *) + | EINPROGRESS (* Operation now in progress *) + | EALREADY (* Operation already in progress *) + | ENOTSOCK (* Socket operation on non-socket *) + | EDESTADDRREQ (* Destination address required *) + | EMSGSIZE (* Message too long *) + | EPROTOTYPE (* Protocol wrong type for socket *) + | ENOPROTOOPT (* Protocol not available *) + | EPROTONOSUPPORT (* Protocol not supported *) + | ESOCKTNOSUPPORT (* Socket type not supported *) + | EOPNOTSUPP (* Operation not supported on socket *) + | EPFNOSUPPORT (* Protocol family not supported *) + | EAFNOSUPPORT (* Address family not supported by protocol family *) + | EADDRINUSE (* Address already in use *) + | EADDRNOTAVAIL (* Can't assign requested address *) + | ENETDOWN (* Network is down *) + | ENETUNREACH (* Network is unreachable *) + | ENETRESET (* Network dropped connection on reset *) + | ECONNABORTED (* Software caused connection abort *) + | ECONNRESET (* Connection reset by peer *) + | ENOBUFS (* No buffer space available *) + | EISCONN (* Socket is already connected *) + | ENOTCONN (* Socket is not connected *) + | ESHUTDOWN (* Can't send after socket shutdown *) + | ETOOMANYREFS (* Too many references: can't splice *) + | ETIMEDOUT (* Connection timed out *) + | ECONNREFUSED (* Connection refused *) + | EHOSTDOWN (* Host is down *) + | EHOSTUNREACH (* No route to host *) + | ELOOP (* Too many levels of symbolic links *) + (* All other errors are mapped to EUNKNOWNERR *) + | EUNKNOWNERR of int (* Unknown error *) + + (* The type of error codes. *) + +exception Unix_error of error * string * string + (* Raised by the system calls below when an error is encountered. + The first component is the error code; the second component + is the function name; the third component is the string parameter + to the function, if it has one, or the empty string otherwise. *) + +val error_message : error -> string + (* Return a string describing the given error code. *) + +val handle_unix_error : ('a -> 'b) -> 'a -> 'b + (* [handle_unix_error f x] applies [f] to [x] and returns the result. + If the exception [Unix_error] is raised, it prints a message + describing the error and exits with code 2. *) + + +(*** Access to the process environment *) + +val environment : unit -> string array + (* Return the process environment, as an array of strings + with the format ``variable=value''. *) +val getenv: string -> string + (* Return the value associated to a variable in the process + environment. Raise [Not_found] if the variable is unbound. + (This function is identical to [Sys.getenv].) *) +val putenv: string -> string -> unit + (* [Unix.putenv name value] sets the value associated to a + variable in the process environment. + [name] is the name of the environment variable, + and [value] its new associated value. *) + +(*** Process handling *) + +type process_status = Unix.process_status = + WEXITED of int + | WSIGNALED of int + | WSTOPPED of int + + (* The termination status of a process. [WEXITED] means that the + process terminated normally by [exit]; the argument is the return + code. [WSIGNALED] means that the process was killed by a signal; + the argument is the signal number. [WSTOPPED] means + that the process was stopped by a signal; the argument is the + signal number. *) + +type wait_flag = Unix.wait_flag = + WNOHANG + | WUNTRACED + + (* Flags for [waitpid]. + [WNOHANG] means do not block if no child has + died yet, but immediately return with a pid equal to 0. + [WUNTRACED] means report also the children that receive stop + signals. *) + +val execv : prog:string -> args: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 + (* 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 + (* Same as [execv] and [execvp] respectively, except that + the program is searched in the path. *) +val fork : unit -> int + (* Fork a new process. The returned integer is 0 for the child + process, the pid of the child process for the parent process. *) +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 + (* 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 + as the current process. + Negative pid arguments represent process groups. + The list of options indicates whether [waitpid] should return + immediately without waiting, or also report stopped children. *) +val system : string -> process_status + (* Execute the given command, wait until it terminates, and return + its termination status. The string is interpreted by the shell + [/bin/sh] and therefore can contain redirections, quotes, variables, + etc. The result [WEXITED 127] indicates that the shell couldn't + be executed. *) +val getpid : unit -> int + (* Return the pid of the process. *) +val getppid : unit -> int + (* Return the pid of the parent process. *) +val nice : int -> int + (* Change the process priority. The integer argument is added to the + ``nice'' value. (Higher values of the ``nice'' value mean + lower priorities.) Return the new nice value. *) + +(*** Basic file input/output *) + +type file_descr = Unix.file_descr + (* The abstract type of file descriptors. *) + +val stdin : file_descr +val stdout : file_descr +val stderr : file_descr + (* File descriptors for standard input, standard output and + standard error. *) + + +type open_flag = Unix.open_flag = + O_RDONLY (* Open for reading *) + | O_WRONLY (* Open for writing *) + | O_RDWR (* Open for reading and writing *) + | O_NONBLOCK (* Open in non-blocking mode *) + | O_APPEND (* Open for append *) + | O_CREAT (* Create if nonexistent *) + | O_TRUNC (* Truncate to 0 length if existing *) + | O_EXCL (* Fail if existing *) + + (* The flags to [open]. *) + +type file_perm = int + (* The type of file access rights. *) + +val openfile : string -> mode:open_flag list -> perm: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 + (* [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 + (* [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 + written. *) + + +(*** Interfacing with the standard input/output library. *) + +val in_channel_of_descr : file_descr -> in_channel + (* Create an input channel reading from the given descriptor. + The channel is initially in binary mode; use + [set_binary_mode_in ic false] if text mode is desired. *) +val out_channel_of_descr : file_descr -> out_channel + (* Create an output channel writing on the given descriptor. + The channel is initially in binary mode; use + [set_binary_mode_out oc false] if text mode is desired. *) +val descr_of_in_channel : in_channel -> file_descr + (* Return the descriptor corresponding to an input channel. *) +val descr_of_out_channel : out_channel -> file_descr + (* Return the descriptor corresponding to an output channel. *) + + +(*** Seeking and truncating *) + +type seek_command = Unix.seek_command = + SEEK_SET + | SEEK_CUR + | SEEK_END + + (* Positioning modes for [lseek]. [SEEK_SET] indicates positions + relative to the beginning of the file, [SEEK_CUR] relative to + the current position, [SEEK_END] relative to the end of the + file. *) + +val lseek : file_descr -> int -> mode:seek_command -> int + (* Set the current position for a file descriptor *) +val truncate : string -> len:int -> unit + (* Truncates the named file to the given size. *) +val ftruncate : file_descr -> len:int -> unit + (* Truncates the file corresponding to the given descriptor + to the given size. *) + + +(*** File statistics *) + +type file_kind = Unix.file_kind = + S_REG (* Regular file *) + | S_DIR (* Directory *) + | S_CHR (* Character device *) + | S_BLK (* Block device *) + | S_LNK (* Symbolic link *) + | S_FIFO (* Named pipe *) + | S_SOCK (* Socket *) + +type stats = Unix.stats = + { st_dev : int; (* Device number *) + st_ino : int; (* Inode number *) + st_kind : file_kind; (* Kind of the file *) + st_perm : file_perm; (* Access rights *) + st_nlink : int; (* Number of links *) + st_uid : int; (* User id of the owner *) + st_gid : int; (* Group ID of the file's group *) + st_rdev : int; (* Device minor number *) + st_size : int; (* Size in bytes *) + st_atime : float; (* Last access time *) + st_mtime : float; (* Last modification time *) + st_ctime : float } (* Last status change time *) + + (* The informations returned by the [stat] calls. *) + +val stat : string -> stats + (* Return the information for the named file. *) +val lstat : string -> stats + (* Same as [stat], but in case the file is a symbolic link, + return the information for the link itself. *) +val fstat : file_descr -> stats + (* Return the information for the file associated with the given + descriptor. *) + + +(*** Operations on file names *) + +val unlink : string -> unit + (* Removes the named file *) +val rename : src:string -> dst:string -> unit + (* [rename old new] changes the name of a file from [old] to [new]. *) +val link : src:string -> dst:string -> unit + (* [link source dest] creates a hard link named [dest] to the file + named [new]. *) + + +(*** File permissions and ownership *) + +type access_permission = Unix.access_permission = + R_OK (* Read permission *) + | W_OK (* Write permission *) + | X_OK (* Execution permission *) + | F_OK (* File exists *) + + (* Flags for the [access] call. *) + +val chmod : string -> perm:file_perm -> unit + (* Change the permissions of the named file. *) +val fchmod : file_descr -> perm:file_perm -> unit + (* Change the permissions of an opened file. *) +val chown : string -> uid:int -> gid:int -> unit + (* Change the owner uid and owner gid of the named file. *) +val fchown : file_descr -> uid:int -> gid: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 + (* Check that the process has the given permissions over the named + file. Raise [Unix_error] otherwise. *) + + +(*** Operations on file descriptors *) + +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 + (* [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already + opened. *) +val set_nonblock : file_descr -> unit +val clear_nonblock : file_descr -> unit + (* Set or clear the ``non-blocking'' flag on the given descriptor. + When the non-blocking flag is set, reading on a descriptor + on which there is temporarily no data available raises the + [EAGAIN] or [EWOULDBLOCK] error instead of blocking; + writing on a descriptor on which there is temporarily no room + for writing also raises [EAGAIN] or [EWOULDBLOCK]. *) +val set_close_on_exec : file_descr -> unit +val clear_close_on_exec : file_descr -> unit + (* Set or clear the ``close-on-exec'' flag on the given descriptor. + A descriptor with the close-on-exec flag is automatically + closed when the current process starts another program with + one of the [exec] functions. *) + + +(*** Directories *) + +val mkdir : string -> perm:file_perm -> unit + (* Create a directory with the given permissions. *) +val rmdir : string -> unit + (* Remove an empty directory. *) +val chdir : string -> unit + (* Change the process working directory. *) +val getcwd : unit -> string + (* Return the name of the current working directory. *) +val chroot : string -> unit + (* Change the process root directory. *) + + +type dir_handle = Unix.dir_handle + + (* The type of descriptors over opened directories. *) + +val opendir : string -> dir_handle + (* Open a descriptor on a directory *) +val readdir : dir_handle -> string + (* Return the next entry in a directory. + Raise [End_of_file] when the end of the directory has been + reached. *) +val rewinddir : dir_handle -> unit + (* Reposition the descriptor to the beginning of the directory *) +val closedir : dir_handle -> unit + (* Close a directory descriptor. *) + + +(*** Pipes and redirections *) + +val pipe : unit -> file_descr * file_descr + (* Create a pipe. The first component of the result is opened + 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 + (* 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 + (* [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 + process is returned immediately; the new process executes + concurrently with the current process. + The standard input and outputs of the new process are connected + to the descriptors [new_stdin], [new_stdout] and [new_stderr]. + Passing e.g. [stdout] for [new_stdout] prevents the redirection + and causes the new process to have the same standard output + as the current process. + The executable file [prog] is searched in the path. + The new process has the same environment as the current process. + All file descriptors of the current process are closed in the + new process, except those redirected to standard input and + outputs. *) + +val create_process_env : + prog:string -> args:string array -> env:string array -> + stdin:file_descr -> stdout:file_descr -> stderr: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. *) + +val open_process_in: string -> in_channel +val open_process_out: string -> out_channel +val open_process: string -> in_channel * out_channel + (* High-level pipe and process management. These functions + run the given command in parallel with the program, + and return channels connected to the standard input and/or + the standard output of the command. The command is interpreted + by the shell [/bin/sh] (cf. [system]). Warning: writes on channels + 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 + (* 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, + and standard error of the command. *) +val close_process_in: in_channel -> process_status +val close_process_out: out_channel -> process_status +val close_process: in_channel * out_channel -> process_status +val close_process_full: in_channel * out_channel * in_channel -> process_status + (* Close channels opened by [open_process_in], [open_process_out], + [open_process] and [open_process_full], respectively, + wait for the associated command to terminate, + and return its termination status. *) + +(*** Symbolic links *) + +val symlink : src:string -> dst:string -> unit + (* [symlink source dest] creates the file [dest] as a symbolic link + to the file [source]. *) +val readlink : string -> string + (* Read the contents of a link. *) + + +(*** 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 + (* Wait until some input/output operations become possible on + some channels. The three list arguments are, respectively, a set + of descriptors to check for reading (first argument), for writing + (second argument), or for exceptional conditions (third argument). + The fourth argument is the maximal timeout, in seconds; a + negative fourth argument means no timeout (unbounded wait). + The result is composed of three sets of descriptors: those ready + for reading (first component), ready for writing (second component), + and over which an exceptional condition is pending (third + component). *) + +(*** Locking *) + +type lock_command = Unix.lock_command = + F_ULOCK (* Unlock a region *) + | F_LOCK (* Lock a region for writing, and block if already locked *) + | F_TLOCK (* Lock a region for writing, or fail if already locked *) + | F_TEST (* Test a region for other process locks *) + | F_RLOCK (* Lock a region for reading, and block if already locked *) + | F_TRLOCK (* Lock a region for reading, or fail if already locked *) + + (* Commands for [lockf]. *) + +val lockf : file_descr -> mode:lock_command -> len: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 + [fd] (as set by [lseek]), and extends [size] bytes forward if + [size] is positive, [size] bytes backwards if [size] is negative, + or to the end of the file if [size] is zero. + A write lock (set with [F_LOCK] or [F_TLOCK]) prevents any other + process from acquiring a read or write lock on the region. + A read lock (set with [F_RLOCK] or [F_TRLOCK]) prevents any other + process from acquiring a write lock on the region, but lets + other processes acquire read locks on it. *) + +(*** Signals *) + + (* Note: installation of signal handlers is performed via + the functions [signal] and [set_signal] of module [Sys]. *) + +val kill : pid:int -> signal:int -> unit + (* [kill pid sig] sends signal number [sig] to the process + with id [pid]. *) + +type sigprocmask_command = Unix.sigprocmask_command = + SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK + +val sigprocmask: mode: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]. + If [cmd] is [SIG_BLOCK], the signals in [sigs] are added to + the set of blocked signals. + If [cmd] is [SIG_UNBLOCK], the signals in [sigs] are removed + from the set of blocked signals. + [sigprocmask] returns the set of previously blocked signals. *) + +val sigpending: unit -> int list + (* Return the set of blocked signals that are currently pending. *) + +val sigsuspend: int list -> unit + (* [sigsuspend sigs] atomically sets the blocked signals to [sig] + and waits for a non-ignored, non-blocked signal to be delivered. + On return, the blocked signals are reset to their initial value. *) + +val pause : unit -> unit + (* Wait until a non-ignored, non-blocked signal is delivered. *) + +(*** Time functions *) + +type process_times = Unix.process_times = + { tms_utime : float; (* User time for the process *) + tms_stime : float; (* System time for the process *) + tms_cutime : float; (* User time for the children processes *) + tms_cstime : float } (* System time for the children processes *) + + (* The execution times (CPU times) of a process. *) + +type tm = Unix.tm = + { tm_sec : int; (* Seconds 0..59 *) + tm_min : int; (* Minutes 0..59 *) + tm_hour : int; (* Hours 0..23 *) + tm_mday : int; (* Day of month 1..31 *) + tm_mon : int; (* Month of year 0..11 *) + tm_year : int; (* Year - 1900 *) + tm_wday : int; (* Day of week (Sunday is 0) *) + tm_yday : int; (* Day of year 0..365 *) + tm_isdst : bool } (* Daylight time savings in effect *) + + (* The type representing wallclock time and calendar date. *) + +val time : unit -> float + (* Return the current time since 00:00:00 GMT, Jan. 1, 1970, + in seconds. *) +val gettimeofday : unit -> float + (* Same as [time], but with resolution better than 1 second. *) +val gmtime : float -> tm + (* Convert a time in seconds, as returned by [time], into a date and + a time. Assumes Greenwich meridian time zone, also known as UTC. *) +val localtime : float -> tm + (* Convert a time in seconds, as returned by [time], into a date and + a time. Assumes the local time zone. *) +val mktime : tm -> float * tm + (* Convert a date and time, specified by the [tm] argument, into + a time in seconds, as returned by [time]. Also return a normalized + copy of the given [tm] record, with the [tm_wday], [tm_yday], + and [tm_isdst] fields recomputed from the other fields. + The [tm] argument is interpreted in the local time zone. *) +val alarm : int -> int + (* Schedule a [SIGALRM] signal after the given number of seconds. *) +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 + (* 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. *) + +type interval_timer = Unix.interval_timer = + ITIMER_REAL + | ITIMER_VIRTUAL + | ITIMER_PROF + (* The three kinds of interval timers. + [ITIMER_REAL] decrements in real time, and sends the signal + [SIGALRM] when expired. + [ITIMER_VIRTUAL] decrements in process virtual time, and sends + [SIGVTALRM] when expired. + [ITIMER_PROF] (for profiling) decrements both when the process + is running and when the system is running on behalf of the + process; it sends [SIGPROF] when expired. *) + +type interval_timer_status = Unix.interval_timer_status = + { it_interval: float; (* Period *) + it_value: float } (* Current value of the timer *) + (* The type describing the status of an interval timer *) + +val getitimer: interval_timer -> interval_timer_status + (* Return the current status of the given interval timer. *) +val setitimer: + interval_timer -> interval_timer_status -> interval_timer_status + (* [setitimer t s] sets the interval timer [t] and returns + its previous status. The [s] argument is interpreted as follows: + [s.it_value], if nonzero, is the time to the next timer expiration; + [s.it_interval], if nonzero, specifies a value to + be used in reloading it_value when the timer expires. + Setting [s.it_value] to zero disable the timer. + Setting [s.it_interval] to zero causes the timer to be disabled + after its next expiration. *) + +(*** User id, group id *) + +val getuid : unit -> int + (* Return the user id of the user executing the process. *) +val geteuid : unit -> int + (* Return the effective user id under which the process runs. *) +val setuid : int -> unit + (* Set the real user id and effective user id for the process. *) +val getgid : unit -> int + (* Return the group id of the user executing the process. *) +val getegid : unit -> int + (* Return the effective group id under which the process runs. *) +val setgid : int -> unit + (* Set the real group id and effective group id for the process. *) +val getgroups : unit -> int array + (* Return the list of groups to which the user executing the process + belongs. *) + + +type passwd_entry = Unix.passwd_entry = + { pw_name : string; + pw_passwd : string; + pw_uid : int; + pw_gid : int; + pw_gecos : string; + pw_dir : string; + pw_shell : string } + (* Structure of entries in the [passwd] database. *) + +type group_entry = Unix.group_entry = + { gr_name : string; + gr_passwd : string; + gr_gid : int; + gr_mem : string array } + (* Structure of entries in the [groups] database. *) + +val getlogin : unit -> string + (* Return the login name of the user executing the process. *) +val getpwnam : string -> passwd_entry + (* Find an entry in [passwd] with the given name, or raise + [Not_found]. *) +val getgrnam : string -> group_entry + (* Find an entry in [group] with the given name, or raise + [Not_found]. *) +val getpwuid : int -> passwd_entry + (* Find an entry in [passwd] with the given user id, or raise + [Not_found]. *) +val getgrgid : int -> group_entry + (* Find an entry in [group] with the given group id, or raise + [Not_found]. *) + + +(*** Internet addresses *) + +type inet_addr = Unix.inet_addr + (* The abstract type of Internet addresses. *) + +val inet_addr_of_string : string -> inet_addr +val string_of_inet_addr : inet_addr -> string + (* Conversions between string with the format [XXX.YYY.ZZZ.TTT] + and Internet addresses. [inet_addr_of_string] raises [Failure] + when given a string that does not match this format. *) + +val inet_addr_any : inet_addr + (* A special Internet address, for use only with [bind], representing + all the Internet addresses that the host machine possesses. *) + +(*** Sockets *) + +type socket_domain = Unix.socket_domain = + PF_UNIX (* Unix domain *) + | PF_INET (* Internet domain *) + + (* The type of socket domains. *) + +type socket_type = Unix.socket_type = + SOCK_STREAM (* Stream socket *) + | SOCK_DGRAM (* Datagram socket *) + | SOCK_RAW (* Raw socket *) + | SOCK_SEQPACKET (* Sequenced packets socket *) + + (* The type of socket kinds, specifying the semantics of + communications. *) + +type sockaddr = Unix.sockaddr = + ADDR_UNIX of string + | ADDR_INET of inet_addr * int + + (* The type of socket addresses. [ADDR_UNIX name] is a socket + address in the Unix domain; [name] is a file name in the file + system. [ADDR_INET(addr,port)] is a socket address in the Internet + domain; [addr] is the Internet address of the machine, and + [port] is the port number. *) + +val socket : + domain:socket_domain -> kind:socket_type -> protocol: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 -> + 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 + (* Bind a socket to an address. *) +val connect : file_descr -> addr:sockaddr -> unit + (* Connect a socket to an address. *) +val listen : file_descr -> max:int -> unit + (* Set up a socket for receiving connection requests. The integer + argument is the maximal number of pending requests. *) + +type shutdown_command = Unix.shutdown_command = + SHUTDOWN_RECEIVE (* Close for receiving *) + | SHUTDOWN_SEND (* Close for sending *) + | SHUTDOWN_ALL (* Close both *) + (* The type of commands for [shutdown]. *) + +val shutdown : file_descr -> mode: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. + [SHUTDOWN_RECEIVE] causes writes on the other end of the connection + to return a closed pipe condition ([SIGPIPE] signal). *) + +val getsockname : file_descr -> sockaddr + (* Return the address of the given socket. *) +val getpeername : file_descr -> sockaddr + (* Return the address of the host connected to the given socket. *) + +type msg_flag = Unix.msg_flag = + MSG_OOB + | MSG_DONTROUTE + | MSG_PEEK + (* The flags for [recv], [recvfrom], [send] and [sendto]. *) + +val recv : + file_descr -> buf:string -> pos:int -> len:int + -> mode:msg_flag list -> int +val recvfrom : + file_descr -> buf:string -> pos:int -> len:int + -> mode: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 sendto : + file_descr -> buf:string -> pos:int -> len:int + -> mode:msg_flag list -> addr:sockaddr -> int + (* Send data over an unconnected socket. *) + +(*** Socket options *) + +type socket_bool_option = + SO_DEBUG (* Record debugging information *) + | SO_BROADCAST (* Permit sending of broadcast messages *) + | SO_REUSEADDR (* Allow reuse of local addresses for bind *) + | SO_KEEPALIVE (* Keep connection active *) + | SO_DONTROUTE (* Bypass the standard routing algorithms *) + | SO_OOBINLINE (* Leave out-of-band data in line *) + | SO_ACCEPTCONN (* Report whether socket listening is enabled *) + (* The socket options that can be consulted with [getsockopt] + and modified with [setsockopt]. These options have a boolean + ([true]/[false]) value. *) + +type socket_int_option = + SO_SNDBUF (* Size of send buffer *) + | SO_RCVBUF (* Size of received buffer *) + | SO_ERROR (* Report the error status and clear it *) + | SO_TYPE (* Report the socket type *) + | SO_RCVLOWAT (* Minimum number of bytes to process for input operations *) + | SO_SNDLOWAT (* Minimum number of bytes to process for output operations *) + (* The socket options that can be consulted with [getsockopt_int] + and modified with [setsockopt_int]. These options have an + integer value. *) + +type socket_optint_option = + SO_LINGER (* Whether to linger on closed connections + that have data present, and for how long + (in seconds) *) + (* The socket options that can be consulted with [getsockopt_optint] + and modified with [setsockopt_optint]. These options have a + value of type [int option], with [None] meaning ``disabled''. *) + +type socket_float_option = + SO_RCVTIMEO (* Timeout for input operations *) + | SO_SNDTIMEO (* Timeout for output operations *) + (* The socket options that can be consulted with [getsockopt_float] + and modified with [setsockopt_float]. These options have a + floating-point value representing a time in seconds. + The value 0 means infinite timeout. *) + +val getsockopt : file_descr -> socket_bool_option -> bool + (* Return the current status of a boolean-valued option + in the given socket. *) +val setsockopt : file_descr -> socket_bool_option -> bool -> unit + (* Set or clear a boolean-valued option in the given socket. *) +external getsockopt_int : file_descr -> socket_int_option -> int + = "unix_getsockopt_int" +external setsockopt_int : file_descr -> socket_int_option -> int -> unit + = "unix_setsockopt_int" + (* Same, for an integer-valued socket option. *) +external getsockopt_optint : file_descr -> socket_optint_option -> int option + = "unix_getsockopt_optint" +external setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit + (* Same, for a socket option whose value is an [int option]. *) + = "unix_setsockopt_optint" +external getsockopt_float : file_descr -> socket_float_option -> float + = "unix_getsockopt_float" +external setsockopt_float : file_descr -> socket_float_option -> float -> unit + = "unix_setsockopt_float" + (* Same, for a socket option whose value is a floating-point number. *) + +(*** High-level network connection functions *) + +val open_connection : sockaddr -> in_channel * out_channel + (* Connect to a server at the given address. + Return a pair of buffered channels connected to the server. + Remember to call [flush] on the output channel at the right times + to ensure correct synchronization. *) +val shutdown_connection : in_channel -> unit + (* ``Shut down'' a connection established with [open_connection]; + 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 + (* 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 + is created for each connection. The function [establish_server] + never returns normally. *) + + +(*** Host and protocol databases *) + +type host_entry = Unix.host_entry = + { h_name : string; + h_aliases : string array; + h_addrtype : socket_domain; + h_addr_list : inet_addr array } + (* Structure of entries in the [hosts] database. *) + +type protocol_entry = Unix.protocol_entry = + { p_name : string; + p_aliases : string array; + p_proto : int } + (* Structure of entries in the [protocols] database. *) + +type service_entry = Unix.service_entry = + { s_name : string; + s_aliases : string array; + s_port : int; + s_proto : string } + (* Structure of entries in the [services] database. *) + +val gethostname : unit -> string + (* Return the name of the local host. *) +val gethostbyname : string -> host_entry + (* Find an entry in [hosts] with the given name, or raise + [Not_found]. *) +val gethostbyaddr : inet_addr -> host_entry + (* Find an entry in [hosts] with the given address, or raise + [Not_found]. *) +val getprotobyname : string -> protocol_entry + (* Find an entry in [protocols] with the given name, or raise + [Not_found]. *) +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 + (* Find an entry in [services] with the given name, or raise + [Not_found]. *) +val getservbyport : int -> protocol:string -> service_entry + (* Find an entry in [services] with the given service number, + or raise [Not_found]. *) + + +(*** Terminal interface *) + +(* The following functions implement the POSIX standard terminal + interface. They provide control over asynchronous communication ports + and pseudo-terminals. Refer to the [termios] man page for a + complete description. *) + +type terminal_io = Unix.terminal_io = { + (* Input modes: *) + mutable c_ignbrk: bool; (* Ignore the break condition. *) + mutable c_brkint: bool; (* Signal interrupt on break condition. *) + mutable c_ignpar: bool; (* Ignore characters with parity errors. *) + mutable c_parmrk: bool; (* Mark parity errors. *) + mutable c_inpck: bool; (* Enable parity check on input. *) + mutable c_istrip: bool; (* Strip 8th bit on input characters. *) + mutable c_inlcr: bool; (* Map NL to CR on input. *) + mutable c_igncr: bool; (* Ignore CR on input. *) + mutable c_icrnl: bool; (* Map CR to NL on input. *) + mutable c_ixon: bool; (* Recognize XON/XOFF characters on input. *) + mutable c_ixoff: bool; (* Emit XON/XOFF chars to control input flow. *) + (* Output modes: *) + mutable c_opost: bool; (* Enable output processing. *) + (* Control modes: *) + mutable c_obaud: int; (* Output baud rate (0 means close connection).*) + mutable c_ibaud: int; (* Input baud rate. *) + mutable c_csize: int; (* Number of bits per character (5-8). *) + mutable c_cstopb: int; (* Number of stop bits (1-2). *) + mutable c_cread: bool; (* Reception is enabled. *) + mutable c_parenb: bool; (* Enable parity generation and detection. *) + mutable c_parodd: bool; (* Specify odd parity instead of even. *) + mutable c_hupcl: bool; (* Hang up on last close. *) + mutable c_clocal: bool; (* Ignore modem status lines. *) + (* Local modes: *) + mutable c_isig: bool; (* Generate signal on INTR, QUIT, SUSP. *) + mutable c_icanon: bool; (* Enable canonical processing + (line buffering and editing) *) + mutable c_noflsh: bool; (* Disable flush after INTR, QUIT, SUSP. *) + mutable c_echo: bool; (* Echo input characters. *) + mutable c_echoe: bool; (* Echo ERASE (to erase previous character). *) + mutable c_echok: bool; (* Echo KILL (to erase the current line). *) + mutable c_echonl: bool; (* Echo NL even if c_echo is not set. *) + (* Control characters: *) + mutable c_vintr: char; (* Interrupt character (usually ctrl-C). *) + mutable c_vquit: char; (* Quit character (usually ctrl-\). *) + mutable c_verase: char; (* Erase character (usually DEL or ctrl-H). *) + mutable c_vkill: char; (* Kill line character (usually ctrl-U). *) + mutable c_veof: char; (* End-of-file character (usually ctrl-D). *) + mutable c_veol: char; (* Alternate end-of-line char. (usually none). *) + mutable c_vmin: int; (* Minimum number of characters to read + before the read request is satisfied. *) + mutable c_vtime: int; (* Maximum read wait (in 0.1s units). *) + mutable c_vstart: char; (* Start character (usually ctrl-Q). *) + mutable c_vstop: char (* Stop character (usually ctrl-S). *) + } + +val tcgetattr: file_descr -> terminal_io + (* Return the status of the terminal referred to by the given + file descriptor. *) + +type setattr_when = Unix.setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH + +val tcsetattr: file_descr -> mode: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]), + when all pending output has been transmitted ([TCSADRAIN]), + or after flushing all input that has been received but not + read ([TCSAFLUSH]). [TCSADRAIN] is recommended when changing + the output parameters; [TCSAFLUSH], when changing the input + parameters. *) + +val tcsendbreak: file_descr -> duration: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). *) + +val tcdrain: file_descr -> unit + (* Waits until all output written on the given file descriptor + has been transmitted. *) + +type flush_queue = Unix.flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH + +val tcflush: file_descr -> mode: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, + [TCOFLUSH] flushes data written but not transmitted, and + [TCIOFLUSH] flushes both. *) + +type flow_action = Unix.flow_action = TCOOFF | TCOON | TCIOFF | TCION + +val tcflow: file_descr -> mode: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, + [TCIOFF] transmits a STOP character to suspend input, + and [TCION] transmits a START character to restart input. *) + +val setsid : unit -> int + (* Put the calling process in a new session and detach it from + its controlling terminal. *) diff --git a/stdlib/.cvsignore b/stdlib/.cvsignore index d583cf4eee..6921a35c04 100644 --- a/stdlib/.cvsignore +++ b/stdlib/.cvsignore @@ -1,2 +1,3 @@ camlheader camlheader_ur +labelled-*
\ No newline at end of file diff --git a/stdlib/.depend b/stdlib/.depend index 6c18ecadbe..17cc045983 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -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 diff --git a/stdlib/Makefile b/stdlib/Makefile index 6c4cdd084d..9a9d58823e 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -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 diff --git a/stdlib/arg.mli b/stdlib/arg.mli index e6687b5960..7e693704ad 100644 --- a/stdlib/arg.mli +++ b/stdlib/arg.mli @@ -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 diff --git a/stdlib/array.mli b/stdlib/array.mli index fce9dd300d..dcff7ea8ff 100644 --- a/stdlib/array.mli +++ b/stdlib/array.mli @@ -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] diff --git a/stdlib/arrayLabels.ml b/stdlib/arrayLabels.ml new file mode 100644 index 0000000000..b5fd5e8106 --- /dev/null +++ b/stdlib/arrayLabels.ml @@ -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 diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli new file mode 100644 index 0000000000..256477fa64 --- /dev/null +++ b/stdlib/arrayLabels.mli @@ -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" diff --git a/stdlib/buffer.mli b/stdlib/buffer.mli index adb7e3038d..5b84995025 100644 --- a/stdlib/buffer.mli +++ b/stdlib/buffer.mli @@ -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] diff --git a/stdlib/digest.mli b/stdlib/digest.mli index dcba690f92..83d48b1e9c 100644 --- a/stdlib/digest.mli +++ b/stdlib/digest.mli @@ -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 diff --git a/stdlib/filename.mli b/stdlib/filename.mli index 2d3bf6513b..1077bf08b1 100644 --- a/stdlib/filename.mli +++ b/stdlib/filename.mli @@ -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 diff --git a/stdlib/format.ml b/stdlib/format.ml index ff26946cd2..cbbb1a16a0 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -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);; diff --git a/stdlib/format.mli b/stdlib/format.mli index 1ad568caaf..72f2db3901 100644 --- a/stdlib/format.mli +++ b/stdlib/format.mli @@ -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 diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml index 4fd386fe6d..4a26087c56 100644 --- a/stdlib/hashtbl.ml +++ b/stdlib/hashtbl.ml @@ -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) = diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli index c2cdd25a9a..d56bbd3523 100644 --- a/stdlib/hashtbl.mli +++ b/stdlib/hashtbl.mli @@ -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) diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli index d4dfb283a2..1ee28e6a5f 100644 --- a/stdlib/lexing.mli +++ b/stdlib/lexing.mli @@ -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 diff --git a/stdlib/list.mli b/stdlib/list.mli index cacec6ef24..c94f92b4ca 100644 --- a/stdlib/list.mli +++ b/stdlib/list.mli @@ -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 diff --git a/stdlib/listLabels.ml b/stdlib/listLabels.ml new file mode 100644 index 0000000000..1c33254d7b --- /dev/null +++ b/stdlib/listLabels.ml @@ -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 diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli new file mode 100644 index 0000000000..3c2f9d761e --- /dev/null +++ b/stdlib/listLabels.mli @@ -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. + *) diff --git a/stdlib/map.mli b/stdlib/map.mli index a3b4b9af91..4c638a7385 100644 --- a/stdlib/map.mli +++ b/stdlib/map.mli @@ -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. diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli index 8a436fd45f..b3bfcba800 100644 --- a/stdlib/marshal.mli +++ b/stdlib/marshal.mli @@ -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. diff --git a/stdlib/obj.mli b/stdlib/obj.mli index 0a3be860ab..c854da66e4 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -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 diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index cf513e9c35..a749529b9b 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -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] diff --git a/stdlib/queue.mli b/stdlib/queue.mli index 1f10951a1d..3eb6af717f 100644 --- a/stdlib/queue.mli +++ b/stdlib/queue.mli @@ -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. *) diff --git a/stdlib/set.mli b/stdlib/set.mli index a47a33ff8e..8756094dc2 100644 --- a/stdlib/set.mli +++ b/stdlib/set.mli @@ -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 diff --git a/stdlib/sort.mli b/stdlib/sort.mli index 684fb41d05..ce137b8bb0 100644 --- a/stdlib/sort.mli +++ b/stdlib/sort.mli @@ -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 diff --git a/stdlib/stack.mli b/stdlib/stack.mli index e46288a634..ccb40797d5 100644 --- a/stdlib/stack.mli +++ b/stdlib/stack.mli @@ -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. *) diff --git a/stdlib/stdLabels.ml b/stdlib/stdLabels.ml new file mode 100644 index 0000000000..b79792e9d8 --- /dev/null +++ b/stdlib/stdLabels.ml @@ -0,0 +1,21 @@ +(***********************************************************************) +(* *) +(* 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 [StdLabels]: meta-module for labelled libraries *) + +module Array = ArrayLabels + +module List = ListLabels + +module String = StringLabels diff --git a/stdlib/stdLabels.mli b/stdlib/stdLabels.mli new file mode 100644 index 0000000000..47c53301fe --- /dev/null +++ b/stdlib/stdLabels.mli @@ -0,0 +1,124 @@ +(***********************************************************************) +(* *) +(* 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 [StdLabels]: meta-module for labelled libraries *) +(* See the real interfaces in ArrayLabels, ListLabels and StringLabels *) + +module Array : sig + external length : 'a array -> int = "%array_length" + external get : 'a array -> int -> 'a = "%array_safe_get" + external set : 'a array -> int -> 'a -> unit = "%array_safe_set" + external make : int -> 'a -> 'a array = "make_vect" + external create : int -> 'a -> 'a array = "make_vect" + val init : int -> f:(int -> 'a) -> 'a array + val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array + val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array + val append : 'a array -> 'a array -> 'a array + val concat : 'a array list -> 'a array + val sub : 'a array -> pos:int -> len:int -> 'a array + val copy : 'a array -> 'a array + val fill : 'a array -> pos:int -> len:int -> 'a -> unit + val blit : + src:'a array -> src_pos:int -> + dst:'a array -> dst_pos:int -> len:int -> unit + val to_list : 'a array -> 'a list + val of_list : 'a list -> 'a array + val iter : f:('a -> unit) -> 'a array -> unit + val map : f:('a -> 'b) -> 'a array -> 'b array + val iteri : f:(int -> 'a -> unit) -> 'a array -> unit + val mapi : f:(int -> 'a -> 'b) -> 'a array -> 'b array + val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a + val fold_right : f:('a -> 'b -> 'b) -> 'a array -> init:'b -> 'b + val sort : cmp:('a -> 'a -> int) -> 'a array -> unit + val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit + external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" + external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" +end + +module List : sig + val length : 'a list -> int + val hd : 'a list -> 'a + val tl : 'a list -> 'a list + val nth : 'a list -> int -> 'a + val rev : 'a list -> 'a list + val append : 'a list -> 'a list -> 'a list + val rev_append : 'a list -> 'a list -> 'a list + val concat : 'a list list -> 'a list + val flatten : 'a list list -> 'a list + val iter : f:('a -> unit) -> 'a list -> unit + val map : f:('a -> 'b) -> 'a list -> 'b list + val rev_map : f:('a -> 'b) -> 'a list -> 'b list + val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a + val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b + val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit + val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val fold_left2 : + f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a + val fold_right2 : + f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c + val for_all : f:('a -> bool) -> 'a list -> bool + val exists : f:('a -> bool) -> 'a list -> bool + val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val mem : 'a -> set:'a list -> bool + val memq : 'a -> set:'a list -> bool + val find : f:('a -> bool) -> 'a list -> 'a + val filter : f:('a -> bool) -> 'a list -> 'a list + val find_all : f:('a -> bool) -> 'a list -> 'a list + val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list + val assoc : 'a -> map:('a * 'b) list -> 'b + val assq : 'a -> map:('a * 'b) list -> 'b + val mem_assoc : 'a -> map:('a * 'b) list -> bool + val mem_assq : 'a -> map:('a * 'b) list -> bool + val remove_assoc : 'a -> map:('a * 'b) list -> ('a * 'b) list + val remove_assq : 'a -> map:('a * 'b) list -> ('a * 'b) list + val split : ('a * 'b) list -> 'a list * 'b list + val combine : 'a list -> 'b list -> ('a * 'b) list + val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list + val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list +end + +module String : sig + external length : string -> int = "%string_length" + external get : string -> int -> char = "%string_safe_get" + external set : string -> int -> char -> unit = "%string_safe_set" + external create : int -> string = "create_string" + val make : int -> char -> string + val copy : string -> string + val sub : string -> pos:int -> len:int -> string + val fill : string -> pos:int -> len:int -> char -> unit + val blit : + src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> unit + val concat : sep:string -> string list -> string + val escaped : string -> string + val index : string -> char -> int + val rindex : string -> char -> int + val index_from : string -> int -> char -> int + val rindex_from : string -> int -> char -> int + val contains : string -> char -> bool + val contains_from : string -> int -> char -> bool + val rcontains_from : string -> int -> char -> bool + val uppercase : string -> string + val lowercase : string -> string + val capitalize : string -> string + val uncapitalize : string -> string + external unsafe_get : string -> int -> char = "%string_unsafe_get" + external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" + external unsafe_blit : + src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> unit + = "blit_string" "noalloc" + external unsafe_fill : string -> pos:int -> len:int -> char -> unit + = "fill_string" "noalloc" +end diff --git a/stdlib/stream.mli b/stdlib/stream.mli index d12f232556..20495ecbfc 100644 --- a/stdlib/stream.mli +++ b/stdlib/stream.mli @@ -45,7 +45,7 @@ val of_channel : in_channel -> char t;; (** Stream iterator *) -val iter : f:('a -> unit) -> 'a t -> unit;; +val iter : ('a -> unit) -> 'a t -> unit;; (* [Stream.iter f s] scans the whole stream s, applying function [f] in turn to each stream element encountered. *) diff --git a/stdlib/string.ml b/stdlib/string.ml index 21543abfbd..bf5e14c055 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -17,7 +17,7 @@ external length : string -> int = "%string_length" external get : string -> int -> char = "%string_safe_get" external set : string -> int -> char -> unit = "%string_safe_set" -external create: int -> string = "create_string" +external create : int -> string = "create_string" external unsafe_get : string -> int -> char = "%string_unsafe_get" external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" external unsafe_blit : string -> int -> string -> int -> int -> unit @@ -56,6 +56,9 @@ let blit s1 ofs1 s2 ofs2 len = then invalid_arg "String.blit" else unsafe_blit s1 ofs1 s2 ofs2 len +let iter f a = + for i = 0 to length a - 1 do f(unsafe_get a i) done + let concat sep l = match l with [] -> "" diff --git a/stdlib/string.mli b/stdlib/string.mli index 22025fc157..afddc66a06 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -43,21 +43,20 @@ val make : int -> char -> string *) val copy : string -> string (* Return a copy of the given string. *) -val sub : string -> pos:int -> len:int -> string +val sub : string -> int -> int -> string (* [String.sub s start len] returns a fresh string of length [len], containing the characters number [start] to [start + len - 1] of string [s]. Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]; that is, if [start < 0], or [len < 0], or [start + len > String.length s]. *) -val fill : string -> pos:int -> len:int -> char -> unit +val fill : string -> int -> int -> char -> unit (* [String.fill s start len c] modifies string [s] in place, replacing the characters number [start] to [start + len - 1] by [c]. Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]. *) -val blit : src:string -> src_pos:int -> - dst:string -> dst_pos:int -> len:int -> unit +val blit : string -> int -> string -> int -> int -> unit (* [String.blit src srcoff dst dstoff len] copies [len] characters from string [src], starting at character number [srcoff], to string [dst], starting at character number [dstoff]. It works @@ -67,10 +66,15 @@ val blit : src:string -> src_pos:int -> designate a valid substring of [src], or if [dstoff] and [len] do not designate a valid substring of [dst]. *) -val concat : sep:string -> string list -> string +val concat : string -> string list -> string (* [String.concat sep sl] catenates the list of strings [sl], inserting the separator string [sep] between each. *) +val iter : (char -> unit) -> string -> unit + (* [String.iter f s] applies function [f] in turn to all + the characters of [s]. It is equivalent to + [f s.(0); f s.(1); ...; f s.(String.length s - 1); ()]. *) + val escaped: string -> string (* Return a copy of the argument, with special characters represented by escape sequences, following the lexical @@ -127,9 +131,7 @@ val uncapitalize: string -> string external unsafe_get : string -> int -> char = "%string_unsafe_get" external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" -external unsafe_blit : - src:string -> src_pos:int -> - dst:string -> dst_pos:int -> len:int -> unit +external unsafe_blit : string -> int -> string -> int -> int -> unit = "blit_string" "noalloc" -external unsafe_fill : string -> pos:int -> len:int -> char -> unit +external unsafe_fill : string -> int -> int -> char -> unit = "fill_string" "noalloc" diff --git a/stdlib/stringLabels.ml b/stdlib/stringLabels.ml new file mode 100644 index 0000000000..008eda92fa --- /dev/null +++ b/stdlib/stringLabels.ml @@ -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 [SringLabels]: labelled String module *) + +include String diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli new file mode 100644 index 0000000000..15555e836b --- /dev/null +++ b/stdlib/stringLabels.mli @@ -0,0 +1,138 @@ +(***********************************************************************) +(* *) +(* 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 [String]: string operations *) + +external length : string -> int = "%string_length" + (* Return the length (number of characters) of the given string. *) + +external get : string -> int -> char = "%string_safe_get" + (* [String.get s n] returns character number [n] in string [s]. + The first character is character number 0. + The last character is character number [String.length s - 1]. + Raise [Invalid_argument] if [n] is outside the range + 0 to [(String.length s - 1)]. + You can also write [s.[n]] instead of [String.get s n]. *) +external set : string -> int -> char -> unit = "%string_safe_set" + (* [String.set s n c] modifies string [s] in place, + replacing the character number [n] by [c]. + Raise [Invalid_argument] if [n] is outside the range + 0 to [(String.length s - 1)]. + You can also write [s.[n] <- c] instead of [String.set s n c]. *) + +external create : int -> string = "create_string" + (* [String.create n] returns a fresh string of length [n]. + The string initially contains arbitrary characters. + Raise [Invalid_argument] if [n <= 0] or [n > Sys.max_string_length]. + *) +val make : int -> char -> string + (* [String.make n c] returns a fresh string of length [n], + filled with the character [c]. + Raise [Invalid_argument] if [n <= 0] or [n > Sys.max_string_length]. + *) +val copy : string -> string + (* Return a copy of the given string. *) +val sub : string -> pos:int -> len:int -> string + (* [String.sub s start len] returns a fresh string of length [len], + containing the characters number [start] to [start + len - 1] + of string [s]. + Raise [Invalid_argument] if [start] and [len] do not + designate a valid substring of [s]; that is, if [start < 0], + or [len < 0], or [start + len > String.length s]. *) +val fill : string -> pos:int -> len:int -> char -> unit + (* [String.fill s start len c] modifies string [s] in place, + replacing the characters number [start] to [start + len - 1] + by [c]. + Raise [Invalid_argument] if [start] and [len] do not + designate a valid substring of [s]. *) +val blit : src:string -> src_pos:int -> + dst:string -> dst_pos:int -> len:int -> unit + (* [String.blit src srcoff dst dstoff len] copies [len] characters + from string [src], starting at character number [srcoff], to + string [dst], starting at character number [dstoff]. It works + correctly even if [src] and [dst] are the same string, + and the source and destination chunks overlap. + Raise [Invalid_argument] if [srcoff] and [len] do not + designate a valid substring of [src], or if [dstoff] and [len] + do not designate a valid substring of [dst]. *) + +val concat : sep:string -> string list -> string + (* [String.concat sep sl] catenates the list of strings [sl], + inserting the separator string [sep] between each. *) + +val iter : f:(char -> unit) -> string -> unit + (* [String.iter f s] applies function [f] in turn to all + the characters of [s]. It is equivalent to + [f s.(0); f s.(1); ...; f s.(String.length s - 1); ()]. *) + +val escaped: string -> string + (* Return a copy of the argument, with special characters represented + by escape sequences, following the lexical conventions of + Objective Caml. *) + +val index: string -> char -> int + (* [String.index s c] returns the position of the leftmost + occurrence of character [c] in string [s]. + Raise [Not_found] if [c] does not occur in [s]. *) +val rindex: string -> char -> int + (* [String.rindex s c] returns the position of the rightmost + occurrence of character [c] in string [s]. + Raise [Not_found] if [c] does not occur in [s]. *) +val index_from: string -> int -> char -> int +val rindex_from: string -> int -> char -> int + (* Same as [String.index] and [String.rindex], but start + searching at the character position given as second argument. + [String.index s c] is equivalent to [String.index_from s 0 c], + and [String.rindex s c] to + [String.rindex_from s (String.length s - 1) c]. *) + +val contains : string -> char -> bool + (* [String.contains s c] tests if character [c] + appears in the string [s]. *) +val contains_from : string -> int -> char -> bool + (* [String.contains_from s start c] tests if character [c] + appears in the substring of [s] starting from [start] to the end + of [s]. + Raise [Invalid_argument] if [start] is not a valid index of [s]. *) +val rcontains_from : string -> int -> char -> bool + (* [String.rcontains_from s stop c] tests if character [c] + appears in the substring of [s] starting from the beginning + of [s] to index [stop]. + Raise [Invalid_argument] if [stop] is not a valid index of [s]. *) + +val uppercase: string -> string + (* Return a copy of the argument, with all lowercase letters + translated to uppercase, including accented letters of the ISO + Latin-1 (8859-1) character set. *) +val lowercase: string -> string + (* Return a copy of the argument, with all uppercase letters + translated to lowercase, including accented letters of the ISO + Latin-1 (8859-1) character set. *) +val capitalize: string -> string + (* Return a copy of the argument, with the first letter + set to uppercase. *) +val uncapitalize: string -> string + (* Return a copy of the argument, with the first letter + set to lowercase. *) + +(*--*) + +external unsafe_get : string -> int -> char = "%string_unsafe_get" +external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" +external unsafe_blit : + src:string -> src_pos:int -> + dst:string -> dst_pos:int -> len:int -> unit + = "blit_string" "noalloc" +external unsafe_fill : string -> pos:int -> len:int -> char -> unit + = "fill_string" "noalloc" diff --git a/stdlib/sys.mli b/stdlib/sys.mli index cb493f77fc..4768d571e4 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -23,7 +23,7 @@ external file_exists: string -> bool = "sys_file_exists" (* Test if a file with the given name exists. *) external remove: string -> unit = "sys_remove" (* Remove the given file name from the file system. *) -external rename : src:string -> dst:string -> unit = "sys_rename" +external rename: string -> string -> unit = "sys_rename" (* Rename a file. The first argument is the old name and the second is the new name. *) external getenv: string -> string = "sys_getenv" diff --git a/stdlib/weak.mli b/stdlib/weak.mli index b326dba383..1327086d30 100644 --- a/stdlib/weak.mli +++ b/stdlib/weak.mli @@ -62,13 +62,12 @@ val check: 'a t -> int -> bool;; full, [false] if it is empty. Note that even if [Weak.check ar n] returns [true], a subsequent [Weak.get ar n] can return [None]. *) -val fill: 'a t -> pos:int -> len:int -> 'a option -> unit;; +val fill: 'a t -> int -> int -> 'a option -> unit;; (* [Weak.fill ar ofs len el] sets to [el] all pointers of [ar] from [ofs] to [ofs + len - 1]. Raise [Invalid_argument "Weak.fill"] if [ofs] and [len] do not designate a valid subarray of [a]. *) -val blit : src:'a t -> src_pos:int -> - dst:'a t -> dst_pos:int -> len:int -> unit;; +val blit : 'a t -> int -> 'a t -> int -> int -> unit;; (* [Weak.blit ar1 off1 ar2 off2 len] copies [len] weak pointers from [ar1] (starting at [off1]) to [ar2] (starting at [off2]). It works correctly even if [ar1] and [ar2] are the same. diff --git a/tools/.cvsignore b/tools/.cvsignore index 22d4dcef7a..fe7e2268d7 100644 --- a/tools/.cvsignore +++ b/tools/.cvsignore @@ -14,4 +14,6 @@ keywords lexer299.ml ocaml299to3 ocamlmklib +lexer301.ml +scrapelabels diff --git a/tools/Makefile b/tools/Makefile index 6ac4ca5a73..34f2d15017 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -89,7 +89,7 @@ install:: clean:: rm -f ocamlmklib -# Converter ocaml 2.04 to 3 +# Converter olabl/ocaml 2.99 to ocaml 3 OCAML299TO3= lexer299.cmo ocaml299to3.cmo LIBRARY3= misc.cmo warnings.cmo linenum.cmo location.cmo @@ -100,6 +100,16 @@ ocaml299to3: $(OCAML299TO3) lexer299.ml: lexer299.mll $(CAMLLEX) lexer299.mll +# Label remover for interface files (upgrade 3.02 to 3.03) + +SCRAPELABELS= lexer301.cmo scrapelabels.cmo + +scrapelabels: $(SCRAPELABELS) + $(CAMLC) $(LINKFLAGS) -o scrapelabels $(LIBRARY3) $(SCRAPELABELS) + +lexer301.ml: lexer301.mll + $(CAMLLEX) lexer301.mll + #install:: # cp ocaml299to3 $(BINDIR)/ocaml299to3$(EXE) diff --git a/tools/lexer301.mll b/tools/lexer301.mll new file mode 100644 index 0000000000..991bd24020 --- /dev/null +++ b/tools/lexer301.mll @@ -0,0 +1,478 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The lexer definition *) + +{ +open Misc + +type token = + AMPERAMPER + | AMPERSAND + | AND + | AS + | ASSERT + | BACKQUOTE + | BAR + | BARBAR + | BARRBRACKET + | BEGIN + | CHAR of (char) + | CLASS + | COLON + | COLONCOLON + | COLONEQUAL + | COLONGREATER + | COMMA + | CONSTRAINT + | DO + | DONE + | DOT + | DOTDOT + | DOWNTO + | ELSE + | END + | EOF + | EQUAL + | EXCEPTION + | EXTERNAL + | FALSE + | FLOAT of (string) + | FOR + | FUN + | FUNCTION + | FUNCTOR + | GREATER + | GREATERRBRACE + | GREATERRBRACKET + | IF + | IN + | INCLUDE + | INFIXOP0 of (string) + | INFIXOP1 of (string) + | INFIXOP2 of (string) + | INFIXOP3 of (string) + | INFIXOP4 of (string) + | INHERIT + | INITIALIZER + | INT of (int) + | LABEL of (string) + | LAZY + | LBRACE + | LBRACELESS + | LBRACKET + | LBRACKETBAR + | LBRACKETLESS + | LESS + | LESSMINUS + | LET + | LIDENT of (string) + | LPAREN + | MATCH + | METHOD + | MINUS + | MINUSDOT + | MINUSGREATER + | MODULE + | MUTABLE + | NEW + | OBJECT + | OF + | OPEN + | OPTLABEL of (string) + | OR + | PARSER + | PLUS + | PREFIXOP of (string) + | PRIVATE + | QUESTION + | QUESTION2 + | QUOTE + | RBRACE + | RBRACKET + | REC + | RPAREN + | SEMI + | SEMISEMI + | SHARP + | SIG + | STAR + | STRING of (string) + | STRUCT + | THEN + | TILDE + | TO + | TRUE + | TRY + | TYPE + | UIDENT of (string) + | UNDERSCORE + | VAL + | VIRTUAL + | WHEN + | WHILE + | WITH + +type error = + | Illegal_character of char + | Unterminated_comment + | Unterminated_string + | Unterminated_string_in_comment + | Keyword_as_label of string +;; + +exception Error of error * int * int + +(* The table of keywords *) + +let keyword_table = + create_hashtable 149 [ + "and", AND; + "as", AS; + "assert", ASSERT; + "begin", BEGIN; + "class", CLASS; + "constraint", CONSTRAINT; + "do", DO; + "done", DONE; + "downto", DOWNTO; + "else", ELSE; + "end", END; + "exception", EXCEPTION; + "external", EXTERNAL; + "false", FALSE; + "for", FOR; + "fun", FUN; + "function", FUNCTION; + "functor", FUNCTOR; + "if", IF; + "in", IN; + "include", INCLUDE; + "inherit", INHERIT; + "initializer", INITIALIZER; + "lazy", LAZY; + "let", LET; + "match", MATCH; + "method", METHOD; + "module", MODULE; + "mutable", MUTABLE; + "new", NEW; + "object", OBJECT; + "of", OF; + "open", OPEN; + "or", OR; + "parser", PARSER; + "private", PRIVATE; + "rec", REC; + "sig", SIG; + "struct", STRUCT; + "then", THEN; + "to", TO; + "true", TRUE; + "try", TRY; + "type", TYPE; + "val", VAL; + "virtual", VIRTUAL; + "when", WHEN; + "while", WHILE; + "with", WITH; + + "mod", INFIXOP3("mod"); + "land", INFIXOP3("land"); + "lor", INFIXOP3("lor"); + "lxor", INFIXOP3("lxor"); + "lsl", INFIXOP4("lsl"); + "lsr", INFIXOP4("lsr"); + "asr", INFIXOP4("asr") +] + +(* To buffer string literals *) + +let initial_string_buffer = String.create 256 +let string_buff = ref initial_string_buffer +let string_index = ref 0 + +let reset_string_buffer () = + string_buff := initial_string_buffer; + string_index := 0 + +let store_string_char c = + if !string_index >= String.length (!string_buff) then begin + let new_buff = String.create (String.length (!string_buff) * 2) in + String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff)); + string_buff := new_buff + end; + String.unsafe_set (!string_buff) (!string_index) c; + incr string_index + +let get_stored_string () = + let s = String.sub (!string_buff) 0 (!string_index) in + string_buff := initial_string_buffer; + s + +(* To translate escape sequences *) + +let char_for_backslash = + match Sys.os_type with + | "Unix" | "Win32" | "Cygwin" -> + begin function + | 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + end + | "MacOS" -> + begin function + | 'n' -> '\013' + | 'r' -> '\010' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + end + | x -> fatal_error "Lexer: unknown system type" + +let char_for_decimal_code lexbuf i = + let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in + Char.chr(c land 0xFF) + +(* To store the position of the beginning of a string and comment *) +let string_start_pos = ref 0;; +let comment_start_pos = ref [];; +let in_comment () = !comment_start_pos <> [];; + +(* Error report *) + +open Format + +let report_error ppf = function + | Illegal_character c -> + fprintf ppf "Illegal character (%s)" (Char.escaped c) + | Unterminated_comment -> + fprintf ppf "Comment not terminated" + | Unterminated_string -> + fprintf ppf "String literal not terminated" + | Unterminated_string_in_comment -> + fprintf ppf "This comment contains an unterminated string literal" + | Keyword_as_label kwd -> + fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd +;; + +} + +let blank = [' ' '\010' '\013' '\009' '\012'] +let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] +let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] +let identchar = + ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] +let symbolchar = + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] +let decimal_literal = ['0'-'9']+ +let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ +let oct_literal = '0' ['o' 'O'] ['0'-'7']+ +let bin_literal = '0' ['b' 'B'] ['0'-'1']+ +let float_literal = + ['0'-'9']+ ('.' ['0'-'9']* )? (['e' 'E'] ['+' '-']? ['0'-'9']+)? + +rule token = parse + blank + + { token lexbuf } + | "_" + { UNDERSCORE } + | "~" { TILDE } + | "~" lowercase identchar * ':' + { let s = Lexing.lexeme lexbuf in + let name = String.sub s 1 (String.length s - 2) in + if Hashtbl.mem keyword_table name then + raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf, + Lexing.lexeme_end lexbuf)); + LABEL name } + | "?" { QUESTION } + | "?" lowercase identchar * ':' + { let s = Lexing.lexeme lexbuf in + let name = String.sub s 1 (String.length s - 2) in + if Hashtbl.mem keyword_table name then + raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf, + Lexing.lexeme_end lexbuf)); + OPTLABEL name } + | lowercase identchar * + { let s = Lexing.lexeme lexbuf in + try + Hashtbl.find keyword_table s + with Not_found -> + LIDENT s } + | uppercase identchar * + { UIDENT(Lexing.lexeme lexbuf) } (* No capitalized keywords *) + | decimal_literal | hex_literal | oct_literal | bin_literal + { INT (int_of_string(Lexing.lexeme lexbuf)) } + | float_literal + { FLOAT (Lexing.lexeme lexbuf) } + | "\"" + { reset_string_buffer(); + let string_start = Lexing.lexeme_start lexbuf in + string_start_pos := string_start; + string lexbuf; + lexbuf.Lexing.lex_start_pos <- + string_start - lexbuf.Lexing.lex_abs_pos; + STRING (get_stored_string()) } + | "'" [^ '\\' '\''] "'" + { CHAR(Lexing.lexeme_char lexbuf 1) } + | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" + { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) } + | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + { CHAR(char_for_decimal_code lexbuf 2) } + | "(*" + { comment_start_pos := [Lexing.lexeme_start lexbuf]; + comment lexbuf; + token lexbuf } + | "(*)" + { let loc = { Location.loc_start = Lexing.lexeme_start lexbuf; + Location.loc_end = Lexing.lexeme_end lexbuf - 1; + Location.loc_ghost = false } + and warn = Warnings.Comment "the start of a comment" + in + Location.prerr_warning loc warn; + comment_start_pos := [Lexing.lexeme_start lexbuf]; + comment lexbuf; + token lexbuf + } + | "*)" + { let loc = { Location.loc_start = Lexing.lexeme_start lexbuf; + Location.loc_end = Lexing.lexeme_end lexbuf; + Location.loc_ghost = false } + and warn = Warnings.Comment "not the end of a comment" + in + Location.prerr_warning loc warn; + lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; + STAR + } + | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n") + (* # linenum ... *) + { token lexbuf } + | "#" { SHARP } + | "&" { AMPERSAND } + | "&&" { AMPERAMPER } + | "`" { BACKQUOTE } + | "'" { QUOTE } + | "(" { LPAREN } + | ")" { RPAREN } + | "*" { STAR } + | "," { COMMA } + | "??" { QUESTION2 } + | "->" { MINUSGREATER } + | "." { DOT } + | ".." { DOTDOT } + | ":" { COLON } + | "::" { COLONCOLON } + | ":=" { COLONEQUAL } + | ":>" { COLONGREATER } + | ";" { SEMI } + | ";;" { SEMISEMI } + | "<" { LESS } + | "<-" { LESSMINUS } + | "=" { EQUAL } + | "[" { LBRACKET } + | "[|" { LBRACKETBAR } + | "[<" { LBRACKETLESS } + | "]" { RBRACKET } + | "{" { LBRACE } + | "{<" { LBRACELESS } + | "|" { BAR } + | "||" { BARBAR } + | "|]" { BARRBRACKET } + | ">" { GREATER } + | ">]" { GREATERRBRACKET } + | "}" { RBRACE } + | ">}" { GREATERRBRACE } + + | "!=" { INFIXOP0 "!=" } + | "+" { PLUS } + | "-" { MINUS } + | "-." { MINUSDOT } + + | "!" symbolchar * + { PREFIXOP(Lexing.lexeme lexbuf) } + | ['~' '?'] symbolchar + + { PREFIXOP(Lexing.lexeme lexbuf) } + | ['=' '<' '>' '|' '&' '$'] symbolchar * + { INFIXOP0(Lexing.lexeme lexbuf) } + | ['@' '^'] symbolchar * + { INFIXOP1(Lexing.lexeme lexbuf) } + | ['+' '-'] symbolchar * + { INFIXOP2(Lexing.lexeme lexbuf) } + | "**" symbolchar * + { INFIXOP4(Lexing.lexeme lexbuf) } + | ['*' '/' '%'] symbolchar * + { INFIXOP3(Lexing.lexeme lexbuf) } + | eof { EOF } + | _ + { raise (Error(Illegal_character ((Lexing.lexeme lexbuf).[0]), + Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) } + +and comment = parse + "(*" + { comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos; + comment lexbuf; + } + | "*)" + { match !comment_start_pos with + | [] -> assert false + | [x] -> comment_start_pos := []; + | _ :: l -> comment_start_pos := l; + comment lexbuf; + } + | "\"" + { reset_string_buffer(); + string_start_pos := Lexing.lexeme_start lexbuf; + begin try string lexbuf + with Error (Unterminated_string, _, _) -> + let st = List.hd !comment_start_pos in + raise (Error (Unterminated_string_in_comment, st, st + 2)) + end; + string_buff := initial_string_buffer; + comment lexbuf } + | "''" + { comment lexbuf } + | "'" [^ '\\' '\''] "'" + { comment lexbuf } + | "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'" + { comment lexbuf } + | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + { comment lexbuf } + | eof + { let st = List.hd !comment_start_pos in + raise (Error (Unterminated_comment, st, st + 2)); + } + | _ + { comment lexbuf } + +and string = parse + '"' + { () } + | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] * + { string lexbuf } + | '\\' ['\\' '"' 'n' 't' 'b' 'r'] + { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); + string lexbuf } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] + { store_string_char(char_for_decimal_code lexbuf 1); + string lexbuf } + | eof + { raise (Error (Unterminated_string, + !string_start_pos, !string_start_pos+1)) } + | _ + { store_string_char(Lexing.lexeme_char lexbuf 0); + string lexbuf } diff --git a/tools/ocaml299to3.ml b/tools/ocaml299to3.ml index b4d1e9b0ca..45273e440c 100644 --- a/tools/ocaml299to3.ml +++ b/tools/ocaml299to3.ml @@ -15,9 +15,9 @@ open Lexer299 let input_buffer = Buffer.create 16383 -let input_function ic ~buf ~len = - let len = input ic ~buf ~pos:0 ~len in - Buffer.add_substring input_buffer buf ~pos:0 ~len; +let input_function ic buf len = + let len = input ic buf 0 len in + Buffer.add_substring input_buffer buf 0 len; len let output_buffer = Buffer.create 16383 @@ -28,7 +28,7 @@ let convert buffer = let input_pos = ref 0 in let copy_input stop = Buffer.add_substring output_buffer (Buffer.contents input_buffer) - ~pos:!input_pos ~len:(stop - !input_pos); + !input_pos (stop - !input_pos); input_pos := stop in let last = ref (EOF, 0, 0) in diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index 3adbc9e96d..7615d46863 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -50,6 +50,7 @@ module Options = Main_args.Make_options (struct let _linkall = option "-linkall" let _make_runtime = option "-make-runtime" let _noassert = option "-noassert" + let _nolabels = option "-nolabels" let _noautolink = option "-noautolink" let _o s = option_with_arg "-o" s let _output_obj = option "-output-obj" diff --git a/tools/ocamlmklib.tpl b/tools/ocamlmklib.tpl index 2c061d0298..e21b549c01 100644 --- a/tools/ocamlmklib.tpl +++ b/tools/ocamlmklib.tpl @@ -40,9 +40,12 @@ while :; do native_objs="$native_objs $1";; *.o|*.a) c_objs="$c_objs $1";; - -cclib|-dllpath) + -cclib) caml_libs="$caml_libs $1 $2" shift;; + -ccopt|-dllpath) + caml_opts="$caml_opts $1 $2" + shift;; -l*) c_libs="$c_libs $1" c_libs_caml="$c_libs_caml -cclib $1";; diff --git a/tools/scrapelabels.ml b/tools/scrapelabels.ml new file mode 100644 index 0000000000..0f8e43f58e --- /dev/null +++ b/tools/scrapelabels.ml @@ -0,0 +1,111 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Lexer301 + +let input_buffer = Buffer.create 16383 +let input_function ic buf len = + let len = input ic buf 0 len in + Buffer.add_substring input_buffer buf 0 len; + len + +let output_buffer = Buffer.create 16383 + +let modified = ref false + +type state = Out | Enter | In | Escape + +let convert buffer = + let input_pos = ref 0 in + let copy_input stop = + Buffer.add_substring output_buffer (Buffer.contents input_buffer) + !input_pos (stop - !input_pos); + input_pos := stop + in + let last = ref (EOF, 0, 0) in + let state = ref Out in + try while true do + let token = Lexer301.token buffer + and start = Lexing.lexeme_start buffer + and stop = Lexing.lexeme_end buffer + and last_token, last_start, last_stop = !last in + begin match token with + | EXCEPTION | CONSTRAINT -> + state := In + | VAL | EXTERNAL | CLASS | METHOD | TYPE | AND -> + state := Enter + | EQUAL when !state = Enter -> + state := In + | COLON -> + begin match !state, last_token with + | In, LIDENT _ -> + modified := true; + copy_input last_start; + input_pos := stop + | Enter, _ -> + state := In + | Escape, _ -> + state := In + | _ -> + state := Out + end + | LBRACE | SEMI | QUESTION when !state = In -> + state := Escape + | SEMISEMI | SIG | STRUCT | END | OBJECT | OPEN | INCLUDE | MODULE -> + state := Out + | EOF -> raise End_of_file + | _ -> () + end; + last := (token, start, stop) + done with + End_of_file -> + copy_input (Buffer.length input_buffer) + +let convert_file name = + let ic = open_in name in + Buffer.clear input_buffer; + Buffer.clear output_buffer; + modified := false; + begin + try convert (Lexing.from_function (input_function ic)); close_in ic + with exn -> close_in ic; raise exn + end; + if !modified then begin + let backup = name ^ ".bak" in + if Sys.file_exists backup then Sys.remove backup; + Sys.rename name backup; + let oc = open_out name in + Buffer.output_buffer oc output_buffer; + close_out oc + end + +let _ = + if Array.length Sys.argv < 2 || Sys.argv.(1) = "-h" || Sys.argv.(1) = "-help" + then begin + print_endline "Usage: scrapelabels <source file> ..."; + print_endline "Description:"; + print_endline + " Remove labels on non-optional arguments in function types."; + print_endline + " To use only on interface (.mli) files."; + print_endline " Old files are renamed to <file>.bak."; + exit 0 + end; + for i = 1 to Array.length Sys.argv - 1 do + let name = Sys.argv.(i) in + if Filename.check_suffix name ".mli" then begin + prerr_endline ("Converting " ^ name); + Printexc.catch convert_file name + end + done diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 32519cbba4..785a94ddc6 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -621,6 +621,24 @@ and class_expr cl_num val_env met_env scl = cl_type = Tcty_fun (l, pat.pat_type, cl.cl_type)} | Pcl_apply (scl', sargs) -> let cl = class_expr cl_num val_env met_env scl' in + let rec nonopt_labels ls ty_fun = + match ty_fun with + | Tcty_fun (l, _, ty_res) -> + if Btype.is_optional l then nonopt_labels ls ty_res + else nonopt_labels (l::ls) ty_res + | _ -> ls + in + let ignore_labels = + !Clflags.classic || + let labels = nonopt_labels [] cl.cl_type in + List.length labels = List.length sargs && + List.for_all (fun (l,_) -> l = "") sargs && + List.exists (fun l -> l <> "") labels && + begin + Location.prerr_warning cl.cl_loc Warnings.Labels_omitted; + true + end + in let rec type_args args omitted ty_fun sargs more_sargs = match ty_fun with | Tcty_fun (l, ty, ty_fun) when sargs <> [] || more_sargs <> [] -> @@ -628,7 +646,7 @@ and class_expr cl_num val_env met_env scl = and optional = if Btype.is_optional l then Optional else Required in let sargs, more_sargs, arg = - if !Clflags.classic && not (Btype.is_optional l) then begin + if ignore_labels && not (Btype.is_optional l) then begin match sargs, more_sargs with (l', sarg0)::_, _ -> raise(Error(sarg0.pexp_loc, Apply_wrong_label(l'))) @@ -680,7 +698,7 @@ and class_expr cl_num val_env met_env scl = ty_fun omitted) in let (args, cty) = - if !Clflags.classic then + if ignore_labels then type_args [] [] cl.cl_type [] sargs else type_args [] [] cl.cl_type sargs [] diff --git a/typing/typecore.ml b/typing/typecore.ml index 5773801fb8..e7682d0ed1 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1148,6 +1148,27 @@ and type_application env funct sargs = in type_unknown_args ((Some arg1, optional) :: args) omitted ty2 sargl in + let rec nonopt_labels ls ty_fun = + match (expand_head env ty_fun).desc with + | Tarrow (l, _, ty_res, _) -> + if is_optional l then nonopt_labels ls ty_res + else nonopt_labels (l::ls) ty_res + | Tvar -> None + | _ -> Some ls + in + let ignore_labels = + !Clflags.classic || + match nonopt_labels [] funct.exp_type with + | Some labels -> + List.length labels = List.length sargs && + List.for_all (fun (l,_) -> l = "") sargs && + List.exists (fun l -> l <> "") labels && + begin + Location.prerr_warning funct.exp_loc Warnings.Labels_omitted; + true + end + | None -> false + in let rec type_args args omitted ty_fun ty_old sargs more_sargs = match expand_head env ty_fun with {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun' @@ -1155,7 +1176,7 @@ and type_application env funct sargs = let name = label_name l and optional = if is_optional l then Optional else Required in let sargs, more_sargs, arg = - if !Clflags.classic && not (is_optional l) then begin + if ignore_labels && not (is_optional l) then begin (* In classic mode, omitted = [] *) match sargs, more_sargs with (l', sarg0) :: _, _ -> @@ -1196,7 +1217,7 @@ and type_application env funct sargs = type_args ((arg,optional)::args) omitted ty_fun ty_old sargs more_sargs | _ -> match sargs with - (l, sarg0) :: _ when !Clflags.classic -> + (l, sarg0) :: _ when ignore_labels -> raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old))); | _ -> type_unknown_args args omitted ty_fun (sargs @ more_sargs) @@ -1215,7 +1236,7 @@ and type_application env funct sargs = ([Some exp, Required], ty_res) | _ -> let ty = funct.exp_type in - if !Clflags.classic then + if ignore_labels then type_args [] [] ty ty [] sargs else type_args [] [] ty ty sargs [] diff --git a/utils/clflags.ml b/utils/clflags.ml index 92e0143540..0c82dee4a4 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -30,7 +30,7 @@ and link_everything = ref false (* -linkall *) and custom_runtime = ref false (* -custom *) and output_c_object = ref false (* -output-obj *) and ccopts = ref ([] : string list) (* -ccopt *) -and classic = ref true (* -labels *) +and classic = ref false (* -nolabels *) and nopervasives = ref false (* -nopervasives *) and preprocessor = ref(None : string option) (* -pp *) and thread_safe = ref false (* -thread *) diff --git a/utils/config.mlp b/utils/config.mlp index cb22d81d1b..a77c8a5e2c 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -12,7 +12,7 @@ (* $Id$ *) -let version = "3.02+3 (2001-08-28)" +let version = "3.02+4 (2001-09-06)" let standard_library = try diff --git a/utils/warnings.ml b/utils/warnings.ml index 2f37b48409..22568041c7 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -17,6 +17,7 @@ type t = (* A is all *) | Comment of string (* C *) | Partial_application (* F *) + | Labels_omitted (* L *) | Method_override of string list (* M *) | Partial_match of string (* P *) | Statement_type (* S *) @@ -28,6 +29,7 @@ type t = (* A is all *) let letter = function (* 'a' is all *) | Comment _ -> 'c' | Partial_application -> 'f' + | Labels_omitted -> 'l' | Method_override _ -> 'm' | Partial_match _ -> 'p' | Statement_type -> 's' @@ -37,7 +39,7 @@ let letter = function (* 'a' is all *) ;; let check c = - try ignore (String.index "acfmpsuvxACFMPSUVX" c) + try ignore (String.index "acflmpsuvxACFLMPSUVX" c) with _ -> raise (Arg.Bad (Printf.sprintf "unknown warning option %c" c)) ;; @@ -80,6 +82,8 @@ let message = function "this pattern-matching is not exhaustive.\n\ Here is an example of a value that is not matched:\n" ^ s | Unused_match -> "this match case is unused." + | Labels_omitted -> + "labels were omitted in the application of this function." | Method_override slist -> String.concat " " ("the following methods are overriden \ diff --git a/utils/warnings.mli b/utils/warnings.mli index 64bef97d0b..babe8f9673 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -17,6 +17,7 @@ open Format type t = (* A is all *) | Comment of string (* C *) | Partial_application (* F *) + | Labels_omitted (* L *) | Method_override of string list (* M *) | Partial_match of string (* P *) | Statement_type (* S *) @@ -25,7 +26,7 @@ type t = (* A is all *) | Other of string (* X *) ;; -val parse_options : iserror:bool -> string -> unit;; +val parse_options : bool -> string -> unit;; val is_active : t -> bool;; val is_error : t -> bool;; |