diff options
Diffstat (limited to 'otherlibs')
606 files changed, 0 insertions, 64459 deletions
diff --git a/otherlibs/bigarray/.cvsignore b/otherlibs/bigarray/.cvsignore deleted file mode 100644 index c54b3a3580..0000000000 --- a/otherlibs/bigarray/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.o -*.x -so_locations diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend deleted file mode 100644 index 7c4e124ea6..0000000000 --- a/otherlibs/bigarray/.depend +++ /dev/null @@ -1,17 +0,0 @@ -bigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h bigarray.h \ - ../../byterun/custom.h ../../byterun/fail.h ../../byterun/intext.h \ - ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h -mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/custom.h ../../byterun/fail.h \ - ../../byterun/sys.h -mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/custom.h \ - ../../byterun/fail.h ../../byterun/sys.h ../unix/unixsupport.h -bigarray.cmo: bigarray.cmi -bigarray.cmx: bigarray.cmi diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile deleted file mode 100644 index 715428fca6..0000000000 --- a/otherlibs/bigarray/Makefile +++ /dev/null @@ -1,74 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -include ../../config/Makefile - -CC=$(BYTECC) -CFLAGS=-I../../byterun -g -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -CAMLC=../../ocamlcomp.sh -I ../unix -CAMLOPT=../../ocamlcompopt.sh -I ../unix -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A - -C_OBJS=bigarray_stubs.o mmap_unix.o - -CAML_OBJS=bigarray.cmo - -all: libbigarray.a bigarray.cma - -allopt: libbigarray.a bigarray.cmxa - -libbigarray.a: $(C_OBJS) - $(MKLIB) -o bigarray $(C_OBJS) - -bigarray.cma: $(CAML_OBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -linkall -o bigarray $(CAML_OBJS) - -bigarray.cmxa: $(CAML_OBJS:.cmo=.cmx) - $(MKLIB) -ocamlopt '$(CAMLOPT)' -linkall -o bigarray \ - $(CAML_OBJS:.cmo=.cmx) - -install: - if test -f dllbigarray.so; then cp dllbigarray.so $(STUBLIBDIR)/dllbigarray.so; fi - cp bigarray.cmi bigarray.mli libbigarray.a bigarray.cma $(LIBDIR) - cd $(LIBDIR); $(RANLIB) libbigarray.a - cp bigarray.h $(LIBDIR)/caml/bigarray.h - -installopt: - cp bigarray.a $(CAML_OBJS:.cmo=.cmx) bigarray.cmxa $(LIBDIR) - cd $(LIBDIR); $(RANLIB) bigarray.a - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f libbigarray.* *.o bigarray.a *.so - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: - gcc -MM -I../../byterun -I../unix *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend - -include .depend diff --git a/otherlibs/bigarray/Makefile.Mac b/otherlibs/bigarray/Makefile.Mac deleted file mode 100644 index 7f449f9974..0000000000 --- a/otherlibs/bigarray/Makefile.Mac +++ /dev/null @@ -1,53 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Moscova, INRIA Rocquencourt # -# # -# Copyright 2000 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -PPCC = mrc -PPCCOptions = -i :::byterun:,:::config: -w 35 {cdbgflag} - -CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib: -I ::unix: - -PPCC_OBJS = bigarray_stubs.c.x mmap_unix.c.x - -CAML_OBJS = bigarray.cmo - -all Ä libbigarray.x bigarray.cma - -libbigarray.x Ä {PPCC_OBJS} - ppclink {ldbgflag} -xm library -o libbigarray.x {PPCC_OBJS} - -bigarray.cma Ä {CAML_OBJS} - {CAMLC} -a -linkall -o bigarray.cma {CAML_OBJS} - -install Ä - duplicate -y bigarray.cmi bigarray.mli libbigarray.x ¶ - bigarray.cma "{LIBDIR}" - -partialclean Ä - delete -y Å.cmÅ || set status 0 - -clean Ä partialclean - delete -i Å.x || set status 0 - -.cmi Ä .mli - {CAMLC} -c {COMPFLAGS} {depdir}{default}.mli - -.cmo Ä .ml - {CAMLC} -c {COMPFLAGS} {depdir}{default}.ml - -depend Ä - begin - MakeDepend -w -objext .x Å.c - :::boot:ocamlrun :::tools:ocamldep -I :::stdlib: -I ::unix: Å.mli Å.ml - end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend diff --git a/otherlibs/bigarray/Makefile.Mac.depend b/otherlibs/bigarray/Makefile.Mac.depend deleted file mode 100644 index b2608cbede..0000000000 --- a/otherlibs/bigarray/Makefile.Mac.depend +++ /dev/null @@ -1,42 +0,0 @@ -#*** Dependencies: Cut here *** -# These dependencies were produced at 20:33:17 on Tue, Aug 21, 2001 by MakeDepend - -:bigarray_stubs.c.x Ä ¶ - :bigarray_stubs.c ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"stdarg.h ¶ - "{CIncludes}"string.h ¶ - :bigarray.h ¶ - "{CIncludes}"memory.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"VaListTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:mmap_unix.c.x Ä ¶ - :mmap_unix.c ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"string.h ¶ - :bigarray.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"WCharTDef.h - -:mmap_win32.c.x Ä ¶ - :mmap_win32.c ¶ - "{CIncludes}"stddef.h ¶ - "{CIncludes}"string.h ¶ - :bigarray.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"WCharTDef.h - -bigarray.cmiÄ ::unix:unix.cmi -bigarray.cmoÄ :::stdlib:array.cmi :::stdlib:obj.cmi ::unix:unix.cmi ¶ - bigarray.cmi -bigarray.cmxÄ :::stdlib:array.cmx :::stdlib:obj.cmx ::unix:unix.cmx ¶ - bigarray.cmi diff --git a/otherlibs/bigarray/Makefile.nt b/otherlibs/bigarray/Makefile.nt deleted file mode 100644 index b4a8dc3058..0000000000 --- a/otherlibs/bigarray/Makefile.nt +++ /dev/null @@ -1,84 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -include ../../config/Makefile - -CC=$(BYTECC) -CFLAGS=-I../../byterun -I../win32unix -DIN_OCAML_BIGARRAY -CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix -CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix - -C_OBJS=bigarray_stubs.obj mmap_win32.obj - -CAML_OBJS=bigarray.cmo - -all: dllbigarray.dll libbigarray.$(A) bigarray.cma - -allopt: libbigarray.$(A) bigarray.cmxa - -dllbigarray.dll: $(C_OBJS:.obj=.$(DO)) - $(call MKDLL,dllbigarray.dll,dllbigarray.$(A),\ - $(C_OBJS:.obj=.$(DO)) ../../byterun/ocamlrun.$(A)) - -libbigarray.$(A): $(C_OBJS:.obj=.$(SO)) - $(call MKLIB,libbigarray.$(A),$(C_OBJS:.obj=.$(SO))) - -bigarray.cma: $(CAML_OBJS) - $(CAMLC) -a -linkall -o bigarray.cma $(CAML_OBJS) \ - -dllib -lbigarray -cclib -lbigarray - -bigarray.cmxa: $(CAML_OBJS:.cmo=.cmx) - $(CAMLOPT) -a -linkall -o bigarray.cmxa \ - $(CAML_OBJS:.cmo=.cmx) -cclib -lbigarray - -install: - cp dllbigarray.dll $(STUBLIBDIR) - cp libbigarray.$(A) dllbigarray.$(A) $(LIBDIR) - cp bigarray.cmi bigarray.mli bigarray.cma $(LIBDIR) - cp bigarray.h $(LIBDIR)/caml/bigarray.h - -installopt: - cp bigarray.$(A) $(CAML_OBJS:.cmo=.cmx) bigarray.cmxa $(LIBDIR) - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.dll *.$(A) *.$(O) - -.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO) - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(SO) - -depend: - gcc -MM $(CFLAGS) *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend - -include .depend diff --git a/otherlibs/bigarray/bigarray.h b/otherlibs/bigarray/bigarray.h deleted file mode 100644 index 17b2dfe430..0000000000 --- a/otherlibs/bigarray/bigarray.h +++ /dev/null @@ -1,81 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#ifndef _bigarray_ -#define _bigarray_ - - -#include "mlvalues.h" - -#define MAX_NUM_DIMS 16 - -enum caml_bigarray_kind { - BIGARRAY_FLOAT32, /* Single-precision floats */ - BIGARRAY_FLOAT64, /* Double-precision floats */ - BIGARRAY_SINT8, /* Signed 8-bit integers */ - BIGARRAY_UINT8, /* Unsigned 8-bit integers */ - BIGARRAY_SINT16, /* Signed 16-bit integers */ - BIGARRAY_UINT16, /* Unsigned 16-bit integers */ - BIGARRAY_INT32, /* Signed 32-bit integers */ - BIGARRAY_INT64, /* Signed 64-bit integers */ - BIGARRAY_CAML_INT, /* Caml-style integers (signed 31 or 63 bits) */ - BIGARRAY_NATIVE_INT, /* Platform-native long integers (32 or 64 bits) */ - BIGARRAY_COMPLEX32, /* Single-precision complex */ - BIGARRAY_COMPLEX64, /* Double-precision complex */ - BIGARRAY_KIND_MASK = 0xFF /* Mask for kind in flags field */ -}; - -enum caml_bigarray_layout { - BIGARRAY_C_LAYOUT = 0, /* Row major, indices start at 0 */ - BIGARRAY_FORTRAN_LAYOUT = 0x100, /* Column major, indices start at 1 */ - BIGARRAY_LAYOUT_MASK = 0x100 /* Mask for layout in flags field */ -}; - -enum caml_bigarray_managed { - BIGARRAY_EXTERNAL = 0, /* Data is not allocated by Caml */ - BIGARRAY_MANAGED = 0x200, /* Data is allocated by Caml */ - BIGARRAY_MAPPED_FILE = 0x400, /* Data is a memory mapped file */ - BIGARRAY_MANAGED_MASK = 0x600 /* Mask for "managed" bits in flags field */ -}; - -struct caml_bigarray_proxy { - long refcount; /* Reference count */ - void * data; /* Pointer to base of actual data */ - unsigned long size; /* Size of data in bytes (if mapped file) */ -}; - -struct caml_bigarray { - void * data; /* Pointer to raw data */ - long num_dims; /* Number of dimensions */ - long flags; /* Kind of element array + memory layout + allocation status */ - struct caml_bigarray_proxy * proxy; /* The proxy for sub-arrays, or NULL */ - long dim[1] /*[num_dims]*/; /* Size in each dimension */ -}; - -#define Bigarray_val(v) ((struct caml_bigarray *) Data_custom_val(v)) - -#define Data_bigarray_val(v) (Bigarray_val(v)->data) - -#if defined(IN_OCAML_BIGARRAY) -#define CAMLBAextern CAMLexport -#else -#define CAMLBAextern CAMLextern -#endif - -CAMLBAextern value alloc_bigarray(int flags, int num_dims, void * data, long * dim); -CAMLBAextern value alloc_bigarray_dims(int flags, int num_dims, void * data, - ... /*dimensions, with type long */); - -#endif diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml deleted file mode 100644 index adfb5847b2..0000000000 --- a/otherlibs/bigarray/bigarray.ml +++ /dev/null @@ -1,226 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Manuel Serrano et Xavier Leroy, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Module [Bigarray]: large, multi-dimensional, numerical arrays *) - -external init : unit -> unit = "bigarray_init" - -let _ = init() - -type ('a, 'b) kind = int - -type int8_signed_elt -type int8_unsigned_elt -type int16_signed_elt -type int16_unsigned_elt -type int_elt -type int32_elt -type int64_elt -type nativeint_elt -type float32_elt -type float64_elt -type complex32_elt -type complex64_elt - -(* Keep those constants in sync with the caml_bigarray_kind enumeration - in bigarray.h *) - -let float32 = 0 -let float64 = 1 -let int8_signed = 2 -let int8_unsigned = 3 -let int16_signed = 4 -let int16_unsigned = 5 -let int32 = 6 -let int64 = 7 -let int = 8 -let nativeint = 9 -let char = int8_unsigned -let complex32 = 10 -let complex64 = 11 - -type 'a layout = int - -type c_layout -type fortran_layout - -(* Keep those constants in sync with the caml_bigarray_layout enumeration - in bigarray.h *) - -let c_layout = 0 -let fortran_layout = 0x100 - -module Genarray = struct - type ('a, 'b, 'c) t - external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t - = "bigarray_create" - external get: ('a, 'b, 'c) t -> int array -> 'a - = "bigarray_get_generic" - external set: ('a, 'b, 'c) t -> int array -> 'a -> unit - = "bigarray_set_generic" - external num_dims: ('a, 'b, 'c) t -> int = "bigarray_num_dims" - external nth_dim: ('a, 'b, 'c) t -> int -> int = "bigarray_dim" - let dims a = - let n = num_dims a in - let d = Array.make n 0 in - for i = 0 to n-1 do d.(i) <- nth_dim a i done; - d - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" - - external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t - = "bigarray_sub" - external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> - ('a, 'b, fortran_layout) t - = "bigarray_sub" - external slice_left: ('a, 'b, c_layout) t -> int array -> - ('a, 'b, c_layout) t - = "bigarray_slice" - external slice_right: ('a, 'b, fortran_layout) t -> int array -> - ('a, 'b, fortran_layout) t - = "bigarray_slice" - external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit - = "bigarray_blit" - external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill" - external map_file: Unix.file_descr -> ('a, 'b) kind -> 'c layout -> - bool -> int array -> ('a, 'b, 'c) t - = "bigarray_map_file" -end - -module Array1 = struct - type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t - let create kind layout dim = - Genarray.create kind layout [|dim|] - external get: ('a, 'b, 'c) t -> int -> 'a = "%bigarray_ref_1" - external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%bigarray_set_1" - let dim a = Genarray.nth_dim a 0 - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" - external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "bigarray_sub" - external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit" - external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill" - let of_array kind layout data = - let ba = create kind layout (Array.length data) in - let ofs = if (Obj.magic layout : 'a layout) = c_layout then 0 else 1 in - for i = 0 to Array.length data - 1 do set ba (i + ofs) data.(i) done; - ba - let map_file fd kind layout shared dim = - Genarray.map_file fd kind layout shared [|dim|] -end - -module Array2 = struct - type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t - let create kind layout dim1 dim2 = - Genarray.create kind layout [|dim1; dim2|] - external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%bigarray_ref_2" - external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%bigarray_set_2" - let dim1 a = Genarray.nth_dim a 0 - let dim2 a = Genarray.nth_dim a 1 - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" - external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "bigarray_sub" - external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "bigarray_sub" - let slice_left a n = Genarray.slice_left a [|n|] - let slice_right a n = Genarray.slice_right a [|n|] - external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit" - external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill" - let of_array kind layout data = - let dim1 = Array.length data in - let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in - let ba = create kind layout dim1 dim2 in - let ofs = if (Obj.magic layout : 'a layout) = c_layout then 0 else 1 in - for i = 0 to dim1 - 1 do - let row = data.(i) in - if Array.length row <> dim2 then - invalid_arg("Bigarray.Array2.of_array: non-rectangular data"); - for j = 0 to dim2 - 1 do - set ba (i + ofs) (j + ofs) row.(j) - done - done; - ba - let map_file fd kind layout shared dim1 dim2 = - Genarray.map_file fd kind layout shared [|dim1;dim2|] -end - -module Array3 = struct - type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t - let create kind layout dim1 dim2 dim3 = - Genarray.create kind layout [|dim1; dim2; dim3|] - external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%bigarray_ref_3" - external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%bigarray_set_3" - let dim1 a = Genarray.nth_dim a 0 - let dim2 a = Genarray.nth_dim a 1 - let dim3 a = Genarray.nth_dim a 2 - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" - external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "bigarray_sub" - external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "bigarray_sub" - let slice_left_1 a n m = Genarray.slice_left a [|n; m|] - let slice_right_1 a n m = Genarray.slice_right a [|n; m|] - let slice_left_2 a n = Genarray.slice_left a [|n|] - let slice_right_2 a n = Genarray.slice_right a [|n|] - external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit" - external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill" - let of_array kind layout data = - let dim1 = Array.length data in - let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in - let dim3 = if dim2 = 0 then 0 else Array.length data.(0).(0) in - let ba = create kind layout dim1 dim2 dim3 in - let ofs = if (Obj.magic layout : 'a layout) = c_layout then 0 else 1 in - for i = 0 to dim1 - 1 do - let row = data.(i) in - if Array.length row <> dim2 then - invalid_arg("Bigarray.Array3.of_array: non-cubic data"); - for j = 0 to dim2 - 1 do - let col = row.(j) in - if Array.length col <> dim3 then - invalid_arg("Bigarray.Array3.of_array: non-cubic data"); - for k = 0 to dim3 - 1 do - set ba (i + ofs) (j + ofs) (k + ofs) col.(j) - done - done - done; - ba - let map_file fd kind layout shared dim1 dim2 dim3 = - Genarray.map_file fd kind layout shared [|dim1;dim2;dim3|] -end - -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" -let array1_of_genarray a = - if Genarray.num_dims a = 1 then a else invalid_arg "Bigarray.array1_of_genarray" -let array2_of_genarray a = - if Genarray.num_dims a = 2 then a else invalid_arg "Bigarray.array2_of_genarray" -let array3_of_genarray a = - if Genarray.num_dims a = 3 then a else invalid_arg "Bigarray.array3_of_genarray" - -external reshape: - ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t - = "bigarray_reshape" -let reshape_1 a dim1 = reshape a [|dim1|] -let reshape_2 a dim1 dim2 = reshape a [|dim1;dim2|] -let reshape_3 a dim1 dim2 dim3 = reshape a [|dim1;dim2;dim3|] - -(* Force bigarray_get_{1,2,3,N} to be linked in, since we don't refer - to those primitives directly in this file *) - -let _ = - let getN = Genarray.get in - let get1 = Array1.get in - let get2 = Array2.get in - let get3 = Array3.get in - () - diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli deleted file mode 100644 index e2ce03de67..0000000000 --- a/otherlibs/bigarray/bigarray.mli +++ /dev/null @@ -1,756 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Large, multi-dimensional, numerical arrays. - - This module implements multi-dimensional arrays of integers and - floating-point numbers, thereafter referred to as ``big arrays''. - The implementation allows efficient sharing of large numerical - arrays between Caml code and C or Fortran numerical libraries. - - Concerning the naming conventions, users of this module are encouraged - to do [open Bigarray] in their source, then refer to array types and - operations via short dot notation, e.g. [Array1.t] or [Array2.sub]. - - Big arrays support all the Caml ad-hoc polymorphic operations: - - comparisons ([=], [<>], [<=], etc, as well as {!Pervasives.compare}); - - hashing (module [Hash]); - - and structured input-output ({!Pervasives.output_value} - and {!Pervasives.input_value}, as well as the functions from the - {!Marshal} module). -*) - -(** {6 Element kinds} *) - -(** Big arrays can contain elements of the following kinds: -- IEEE single precision (32 bits) floating-point numbers - ({!Bigarray.float32_elt}), -- IEEE double precision (64 bits) floating-point numbers - ({!Bigarray.float64_elt}), -- IEEE single precision (2 * 32 bits) floating-point complex numbers - ({!Bigarray.complex32_elt}), -- IEEE double precision (2 * 64 bits) floating-point complex numbers - ({!Bigarray.complex64_elt}), -- 8-bit integers (signed or unsigned) - ({!Bigarray.int8_signed_elt} or {!Bigarray.int8_unsigned_elt}), -- 16-bit integers (signed or unsigned) - ({!Bigarray.int16_signed_elt} or {!Bigarray.int16_unsigned_elt}), -- Caml integers (signed, 31 bits on 32-bit architectures, - 63 bits on 64-bit architectures) ({!Bigarray.int_elt}), -- 32-bit signed integer ({!Bigarray.int32_elt}), -- 64-bit signed integers ({!Bigarray.int64_elt}), -- platform-native signed integers (32 bits on 32-bit architectures, - 64 bits on 64-bit architectures) ({!Bigarray.nativeint_elt}). - - Each element kind is represented at the type level by one - of the abstract types defined below. -*) - -type float32_elt -type float64_elt -type complex32_elt -type complex64_elt -type int8_signed_elt -type int8_unsigned_elt -type int16_signed_elt -type int16_unsigned_elt -type int_elt -type int32_elt -type int64_elt -type nativeint_elt - -type ('a, 'b) kind -(** To each element kind is associated a Caml type, which is - the type of Caml values that can be stored in the big array - or read back from it. This type is not necessarily the same - as the type of the array elements proper: for instance, - a big array whose elements are of kind [float32_elt] contains - 32-bit single precision floats, but reading or writing one of - its elements from Caml uses the Caml type [float], which is - 64-bit double precision floats. - - The abstract type [('a, 'b) kind] captures this association - of a Caml type ['a] for values read or written in the big array, - and of an element kind ['b] which represents the actual contents - of the big array. The following predefined values of type - [kind] list all possible associations of Caml types with - element kinds: *) - -val float32 : (float, float32_elt) kind -(** See {!Bigarray.char}. *) - -val float64 : (float, float64_elt) kind -(** See {!Bigarray.char}. *) - -val complex32 : (Complex.t, complex32_elt) kind -(** See {!Bigarray.char}. *) - -val complex64 : (Complex.t, complex64_elt) kind -(** See {!Bigarray.char}. *) - -val int8_signed : (int, int8_signed_elt) kind -(** See {!Bigarray.char}. *) - -val int8_unsigned : (int, int8_unsigned_elt) kind -(** See {!Bigarray.char}. *) - -val int16_signed : (int, int16_signed_elt) kind -(** See {!Bigarray.char}. *) - -val int16_unsigned : (int, int16_unsigned_elt) kind -(** See {!Bigarray.char}. *) - -val int : (int, int_elt) kind -(** See {!Bigarray.char}. *) - -val int32 : (int32, int32_elt) kind -(** See {!Bigarray.char}. *) - -val int64 : (int64, int64_elt) kind -(** See {!Bigarray.char}. *) - -val nativeint : (nativeint, nativeint_elt) kind -(** See {!Bigarray.char}. *) - -val char : (char, int8_unsigned_elt) kind -(** As shown by the types of the values above, - big arrays of kind [float32_elt] and [float64_elt] are - accessed using the Caml type [float]. Big arrays of complex kinds - [complex32_elt], [complex64_elt] are accessed with the Caml type - {!Complex.t}. Big arrays of - integer kinds are accessed using the smallest Caml integer - type large enough to represent the array elements: - [int] for 8- and 16-bit integer bigarrays, as well as Caml-integer - bigarrays; [int32] for 32-bit integer bigarrays; [int64] - for 64-bit integer bigarrays; and [nativeint] for - platform-native integer bigarrays. Finally, big arrays of - kind [int8_unsigned_elt] can also be accessed as arrays of - characters instead of arrays of small integers, by using - the kind value [char] instead of [int8_unsigned]. *) - -(** {6 Array layouts} *) - -type c_layout -(** See {!Bigarray.fortran_layout}.*) - -type fortran_layout -(** To facilitate interoperability with existing C and Fortran code, - this library supports two different memory layouts for big arrays, - one compatible with the C conventions, - the other compatible with the Fortran conventions. - - In the C-style layout, array indices start at 0, and - multi-dimensional arrays are laid out in row-major format. - That is, for a two-dimensional array, all elements of - row 0 are contiguous in memory, followed by all elements of - row 1, etc. In other terms, the array elements at [(x,y)] - and [(x, y+1)] are adjacent in memory. - - In the Fortran-style layout, array indices start at 1, and - multi-dimensional arrays are laid out in column-major format. - That is, for a two-dimensional array, all elements of - column 0 are contiguous in memory, followed by all elements of - column 1, etc. In other terms, the array elements at [(x,y)] - and [(x+1, y)] are adjacent in memory. - - Each layout style is identified at the type level by the - abstract types {!Bigarray.c_layout} and [fortran_layout] respectively. *) - -type 'a layout -(** The type ['a layout] represents one of the two supported - memory layouts: C-style if ['a] is {!Bigarray.c_layout}, Fortran-style - if ['a] is {!Bigarray.fortran_layout}. *) - - -(** {7 Supported layouts} - - The abstract values [c_layout] and [fortran_layout] represent - the two supported layouts at the level of values. -*) - -val c_layout : c_layout layout -val fortran_layout : fortran_layout layout - - -(** {6 Generic arrays (of arbitrarily many dimensions)} *) - -module Genarray : - sig - type ('a, 'b, 'c) t - (** The type [Genarray.t] is the type of big arrays with variable - numbers of dimensions. Any number of dimensions between 1 and 16 - is supported. - - The three type parameters to [Genarray.t] identify the array element - kind and layout, as follows: - - the first parameter, ['a], is the Caml type for accessing array - elements ([float], [int], [int32], [int64], [nativeint]); - - the second parameter, ['b], is the actual kind of array elements - ([float32_elt], [float64_elt], [int8_signed_elt], [int8_unsigned_elt], - etc); - - the third parameter, ['c], identifies the array layout - ([c_layout] or [fortran_layout]). - - For instance, [(float, float32_elt, fortran_layout) Genarray.t] - is the type of generic big arrays containing 32-bit floats - in Fortran layout; reads and writes in this array use the - Caml type [float]. *) - - 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 - [float32], [float64], [int8_signed], etc) and whose layout is - determined by the parameter [layout] (one of [c_layout] or - [fortran_layout]). The [dimensions] parameter is an array of - integers that indicate the size of the big array in each dimension. - The length of [dimensions] determines the number of dimensions - of the bigarray. - - For instance, [Genarray.create int32 c_layout [|4;6;8|]] - returns a fresh big array of 32-bit integers, in C layout, - having three dimensions, the three dimensions being 4, 6 and 8 - respectively. - - Big arrays returned by [Genarray.create] are not initialized: - the initial values of array elements is unspecified. - - [Genarray.create] raises [Invalid_arg] if the number of dimensions - is not in the range 1 to 16 inclusive, or if one of the dimensions - is negative. *) - - external num_dims: ('a, 'b, 'c) t -> int = "bigarray_num_dims" - (** Return the number of dimensions of the given big array. *) - - val dims : ('a, 'b, 'c) t -> int array - (** [Genarray.dims a] returns all dimensions of the big array [a], - as an array of integers of length [Genarray.num_dims a]. *) - - external nth_dim: ('a, 'b, 'c) t -> int -> int = "bigarray_dim" - (** [Genarray.nth_dim a n] returns the [n]-th dimension of the - big array [a]. The first dimension corresponds to [n = 0]; - the second dimension corresponds to [n = 1]; the last dimension, - to [n = Genarray.num_dims a - 1]. - Raise [Invalid_arg] if [n] is less than 0 or greater or equal than - [Genarray.num_dims a]. *) - - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" - (** Return the kind of the given big array. *) - - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" - (** Return the layout of the given big array. *) - - external get: ('a, 'b, 'c) t -> int array -> 'a = "bigarray_get_generic" - (** Read an element of a generic big array. - [Genarray.get a [|i1; ...; iN|]] returns the element of [a] - whose coordinates are [i1] in the first dimension, [i2] in - the second dimension, ..., [iN] in the [N]-th dimension. - - If [a] has C layout, the coordinates must be greater or equal than 0 - and strictly less than the corresponding dimensions of [a]. - If [a] has Fortran layout, the coordinates must be greater or equal - than 1 and less or equal than the corresponding dimensions of [a]. - Raise [Invalid_arg] if the array [a] does not have exactly [N] - dimensions, or if the coordinates are outside the array bounds. - - If [N > 3], alternate syntax is provided: you can write - [a.{i1, i2, ..., iN}] instead of [Genarray.get a [|i1; ...; iN|]]. - (The syntax [a.{...}] with one, two or three coordinates is - reserved for accessing one-, two- and three-dimensional arrays - as described below.) *) - - external set: ('a, 'b, 'c) t -> int array -> 'a -> unit - = "bigarray_set_generic" - (** Assign an element of a generic big array. - [Genarray.set a [|i1; ...; iN|] v] stores the value [v] in the - element of [a] whose coordinates are [i1] in the first dimension, - [i2] in the second dimension, ..., [iN] in the [N]-th dimension. - - The array [a] must have exactly [N] dimensions, and all coordinates - must lie inside the array bounds, as described for [Genarray.get]; - otherwise, [Invalid_arg] is raised. - - If [N > 3], alternate syntax is provided: you can write - [a.{i1, i2, ..., iN} <- v] instead of - [Genarray.set a [|i1; ...; iN|] v]. - (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 -> 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] - returns a big array with the same number of dimensions as [a], - and the same dimensions as [a], except the first dimension, - which corresponds to the interval [[ofs ... ofs + len - 1]] - of the first dimension of [a]. No copying of elements is - involved: the sub-array and the original array share the same - storage space. In other terms, the element at coordinates - [[|i1; ...; iN|]] of the sub-array is identical to the - element at coordinates [[|i1+ofs; ...; iN|]] of the original - array [a]. - - [Genarray.sub_left] applies only to big arrays in C layout. - Raise [Invalid_arg] if [ofs] and [len] do not designate - 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 -> 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] - returns a big array with the same number of dimensions as [a], - and the same dimensions as [a], except the last dimension, - which corresponds to the interval [[ofs ... ofs + len - 1]] - of the last dimension of [a]. No copying of elements is - involved: the sub-array and the original array share the same - storage space. In other terms, the element at coordinates - [[|i1; ...; iN|]] of the sub-array is identical to the - element at coordinates [[|i1; ...; iN+ofs|]] of the original - array [a]. - - [Genarray.sub_right] applies only to big arrays in Fortran layout. - Raise [Invalid_arg] if [ofs] and [len] do not designate - a valid sub-array of [a], that is, if [ofs < 1], or [len < 0], - or [ofs + len > Genarray.nth_dim a (Genarray.num_dims a - 1)]. *) - - external slice_left: - ('a, 'b, c_layout) t -> int array -> ('a, 'b, c_layout) t - = "bigarray_slice" - (** Extract a sub-array of lower dimension from the given big array - by fixing one or several of the first (left-most) coordinates. - [Genarray.slice_left a [|i1; ... ; iM|]] returns the ``slice'' - of [a] obtained by setting the first [M] coordinates to - [i1], ..., [iM]. If [a] has [N] dimensions, the slice has - dimension [N - M], and the element at coordinates - [[|j1; ...; j(N-M)|]] in the slice is identical to the element - at coordinates [[|i1; ...; iM; j1; ...; j(N-M)|]] in the original - array [a]. No copying of elements is involved: the slice and - the original array share the same storage space. - - [Genarray.slice_left] applies only to big arrays in C layout. - Raise [Invalid_arg] if [M >= N], or if [[|i1; ... ; iM|]] - is outside the bounds of [a]. *) - - external slice_right: - ('a, 'b, fortran_layout) t -> int array -> ('a, 'b, fortran_layout) t - = "bigarray_slice" - (** Extract a sub-array of lower dimension from the given big array - by fixing one or several of the last (right-most) coordinates. - [Genarray.slice_right a [|i1; ... ; iM|]] returns the ``slice'' - of [a] obtained by setting the last [M] coordinates to - [i1], ..., [iM]. If [a] has [N] dimensions, the slice has - dimension [N - M], and the element at coordinates - [[|j1; ...; j(N-M)|]] in the slice is identical to the element - at coordinates [[|j1; ...; j(N-M); i1; ...; iM|]] in the original - array [a]. No copying of elements is involved: the slice and - the original array share the same storage space. - - [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: ('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 - [dst]. Both arrays [src] and [dst] must have the same number of - dimensions and equal dimensions. Copying a sub-array of [src] - to a sub-array of [dst] can be achieved by applying [Genarray.blit] - to sub-array or slices of [src] and [dst]. *) - - external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill" - (** Set all elements of a big array to a given value. - [Genarray.fill a v] stores the value [v] in all elements of - the big array [a]. Setting only some elements of [a] to [v] - can be achieved by applying [Genarray.fill] to a sub-array - or a slice of [a]. *) - - external 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], - and dimensions as specified in [dims]. The data contained in - this big array are the contents of the file referred to by - the file descriptor [fd] (as opened previously with - [Unix.openfile], for example). If [shared] is [true], - all modifications performed on the array are reflected in - the file. This requires that [fd] be opened with write permissions. - If [shared] is [false], modifications performed on the array - are done in memory only, using copy-on-write of the modified - pages; the underlying file is not affected. - - [Genarray.map_file] is much more efficient than reading - the whole file in a big array, modifying that big array, - and writing it afterwards. - - To adjust automatically the dimensions of the big array to - the actual size of the file, the major dimension (that is, - the first dimension for an array with C layout, and the last - dimension for an array with Fortran layout) can be given as - [-1]. [Genarray.map_file] then determines the major dimension - from the size of the file. The file must contain an integral - number of sub-arrays as determined by the non-major dimensions, - otherwise [Failure] is raised. - - If all dimensions of the big array are given, the file size is - matched against the size of the big array. If the file is larger - than the big array, only the initial portion of the file is - mapped to the big array. If the file is smaller than the big - array, the file is automatically grown to the size of the big array. - This requires write permissions on [fd]. *) - - end - -(** {6 One-dimensional arrays} *) - -(** One-dimensional arrays. The [Array1] structure provides operations similar to those of - {!Bigarray.Genarray}, but specialized to the case of one-dimensional arrays. - (The [Array2] and [Array3] structures below provide operations - specialized for two- and three-dimensional arrays.) - Statically knowing the number of dimensions of the array allows - faster operations, and more precise static type-checking. *) -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: ('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 - as described for [Genarray.create]. *) - - val dim: ('a, 'b, 'c) t -> int - (** Return the size (dimension) of the given one-dimensional - big array. *) - - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" - (** Return the kind of the given big array. *) - - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" - (** Return the layout of the given big array. *) - - external get: ('a, 'b, 'c) t -> int -> 'a = "%bigarray_ref_1" - (** [Array1.get a x], or alternatively [a.{x}], - returns the element of [a] at index [x]. - [x] must be greater or equal than [0] and strictly less than - [Array1.dim a] if [a] has C layout. If [a] has Fortran layout, - [x] must be greater or equal than [1] and less or equal than - [Array1.dim a]. Otherwise, [Invalid_arg] is raised. *) - - external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%bigarray_set_1" - (** [Array1.set a x v], also written [a.{x} <- v], - stores the value [v] at index [x] in [a]. - [x] must be inside the bounds of [a] as described in - {!Bigarray.Array1.get}; - otherwise, [Invalid_arg] is raised. *) - - 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: ('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: ('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 -> ('a, 'b) kind -> 'c layout -> - bool -> int -> ('a, 'b, 'c) t - (** Memory mapping of a file as a one-dimensional big array. - See {!Bigarray.Genarray.map_file} for more details. *) -end - - -(** {6 Two-dimensional arrays} *) - -(** Two-dimensional arrays. The [Array2] structure provides operations similar to those of - {!Bigarray.Genarray}, but specialized to the case of two-dimensional arrays. *) -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: ('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] - determine the array element kind and the array layout - as described for {!Bigarray.Genarray.create}. *) - - val dim1: ('a, 'b, 'c) t -> int - (** Return the first dimension of the given two-dimensional big array. *) - - val dim2: ('a, 'b, 'c) t -> int - (** Return the second dimension of the given two-dimensional big array. *) - - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" - (** Return the kind of the given big array. *) - - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" - (** Return the layout of the given big array. *) - - external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%bigarray_ref_2" - (** [Array2.get a x y], also written [a.{x,y}], - returns the element of [a] at coordinates ([x], [y]). - [x] and [y] must be within the bounds - of [a], as described for {!Bigarray.Genarray.get}; - otherwise, [Invalid_arg] is raised. *) - - external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%bigarray_set_2" - (** [Array2.set a x y v], or alternatively [a.{x,y} <- v], - stores the value [v] at coordinates ([x], [y]) in [a]. - [x] and [y] must be within the bounds of [a], - as described for {!Bigarray.Genarray.set}; - otherwise, [Invalid_arg] is raised. *) - - 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 {!Bigarray.Genarray.sub_left} for more details. - [Array2.sub_left] applies only to arrays with C layout. *) - - external sub_right: - ('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 {!Bigarray.Genarray.sub_right} for more details. - [Array2.sub_right] applies only to arrays with Fortran layout. *) - - 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 {!Bigarray.Genarray.slice_left} for more details. - [Array2.slice_left] applies only to arrays with C layout. *) - - val slice_right: - ('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 {!Bigarray.Genarray.slice_right} - for more details. [Array2.slice_right] applies only to arrays - with Fortran layout. *) - - external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit - = "bigarray_blit" - (** Copy the first big array to the second big array. - See {!Bigarray.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 {!Bigarray.Genarray.fill} for more details. *) - - 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 -> ('a, 'b) kind -> 'c layout -> - bool -> int -> int -> ('a, 'b, 'c) t - (** Memory mapping of a file as a two-dimensional big array. - See {!Bigarray.Genarray.map_file} for more details. *) - - end - -(** {6 Three-dimensional arrays} *) - -(** Three-dimensional arrays. The [Array3] structure provides operations similar to those of - {!Bigarray.Genarray}, but specialized to the case of three-dimensional arrays. *) -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: ('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. - [kind] and [layout] determine the array element kind and - the array layout as described for {!Bigarray.Genarray.create}. *) - - val dim1: ('a, 'b, 'c) t -> int - (** Return the first dimension of the given three-dimensional big array. *) - - val dim2: ('a, 'b, 'c) t -> int - (** Return the second dimension of the given three-dimensional big array. *) - - val dim3: ('a, 'b, 'c) t -> int - (** Return the third dimension of the given three-dimensional big array. *) - - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" - (** Return the kind of the given big array. *) - - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" - (** Return the layout of the given big array. *) - - external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%bigarray_ref_3" - (** [Array3.get a x y z], also written [a.{x,y,z}], - returns the element of [a] at coordinates ([x], [y], [z]). - [x], [y] and [z] must be within the bounds of [a], - as described for {!Bigarray.Genarray.get}; - otherwise, [Invalid_arg] is raised. *) - - 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 {!Bigarray.Genarray.set}; - otherwise, [Invalid_arg] is raised. *) - - 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 {!Bigarray.Genarray.sub_left} for more details. [Array3.sub_left] - applies only to arrays with C layout. *) - - external sub_right: - ('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 {!Bigarray.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 -> 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 {!Bigarray.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 -> - 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 {!Bigarray.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 -> 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 {!Bigarray.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 -> 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 {!Bigarray.Genarray.slice_right} for more details. - [Array3.slice_right_2] applies only to arrays with Fortran - layout. *) - - external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit - = "bigarray_blit" - (** Copy the first big array to the second big array. - See {!Bigarray.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 {!Bigarray.Genarray.fill} for more details. *) - - val of_array: - ('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 -> ('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 {!Bigarray.Genarray.map_file} for more details. *) - - end - -(** {6 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" -(** Return the generic big array corresponding to the given one-dimensional big array. *) - -external genarray_of_array2 : - ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t = "%identity" -(** Return the generic big array corresponding to the given two-dimensional big array. *) - -external genarray_of_array3 : - ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t = "%identity" -(** Return the generic big array corresponding to the given three-dimensional big array. *) - -val array1_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array1.t -(** Return the one-dimensional big array corresponding to the given - generic big array. Raise [Invalid_arg] if the generic big array - does not have exactly one dimension. *) - -val array2_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array2.t -(** Return the two-dimensional big array corresponding to the given - generic big array. Raise [Invalid_arg] if the generic big array - does not have exactly two dimensions. *) - -val array3_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array3.t -(** Return the three-dimensional big array corresponding to the given - generic big array. Raise [Invalid_arg] if the generic big array - does not have exactly three dimensions. *) - - -(** {6 Re-shaping big arrays} *) - -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 - and have the same layout. For instance, assuming that [b] - is a one-dimensional array of dimension 12, [reshape b [|3;4|]] - returns a two-dimensional array [b'] of dimensions 3 and 4. - If [b] has C layout, the element [(x,y)] of [b'] corresponds - to the element [x * 3 + y] of [b]. If [b] has Fortran layout, - the element [(x,y)] of [b'] corresponds to the element - [x + (y - 1) * 4] of [b]. - The returned big array must have exactly the same number of - 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 -> int -> ('a, 'b, 'c) Array1.t -(** Specialized version of {!Bigarray.reshape} for reshaping to one-dimensional arrays. *) - -val reshape_2 : ('a, 'b, 'c) Genarray.t -> int -> int -> ('a, 'b, 'c) Array2.t -(** Specialized version of {!Bigarray.reshape} for reshaping to two-dimensional arrays. *) - -val reshape_3 : - ('a, 'b, 'c) Genarray.t -> int -> int -> int -> ('a, 'b, 'c) Array3.t -(** Specialized version of {!Bigarray.reshape} for reshaping to three-dimensional arrays. *) - diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c deleted file mode 100644 index 969c111b12..0000000000 --- a/otherlibs/bigarray/bigarray_stubs.c +++ /dev/null @@ -1,1073 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <stddef.h> -#include <stdarg.h> -#include <string.h> -#include "alloc.h" -#include "bigarray.h" -#include "custom.h" -#include "fail.h" -#include "intext.h" -#include "memory.h" -#include "mlvalues.h" - -CAMLextern int compare_unordered; /* from byterun/compare.c */ - -extern void bigarray_unmap_file(void * addr, unsigned long len); - /* from mmap_xxx.c */ - -/* Compute the number of elements of a big array */ - -static unsigned long bigarray_num_elts(struct caml_bigarray * b) -{ - unsigned long num_elts; - int i; - num_elts = 1; - for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i]; - return num_elts; -} - -/* Size in bytes of a bigarray element, indexed by bigarray kind */ - -int bigarray_element_size[] = -{ 4 /*FLOAT32*/, 8 /*FLOAT64*/, - 1 /*SINT8*/, 1 /*UINT8*/, - 2 /*SINT16*/, 2 /*UINT16*/, - 4 /*INT32*/, 8 /*INT64*/, - sizeof(value) /*CAML_INT*/, sizeof(value) /*NATIVE_INT*/, - 8 /*COMPLEX32*/, 16 /*COMPLEX64*/ -}; - -/* Compute the number of bytes for the elements of a big array */ - -unsigned long bigarray_byte_size(struct caml_bigarray * b) -{ - return bigarray_num_elts(b) - * bigarray_element_size[b->flags & BIGARRAY_KIND_MASK]; -} - -/* Operation table for bigarrays */ - -static void bigarray_finalize(value v); -static int bigarray_compare(value v1, value v2); -static long bigarray_hash(value v); -static void bigarray_serialize(value, unsigned long *, unsigned long *); -unsigned long bigarray_deserialize(void * dst); -static struct custom_operations bigarray_ops = { - "_bigarray", - bigarray_finalize, - bigarray_compare, - bigarray_hash, - bigarray_serialize, - bigarray_deserialize -}; - -/* Multiplication of unsigned longs with overflow detection */ - -static unsigned long -bigarray_multov(unsigned long a, unsigned long b, int * overflow) -{ -#define HALF_SIZE (sizeof(unsigned long) * 4) -#define LOW_HALF(x) ((x) & ((1UL << HALF_SIZE) - 1)) -#define HIGH_HALF(x) ((x) >> HALF_SIZE) - /* Cut in half words */ - unsigned long al = LOW_HALF(a); - unsigned long ah = HIGH_HALF(a); - unsigned long bl = LOW_HALF(b); - unsigned long bh = HIGH_HALF(b); - /* Exact product is: - al * bl - + ah * bl << HALF_SIZE - + al * bh << HALF_SIZE - + ah * bh << 2*HALF_SIZE - Overflow occurs if: - ah * bh is not 0, i.e. ah != 0 and bh != 0 - OR ah * bl has high half != 0 - OR ah * bl has high half != 0 - OR the sum al * bl + LOW_HALF(ah * bl) << HALF_SIZE - + LOW_HALF(al * bh) << HALF_SIZE overflows. - This sum is equal to p = (a * b) modulo word size. */ - unsigned long p1 = al * bh; - unsigned long p2 = ah * bl; - unsigned long p = a * b; - if (ah != 0 && bh != 0) *overflow = 1; - if (p1 >= (1UL << HALF_SIZE) || p2 >= (1UL << HALF_SIZE)) *overflow = 1; - p1 <<= HALF_SIZE; - p2 <<= HALF_SIZE; - p1 += p2; - if (p < p1 || p1 < p2) *overflow = 1; /* overflow in sums */ - return p; -#undef HALF_SIZE -#undef LOW_HALF -#undef HIGH_HALF -} - -/* Allocation of a big array */ - -#define MAX_BIGARRAY_MEMORY 256*1024*1024 -/* 256 Mb -- after allocating that much, it's probably worth speeding - up the major GC */ - -/* [alloc_bigarray] will allocate a new bigarray object in the heap. - If [data] is NULL, the memory for the contents is also allocated - (with [malloc]) by [alloc_bigarray]. - [data] cannot point into the Caml heap. - [dim] may point into an object in the Caml heap. -*/ -CAMLexport value -alloc_bigarray(int flags, int num_dims, void * data, long * dim) -{ - unsigned long num_elts, size; - int overflow, i; - value res; - struct caml_bigarray * b; - long dimcopy[MAX_NUM_DIMS]; - - Assert(num_dims >= 1 && num_dims <= MAX_NUM_DIMS); - Assert((flags & BIGARRAY_KIND_MASK) <= BIGARRAY_COMPLEX64); - for (i = 0; i < num_dims; i++) dimcopy[i] = dim[i]; - size = 0; - if (data == NULL) { - overflow = 0; - num_elts = 1; - for (i = 0; i < num_dims; i++) { - num_elts = bigarray_multov(num_elts, dimcopy[i], &overflow); - } - size = bigarray_multov(num_elts, - bigarray_element_size[flags & BIGARRAY_KIND_MASK], - &overflow); - if (overflow) raise_out_of_memory(); - data = malloc(size); - if (data == NULL && size != 0) raise_out_of_memory(); - flags |= BIGARRAY_MANAGED; - } - res = alloc_custom(&bigarray_ops, - sizeof(struct caml_bigarray) - + (num_dims - 1) * sizeof(long), - size, MAX_BIGARRAY_MEMORY); - b = Bigarray_val(res); - b->data = data; - b->num_dims = num_dims; - b->flags = flags; - b->proxy = NULL; - for (i = 0; i < num_dims; i++) b->dim[i] = dimcopy[i]; - return res; -} - -/* Same as alloc_bigarray, but dimensions are passed as a list of - arguments */ - -CAMLexport value alloc_bigarray_dims(int flags, int num_dims, void * data, ...) -{ - va_list ap; - long dim[MAX_NUM_DIMS]; - int i; - value res; - - va_start(ap, data); - for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, long); - va_end(ap); - res = alloc_bigarray(flags, num_dims, data, dim); - return res; -} - -/* Allocate a bigarray from Caml */ - -CAMLprim value bigarray_create(value vkind, value vlayout, value vdim) -{ - long dim[MAX_NUM_DIMS]; - mlsize_t num_dims; - int i, flags; - - num_dims = Wosize_val(vdim); - if (num_dims < 1 || num_dims > MAX_NUM_DIMS) - invalid_argument("Bigarray.create: bad number of dimensions"); - for (i = 0; i < num_dims; i++) { - dim[i] = Long_val(Field(vdim, i)); - if (dim[i] < 0 || dim[i] > 0x7FFFFFFFL) - invalid_argument("Bigarray.create: negative dimension"); - } - flags = Int_val(vkind) | Int_val(vlayout); - return alloc_bigarray(flags, num_dims, NULL, dim); -} - -/* Given a big array and a vector of indices, check that the indices - are within the bounds and return the offset of the corresponding - array element in the data part of the array. */ - -static long bigarray_offset(struct caml_bigarray * b, long * index) -{ - long offset; - int i; - - offset = 0; - if ((b->flags & BIGARRAY_LAYOUT_MASK) == BIGARRAY_C_LAYOUT) { - /* C-style layout: row major, indices start at 0 */ - for (i = 0; i < b->num_dims; i++) { - if ((unsigned long) index[i] >= (unsigned long) b->dim[i]) - array_bound_error(); - offset = offset * b->dim[i] + index[i]; - } - } else { - /* Fortran-style layout: column major, indices start at 1 */ - for (i = b->num_dims - 1; i >= 0; i--) { - if ((unsigned long) (index[i] - 1) >= (unsigned long) b->dim[i]) - array_bound_error(); - offset = offset * b->dim[i] + (index[i] - 1); - } - } - return offset; -} - -/* Helper function to allocate a record of two double floats */ - -static value copy_two_doubles(double d0, double d1) -{ - value res = alloc_small(2 * Double_wosize, Double_array_tag); - Store_double_field(res, 0, d0); - Store_double_field(res, 1, d1); - return res; -} - -/* Generic code to read from a big array */ - -value bigarray_get_N(value vb, value * vind, int nind) -{ - struct caml_bigarray * b = Bigarray_val(vb); - long index[MAX_NUM_DIMS]; - int i; - long offset; - - /* Check number of indices = number of dimensions of array - (maybe not necessary if ML typing guarantees this) */ - if (nind != b->num_dims) - invalid_argument("Bigarray.get: wrong number of indices"); - /* Compute offset and check bounds */ - for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]); - offset = bigarray_offset(b, index); - /* Perform read */ - switch ((b->flags) & BIGARRAY_KIND_MASK) { - default: - Assert(0); - case BIGARRAY_FLOAT32: - return copy_double(((float *) b->data)[offset]); - case BIGARRAY_FLOAT64: - return copy_double(((double *) b->data)[offset]); - case BIGARRAY_SINT8: - return Val_int(((schar *) b->data)[offset]); - case BIGARRAY_UINT8: - return Val_int(((unsigned char *) b->data)[offset]); - case BIGARRAY_SINT16: - return Val_int(((int16 *) b->data)[offset]); - case BIGARRAY_UINT16: - return Val_int(((uint16 *) b->data)[offset]); - case BIGARRAY_INT32: - return copy_int32(((int32 *) b->data)[offset]); - case BIGARRAY_INT64: - return copy_int64(((int64 *) b->data)[offset]); - case BIGARRAY_NATIVE_INT: - return copy_nativeint(((long *) b->data)[offset]); - case BIGARRAY_CAML_INT: - return Val_long(((long *) b->data)[offset]); - case BIGARRAY_COMPLEX32: - { float * p = ((float *) b->data) + offset * 2; - return copy_two_doubles(p[0], p[1]); } - case BIGARRAY_COMPLEX64: - { double * p = ((double *) b->data) + offset * 2; - return copy_two_doubles(p[0], p[1]); } - } -} - -CAMLprim value bigarray_get_1(value vb, value vind1) -{ - return bigarray_get_N(vb, &vind1, 1); -} - -CAMLprim value bigarray_get_2(value vb, value vind1, value vind2) -{ - value vind[2]; - vind[0] = vind1; vind[1] = vind2; - return bigarray_get_N(vb, vind, 2); -} - -CAMLprim value bigarray_get_3(value vb, value vind1, value vind2, value vind3) -{ - value vind[3]; - vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; - return bigarray_get_N(vb, vind, 3); -} - -#if 0 -CAMLprim value bigarray_get_4(value vb, value vind1, value vind2, - value vind3, value vind4) -{ - value vind[4]; - vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; - return bigarray_get_N(vb, vind, 4); -} - -CAMLprim value bigarray_get_5(value vb, value vind1, value vind2, - value vind3, value vind4, value vind5) -{ - value vind[5]; - vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; - vind[3] = vind4; vind[4] = vind5; - return bigarray_get_N(vb, vind, 5); -} - -CAMLprim value bigarray_get_6(value vb, value vind1, value vind2, - value vind3, value vind4, value vind5, value vind6) -{ - value vind[6]; - vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; - vind[3] = vind4; vind[4] = vind5; vind[5] = vind6; - return bigarray_get_N(vb, vind, 6); -} -#endif - -CAMLprim value bigarray_get_generic(value vb, value vind) -{ - return bigarray_get_N(vb, &Field(vind, 0), Wosize_val(vind)); -} - -/* Generic write to a big array */ - -static value bigarray_set_aux(value vb, value * vind, long nind, value newval) -{ - struct caml_bigarray * b = Bigarray_val(vb); - long index[MAX_NUM_DIMS]; - int i; - long offset; - - /* Check number of indices = number of dimensions of array - (maybe not necessary if ML typing guarantees this) */ - if (nind != b->num_dims) - invalid_argument("Bigarray.set: wrong number of indices"); - /* Compute offset and check bounds */ - for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]); - offset = bigarray_offset(b, index); - /* Perform write */ - switch (b->flags & BIGARRAY_KIND_MASK) { - default: - Assert(0); - case BIGARRAY_FLOAT32: - ((float *) b->data)[offset] = Double_val(newval); break; - case BIGARRAY_FLOAT64: - ((double *) b->data)[offset] = Double_val(newval); break; - case BIGARRAY_SINT8: - case BIGARRAY_UINT8: - ((schar *) b->data)[offset] = Int_val(newval); break; - case BIGARRAY_SINT16: - case BIGARRAY_UINT16: - ((int16 *) b->data)[offset] = Int_val(newval); break; - case BIGARRAY_INT32: - ((int32 *) b->data)[offset] = Int32_val(newval); break; - case BIGARRAY_INT64: - ((int64 *) b->data)[offset] = Int64_val(newval); break; - case BIGARRAY_NATIVE_INT: - ((long *) b->data)[offset] = Nativeint_val(newval); break; - case BIGARRAY_CAML_INT: - ((long *) b->data)[offset] = Long_val(newval); break; - case BIGARRAY_COMPLEX32: - { float * p = ((float *) b->data) + offset * 2; - p[0] = Double_field(newval, 0); - p[1] = Double_field(newval, 1); - break; } - case BIGARRAY_COMPLEX64: - { double * p = ((double *) b->data) + offset * 2; - p[0] = Double_field(newval, 0); - p[1] = Double_field(newval, 1); - break; } - } - return Val_unit; -} - -CAMLprim value bigarray_set_1(value vb, value vind1, value newval) -{ - return bigarray_set_aux(vb, &vind1, 1, newval); -} - -CAMLprim value bigarray_set_2(value vb, value vind1, value vind2, value newval) -{ - value vind[2]; - vind[0] = vind1; vind[1] = vind2; - return bigarray_set_aux(vb, vind, 2, newval); -} - -CAMLprim value bigarray_set_3(value vb, value vind1, value vind2, value vind3, - value newval) -{ - value vind[3]; - vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; - return bigarray_set_aux(vb, vind, 3, newval); -} - -#if 0 -CAMLprim value bigarray_set_4(value vb, value vind1, value vind2, - value vind3, value vind4, value newval) -{ - value vind[4]; - vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; - return bigarray_set_aux(vb, vind, 4, newval); -} - -CAMLprim value bigarray_set_5(value vb, value vind1, value vind2, - value vind3, value vind4, value vind5, value newval) -{ - value vind[5]; - vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; - vind[3] = vind4; vind[4] = vind5; - return bigarray_set_aux(vb, vind, 5, newval); -} - -CAMLprim value bigarray_set_6(value vb, value vind1, value vind2, - value vind3, value vind4, value vind5, - value vind6, value newval) -{ - value vind[6]; - vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; - vind[3] = vind4; vind[4] = vind5; vind[5] = vind6; - return bigarray_set_aux(vb, vind, 6, newval); -} - -value bigarray_set_N(value vb, value * vind, int nargs) -{ - return bigarray_set_aux(vb, vind, nargs - 1, vind[nargs - 1]); -} -#endif - -CAMLprim value bigarray_set_generic(value vb, value vind, value newval) -{ - return bigarray_set_aux(vb, &Field(vind, 0), Wosize_val(vind), newval); -} - -/* Return the number of dimensions of a big array */ - -CAMLprim value bigarray_num_dims(value vb) -{ - struct caml_bigarray * b = Bigarray_val(vb); - return Val_long(b->num_dims); -} - -/* Return the n-th dimension of a big array */ - -CAMLprim value bigarray_dim(value vb, value vn) -{ - struct caml_bigarray * b = Bigarray_val(vb); - long n = Long_val(vn); - if (n >= b->num_dims) invalid_argument("Bigarray.dim"); - return Val_long(b->dim[n]); -} - -/* Return the kind of a big array */ - -CAMLprim value bigarray_kind(value vb) -{ - return Val_int(Bigarray_val(vb)->flags & BIGARRAY_KIND_MASK); -} - -/* Return the layout of a big array */ - -CAMLprim value bigarray_layout(value vb) -{ - return Val_int(Bigarray_val(vb)->flags & BIGARRAY_LAYOUT_MASK); -} - -/* Finalization of a big array */ - -static void bigarray_finalize(value v) -{ - struct caml_bigarray * b = Bigarray_val(v); - - switch (b->flags & BIGARRAY_MANAGED_MASK) { - case BIGARRAY_EXTERNAL: - break; - case BIGARRAY_MANAGED: - if (b->proxy == NULL) { - free(b->data); - } else { - if (-- b->proxy->refcount == 0) { - free(b->proxy->data); - stat_free(b->proxy); - } - } - break; - case BIGARRAY_MAPPED_FILE: - if (b->proxy == NULL) { - bigarray_unmap_file(b->data, bigarray_byte_size(b)); - } else { - if (-- b->proxy->refcount == 0) { - bigarray_unmap_file(b->proxy->data, b->proxy->size); - stat_free(b->proxy); - } - } - break; - } -} - -/* Comparison of two big arrays */ - -static int bigarray_compare(value v1, value v2) -{ - struct caml_bigarray * b1 = Bigarray_val(v1); - struct caml_bigarray * b2 = Bigarray_val(v2); - unsigned long n, num_elts; - int i; - - /* Compare number of dimensions */ - if (b1->num_dims != b2->num_dims) return b2->num_dims - b1->num_dims; - /* Same number of dimensions: compare dimensions lexicographically */ - for (i = 0; i < b1->num_dims; i++) { - long d1 = b1->dim[i]; - long d2 = b2->dim[i]; - if (d1 != d2) return d1 < d2 ? -1 : 1; - } - /* Same dimensions: compare contents lexicographically */ - num_elts = bigarray_num_elts(b1); - -#define DO_INTEGER_COMPARISON(type) \ - { type * p1 = b1->data; type * p2 = b2->data; \ - for (n = 0; n < num_elts; n++) { \ - type e1 = *p1++; type e2 = *p2++; \ - if (e1 < e2) return -1; \ - if (e1 > e2) return 1; \ - } \ - return 0; \ - } -#define DO_FLOAT_COMPARISON(type) \ - { type * p1 = b1->data; type * p2 = b2->data; \ - for (n = 0; n < num_elts; n++) { \ - type e1 = *p1++; type e2 = *p2++; \ - if (e1 < e2) return -1; \ - if (e1 > e2) return 1; \ - if (e1 != e2) { \ - compare_unordered = 1; \ - if (e1 == e1) return 1; \ - if (e2 == e2) return -1; \ - } \ - } \ - return 0; \ - } - - switch (b1->flags & BIGARRAY_KIND_MASK) { - case BIGARRAY_COMPLEX32: - num_elts *= 2; /*fallthrough*/ - case BIGARRAY_FLOAT32: - DO_FLOAT_COMPARISON(float); - case BIGARRAY_COMPLEX64: - num_elts *= 2; /*fallthrough*/ - case BIGARRAY_FLOAT64: - DO_FLOAT_COMPARISON(double); - case BIGARRAY_SINT8: - DO_INTEGER_COMPARISON(schar); - case BIGARRAY_UINT8: - DO_INTEGER_COMPARISON(unsigned char); - case BIGARRAY_SINT16: - DO_INTEGER_COMPARISON(int16); - case BIGARRAY_UINT16: - DO_INTEGER_COMPARISON(uint16); - case BIGARRAY_INT32: - DO_INTEGER_COMPARISON(int32); - case BIGARRAY_INT64: -#ifdef ARCH_INT64_TYPE - DO_INTEGER_COMPARISON(int64); -#else - { int64 * p1 = b1->data; int64 * p2 = b2->data; - for (n = 0; n < num_elts; n++) { - int64 e1 = *p1++; int64 e2 = *p2++; - if ((int32)e1.h > (int32)e2.h) return 1; - if ((int32)e1.h < (int32)e2.h) return -1; - if (e1.l > e2.l) return 1; - if (e1.l < e2.l) return -1; - } - return 0; - } -#endif - case BIGARRAY_CAML_INT: - case BIGARRAY_NATIVE_INT: - DO_INTEGER_COMPARISON(long); - default: - Assert(0); - return 0; /* should not happen */ - } -#undef DO_INTEGER_COMPARISON -#undef DO_FLOAT_COMPARISON -} - -/* Hashing of a bigarray */ - -static long bigarray_hash(value v) -{ - struct caml_bigarray * b = Bigarray_val(v); - long num_elts, n, h; - int i; - - num_elts = 1; - for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i]; - if (num_elts >= 50) num_elts = 50; - h = 0; - -#define COMBINE(h,v) ((h << 4) + h + (v)) - - switch (b->flags & BIGARRAY_KIND_MASK) { - case BIGARRAY_SINT8: - case BIGARRAY_UINT8: { - unsigned char * p = b->data; - for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++); - break; - } - case BIGARRAY_SINT16: - case BIGARRAY_UINT16: { - unsigned short * p = b->data; - for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++); - break; - } - case BIGARRAY_FLOAT32: - case BIGARRAY_COMPLEX32: - case BIGARRAY_INT32: -#ifndef ARCH_SIXTYFOUR - case BIGARRAY_CAML_INT: - case BIGARRAY_NATIVE_INT: -#endif - { - uint32 * p = b->data; - for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++); - break; - } - case BIGARRAY_FLOAT64: - case BIGARRAY_COMPLEX64: - case BIGARRAY_INT64: -#ifdef ARCH_SIXTYFOUR - case BIGARRAY_CAML_INT: - case BIGARRAY_NATIVE_INT: -#endif -#ifdef ARCH_SIXTYFOUR - { - unsigned long * p = b->data; - for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++); - break; - } -#else - { - uint32 * p = b->data; - for (n = 0; n < num_elts; n++) { -#ifdef ARCH_BIG_ENDIAN - h = COMBINE(h, p[1]); h = COMBINE(h, p[0]); p += 2; -#else - h = COMBINE(h, p[0]); h = COMBINE(h, p[1]); p += 2; -#endif - } - break; - } -#endif - } -#undef COMBINE - return h; -} - -static void bigarray_serialize_longarray(void * data, - long num_elts, - long min_val, long max_val) -{ -#ifdef ARCH_SIXTYFOUR - int overflow_32 = 0; - long * p, n; - for (n = 0, p = data; n < num_elts; n++, p++) { - if (*p < min_val || *p > max_val) { overflow_32 = 1; break; } - } - if (overflow_32) { - serialize_int_1(1); - serialize_block_8(data, num_elts); - } else { - serialize_int_1(0); - for (n = 0, p = data; n < num_elts; n++, p++) serialize_int_4((int32) *p); - } -#else - serialize_int_1(0); - serialize_block_4(data, num_elts); -#endif -} - -static void bigarray_serialize(value v, - unsigned long * wsize_32, - unsigned long * wsize_64) -{ - struct caml_bigarray * b = Bigarray_val(v); - long num_elts; - int i; - - /* Serialize header information */ - serialize_int_4(b->num_dims); - serialize_int_4(b->flags & (BIGARRAY_KIND_MASK | BIGARRAY_LAYOUT_MASK)); - for (i = 0; i < b->num_dims; i++) serialize_int_4(b->dim[i]); - /* Compute total number of elements */ - num_elts = 1; - for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i]; - /* Serialize elements */ - switch (b->flags & BIGARRAY_KIND_MASK) { - case BIGARRAY_SINT8: - case BIGARRAY_UINT8: - serialize_block_1(b->data, num_elts); break; - case BIGARRAY_SINT16: - case BIGARRAY_UINT16: - serialize_block_2(b->data, num_elts); break; - case BIGARRAY_FLOAT32: - case BIGARRAY_INT32: - serialize_block_4(b->data, num_elts); break; - case BIGARRAY_COMPLEX32: - serialize_block_4(b->data, num_elts * 2); break; - case BIGARRAY_FLOAT64: - case BIGARRAY_INT64: - serialize_block_8(b->data, num_elts); break; - case BIGARRAY_COMPLEX64: - serialize_block_8(b->data, num_elts * 2); break; - case BIGARRAY_CAML_INT: - bigarray_serialize_longarray(b->data, num_elts, -0x40000000, 0x3FFFFFFF); - break; - case BIGARRAY_NATIVE_INT: - bigarray_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF); - break; - } - /* Compute required size in Caml heap. Assumes struct caml_bigarray - is exactly 4 + num_dims words */ - Assert(sizeof(struct caml_bigarray) == 5 * sizeof(value)); - *wsize_32 = (4 + b->num_dims) * 4; - *wsize_64 = (4 + b->num_dims) * 8; -} - -static void bigarray_deserialize_longarray(void * dest, long num_elts) -{ - int sixty = deserialize_uint_1(); -#ifdef ARCH_SIXTYFOUR - if (sixty) { - deserialize_block_8(dest, num_elts); - } else { - long * p, n; - for (n = 0, p = dest; n < num_elts; n++, p++) *p = deserialize_sint_4(); - } -#else - if (sixty) - deserialize_error("input_value: cannot read bigarray " - "with 64-bit Caml ints"); - deserialize_block_4(dest, num_elts); -#endif -} - -unsigned long bigarray_deserialize(void * dst) -{ - struct caml_bigarray * b = dst; - int i, elt_size; - unsigned long num_elts; - - /* Read back header information */ - b->num_dims = deserialize_uint_4(); - b->flags = deserialize_uint_4() | BIGARRAY_MANAGED; - b->proxy = NULL; - for (i = 0; i < b->num_dims; i++) b->dim[i] = deserialize_uint_4(); - /* Compute total number of elements */ - num_elts = bigarray_num_elts(b); - /* Determine element size in bytes */ - if ((b->flags & BIGARRAY_KIND_MASK) > BIGARRAY_COMPLEX64) - deserialize_error("input_value: bad bigarray kind"); - elt_size = bigarray_element_size[b->flags & BIGARRAY_KIND_MASK]; - /* Allocate room for data */ - b->data = malloc(elt_size * num_elts); - if (b->data == NULL) - deserialize_error("input_value: out of memory for bigarray"); - /* Read data */ - switch (b->flags & BIGARRAY_KIND_MASK) { - case BIGARRAY_SINT8: - case BIGARRAY_UINT8: - deserialize_block_1(b->data, num_elts); break; - case BIGARRAY_SINT16: - case BIGARRAY_UINT16: - deserialize_block_2(b->data, num_elts); break; - case BIGARRAY_FLOAT32: - case BIGARRAY_INT32: - deserialize_block_4(b->data, num_elts); break; - case BIGARRAY_COMPLEX32: - deserialize_block_4(b->data, num_elts * 2); break; - case BIGARRAY_FLOAT64: - case BIGARRAY_INT64: - deserialize_block_8(b->data, num_elts); break; - case BIGARRAY_COMPLEX64: - deserialize_block_8(b->data, num_elts * 2); break; - case BIGARRAY_CAML_INT: - case BIGARRAY_NATIVE_INT: - bigarray_deserialize_longarray(b->data, num_elts); break; - } - return sizeof(struct caml_bigarray) + (b->num_dims - 1) * sizeof(long); -} - -/* Create / update proxy to indicate that b2 is a sub-array of b1 */ - -static void bigarray_update_proxy(struct caml_bigarray * b1, - struct caml_bigarray * b2) -{ - struct caml_bigarray_proxy * proxy; - /* Nothing to do for un-managed arrays */ - if ((b1->flags & BIGARRAY_MANAGED_MASK) == BIGARRAY_EXTERNAL) return; - if (b1->proxy != NULL) { - /* If b1 is already a proxy for a larger array, increment refcount of - proxy */ - b2->proxy = b1->proxy; - ++ b1->proxy->refcount; - } else { - /* Otherwise, create proxy and attach it to both b1 and b2 */ - proxy = stat_alloc(sizeof(struct caml_bigarray_proxy)); - proxy->refcount = 2; /* original array + sub array */ - proxy->data = b1->data; - proxy->size = - b1->flags & BIGARRAY_MAPPED_FILE ? bigarray_byte_size(b1) : 0; - b1->proxy = proxy; - b2->proxy = proxy; - } -} - -/* Slicing */ - -CAMLprim value bigarray_slice(value vb, value vind) -{ - CAMLparam2 (vb, vind); - #define b ((struct caml_bigarray *) Bigarray_val(vb)) - CAMLlocal1 (res); - long index[MAX_NUM_DIMS]; - int num_inds, i; - long offset; - long * sub_dims; - char * sub_data; - - /* Check number of indices < number of dimensions of array */ - num_inds = Wosize_val(vind); - if (num_inds >= b->num_dims) - invalid_argument("Bigarray.slice: too many indices"); - /* Compute offset and check bounds */ - if ((b->flags & BIGARRAY_LAYOUT_MASK) == BIGARRAY_C_LAYOUT) { - /* We slice from the left */ - for (i = 0; i < num_inds; i++) index[i] = Long_val(Field(vind, i)); - for (/*nothing*/; i < b->num_dims; i++) index[i] = 0; - offset = bigarray_offset(b, index); - sub_dims = b->dim + num_inds; - } else { - /* We slice from the right */ - for (i = 0; i < num_inds; i++) - index[b->num_dims - num_inds + i] = Long_val(Field(vind, i)); - for (i = 0; i < b->num_dims - num_inds; i++) index[i] = 1; - offset = bigarray_offset(b, index); - sub_dims = b->dim; - } - sub_data = - (char *) b->data + - offset * bigarray_element_size[b->flags & BIGARRAY_KIND_MASK]; - /* Allocate a Caml bigarray to hold the result */ - res = alloc_bigarray(b->flags, b->num_dims - num_inds, sub_data, sub_dims); - /* Create or update proxy in case of managed bigarray */ - bigarray_update_proxy(b, Bigarray_val(res)); - /* Return result */ - CAMLreturn (res); - - #undef b -} - -/* Extracting a sub-array of same number of dimensions */ - -CAMLprim value bigarray_sub(value vb, value vofs, value vlen) -{ - CAMLparam3 (vb, vofs, vlen); - CAMLlocal1 (res); - #define b ((struct caml_bigarray *) Bigarray_val(vb)) - long ofs = Long_val(vofs); - long len = Long_val(vlen); - int i, changed_dim; - long mul; - char * sub_data; - - /* Compute offset and check bounds */ - if ((b->flags & BIGARRAY_LAYOUT_MASK) == BIGARRAY_C_LAYOUT) { - /* We reduce the first dimension */ - mul = 1; - for (i = 1; i < b->num_dims; i++) mul *= b->dim[i]; - changed_dim = 0; - } else { - /* We reduce the last dimension */ - mul = 1; - for (i = 0; i < b->num_dims - 1; i++) mul *= b->dim[i]; - changed_dim = b->num_dims - 1; - ofs--; /* Fortran arrays start at 1 */ - } - if (ofs < 0 || len < 0 || ofs + len > b->dim[changed_dim]) - invalid_argument("Bigarray.sub: bad sub-array"); - sub_data = - (char *) b->data + - ofs * mul * bigarray_element_size[b->flags & BIGARRAY_KIND_MASK]; - /* Allocate a Caml bigarray to hold the result */ - res = alloc_bigarray(b->flags, b->num_dims, sub_data, b->dim); - /* Doctor the changed dimension */ - Bigarray_val(res)->dim[changed_dim] = len; - /* Create or update proxy in case of managed bigarray */ - bigarray_update_proxy(b, Bigarray_val(res)); - /* Return result */ - CAMLreturn (res); - - #undef b -} - -/* Copying a big array into another one */ - -CAMLprim value bigarray_blit(value vsrc, value vdst) -{ - struct caml_bigarray * src = Bigarray_val(vsrc); - struct caml_bigarray * dst = Bigarray_val(vdst); - int i; - long num_bytes; - - /* Check same numbers of dimensions and same dimensions */ - if (src->num_dims != dst->num_dims) goto blit_error; - for (i = 0; i < src->num_dims; i++) - if (src->dim[i] != dst->dim[i]) goto blit_error; - /* Compute number of bytes in array data */ - num_bytes = - bigarray_num_elts(src) - * bigarray_element_size[src->flags & BIGARRAY_KIND_MASK]; - /* Do the copying */ - memmove (dst->data, src->data, num_bytes); - return Val_unit; - blit_error: - invalid_argument("Bigarray.blit: dimension mismatch"); - return Val_unit; /* not reached */ -} - -/* Filling a big array with a given value */ - -CAMLprim value bigarray_fill(value vb, value vinit) -{ - struct caml_bigarray * b = Bigarray_val(vb); - long num_elts = bigarray_num_elts(b); - - switch (b->flags & BIGARRAY_KIND_MASK) { - default: - Assert(0); - case BIGARRAY_FLOAT32: { - float init = Double_val(vinit); - float * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; - break; - } - case BIGARRAY_FLOAT64: { - double init = Double_val(vinit); - double * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; - break; - } - case BIGARRAY_SINT8: - case BIGARRAY_UINT8: { - int init = Int_val(vinit); - char * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; - break; - } - case BIGARRAY_SINT16: - case BIGARRAY_UINT16: { - int init = Int_val(vinit); - short * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; - break; - } - case BIGARRAY_INT32: { - int32 init = Int32_val(vinit); - int32 * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; - break; - } - case BIGARRAY_INT64: { - int64 init = Int64_val(vinit); - int64 * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; - break; - } - case BIGARRAY_NATIVE_INT: { - long init = Nativeint_val(vinit); - long * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; - break; - } - case BIGARRAY_CAML_INT: { - long init = Long_val(vinit); - long * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; - break; - } - case BIGARRAY_COMPLEX32: { - float init0 = Double_field(vinit, 0); - float init1 = Double_field(vinit, 1); - float * p; - for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; } - break; - } - case BIGARRAY_COMPLEX64: { - double init0 = Double_field(vinit, 0); - double init1 = Double_field(vinit, 1); - double * p; - for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; } - break; - } - } - return Val_unit; -} - -/* Reshape an array: change dimensions and number of dimensions, preserving - array contents */ - -CAMLprim value bigarray_reshape(value vb, value vdim) -{ - CAMLparam2 (vb, vdim); - CAMLlocal1 (res); - #define b ((struct caml_bigarray *) Bigarray_val(vb)) - long dim[MAX_NUM_DIMS]; - mlsize_t num_dims; - unsigned long num_elts; - int i; - - num_dims = Wosize_val(vdim); - if (num_dims < 1 || num_dims > MAX_NUM_DIMS) - invalid_argument("Bigarray.reshape: bad number of dimensions"); - num_elts = 1; - for (i = 0; i < num_dims; i++) { - dim[i] = Long_val(Field(vdim, i)); - if (dim[i] < 0 || dim[i] > 0x7FFFFFFFL) - invalid_argument("Bigarray.reshape: negative dimension"); - num_elts *= dim[i]; - } - /* Check that sizes agree */ - if (num_elts != bigarray_num_elts(b)) - invalid_argument("Bigarray.reshape: size mismatch"); - /* Create bigarray with same data and new dimensions */ - res = alloc_bigarray(b->flags, num_dims, b->data, dim); - /* Create or update proxy in case of managed bigarray */ - bigarray_update_proxy(b, Bigarray_val(res)); - /* Return result */ - CAMLreturn (res); - - #undef b -} - -/* Initialization */ - -CAMLprim value bigarray_init(value unit) -{ - register_custom_operations(&bigarray_ops); - return Val_unit; -} diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c deleted file mode 100644 index e0f649f920..0000000000 --- a/otherlibs/bigarray/mmap_unix.c +++ /dev/null @@ -1,117 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <stddef.h> -#include <string.h> -#include "bigarray.h" -#include "custom.h" -#include "fail.h" -#include "mlvalues.h" -#include "sys.h" - -extern int bigarray_element_size[]; /* from bigarray_stubs.c */ - -#ifdef HAS_UNISTD -#include <unistd.h> -#endif -#ifdef HAS_MMAP -#include <sys/types.h> -#include <sys/mman.h> -#endif - -#if defined(HAS_MMAP) - -#ifndef MAP_FAILED -#define MAP_FAILED ((void *) -1) -#endif - -CAMLprim value bigarray_map_file(value vfd, value vkind, value vlayout, - value vshared, value vdim) -{ - int fd, flags, major_dim, shared; - long num_dims, i; - long dim[MAX_NUM_DIMS]; - long currpos, file_size; - unsigned long array_size; - char c; - void * addr; - - fd = Int_val(vfd); - flags = Int_val(vkind) | Int_val(vlayout); - num_dims = Wosize_val(vdim); - major_dim = flags & BIGARRAY_FORTRAN_LAYOUT ? num_dims - 1 : 0; - /* Extract dimensions from Caml array */ - num_dims = Wosize_val(vdim); - if (num_dims < 1 || num_dims > MAX_NUM_DIMS) - invalid_argument("Bigarray.mmap: bad number of dimensions"); - for (i = 0; i < num_dims; i++) { - dim[i] = Long_val(Field(vdim, i)); - if (dim[i] == -1 && i == major_dim) continue; - if (dim[i] < 0 || dim[i] > 0x7FFFFFFFL) - invalid_argument("Bigarray.create: negative dimension"); - } - /* Determine file size */ - currpos = lseek(fd, 0, SEEK_CUR); - if (currpos == -1) sys_error(NO_ARG); - file_size = lseek(fd, 0, SEEK_END); - if (file_size == -1) sys_error(NO_ARG); - /* Determine array size in bytes (or size of array without the major - dimension if that dimension wasn't specified) */ - array_size = bigarray_element_size[flags & BIGARRAY_KIND_MASK]; - for (i = 0; i < num_dims; i++) - if (dim[i] != -1) array_size *= dim[i]; - /* Check if the first/last dimension is unknown */ - if (dim[major_dim] == -1) { - /* Determine first/last dimension from file size */ - if ((unsigned long) file_size % array_size != 0) - failwith("Bigarray.mmap: file size doesn't match array dimensions"); - dim[major_dim] = (unsigned long) file_size / array_size; - array_size = file_size; - } else { - /* Check that file is large enough, and grow it otherwise */ - if (file_size < array_size) { - if (lseek(fd, array_size - 1, SEEK_SET) == -1) sys_error(NO_ARG); - c = 0; - if (write(fd, &c, 1) != 1) sys_error(NO_ARG); - } - } - /* Restore original file position */ - lseek(fd, currpos, SEEK_SET); - /* Do the mmap */ - shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE; - addr = mmap(NULL, array_size, PROT_READ | PROT_WRITE, shared, fd, 0); - if (addr == (void *) MAP_FAILED) sys_error(NO_ARG); - /* Build and return the Caml bigarray */ - return alloc_bigarray(flags | BIGARRAY_MAPPED_FILE, num_dims, addr, dim); -} - -#else - -value bigarray_map_file(value vfd, value vkind, value vlayout, - value vshared, value vdim) -{ - invalid_argument("Bigarray.map_file: not supported"); - return Val_unit; -} - -#endif - - -void bigarray_unmap_file(void * addr, unsigned long len) -{ -#if defined(HAS_MMAP) - munmap(addr, len); -#endif -} diff --git a/otherlibs/bigarray/mmap_win32.c b/otherlibs/bigarray/mmap_win32.c deleted file mode 100644 index a3701611d7..0000000000 --- a/otherlibs/bigarray/mmap_win32.c +++ /dev/null @@ -1,116 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <stddef.h> -#include <stdio.h> -#include <string.h> -#include "bigarray.h" -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "mlvalues.h" -#include "sys.h" -#include "unixsupport.h" - -extern int bigarray_element_size[]; /* from bigarray_stubs.c */ - -static void bigarray_sys_error(void); - -CAMLprim value bigarray_map_file(value vfd, value vkind, value vlayout, - value vshared, value vdim) -{ - HANDLE fd, fmap; - int flags, major_dim, mode, perm; - long num_dims, i; - long dim[MAX_NUM_DIMS]; - long currpos, file_size; - unsigned long array_size; - char c; - void * addr; - - fd = Handle_val(vfd); - flags = Int_val(vkind) | Int_val(vlayout); - num_dims = Wosize_val(vdim); - major_dim = flags & BIGARRAY_FORTRAN_LAYOUT ? num_dims - 1 : 0; - /* Extract dimensions from Caml array */ - num_dims = Wosize_val(vdim); - if (num_dims < 1 || num_dims > MAX_NUM_DIMS) - invalid_argument("Bigarray.mmap: bad number of dimensions"); - for (i = 0; i < num_dims; i++) { - dim[i] = Long_val(Field(vdim, i)); - if (dim[i] == -1 && i == major_dim) continue; - if (dim[i] < 0 || dim[i] > 0x7FFFFFFFL) - invalid_argument("Bigarray.create: negative dimension"); - } - /* Determine file size */ - currpos = SetFilePointer(fd, 0, NULL, FILE_CURRENT); - if (currpos == -1) bigarray_sys_error(); - file_size = SetFilePointer(fd, 0, NULL, FILE_END); - if (file_size == -1) bigarray_sys_error(); - /* Determine array size in bytes (or size of array without the major - dimension if that dimension wasn't specified) */ - array_size = bigarray_element_size[flags & BIGARRAY_KIND_MASK]; - for (i = 0; i < num_dims; i++) - if (dim[i] != -1) array_size *= dim[i]; - /* Check if the first/last dimension is unknown */ - if (dim[major_dim] == -1) { - /* Determine first/last dimension from file size */ - if ((unsigned long) file_size % array_size != 0) - failwith("Bigarray.mmap: file size doesn't match array dimensions"); - dim[major_dim] = (unsigned long) file_size / array_size; - array_size = file_size; - } - /* Restore original file position */ - SetFilePointer(fd, currpos, NULL, FILE_BEGIN); - /* Create the file mapping */ - if (Bool_val(vshared)) { - perm = PAGE_READWRITE; - mode = FILE_MAP_WRITE; - } else { - perm = PAGE_READONLY; /* doesn't work under Win98 */ - mode = FILE_MAP_COPY; - } - fmap = CreateFileMapping(fd, NULL, perm, 0, array_size, NULL); - if (fmap == NULL) bigarray_sys_error(); - /* Map the mapping in memory */ - addr = MapViewOfFile(fmap, mode, 0, 0, array_size); - if (addr == NULL) bigarray_sys_error(); - /* Close the file mapping */ - CloseHandle(fmap); - /* Build and return the Caml bigarray */ - return alloc_bigarray(flags | BIGARRAY_MAPPED_FILE, num_dims, addr, dim); -} - -void bigarray_unmap_file(void * addr, unsigned long len) -{ - UnmapViewOfFile(addr); -} - -static void bigarray_sys_error(void) -{ - char buffer[512]; - unsigned long errnum; - - errnum = GetLastError(); - if (!FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS, - NULL, - errnum, - 0, - buffer, - sizeof(buffer), - NULL)) - sprintf(buffer, "Unknown error %ld\n", errnum); - raise_sys_error(copy_string(buffer)); -} diff --git a/otherlibs/db/.depend b/otherlibs/db/.depend deleted file mode 100644 index 5d94dce520..0000000000 --- a/otherlibs/db/.depend +++ /dev/null @@ -1,2 +0,0 @@ -db.cmo: db.cmi -db.cmx: db.cmi diff --git a/otherlibs/dbm/.cvsignore b/otherlibs/dbm/.cvsignore deleted file mode 100644 index 074dd28a45..0000000000 --- a/otherlibs/dbm/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -so_locations diff --git a/otherlibs/dbm/.depend b/otherlibs/dbm/.depend deleted file mode 100644 index 6fa318eed6..0000000000 --- a/otherlibs/dbm/.depend +++ /dev/null @@ -1,2 +0,0 @@ -dbm.cmo: dbm.cmi -dbm.cmx: dbm.cmi diff --git a/otherlibs/dbm/Makefile b/otherlibs/dbm/Makefile deleted file mode 100644 index 394586416c..0000000000 --- a/otherlibs/dbm/Makefile +++ /dev/null @@ -1,73 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the ndbm library - -include ../../config/Makefile - -# Compilation optiosn -CC=$(BYTECC) -g -CAMLC=../../ocamlcomp.sh -CAMLOPT=../../ocamlcompopt.sh -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A - -CFLAGS=$(DBM_INCLUDES) -I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -COBJS=cldbm.o - -all: libmldbm.a dbm.cmi dbm.cma - -allopt: libmldbm.a dbm.cmi dbm.cmxa - -libmldbm.a: $(COBJS) - $(MKLIB) -oc mldbm $(COBJS) $(DBM_LINK) - -dbm.cma: dbm.cmo - $(MKLIB) -ocamlc '$(CAMLC)' -o dbm -oc mldbm dbm.cmo $(DBM_LINK) - -dbm.cmxa: dbm.cmx - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o dbm -oc mldbm dbm.cmx $(DBM_LINK) - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.a *.o *.so - -install: - if test -f dllmldbm.so; then cp dllmldbm.so $(STUBLIBDIR)/dllmldbm.so; fi - cp libmldbm.a $(LIBDIR)/libmldbm.a - cd $(LIBDIR); $(RANLIB) libmldbm.a - cp dbm.cma dbm.cmi dbm.mli $(LIBDIR) - -installopt: - cp dbm.cmx dbm.cmxa dbm.a $(LIBDIR) - cd $(LIBDIR); $(RANLIB) dbm.a - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/dbm/cldbm.c b/otherlibs/dbm/cldbm.c deleted file mode 100644 index a9da59b3db..0000000000 --- a/otherlibs/dbm/cldbm.c +++ /dev/null @@ -1,166 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Francois Rouaix, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <string.h> -#include <fcntl.h> -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <fail.h> -#include <callback.h> - -#ifdef DBM_USES_GDBM_NDBM -#include <gdbm-ndbm.h> -#else -#include <ndbm.h> -#endif - -/* Quite close to sys_open_flags, but we need RDWR */ -static int dbm_open_flags[] = { - O_RDONLY, O_WRONLY, O_RDWR, O_CREAT -}; - -static void raise_dbm (char *errmsg) Noreturn; - -static void raise_dbm(char *errmsg) -{ - static value * dbm_exn = NULL; - if (dbm_exn == NULL) - dbm_exn = caml_named_value("dbmerror"); - raise_with_string(*dbm_exn, errmsg); -} - -#define DBM_val(v) *((DBM **) &Field(v, 0)) - -static value alloc_dbm(DBM * db) -{ - value res = alloc_small(1, Abstract_tag); - DBM_val(res) = db; - return res; -} - -static DBM * extract_dbm(value vdb) -{ - if (DBM_val(vdb) == NULL) raise_dbm("DBM has been closed"); - return DBM_val(vdb); -} - -/* Dbm.open : string -> Sys.open_flag list -> int -> t */ -value caml_dbm_open(value vfile, value vflags, value vmode) /* ML */ -{ - char *file = String_val(vfile); - int flags = convert_flag_list(vflags, dbm_open_flags); - int mode = Int_val(vmode); - DBM *db = dbm_open(file,flags,mode); - - if (db == NULL) - raise_dbm("Can't open file"); - else - return (alloc_dbm(db)); -} - -/* Dbm.close: t -> unit */ -value caml_dbm_close(value vdb) /* ML */ -{ - dbm_close(extract_dbm(vdb)); - DBM_val(vdb) = NULL; - return Val_unit; -} - -/* Dbm.fetch: t -> string -> string */ -value caml_dbm_fetch(value vdb, value vkey) /* ML */ -{ - datum key,answer; - key.dptr = String_val(vkey); - key.dsize = string_length(vkey); - answer = dbm_fetch(extract_dbm(vdb), key); - if (answer.dptr) { - value res = alloc_string(answer.dsize); - memmove (String_val (res), answer.dptr, answer.dsize); - return res; - } - else raise_not_found(); -} - -value caml_dbm_insert(value vdb, value vkey, value vcontent) /* ML */ -{ - datum key, content; - - key.dptr = String_val(vkey); - key.dsize = string_length(vkey); - content.dptr = String_val(vcontent); - content.dsize = string_length(vcontent); - - switch(dbm_store(extract_dbm(vdb), key, content, DBM_INSERT)) { - case 0: - return Val_unit; - case 1: /* DBM_INSERT and already existing */ - raise_dbm("Entry already exists"); - default: - raise_dbm("dbm_store failed"); - } -} - -value caml_dbm_replace(value vdb, value vkey, value vcontent) /* ML */ -{ - datum key, content; - - key.dptr = String_val(vkey); - key.dsize = string_length(vkey); - content.dptr = String_val(vcontent); - content.dsize = string_length(vcontent); - - switch(dbm_store(extract_dbm(vdb), key, content, DBM_REPLACE)) { - case 0: - return Val_unit; - default: - raise_dbm("dbm_store failed"); - } -} - -value caml_dbm_delete(value vdb, value vkey) /* ML */ -{ - datum key; - key.dptr = String_val(vkey); - key.dsize = string_length(vkey); - - if (dbm_delete(extract_dbm(vdb), key) < 0) - raise_dbm("dbm_delete"); - else return Val_unit; -} - -value caml_dbm_firstkey(value vdb) /* ML */ -{ - datum key = dbm_firstkey(extract_dbm(vdb)); - - if (key.dptr) { - value res = alloc_string(key.dsize); - memmove (String_val (res), key.dptr, key.dsize); - return res; - } - else raise_not_found(); -} - -value caml_dbm_nextkey(value vdb) /* ML */ -{ - datum key = dbm_nextkey(extract_dbm(vdb)); - - if (key.dptr) { - value res = alloc_string(key.dsize); - memmove (String_val (res), key.dptr, key.dsize); - return res; - } - else raise_not_found(); -} diff --git a/otherlibs/dbm/dbm.ml b/otherlibs/dbm/dbm.ml deleted file mode 100644 index c98f7fe24d..0000000000 --- a/otherlibs/dbm/dbm.ml +++ /dev/null @@ -1,58 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Francois Rouaix, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type t - -type open_flag = - Dbm_rdonly | Dbm_wronly | Dbm_rdwr | Dbm_create - -type dbm_flag = - DBM_INSERT - | DBM_REPLACE - -exception Dbm_error of string - -external raw_opendbm : string -> open_flag list -> int -> t - = "caml_dbm_open" - -let opendbm file flags mode = - try - raw_opendbm file flags mode - with Dbm_error msg -> - raise(Dbm_error("Can't open file " ^ file)) - - (* By exporting opendbm as val, we are sure to link in this - file (we must register the exception). Since t is abstract, programs - have to call it in order to do anything *) - -external close : t -> unit = "caml_dbm_close" -external find : t -> string -> string = "caml_dbm_fetch" -external add : t -> string -> string -> unit = "caml_dbm_insert" -external replace : t -> string -> string -> unit = "caml_dbm_replace" -external remove : t -> string -> unit = "caml_dbm_delete" -external firstkey : t -> string = "caml_dbm_firstkey" -external nextkey : t -> string = "caml_dbm_nextkey" - -let _ = Callback.register_exception "dbmerror" (Dbm_error "") - -(* Usual iterator *) -let iter f t = - let rec walk = function - None -> () - | Some k -> - f k (find t k); - walk (try Some(nextkey t) with Not_found -> None) - in - walk (try Some(firstkey t) with Not_found -> None) diff --git a/otherlibs/dbm/dbm.mli b/otherlibs/dbm/dbm.mli deleted file mode 100644 index d451745f9e..0000000000 --- a/otherlibs/dbm/dbm.mli +++ /dev/null @@ -1,80 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Francois Rouaix, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Interface to the NDBM database. *) - -type t -(** The type of file descriptors opened on NDBM databases. *) - - -type open_flag = - Dbm_rdonly - | Dbm_wronly - | Dbm_rdwr - | Dbm_create -(** Flags for opening a database (see {!Dbm.opendbm}). *) - - -exception Dbm_error of string -(** Raised by the following functions when an error is encountered. *) - -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 - the database for reading only, [Dbm_wronly] for writing only, - [Dbm_rdwr] for reading and writing; [Dbm_create] causes the - database to be created if it does not already exist. - The third argument is the permissions to give to the database - files, if the database is created. *) - -external close : t -> unit = "caml_dbm_close" -(** Close the given descriptor. *) - -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 -> 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 -> 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 - replaced by the new [data]. *) - -external remove : t -> string -> unit = "caml_dbm_delete" -(** [remove db key data] removes the data associated with [key] - in [db]. If [key] has no associated data, raise - [Dbm_error "dbm_delete"]. *) - -external firstkey : t -> string = "caml_dbm_firstkey" -(** See {!Dbm.nextkey}.*) - -external nextkey : t -> string = "caml_dbm_nextkey" -(** Enumerate all keys in the given database, in an unspecified order. - [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 : (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/.cvsignore b/otherlibs/dynlink/.cvsignore deleted file mode 100644 index 5ea9775e1d..0000000000 --- a/otherlibs/dynlink/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -extract_crc diff --git a/otherlibs/dynlink/.depend b/otherlibs/dynlink/.depend deleted file mode 100644 index 251aef84c3..0000000000 --- a/otherlibs/dynlink/.depend +++ /dev/null @@ -1,10 +0,0 @@ -dynlink.cmo: ../../utils/config.cmi ../../utils/consistbl.cmi \ - ../../bytecomp/dll.cmi ../../bytecomp/emitcode.cmi \ - ../../bytecomp/meta.cmi ../../utils/misc.cmi ../../bytecomp/opcodes.cmo \ - ../../bytecomp/symtable.cmi dynlink.cmi -dynlink.cmx: ../../utils/config.cmx ../../utils/consistbl.cmx \ - ../../bytecomp/dll.cmx ../../bytecomp/emitcode.cmx \ - ../../bytecomp/meta.cmx ../../utils/misc.cmx ../../bytecomp/opcodes.cmx \ - ../../bytecomp/symtable.cmx dynlink.cmi -extract_crc.cmo: dynlink.cmi -extract_crc.cmx: dynlink.cmx diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile deleted file mode 100644 index 43b9599ca8..0000000000 --- a/otherlibs/dynlink/Makefile +++ /dev/null @@ -1,61 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the dynamic link library - -include ../../config/Makefile - -CAMLC=../../boot/ocamlrun ../../ocamlc -INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp -COMPFLAGS=-warn-error A -I ../../stdlib $(INCLUDES) - -OBJS=dynlink.cmo -COMPILEROBJS=misc.cmo config.cmo tbl.cmo clflags.cmo consistbl.cmo \ - ident.cmo path.cmo \ - types.cmo btype.cmo predef.cmo runtimedef.cmo \ - bytesections.cmo dll.cmo symtable.cmo opcodes.cmo meta.cmo - -all: dynlink.cma extract_crc - -allopt: - -dynlink.cma: $(OBJS) - $(CAMLC) $(COMPFLAGS) -a -o dynlink.cma $(COMPILEROBJS) $(OBJS) - -extract_crc: dynlink.cma extract_crc.cmo - $(CAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo - -install: - cp dynlink.cmi dynlink.cma dynlink.mli extract_crc $(LIBDIR) - -installopt: - -partialclean: - rm -f extract_crc *.cm[ioa] - -clean: partialclean - -.SUFFIXES: .ml .mli .cmo .cmi - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -depend: - ../../boot/ocamlrun ../../tools/ocamldep $(INCLUDES) *.mli *.ml >.depend - -include .depend diff --git a/otherlibs/dynlink/Makefile.Mac b/otherlibs/dynlink/Makefile.Mac deleted file mode 100644 index 3b7fca1cb5..0000000000 --- a/otherlibs/dynlink/Makefile.Mac +++ /dev/null @@ -1,56 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the dynamic link library - -CAMLC = :::boot:ocamlrun :::ocamlc -INCLUDES = -I :::utils: -I :::typing: -I :::bytecomp: -COMPFLAGS = -I :::stdlib: {INCLUDES} - -OBJS = dynlink.cmo -COMPILEROBJS = misc.cmo config.cmo tbl.cmo ¶ - clflags.cmo ident.cmo path.cmo ¶ - types.cmo btype.cmo predef.cmo runtimedef.cmo ¶ - bytesections.cmo dll.cmo symtable.cmo opcodes.cmo meta.cmo - -all Ä dynlink.cma extract_crc - -allopt Ä - -dynlink.cma Ä {OBJS} - {CAMLC} {COMPFLAGS} -a -o dynlink.cma {COMPILEROBJS} {OBJS} - -extract_crc Ä dynlink.cma extract_crc.cmo - {CAMLC} {COMPFLAGS} -o extract_crc dynlink.cma extract_crc.cmo - -install Ä - duplicate -y dynlink.cmi dynlink.cma extract_crc "{LIBDIR}" - -installopt Ä - -partialclean Ä - delete -i extract_crc - delete -i Å.cm[aio] || set status 0 - -clean Ä partialclean - -.cmi Ä .mli - {CAMLC} -c {COMPFLAGS} {default}.mli - -.cmo Ä .ml - {CAMLC} -c {COMPFLAGS} {default}.ml - -depend Ä - :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml > Makefile.Mac.depend diff --git a/otherlibs/dynlink/Makefile.Mac.depend b/otherlibs/dynlink/Makefile.Mac.depend deleted file mode 100644 index 6a7522b5be..0000000000 --- a/otherlibs/dynlink/Makefile.Mac.depend +++ /dev/null @@ -1,4 +0,0 @@ -dynlink.cmoÄ dynlink.cmi -dynlink.cmxÄ dynlink.cmi -extract_crc.cmoÄ dynlink.cmi -extract_crc.cmxÄ dynlink.cmx diff --git a/otherlibs/dynlink/Makefile.nt b/otherlibs/dynlink/Makefile.nt deleted file mode 100644 index 6718083d93..0000000000 --- a/otherlibs/dynlink/Makefile.nt +++ /dev/null @@ -1,62 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the dynamic link library - -include ../../config/Makefile - -CAMLC=../../boot/ocamlrun ../../ocamlc -INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp -COMPFLAGS=-warn-error A -I ../../stdlib $(INCLUDES) - -OBJS=dynlink.cmo -COMPILEROBJS=misc.cmo config.cmo tbl.cmo clflags.cmo consistbl.cmo \ - ident.cmo path.cmo \ - types.cmo btype.cmo predef.cmo runtimedef.cmo \ - bytesections.cmo dll.cmo symtable.cmo opcodes.cmo meta.cmo - -all: dynlink.cma extract_crc - -allopt: - -dynlink.cma: $(OBJS) - $(CAMLC) $(COMPFLAGS) -a -o dynlink.cma $(COMPILEROBJS) $(OBJS) - -extract_crc: dynlink.cma extract_crc.cmo - $(CAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo - -install: - cp dynlink.cmi dynlink.cma dynlink.mli $(LIBDIR) - cp extract_crc $(LIBDIR)/extract_crc.exe - -installopt: - -partialclean: - rm -f extract_crc *.cm[ioa] - -clean: partialclean - -.SUFFIXES: .ml .mli .cmo .cmi - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -depend: - ../../boot/ocamlrun ../../tools/ocamldep $(INCLUDES) *.mli *.ml >.depend - -include .depend diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml deleted file mode 100644 index 2d4047a615..0000000000 --- a/otherlibs/dynlink/dynlink.ml +++ /dev/null @@ -1,248 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Dynamic loading of .cmo files *) - -open Emitcode - -type linking_error = - Undefined_global of string - | Unavailable_primitive of string - | Uninitialized_global of string - -type error = - Not_a_bytecode_file of string - | Inconsistent_import of string - | Unavailable_unit of string - | Unsafe_file - | Linking_error of string * linking_error - | Corrupted_interface of string - | File_not_found of string - | Cannot_open_dll of string - -exception Error of error - -(* Management of interface CRCs *) - -let crc_interfaces = ref (Consistbl.create ()) -let allow_extension = ref true - -(* Check that the object file being loaded has been compiled against - the same interfaces as the program itself. In addition, check that - only authorized compilation units are referenced. *) - -let check_consistency file_name cu = - try - List.iter - (fun (name, crc) -> - if name = cu.cu_name then - Consistbl.set !crc_interfaces name crc file_name - else if !allow_extension then - Consistbl.check !crc_interfaces name crc file_name - else - Consistbl.check_noadd !crc_interfaces name crc file_name) - cu.cu_imports - with Consistbl.Inconsistency(name, user, auth) -> - raise(Error(Inconsistent_import name)) - | Consistbl.Not_available(name) -> - raise(Error(Unavailable_unit name)) - -(* Empty the crc_interfaces table *) - -let clear_available_units () = - Consistbl.clear !crc_interfaces; - allow_extension := false - -(* Allow only access to the units with the given names *) - -let allow_only names = - Consistbl.filter (fun name -> List.mem name names) !crc_interfaces; - allow_extension := false - -(* Prohibit access to the units with the given names *) - -let prohibit names = - Consistbl.filter (fun name -> not (List.mem name names)) !crc_interfaces; - allow_extension := false - -(* Initialize the crc_interfaces table with a list of units with fixed CRCs *) - -let add_available_units units = - List.iter (fun (unit, crc) -> Consistbl.set !crc_interfaces unit crc "") - units - -(* Default interface CRCs: those found in the current executable *) -let default_crcs = ref [] - -let default_available_units () = - clear_available_units(); - add_available_units !default_crcs; - allow_extension := true - -(* Initialize the linker tables and everything *) - -let init () = - default_crcs := Symtable.init_toplevel(); - default_available_units () - -(* Read the CRC of an interface from its .cmi file *) - -let digest_interface unit loadpath = - let filename = - let shortname = unit ^ ".cmi" in - try - Misc.find_in_path_uncap loadpath shortname - with Not_found -> - raise (Error(File_not_found shortname)) in - let ic = open_in_bin filename in - try - let buffer = String.create (String.length Config.cmi_magic_number) in - really_input ic buffer 0 (String.length Config.cmi_magic_number); - if buffer <> Config.cmi_magic_number then begin - close_in ic; - raise(Error(Corrupted_interface filename)) - end; - input_value ic; - let crc = - match input_value ic with - (_, crc) :: _ -> crc - | _ -> raise(Error(Corrupted_interface filename)) - in - close_in ic; - crc - with End_of_file | Failure _ -> - close_in ic; - raise(Error(Corrupted_interface filename)) - -(* Initialize the crc_interfaces table with a list of units. - Their CRCs are read from their interfaces. *) - -let add_interfaces units loadpath = - add_available_units - (List.map (fun unit -> (unit, digest_interface unit loadpath)) units) - -(* Check whether the object file being loaded was compiled in unsafe mode *) - -let unsafe_allowed = ref false - -let allow_unsafe_modules b = - unsafe_allowed := b - -let check_unsafe_module cu = - if (not !unsafe_allowed) && cu.cu_primitives <> [] - then raise(Error(Unsafe_file)) - -(* Load in-core and execute a bytecode object file *) - -let load_compunit ic file_name compunit = - check_consistency file_name compunit; - check_unsafe_module compunit; - seek_in ic compunit.cu_pos; - let code_size = compunit.cu_codesize + 8 in - let code = Meta.static_alloc code_size in - unsafe_really_input ic code 0 compunit.cu_codesize; - String.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); - String.unsafe_set code (compunit.cu_codesize + 1) '\000'; - String.unsafe_set code (compunit.cu_codesize + 2) '\000'; - String.unsafe_set code (compunit.cu_codesize + 3) '\000'; - String.unsafe_set code (compunit.cu_codesize + 4) '\001'; - String.unsafe_set code (compunit.cu_codesize + 5) '\000'; - String.unsafe_set code (compunit.cu_codesize + 6) '\000'; - String.unsafe_set code (compunit.cu_codesize + 7) '\000'; - let initial_symtable = Symtable.current_state() in - begin try - Symtable.patch_object code compunit.cu_reloc; - Symtable.check_global_initialized compunit.cu_reloc; - Symtable.update_global_table() - with Symtable.Error error -> - let new_error = - match error with - Symtable.Undefined_global s -> Undefined_global s - | Symtable.Unavailable_primitive s -> Unavailable_primitive s - | Symtable.Uninitialized_global s -> Uninitialized_global s - | _ -> assert false in - raise(Error(Linking_error (file_name, new_error))) - end; - begin try - ignore((Meta.reify_bytecode code code_size) ()) - with exn -> - Symtable.restore_state initial_symtable; - raise exn - end - -let loadfile file_name = - let ic = open_in_bin file_name in - try - let buffer = String.create (String.length Config.cmo_magic_number) in - really_input ic buffer 0 (String.length Config.cmo_magic_number); - if buffer = Config.cmo_magic_number then begin - let compunit_pos = input_binary_int ic in (* Go to descriptor *) - seek_in ic compunit_pos; - load_compunit ic file_name (input_value ic : compilation_unit) - end else - if buffer = Config.cma_magic_number then begin - let toc_pos = input_binary_int ic in (* Go to table of contents *) - seek_in ic toc_pos; - let lib = (input_value ic : library) in - begin try - Dll.open_dlls (List.map Dll.extract_dll_name lib.lib_dllibs) - with Failure reason -> - raise(Error(Cannot_open_dll reason)) - end; - List.iter (load_compunit ic file_name) lib.lib_units - end else - raise(Error(Not_a_bytecode_file file_name)); - close_in ic - with exc -> - close_in ic; raise exc - -let loadfile_private file_name = - let initial_symtable = Symtable.current_state() - and initial_crc = !crc_interfaces in - try - loadfile file_name; - Symtable.hide_additions initial_symtable; - crc_interfaces := initial_crc - with exn -> - Symtable.hide_additions initial_symtable; - crc_interfaces := initial_crc; - raise exn - -(* Error report *) - -let error_message = function - Not_a_bytecode_file name -> - name ^ " is not a bytecode object file" - | Inconsistent_import name -> - "interface mismatch on " ^ name - | Unavailable_unit name -> - "no implementation available for " ^ name - | Unsafe_file -> - "this object file uses unsafe features" - | Linking_error (name, Undefined_global s) -> - "error while linking " ^ name ^ ".\n" ^ - "Reference to undefined global `" ^ s ^ "'" - | Linking_error (name, Unavailable_primitive s) -> - "error while linking " ^ name ^ ".\n" ^ - "The external function `" ^ s ^ "' is not available" - | Linking_error (name, Uninitialized_global s) -> - "error while linking " ^ name ^ ".\n" ^ - "The module `" ^ s ^ "' is not yet initialized" - | Corrupted_interface name -> - "corrupted interface file " ^ name - | File_not_found name -> - "cannot find file " ^ name ^ " in search path" - | Cannot_open_dll reason -> - "error loading shared library: " ^ reason diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli deleted file mode 100644 index ac5c1a2113..0000000000 --- a/otherlibs/dynlink/dynlink.mli +++ /dev/null @@ -1,129 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Dynamic loading of bytecode object files. *) - -(** {6 Initialization} *) - -val init : unit -> unit -(** Initialize the [Dynlink] library. - Must be called before any other function in this module. *) - -(** {6 Dynamic loading of compiled bytecode files} *) - -val loadfile : string -> unit -(** Load the given bytecode object file ([.cmo] file) or - bytecode library file ([.cma] file), and link it with the running program. - All toplevel expressions in the loaded compilation units - are evaluated. No facilities are provided to - access value names defined by the unit. Therefore, the unit - must register itself its entry points with the main program, - e.g. by modifying tables of functions. *) - -val loadfile_private : string -> unit -(** Same as [loadfile], except that the compilation units just loaded - are hidden (cannot be referenced) from other modules dynamically - loaded afterwards. *) - -(** {6 Access control} *) - -val allow_only: string list -> unit -(** [allow_only units] restricts the compilation units that dynamically-linked - units can reference: it only allows references to the units named in - list [units]. References to any other compilation unit will cause - a [Unavailable_unit] error during [loadfile] or [loadfile_private]. - - Initially (just after calling [init]), all compilation units composing - the program currently running are available for reference from - dynamically-linked units. [allow_only] can be used to grant access - to some of them only, e.g. to the units that compose the API for - dynamically-linked code, and prevent access to all other units, - e.g. private, internal modules of the running program. *) - -val prohibit: string list -> unit -(** [prohibit units] prohibits dynamically-linked units from referencing - the units named in list [units]. This can be used to prevent - access to selected units, e.g. private, internal modules of - the running program. *) - -val default_available_units: unit -> unit -(** Reset the set of units that can be referenced from dynamically-linked - code to its default value, that is, all units composing the currently - running program. *) - -val allow_unsafe_modules : bool -> unit -(** Govern whether unsafe object files are allowed to be - dynamically linked. A compilation unit is ``unsafe'' if it contains - declarations of external functions, which can break type safety. - By default, dynamic linking of unsafe object files is - not allowed. *) - -(** {6 Deprecated, low-level API for access control} *) - -(** @deprecated The functions [add_interfaces], [add_available_units] - and [clear_available_units] should not be used in new programs, - since the default initialization of allowed units, along with the - [allow_only] and [prohibit] function, provides a better, safer - mechanism to control access to program units. The three functions - below are provided for backward compatibility only. *) - -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 - [path] (a list of directory names). *) - -val add_available_units : (string * Digest.t) list -> unit -(** Same as {!Dynlink.add_interfaces}, but instead of searching [.cmi] files - to find the unit interfaces, uses the interface digests given - for each unit. This way, the [.cmi] interface files need not be - available at run-time. The digests can be extracted from [.cmi] - files using the [extract_crc] program installed in the - Objective Caml standard library directory. *) - -val clear_available_units : unit -> unit -(** Empty the list of compilation units accessible to dynamically-linked - programs. *) - -(** {6 Error reporting} *) - -type linking_error = - Undefined_global of string - | Unavailable_primitive of string - | Uninitialized_global of string - -type error = - Not_a_bytecode_file of string - | Inconsistent_import of string - | Unavailable_unit of string - | Unsafe_file - | Linking_error of string * linking_error - | Corrupted_interface of string - | File_not_found of string - | Cannot_open_dll of string - -exception Error of error -(** Errors in dynamic linking are reported by raising the [Error] - exception with a description of the error. *) - -val error_message : error -> string -(** Convert an error description to a printable message. *) - - -(**/**) - -(** {6 Internal functions} *) - -val digest_interface : string -> string list -> Digest.t diff --git a/otherlibs/dynlink/extract_crc.ml b/otherlibs/dynlink/extract_crc.ml deleted file mode 100644 index 80a1568374..0000000000 --- a/otherlibs/dynlink/extract_crc.ml +++ /dev/null @@ -1,53 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Print the digests of unit interfaces *) - -let load_path = ref [] -let first = ref true - -let print_crc unit = - try - let crc = Dynlink.digest_interface unit (!load_path @ ["."]) in - if !first then first := false else print_string ";\n"; - print_string " \""; print_string (String.capitalize unit); - print_string "\",\n \""; - for i = 0 to String.length crc - 1 do - Printf.printf "\\%03d" (Char.code crc.[i]) - done; - print_string "\"" - with exn -> - prerr_string "Error while reading the interface for "; - prerr_endline unit; - begin match exn with - Sys_error msg -> prerr_endline msg - | Dynlink.Error _ -> prerr_endline "Ill formed .cmi file" - | _ -> raise exn - end; - exit 2 - -let usage = "Usage: extract_crc [-I <dir>] <files>" - -let main () = - print_string "let crc_unit_list = [\n"; - Arg.parse - ["-I", Arg.String(fun dir -> load_path := !load_path @ [dir]), - "<dir> Add <dir> to the list of include directories"] - print_crc usage; - print_string "\n]\n" - -let _ = main(); exit 0 - - diff --git a/otherlibs/graph/.cvsignore b/otherlibs/graph/.cvsignore deleted file mode 100644 index 074dd28a45..0000000000 --- a/otherlibs/graph/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -so_locations diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend deleted file mode 100644 index 1bc2b88109..0000000000 --- a/otherlibs/graph/.depend +++ /dev/null @@ -1,48 +0,0 @@ -color.o: color.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h -draw.o: draw.c libgraph.h ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h -dump_img.o: dump_img.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h image.h ../../byterun/alloc.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h -events.o: events.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/signals.h -fill.o: fill.c libgraph.h ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h -image.o: image.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h image.h ../../byterun/alloc.h \ - ../../byterun/custom.h -make_img.o: make_img.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h image.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h -open.o: open.c libgraph.h ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/callback.h ../../byterun/fail.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h -point_col.o: point_col.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h -sound.o: sound.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h -subwindow.o: subwindow.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h -text.o: text.c libgraph.h ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h -graphics.cmo: graphics.cmi -graphics.cmx: graphics.cmi -graphicsX11.cmo: graphics.cmi graphicsX11.cmi -graphicsX11.cmx: graphics.cmx graphicsX11.cmi diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile deleted file mode 100644 index a35e1d3bae..0000000000 --- a/otherlibs/graph/Makefile +++ /dev/null @@ -1,75 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the portable graphics library - -include ../../config/Makefile - -CC=$(BYTECC) -CFLAGS=-I../../byterun $(X11_INCLUDES) -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -CAMLC=../../ocamlcomp.sh -CAMLOPT=../../ocamlcompopt.sh -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A - -OBJS=open.o draw.o fill.o color.o text.o \ - image.o make_img.o dump_img.o point_col.o sound.o events.o \ - subwindow.o - -CAMLOBJS=graphics.cmo graphicsX11.cmo - -all: libgraphics.a graphics.cmi graphics.cma - -allopt: libgraphics.a graphics.cmi graphics.cmxa - -libgraphics.a: $(OBJS) - $(MKLIB) -o graphics $(OBJS) $(X11_LINK) - -graphics.cma: $(CAMLOBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -o graphics $(CAMLOBJS) $(X11_LINK) - -graphics.cmxa: $(CAMLOBJS:.cmo=.cmx) - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o graphics $(CAMLOBJS:.cmo=.cmx) $(X11_LINK) - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.a *.so *.o - -install: - if test -f dllgraphics.so; then cp dllgraphics.so $(STUBLIBDIR)/dllgraphics.so; fi - cp libgraphics.a $(LIBDIR)/libgraphics.a - cd $(LIBDIR); $(RANLIB) libgraphics.a - cp graphics.cm[ia] graphicsX11.cmi graphics.mli graphicsX11.mli $(LIBDIR) - -installopt: - cp graphics.cmx graphics.cmxa graphics.a $(LIBDIR) - cd $(LIBDIR); $(RANLIB) graphics.a - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: - gcc -MM $(CFLAGS) *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend - -include .depend diff --git a/otherlibs/graph/Makefile.Mac b/otherlibs/graph/Makefile.Mac deleted file mode 100644 index 7269595e68..0000000000 --- a/otherlibs/graph/Makefile.Mac +++ /dev/null @@ -1,40 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib: - -all Ä graphics.cmi graphics.cma - set status 0 - -graphics.cma Ä graphics.cmo - {CAMLC} -a -o graphics.cma graphics.cmo - -partialclean Ä - delete -i Å.cm[aio] || set status 0 - -clean Ä partialclean - set status 0 - -install Ä - duplicate -y graphics.cm[ia] graphics.mli "{LIBDIR}" - -.cmi Ä .mli - {CAMLC} -c {default}.mli - -.cmo Ä .ml - {CAMLC} -c {default}.ml - -depend Ä - :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml > Makefile.Mac.depend diff --git a/otherlibs/graph/Makefile.Mac.depend b/otherlibs/graph/Makefile.Mac.depend deleted file mode 100644 index 2877a11eb5..0000000000 --- a/otherlibs/graph/Makefile.Mac.depend +++ /dev/null @@ -1,4 +0,0 @@ -graphics.cmoÄ graphics.cmi -graphics.cmxÄ graphics.cmi -graphicsX11.cmoÄ graphics.cmi graphicsX11.cmi -graphicsX11.cmxÄ graphics.cmx graphicsX11.cmi diff --git a/otherlibs/graph/color.c b/otherlibs/graph/color.c deleted file mode 100644 index f47fa58147..0000000000 --- a/otherlibs/graph/color.c +++ /dev/null @@ -1,230 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "libgraph.h" -#include <X11/Xatom.h> - -/* Cache to speed up the translation rgb -> pixel value. */ - -struct color_cache_entry { - int rgb; /* RGB value with format 0xRRGGBB */ - unsigned long pixel; /* Pixel value */ -}; - -#define Color_cache_size 512 -static struct color_cache_entry color_cache[Color_cache_size]; -#define Empty (-1) -#define Hash_rgb(r,g,b) \ - ((((r) & 0xE0) << 1) + (((g) & 0xE0) >> 2) + (((b) & 0xE0) >> 5)) -#define Color_cache_slack 16 - -static int num_overflows = 0; - -/* rgb -> pixel conversion *without* display connection */ - -Bool direct_rgb = False; -int red_l, red_r; -int green_l, green_r; -int blue_l, blue_r; -unsigned long red_mask, green_mask, blue_mask; - -/* rgb -> pixel table */ -unsigned long red_vals[256]; -unsigned long green_vals[256]; -unsigned long blue_vals[256]; - -void get_shifts( unsigned long mask, int *lsl, int *lsr ) -{ - int l = 0; - int r = 0; - int bit = 1; - if ( mask == 0 ){ *lsl = -1; *lsr = -1; return; } - - for( l = 0; l < 32; l++ ){ - if( bit & mask ){ break; } - bit = bit << 1; - } - for( r = l; r < 32; r++ ){ - if( ! (bit & mask) ){ break; } - bit = bit << 1; - } - /* fix r */ - if ( r == 32 ) { r = 31; } - *lsl = l; - *lsr = 16 - (r - l); -} - -void gr_init_direct_rgb_to_pixel(void) -{ - Visual *visual; - int i; - - visual = DefaultVisual(grdisplay,grscreen); - - if ( visual->class == TrueColor || visual->class == DirectColor ){ - int lsl, lsr; - - red_mask = visual->red_mask; - green_mask = visual->green_mask; - blue_mask = visual->blue_mask; - -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "visual %lx %lx %lx\n", - red_mask, - green_mask, - blue_mask); -#endif - - get_shifts(red_mask, &red_l, &red_r); -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "red %d %d\n", red_l, red_r); -#endif - for(i=0; i<256; i++){ - red_vals[i] = (((i << 8) + i) >> red_r) << red_l; - } - - get_shifts(green_mask, &green_l, &green_r); -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "green %d %d\n", green_l, green_r); -#endif - for(i=0; i<256; i++){ - green_vals[i] = (((i << 8) + i) >> green_r) << green_l; - } - - get_shifts(blue_mask, &blue_l, &blue_r); -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "blue %d %d\n", blue_l, blue_r); -#endif - for(i=0; i<256; i++){ - blue_vals[i] = (((i << 8) + i) >> blue_r) << blue_l; - } - - if( red_l < 0 || red_r < 0 || - green_l < 0 || green_r < 0 || - blue_l < 0 || blue_r < 0 ){ -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "Damn, boost failed\n"); -#endif - direct_rgb = False; - } else { -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "Boost ok\n"); -#endif - direct_rgb = True; - } - } else { - /* we cannot use direct_rgb_to_pixel */ -#ifdef QUICKCOLORDEBUG - fprintf(stderr, "No boost!\n"); -#endif - direct_rgb = False; - } -} - -void gr_init_color_cache(void) -{ - int i; - for (i = 0; i < Color_cache_size; i++) color_cache[i].rgb = Empty; - i = Hash_rgb(0, 0, 0); - color_cache[i].rgb = 0; - color_cache[i].pixel = grblack; - i = Hash_rgb(0xFF, 0xFF, 0xFF); - color_cache[i].rgb = 0xFFFFFF; - color_cache[i].pixel = grwhite; -} - -unsigned long gr_pixel_rgb(int rgb) -{ - unsigned int r, g, b; - int h, i; - XColor color; - unsigned short tmp; - - r = (rgb >> 16) & 0xFF; - g = (rgb >> 8) & 0xFF; - b = rgb & 0xFF; - - if (direct_rgb){ - return red_vals[r] | green_vals[g] | blue_vals[b]; - } - - h = Hash_rgb(r, g, b); - i = h; - while(1) { - if (color_cache[i].rgb == Empty) break; - if (color_cache[i].rgb == rgb) return color_cache[i].pixel; - i = (i + 1) & (Color_cache_size - 1); - if (i == h) { - /* Cache is full. Instead of inserting at slot h, which causes - thrashing if many colors hash to the same value, - insert at h + n where n is pseudo-random and - smaller than Color_cache_slack */ - int slack = num_overflows++ & (Color_cache_slack - 1); - i = (i + slack) & (Color_cache_size - 1); - break; - } - } - color.red = r * 0x101; - color.green = g * 0x101; - color.blue = b * 0x101; - XAllocColor(grdisplay, grcolormap, &color); - color_cache[i].rgb = rgb; - color_cache[i].pixel = color.pixel; - return color.pixel; -} - -int gr_rgb_pixel(long unsigned int pixel) -{ - register int r,g,b; - - XColor color; - int i; - - if (direct_rgb) { - r = (((pixel & red_mask) >> red_l) << 8) >> (16 - red_r); - g = (((pixel & green_mask) >> green_l) << 8) >> (16 - green_r); - b = (((pixel & blue_mask) >> blue_l) << 8) >> (16 - blue_r); - return (r << 16) + (g << 8) + b; - } - - if (pixel == grblack) return 0; - if (pixel == grwhite) return 0xFFFFFF; - - /* Probably faster to do a linear search than to query the X server. */ - for (i = 0; i < Color_cache_size; i++) { - if (color_cache[i].rgb != Empty && color_cache[i].pixel == pixel) - return color_cache[i].rgb; - } - color.pixel = pixel; - XQueryColor(grdisplay, grcolormap, &color); - return - ((color.red >> 8) << 16) + ((color.green >> 8) << 8) + (color.blue >> 8); -} - -value gr_set_color(value vrgb) -{ - int xcolor; - gr_check_open(); - grcolor = Int_val(vrgb); - if (grcolor >= 0 ){ - xcolor = gr_pixel_rgb(Int_val(vrgb)); - XSetForeground(grdisplay, grwindow.gc, xcolor); - XSetForeground(grdisplay, grbstore.gc, xcolor); - } else { - XSetForeground(grdisplay, grwindow.gc, grbackground); - XSetForeground(grdisplay, grbstore.gc, grbackground); - } - return Val_unit; -} diff --git a/otherlibs/graph/draw.c b/otherlibs/graph/draw.c deleted file mode 100644 index 18166168bf..0000000000 --- a/otherlibs/graph/draw.c +++ /dev/null @@ -1,131 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "libgraph.h" -#include <alloc.h> - -value gr_plot(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - gr_check_open(); - if(grremember_mode) - XDrawPoint(grdisplay, grbstore.win, grbstore.gc, x, Bcvt(y)); - if(grdisplay_mode) { - XDrawPoint(grdisplay, grwindow.win, grwindow.gc, x, Wcvt(y)); - XFlush(grdisplay); - } - return Val_unit; -} - -value gr_moveto(value vx, value vy) -{ - grx = Int_val(vx); - gry = Int_val(vy); - return Val_unit; -} - -value gr_current_x(void) -{ - return Val_int(grx); -} - -value gr_current_y(void) -{ - return Val_int(gry); -} - -value gr_lineto(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - gr_check_open(); - if(grremember_mode) - XDrawLine(grdisplay, grbstore.win, grbstore.gc, - grx, Bcvt(gry), x, Bcvt(y)); - if(grdisplay_mode) { - XDrawLine(grdisplay, grwindow.win, grwindow.gc, - grx, Wcvt(gry), x, Wcvt(y)); - XFlush(grdisplay); - } - grx = x; - gry = y; - return Val_unit; -} - -value gr_draw_rect(value vx, value vy, value vw, value vh) -{ - int x = Int_val(vx); - int y = Int_val(vy); - int w = Int_val(vw); - int h = Int_val(vh); - - gr_check_open(); - y = Bcvt(y) - h + 1; - /* Correct for XDrawRectangle irritating habit of drawing a larger - rectangle hanging out one pixel below and to the right of the - expected rectangle */ - if (w == 0 || h == 0) return Val_unit; - y += 1; - w -= 1; - h -= 1; - if(grremember_mode) - XDrawRectangle(grdisplay, grbstore.win, grbstore.gc, - x, y, w, h); - if(grdisplay_mode) { - XDrawRectangle(grdisplay, grwindow.win, grwindow.gc, - x, y, w, h); - XFlush(grdisplay); - } - return Val_unit; -} - -value gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2) -{ - int x = Int_val(vx); - int y = Int_val(vy); - int rx = Int_val(vrx); - int ry = Int_val(vry); - int a1 = Int_val(va1); - int a2 = Int_val(va2); - - gr_check_open(); - if(grremember_mode) - XDrawArc(grdisplay, grbstore.win, grbstore.gc, - x - rx, Bcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64); - if(grdisplay_mode) { - XDrawArc(grdisplay, grwindow.win, grwindow.gc, - x - rx, Wcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64); - XFlush(grdisplay); - } - return Val_unit; -} - -value gr_draw_arc(value *argv, int argc) -{ - return gr_draw_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -value gr_set_line_width(value vwidth) -{ - int width = Int_val(vwidth); - - gr_check_open(); - XSetLineAttributes(grdisplay, grwindow.gc, - width, LineSolid, CapRound, JoinRound); - XSetLineAttributes(grdisplay, grbstore.gc, - width, LineSolid, CapRound, JoinRound); - return Val_unit; -} diff --git a/otherlibs/graph/dump_img.c b/otherlibs/graph/dump_img.c deleted file mode 100644 index 75a9dce43e..0000000000 --- a/otherlibs/graph/dump_img.c +++ /dev/null @@ -1,55 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "libgraph.h" -#include "image.h" -#include <alloc.h> -#include <memory.h> - -value gr_dump_image(value image) -{ - int width, height, i, j; - XImage * idata, * imask; - value m = Val_unit; - - Begin_roots2(image, m); - gr_check_open(); - width = Width_im(image); - height = Height_im(image); - m = alloc(height, 0); - for (i = 0; i < height; i++) { - value v = alloc(width, 0); - modify(&Field(m, i), v); - } - - idata = - XGetImage(grdisplay, Data_im(image), 0, 0, width, height, (-1), ZPixmap); - for (i = 0; i < height; i++) - for (j = 0; j < width; j++) - Field(Field(m, i), j) = Val_int(gr_rgb_pixel(XGetPixel(idata, j, i))); - XDestroyImage(idata); - - if (Mask_im(image) != None) { - imask = - XGetImage(grdisplay, Mask_im(image), 0, 0, width, height, 1, ZPixmap); - for (i = 0; i < height; i++) - for (j = 0; j < width; j++) - if (XGetPixel(imask, j, i) == 0) - Field(Field(m, i), j) = Val_int(Transparent); - XDestroyImage(imask); - } - End_roots(); - return m; -} diff --git a/otherlibs/graph/events.c b/otherlibs/graph/events.c deleted file mode 100644 index 1f0029d25f..0000000000 --- a/otherlibs/graph/events.c +++ /dev/null @@ -1,287 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <signal.h> -#include "libgraph.h" -#include <alloc.h> -#include <signals.h> -#include <sys/types.h> -#include <sys/time.h> -#ifdef HAS_SYS_SELECT_H -#include <sys/select.h> -#endif -#include <string.h> -#include <unistd.h> - -struct event_data { - short kind; - short mouse_x, mouse_y; - unsigned char button; - unsigned char key; -}; - -static struct event_data gr_queue[SIZE_QUEUE]; -static unsigned int gr_head = 0; /* position of next read */ -static unsigned int gr_tail = 0; /* position of next write */ - -#define QueueIsEmpty (gr_tail == gr_head) - -static void gr_enqueue_event(int kind, int mouse_x, int mouse_y, - int button, int key) -{ - struct event_data * ev; - - ev = &(gr_queue[gr_tail]); - ev->kind = kind; - ev->mouse_x = mouse_x; - ev->mouse_y = mouse_y; - ev->button = (button != 0); - ev->key = key; - gr_tail = (gr_tail + 1) % SIZE_QUEUE; - /* If queue was full, it now appears empty; drop oldest entry from queue. */ - if (QueueIsEmpty) gr_head = (gr_head + 1) % SIZE_QUEUE; -} - -#define BUTTON_STATE(state) \ - ((state) & (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask)) - -void gr_handle_event(XEvent * event) -{ - switch (event->type) { - - case Expose: - XCopyArea(grdisplay, grbstore.win, grwindow.win, grwindow.gc, - event->xexpose.x, event->xexpose.y + grbstore.h - grwindow.h, - event->xexpose.width, event->xexpose.height, - event->xexpose.x, event->xexpose.y); - XFlush(grdisplay); - break; - - case ConfigureNotify: - grwindow.w = event->xconfigure.width; - grwindow.h = event->xconfigure.height; - if (grwindow.w > grbstore.w || grwindow.h > grbstore.h) { - - /* Allocate a new backing store large enough to accomodate - both the old backing store and the current window. */ - struct canvas newbstore; - newbstore.w = max(grwindow.w, grbstore.w); - newbstore.h = max(grwindow.h, grbstore.h); - newbstore.win = - XCreatePixmap(grdisplay, grwindow.win, newbstore.w, newbstore.h, - XDefaultDepth(grdisplay, grscreen)); - newbstore.gc = XCreateGC(grdisplay, newbstore.win, 0, NULL); - XSetBackground(grdisplay, newbstore.gc, grwhite); - XSetForeground(grdisplay, newbstore.gc, grwhite); - XFillRectangle(grdisplay, newbstore.win, newbstore.gc, - 0, 0, newbstore.w, newbstore.h); - XSetForeground(grdisplay, newbstore.gc, grcolor); - if (grfont != NULL) - XSetFont(grdisplay, newbstore.gc, grfont->fid); - - /* Copy the old backing store into the new one */ - XCopyArea(grdisplay, grbstore.win, newbstore.win, newbstore.gc, - 0, 0, grbstore.w, grbstore.h, 0, newbstore.h - grbstore.h); - - /* Free the old backing store */ - XFreeGC(grdisplay, grbstore.gc); - XFreePixmap(grdisplay, grbstore.win); - - /* Use the new backing store */ - grbstore = newbstore; - XFlush(grdisplay); - } - break; - - case MappingNotify: - XRefreshKeyboardMapping(&(event->xmapping)); - break; - - case KeyPress: - { KeySym thekey; - char keytxt[256]; - int nchars; - char * p; - nchars = XLookupString(&(event->xkey), keytxt, sizeof(keytxt), - &thekey, 0); - for (p = keytxt; nchars > 0; p++, nchars--) - gr_enqueue_event(event->type, event->xkey.x, event->xkey.y, - BUTTON_STATE(event->xkey.state), *p); - break; - } - - case ButtonPress: - case ButtonRelease: - gr_enqueue_event(event->type, event->xbutton.x, event->xbutton.y, - event->type == ButtonPress, 0); - break; - - case MotionNotify: - gr_enqueue_event(event->type, event->xmotion.x, event->xmotion.y, - BUTTON_STATE(event->xmotion.state), 0); - break; - } -} - -static value gr_wait_allocate_result(int mouse_x, int mouse_y, int button, - int keypressed, int key) -{ - value res = alloc_small(5, 0); - Field(res, 0) = Val_int(mouse_x); - Field(res, 1) = Val_int(mouse_y == -1 ? -1 : Wcvt(mouse_y)); - Field(res, 2) = Val_bool(button); - Field(res, 3) = Val_bool(keypressed); - Field(res, 4) = Val_int(key & 0xFF); - return res; -} - -static value gr_wait_event_poll(void) -{ - int mouse_x, mouse_y, button, key, keypressed; - Window rootwin, childwin; - int root_x, root_y, win_x, win_y; - unsigned int modifiers; - unsigned int i; - - if (XQueryPointer(grdisplay, grwindow.win, - &rootwin, &childwin, - &root_x, &root_y, &win_x, &win_y, - &modifiers)) { - mouse_x = win_x; - mouse_y = win_y; - } else { - mouse_x = -1; - mouse_y = -1; - } - button = modifiers & (Button1Mask | Button2Mask | Button3Mask - | Button4Mask | Button5Mask); - /* Look inside event queue for pending KeyPress events */ - key = 0; - keypressed = False; - for (i = gr_head; i != gr_tail; i = (i + 1) % SIZE_QUEUE) { - if (gr_queue[i].kind == KeyPress) { - keypressed = True; - key = gr_queue[i].key; - break; - } - } - return gr_wait_allocate_result(mouse_x, mouse_y, button, keypressed, key); -} - -static value gr_wait_event_in_queue(long mask) -{ - struct event_data * ev; - /* Pop events in queue until one matches mask. */ - while (gr_head != gr_tail) { - ev = &(gr_queue[gr_head]); - gr_head = (gr_head + 1) % SIZE_QUEUE; - if ((ev->kind == KeyPress && (mask & KeyPressMask)) - || (ev->kind == ButtonPress && (mask & ButtonPressMask)) - || (ev->kind == ButtonRelease && (mask & ButtonReleaseMask)) - || (ev->kind == MotionNotify && (mask & PointerMotionMask))) - return gr_wait_allocate_result(ev->mouse_x, ev->mouse_y, - ev->button, ev->kind == KeyPress, - ev->key); - } - return Val_false; -} - -static value gr_wait_event_blocking(long mask) -{ -#ifdef POSIX_SIGNALS - sigset_t sigset; -#else - void (*oldsig)(); -#endif - XEvent event; - fd_set readfds; - value res; - - /* First see if we have a matching event in the queue */ - res = gr_wait_event_in_queue(mask); - if (res != Val_false) return res; - - /* Increase the selected events if required */ - if ((mask & ~grselected_events) != 0) { - grselected_events |= mask; - XSelectInput(grdisplay, grwindow.win, grselected_events); - } - - /* Block or deactivate the EVENT signal */ -#ifdef POSIX_SIGNALS - sigemptyset(&sigset); - sigaddset(&sigset, EVENT_SIGNAL); - sigprocmask(SIG_BLOCK, &sigset, NULL); -#else - oldsig = signal(EVENT_SIGNAL, SIG_IGN); -#endif - - /* Replenish our event queue from that of X11 */ - while (1) { - if (XCheckMaskEvent(grdisplay, -1 /*all events*/, &event)) { - /* One event available: add it to our queue */ - gr_handle_event(&event); - /* See if we now have a matching event */ - res = gr_wait_event_in_queue(mask); - if (res != Val_false) break; - } else { - /* No event available: block on input socket until one is */ - FD_ZERO(&readfds); - FD_SET(ConnectionNumber(grdisplay), &readfds); - enter_blocking_section(); - select(FD_SETSIZE, &readfds, NULL, NULL, NULL); - leave_blocking_section(); - } - } - - /* Restore the EVENT signal to its initial state */ -#ifdef POSIX_SIGNALS - sigprocmask(SIG_UNBLOCK, &sigset, NULL); -#else - signal(EVENT_SIGNAL, oldsig); -#endif - - /* Return result */ - return res; -} - -value gr_wait_event(value eventlist) /* ML */ -{ - int mask; - Bool poll; - - gr_check_open(); - mask = 0; - poll = False; - while (eventlist != Val_int(0)) { - switch (Int_val(Field(eventlist, 0))) { - case 0: /* Button_down */ - mask |= ButtonPressMask | OwnerGrabButtonMask; break; - case 1: /* Button_up */ - mask |= ButtonReleaseMask | OwnerGrabButtonMask; break; - case 2: /* Key_pressed */ - mask |= KeyPressMask; break; - case 3: /* Mouse_motion */ - mask |= PointerMotionMask; break; - case 4: /* Poll */ - poll = True; break; - } - eventlist = Field(eventlist, 1); - } - if (poll) - return gr_wait_event_poll(); - else - return gr_wait_event_blocking(mask); -} diff --git a/otherlibs/graph/fill.c b/otherlibs/graph/fill.c deleted file mode 100644 index faaa3c4cf3..0000000000 --- a/otherlibs/graph/fill.c +++ /dev/null @@ -1,88 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "libgraph.h" -#include <memory.h> - -value gr_fill_rect(value vx, value vy, value vw, value vh) -{ - int x = Int_val(vx); - int y = Int_val(vy); - int w = Int_val(vw); - int h = Int_val(vh); - - gr_check_open(); - if(grremember_mode) - XFillRectangle(grdisplay, grbstore.win, grbstore.gc, - x, Bcvt(y) - h + 1, w, h); - if(grdisplay_mode) { - XFillRectangle(grdisplay, grwindow.win, grwindow.gc, - x, Wcvt(y) - h + 1, w, h); - XFlush(grdisplay); - } - return Val_unit; -} - -value gr_fill_poly(value array) -{ - XPoint * points; - int npoints, i; - - gr_check_open(); - npoints = Wosize_val(array); - points = (XPoint *) stat_alloc(npoints * sizeof(XPoint)); - for (i = 0; i < npoints; i++) { - points[i].x = Int_val(Field(Field(array, i), 0)); - points[i].y = Bcvt(Int_val(Field(Field(array, i), 1))); - } - if(grremember_mode) - XFillPolygon(grdisplay, grbstore.win, grbstore.gc, points, - npoints, Complex, CoordModeOrigin); - if(grdisplay_mode) { - for (i = 0; i < npoints; i++) - points[i].y = BtoW(points[i].y); - XFillPolygon(grdisplay, grwindow.win, grwindow.gc, points, - npoints, Complex, CoordModeOrigin); - XFlush(grdisplay); - } - stat_free((char *) points); - return Val_unit; -} - -value gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2) -{ - int x = Int_val(vx); - int y = Int_val(vy); - int rx = Int_val(vrx); - int ry = Int_val(vry); - int a1 = Int_val(va1); - int a2 = Int_val(va2); - - gr_check_open(); - if(grremember_mode) - XFillArc(grdisplay, grbstore.win, grbstore.gc, - x - rx, Bcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64); - if(grdisplay_mode) { - XFillArc(grdisplay, grwindow.win, grwindow.gc, - x - rx, Wcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64); - XFlush(grdisplay); - } - return Val_unit; -} - -value gr_fill_arc(value *argv, int argc) -{ - return gr_fill_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} diff --git a/otherlibs/graph/graphics.ml b/otherlibs/graph/graphics.ml deleted file mode 100644 index 88e7450e0a..0000000000 --- a/otherlibs/graph/graphics.ml +++ /dev/null @@ -1,228 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -exception Graphic_failure of string - -(* Initializations *) - -let _ = - Callback.register_exception "Graphics.Graphic_failure" (Graphic_failure "") - -external raw_open_graph: string -> unit = "gr_open_graph" -external raw_close_graph: unit -> unit = "gr_close_graph" -external sigio_signal: unit -> int = "gr_sigio_signal" -external sigio_handler: int -> unit = "gr_sigio_handler" - -let unix_open_graph arg = - Sys.set_signal (sigio_signal()) (Sys.Signal_handle sigio_handler); - raw_open_graph arg - -let unix_close_graph () = - Sys.set_signal (sigio_signal()) Sys.Signal_ignore; - raw_close_graph () - -let (open_graph, close_graph) = - match Sys.os_type with - | "Unix" | "Cygwin" -> (unix_open_graph, unix_close_graph) - | "Win32" -> (raw_open_graph, raw_close_graph) - | "MacOS" -> (raw_open_graph, raw_close_graph) - | _ -> invalid_arg ("Graphics: unknown OS type: " ^ Sys.os_type) - -external set_window_title : string -> unit = "gr_set_window_title" -external clear_graph : unit -> unit = "gr_clear_graph" -external size_x : unit -> int = "gr_size_x" -external size_y : unit -> int = "gr_size_y" - -(* Double-buffering *) - -external display_mode : bool -> unit = "gr_display_mode" -external remember_mode : bool -> unit = "gr_remember_mode" -external synchronize : unit -> unit = "gr_synchronize" - -let auto_synchronize = function - | true -> display_mode true; remember_mode true; synchronize () - | false -> display_mode false; remember_mode true -;; - - -(* Colors *) - -type color = int - -let rgb r g b = (r lsl 16) + (g lsl 8) + b - -external set_color : color -> unit = "gr_set_color" - -let black = 0x000000 -and white = 0xFFFFFF -and red = 0xFF0000 -and green = 0x00FF00 -and blue = 0x0000FF -and yellow = 0xFFFF00 -and cyan = 0x00FFFF -and magenta = 0xFF00FF - -let background = white -and foreground = black - -(* Drawing *) - -external plot : int -> int -> unit = "gr_plot" -let plots points = - for i = 0 to Array.length points - 1 do - let (x, y) = points.(i) in - plot x y; - done -;; -external point_color : int -> int -> color = "gr_point_color" -external moveto : int -> int -> unit = "gr_moveto" -external current_x : unit -> int = "gr_current_x" -external current_y : unit -> int = "gr_current_y" -let current_point () = current_x (), current_y () -external lineto : int -> int -> unit = "gr_lineto" -let rlineto x y = lineto (current_x () + x) (current_y () + y) -let rmoveto x y = moveto (current_x () + x) (current_y () + y) -external draw_rect : int -> int -> int -> int -> unit = "gr_draw_rect" -let draw_poly, draw_poly_line = - let dodraw close_flag points = - if Array.length points > 0 then begin - let (savex, savey) = current_point () in - moveto (fst points.(0)) (snd points.(0)); - for i = 1 to Array.length points - 1 do - let (x, y) = points.(i) in - lineto x y; - done; - if close_flag then lineto (fst points.(0)) (snd points.(0)); - moveto savex savey; - end; - in dodraw true, dodraw false -;; -let draw_segments segs = - let (savex, savey) = current_point () in - for i = 0 to Array.length segs - 1 do - let (x1, y1, x2, y2) = segs.(i) in - moveto x1 y1; - lineto x2 y2; - done; - moveto savex savey; -;; -external draw_arc : int -> int -> int -> int -> int -> int -> unit - = "gr_draw_arc" "gr_draw_arc_nat" -let draw_ellipse x y rx ry = draw_arc x y rx ry 0 360 -let draw_circle x y r = draw_arc x y r r 0 360 -external set_line_width : int -> unit = "gr_set_line_width" - -external fill_rect : int -> int -> int -> int -> unit = "gr_fill_rect" -external fill_poly : (int * int) array -> unit = "gr_fill_poly" -external fill_arc : int -> int -> int -> int -> int -> int -> unit - = "gr_fill_arc" "gr_fill_arc_nat" -let fill_ellipse x y rx ry = fill_arc x y rx ry 0 360 -let fill_circle x y r = fill_arc x y r r 0 360 - -(* Text *) - -external draw_char : char -> unit = "gr_draw_char" -external draw_string : string -> unit = "gr_draw_string" -external set_font : string -> unit = "gr_set_font" -external set_text_size : int -> unit = "gr_set_text_size" -external text_size : string -> int * int = "gr_text_size" - -(* Images *) - -type image - -let transp = -1 - -external make_image : color array array -> image = "gr_make_image" -external dump_image : image -> color array array = "gr_dump_image" -external draw_image : image -> int -> int -> unit = "gr_draw_image" -external create_image : int -> int -> image = "gr_create_image" -external blit_image : image -> int -> int -> unit = "gr_blit_image" - -let get_image x y w h = - let image = create_image w h in - blit_image image x y; - image - -(* Events *) - -type status = - { mouse_x : int; - mouse_y : int; - button : bool; - keypressed : bool; - key : char } - -type event = - Button_down - | Button_up - | Key_pressed - | Mouse_motion - | Poll - -external wait_next_event : event list -> status = "gr_wait_event" - -let mouse_pos () = - let e = wait_next_event [Poll] in (e.mouse_x, e.mouse_y) - -let button_down () = - let e = wait_next_event [Poll] in e.button - -let read_key () = - let e = wait_next_event [Key_pressed] in e.key - -let key_pressed () = - let e = wait_next_event [Poll] in e.keypressed - -(*** Sound *) - -external sound : int -> int -> unit = "gr_sound" - -(* Splines *) -let add (x1, y1) (x2, y2) = (x1 +. x2, y1 +. y2) -and sub (x1, y1) (x2, y2) = (x1 -. x2, y1 -. y2) -and middle (x1, y1) (x2, y2) = ((x1 +. x2) /. 2.0, (y1 +. y2) /. 2.0) -and area (x1, y1) (x2, y2) = abs_float (x1 *. y2 -. x2 *. y1) -and norm (x1, y1) = sqrt (x1 *. x1 +. y1 *. y1);; - -let test a b c d = - let v = sub d a in - let s = norm v in - area v (sub a b) <= s && area v (sub a c) <= s;; - -let spline a b c d = - let rec spl accu a b c d = - if test a b c d then d :: accu else - let a' = middle a b - and o = middle b c in - let b' = middle a' o - and d' = middle c d in - let c' = middle o d' in - let i = middle b' c' in - spl (spl accu a a' b' i) i c' d' d in - spl [a] a b c d;; - -let curveto b c (x, y as d) = - let float_point (x, y) = (float_of_int x, float_of_int y) in - let round f = int_of_float (f +. 0.5) in - let int_point (x, y) = (round x, round y) in - let points = - spline - (float_point (current_point ())) - (float_point b) (float_point c) (float_point d) in - draw_poly_line - (Array.of_list (List.map int_point points)); - moveto x y;; - diff --git a/otherlibs/graph/graphics.mli b/otherlibs/graph/graphics.mli deleted file mode 100644 index ff271ce556..0000000000 --- a/otherlibs/graph/graphics.mli +++ /dev/null @@ -1,374 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Machine-independent graphics primitives. *) - -exception Graphic_failure of string -(** Raised by the functions below when they encounter an error. *) - - -(** {6 Initializations} *) - -val open_graph : string -> unit -(** Show the graphics window or switch the screen to graphic mode. - The graphics window is cleared and the current point is set - to (0, 0). The string argument is used to pass optional - information on the desired graphics mode, the graphics window - size, and so on. Its interpretation is implementation-dependent. - If the empty string is given, a sensible default is selected. *) - -val close_graph : unit -> unit -(** Delete the graphics window or switch the screen back to text mode. *) - -val set_window_title : string -> unit -(** Set the title of the graphics window. *) - -external clear_graph : unit -> unit = "gr_clear_graph" -(** Erase the graphics window. *) - -external size_x : unit -> int = "gr_size_x" -(** See {!Graphics.size_y}. *) - -external size_y : unit -> int = "gr_size_y" -(** Return the size of the graphics window. Coordinates of the screen - pixels range over [0 .. size_x()-1] and [0 .. size_y()-1]. - Drawings outside of this rectangle are clipped, without causing - an error. The origin (0,0) is at the lower left corner. *) - -(** {6 Colors} *) - -type color = int -(** A color is specified by its R, G, B components. Each component - is in the range [0..255]. The three components are packed in - an [int]: [0xRRGGBB], where [RR] are the two hexadecimal digits for - the red component, [GG] for the green component, [BB] for the - blue component. *) - -val rgb : int -> int -> int -> color -(** [rgb r g b] returns the integer encoding the color with red - component [r], green component [g], and blue component [b]. - [r], [g] and [b] are in the range [0..255]. *) - -external set_color : color -> unit = "gr_set_color" -(** Set the current drawing color. *) - -val background : color -(** See {!Graphics.foreground}.*) - -val foreground : color -(** Default background and foreground colors (usually, either black - foreground on a white background or white foreground on a - black background). - {!Graphics.clear_graph} fills the screen with the [background] color. - The initial drawing color is [foreground]. *) - - -(** {7 Some predefined colors} *) - -val black : color -val white : color -val red : color -val green : color -val blue : color -val yellow : color -val cyan : color -val magenta : color - - -(** {6 Point and line drawing} *) - -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 : int -> int -> color = "gr_point_color" -(** Return the color of the given point in the backing store - (see "Double buffering" below). *) - -external moveto : int -> int -> unit = "gr_moveto" -(** Position the current point. *) - -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. *) - -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 : 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 : 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. *) - -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 : 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. *) - -val draw_poly_line : (int * int) array -> unit -(** [draw_poly_line points] draws the line that joins the - points given by the array argument. - The array contains the coordinates of the vertices of the - polygonal line, which need not be closed. - The current point is unchanged. *) - -val draw_poly : (int * int) array -> unit -(** [draw_poly polygon] draws the given polygon. - The array contains the coordinates of the vertices of the - polygon. - The current point is unchanged. *) - -val draw_segments : (int * int * int * int) array -> unit -(** [draw_segments segments] draws the segments given in the array - argument. Each segment is specified as a quadruple - [(x0, y0, x1, y1)] where [(x0, y0)] and [(x1, y1)] are - the coordinates of the end points of the segment. - The current point is unchanged. *) - -external draw_arc : - 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 : 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 : 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" -(** Set the width of points and lines drawn with the functions above. - Under X Windows, [set_line_width 0] selects a width of 1 pixel - and a faster, but less precise drawing algorithm than the one - used when [set_line_width 1] is specified. *) - -(** {6 Text drawing} *) - -external draw_char : char -> unit = "gr_draw_char" -(** See {!Graphics.draw_string}.*) - -external draw_string : string -> unit = "gr_draw_string" -(** Draw a character or a character string with lower left corner - at current position. After drawing, the current position is set - to the lower right corner of the text drawn. *) - -external set_font : string -> unit = "gr_set_font" -(** Set the font used for drawing text. - The interpretation of the arguments to [set_font] - is implementation-dependent. *) - -val set_text_size : int -> unit -(** Set the character size used for drawing text. - The interpretation of the arguments to [set_text_size] - is implementation-dependent. *) - -external text_size : string -> int * int = "gr_text_size" -(** Return the dimensions of the given text, if it were drawn with - the current font and size. *) - - -(** {6 Filling} *) - -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 : - 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 {!Graphics.draw_arc}. *) - -val fill_ellipse : int -> int -> int -> int -> unit -(** Fill an ellipse with the current color. The - parameters are the same as for {!Graphics.draw_ellipse}. *) - -val fill_circle : int -> int -> int -> unit -(** Fill a circle with the current color. The - parameters are the same as for {!Graphics.draw_circle}. *) - - -(** {6 Images} *) - -type image -(** The abstract type for images, in internal representation. - Externally, images are represented as matrices of colors. *) - -val transp : color -(** In matrices of colors, this color represent a ``transparent'' - point: when drawing the corresponding image, all pixels on the - screen corresponding to a transparent pixel in the image will - not be modified, while other points will be set to the color - of the corresponding point in the image. This allows superimposing - an image over an existing background. *) - -external make_image : color array array -> image = "gr_make_image" -(** Convert the given color matrix to an image. - Each sub-array represents one horizontal line. All sub-arrays - must have the same length; otherwise, exception [Graphic_failure] - is raised. *) - -external dump_image : image -> color array array = "gr_dump_image" -(** Convert an image to a color matrix. *) - -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 : int -> int -> int -> int -> image -(** Capture the contents of a rectangle on the screen as an image. - The parameters are the same as for {!Graphics.fill_rect}. *) - -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 -> 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 - equal to those of the image. Pixels that were transparent in - [img] are left unchanged. *) - - -(** {6 Mouse and keyboard events} *) - -type status = - { mouse_x : int; (** X coordinate of the mouse *) - mouse_y : int; (** Y coordinate of the mouse *) - button : bool; (** true if a mouse button is pressed *) - keypressed : bool; (** true if a key has been pressed *) - key : char; (** the character for the key pressed *) - } -(** To report events. *) - - -type event = - Button_down (** A mouse button is pressed *) - | Button_up (** A mouse button is released *) - | Key_pressed (** A key is pressed *) - | Mouse_motion (** The mouse is moved *) - | Poll (** Don't wait; return immediately *) -(** To specify events to wait for. *) - - -external wait_next_event : event list -> status = "gr_wait_event" -(** Wait until one of the events specified in the given event list - occurs, and return the status of the mouse and keyboard at - that time. If [Poll] is given in the event list, return immediately - with the current status. If the mouse cursor is outside of the - graphics window, the [mouse_x] and [mouse_y] fields of the event are - outside the range [0..size_x()-1, 0..size_y()-1]. Keypresses - are queued, and dequeued one by one when the [Key_pressed] - event is specified. *) - -(** {6 Mouse and keyboard polling} *) - -val mouse_pos : unit -> int * int -(** Return the position of the mouse cursor, relative to the - graphics window. If the mouse cursor is outside of the graphics - window, [mouse_pos()] returns a point outside of the range - [0..size_x()-1, 0..size_y()-1]. *) - -val button_down : unit -> bool -(** Return [true] if the mouse button is pressed, [false] otherwise. *) - -val read_key : unit -> char -(** Wait for a key to be pressed, and return the corresponding - character. Keypresses are queued. *) - -val key_pressed : unit -> bool -(** Return [true] if a keypress is available; that is, if [read_key] - would not block. *) - - -(** {6 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). *) - -(** {6 Double buffering} *) - -val auto_synchronize : bool -> unit -(** By default, drawing takes place both on the window displayed - on screen, and in a memory area (the ``backing store''). - The backing store image is used to re-paint the on-screen - window when necessary. - - To avoid flicker during animations, it is possible to turn - off on-screen drawing, perform a number of drawing operations - in the backing store only, then refresh the on-screen window - explicitly. - - [auto_synchronize false] turns on-screen drawing off. All - subsequent drawing commands are performed on the backing store - only. - - [auto_synchronize true] refreshes the on-screen window from - the backing store (as per [synchronize]), then turns on-screen - drawing back on. All subsequent drawing commands are performed - both on screen and in the backing store. - - The default drawing mode corresponds to [auto_synchronize true]. *) - -external synchronize : unit -> unit = "gr_synchronize" -(** Synchronize the backing store and the on-screen window, by - copying the contents of the backing store onto the graphics - window. *) - - -external display_mode : bool -> unit = "gr_display_mode" -(** Set display mode on or off. When turned on, drawings are done - in the graphics window; when turned off, drawings do not affect - the graphics window. This occurs independently of - drawing into the backing store (see the function {!Graphics.remember_mode} - below). Default display mode is on. *) - - -external remember_mode : bool -> unit = "gr_remember_mode" -(** Set remember mode on or off. When turned on, drawings are done - in the backing store; when turned off, the backing store is - unaffected by drawings. This occurs independently of drawing - onto the graphics window (see the function {!Graphics.display_mode} above). - Default remember mode is on. *) - - diff --git a/otherlibs/graph/graphicsX11.ml b/otherlibs/graph/graphicsX11.ml deleted file mode 100644 index 69f7b718d6..0000000000 --- a/otherlibs/graph/graphicsX11.ml +++ /dev/null @@ -1,42 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Pierre Weis and Jun Furuse, projet Cristal, INRIA Rocquencourt *) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Module [GraphicsX11]: additional graphics primitives for the X Windows system *) - -type window_id = string - -external window_id : unit -> window_id = "gr_window_id" - -let subwindows = Hashtbl.create 13 - -external open_subwindow : int -> int -> int -> int -> window_id - = "gr_open_subwindow" -external close_subwindow : window_id -> unit - = "gr_close_subwindow" - -let open_subwindow ~x ~y ~width ~height = - let wid = open_subwindow x y width height in - Hashtbl.add subwindows wid (); - wid -;; - -let close_subwindow wid = - if Hashtbl.mem subwindows wid then begin - close_subwindow wid; - Hashtbl.remove subwindows wid - end else - raise (Graphics.Graphic_failure ("close_subwindow: no such subwindow: " ^ wid)) -;; - diff --git a/otherlibs/graph/graphicsX11.mli b/otherlibs/graph/graphicsX11.mli deleted file mode 100644 index ff55adf668..0000000000 --- a/otherlibs/graph/graphicsX11.mli +++ /dev/null @@ -1,31 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Pierre Weis and Jun Furuse, projet Cristal, INRIA Rocquencourt *) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Additional graphics primitives for the X Windows system. *) - -type window_id = string - -val window_id : unit -> window_id -(** Return the unique identifier of the Caml graphics window. - The returned string is an unsigned 32 bits integer - in decimal form. *) - -val open_subwindow : x:int -> y:int -> width:int -> height:int -> window_id -(** Create a sub-window of the current Caml graphics window - and return its identifier. *) - -val close_subwindow : window_id -> unit -(** Close the sub-window having the given identifier. *) - diff --git a/otherlibs/graph/image.c b/otherlibs/graph/image.c deleted file mode 100644 index 8d47fc4e58..0000000000 --- a/otherlibs/graph/image.c +++ /dev/null @@ -1,105 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "libgraph.h" -#include "image.h" -#include <alloc.h> -#include <custom.h> - -static void gr_free_image(value im) -{ - XFreePixmap(grdisplay, Data_im(im)); - if (Mask_im(im) != None) XFreePixmap(grdisplay, Mask_im(im)); -} - -static struct custom_operations image_ops = { - "_image", - gr_free_image, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; - -#define Max_image_mem 2000000 - -value gr_new_image(int w, int h) -{ - value res = alloc_custom(&image_ops, sizeof(struct grimage), - w * h, Max_image_mem); - Width_im(res) = w; - Height_im(res) = h; - Data_im(res) = XCreatePixmap(grdisplay, grwindow.win, w, h, - XDefaultDepth(grdisplay, grscreen)); - Mask_im(res) = None; - return res; -} - -value gr_create_image(value vw, value vh) -{ - gr_check_open(); - return gr_new_image(Int_val(vw), Int_val(vh)); -} - -value gr_blit_image(value im, value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - gr_check_open(); - XCopyArea(grdisplay, grbstore.win, Data_im(im), grbstore.gc, - x, Bcvt(y) + 1 - Height_im(im), - Width_im(im), Height_im(im), - 0, 0); - return Val_unit; -} - -value gr_draw_image(value im, value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - int wy = Wcvt(y) + 1 - Height_im(im); - int by = Bcvt(y) + 1 - Height_im(im); - - gr_check_open(); - if (Mask_im(im) != None) { - if(grremember_mode) { - XSetClipOrigin(grdisplay, grbstore.gc, x, by); - XSetClipMask(grdisplay, grbstore.gc, Mask_im(im)); - } - if(grdisplay_mode) { - XSetClipOrigin(grdisplay, grwindow.gc, x, wy); - XSetClipMask(grdisplay, grwindow.gc, Mask_im(im)); - } - } - if(grremember_mode) - XCopyArea(grdisplay, Data_im(im), grbstore.win, grbstore.gc, - 0, 0, - Width_im(im), Height_im(im), - x, by); - if(grdisplay_mode) - XCopyArea(grdisplay, Data_im(im), grwindow.win, grwindow.gc, - 0, 0, - Width_im(im), Height_im(im), - x, wy); - if (Mask_im(im) != None) { - if(grremember_mode) - XSetClipMask(grdisplay, grbstore.gc, None); - if(grdisplay_mode) - XSetClipMask(grdisplay, grwindow.gc, None); - } - if(grdisplay_mode) - XFlush(grdisplay); - return Val_unit; -} diff --git a/otherlibs/graph/image.h b/otherlibs/graph/image.h deleted file mode 100644 index 441da97fbc..0000000000 --- a/otherlibs/graph/image.h +++ /dev/null @@ -1,29 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -struct grimage { - int width, height; /* Dimensions of the image */ - Pixmap data; /* Pixels */ - Pixmap mask; /* Mask for transparent points, or None */ -}; - -#define Width_im(i) (((struct grimage *)Data_custom_val(i))->width) -#define Height_im(i) (((struct grimage *)Data_custom_val(i))->height) -#define Data_im(i) (((struct grimage *)Data_custom_val(i))->data) -#define Mask_im(i) (((struct grimage *)Data_custom_val(i))->mask) - -#define Transparent (-1) - -value gr_new_image(int w, int h); diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h deleted file mode 100644 index 605c5a463f..0000000000 --- a/otherlibs/graph/libgraph.h +++ /dev/null @@ -1,84 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <stdio.h> -#include <X11/Xlib.h> -#include <X11/Xutil.h> -#include <mlvalues.h> - -struct canvas { - int w, h; /* Dimensions of the drawable */ - Drawable win; /* The drawable itself */ - GC gc; /* The associated graphics context */ -}; - -extern Display * grdisplay; /* The display connection */ -extern int grscreen; /* The screen number */ -extern Colormap grcolormap; /* The color map */ -extern struct canvas grwindow; /* The graphics window */ -extern struct canvas grbstore; /* The pixmap used for backing store */ -extern int grwhite, grblack; /* Black and white pixels for X */ -extern int grbackground; /* Background color for X - (used for CAML color -1) */ -extern Bool grdisplay_mode; /* Display-mode flag */ -extern Bool grremember_mode; /* Remember-mode flag */ -extern int grx, gry; /* Coordinates of the current point */ -extern int grcolor; /* Current *CAML* drawing color (can be -1) */ -extern XFontStruct * grfont; /* Current font */ -extern long grselected_events; /* Events we are interested in */ - -extern Bool direct_rgb; -extern int byte_order; -extern int bitmap_unit; -extern int bits_per_pixel; - -#define Wcvt(y) (grwindow.h - 1 - (y)) -#define Bcvt(y) (grbstore.h - 1 - (y)) -#define WtoB(y) ((y) + grbstore.h - grwindow.h) -#define BtoW(y) ((y) + grwindow.h - grbstore.h) -#define min(a,b) ((a) < (b) ? (a) : (b)) -#define max(a,b) ((a) > (b) ? (a) : (b)) - -#define DEFAULT_SCREEN_WIDTH 600 -#define DEFAULT_SCREEN_HEIGHT 450 -#define BORDER_WIDTH 2 -#define DEFAULT_WINDOW_NAME "Caml graphics" -#define DEFAULT_SELECTED_EVENTS \ - (ExposureMask | KeyPressMask | StructureNotifyMask) -#define DEFAULT_FONT "fixed" -#define SIZE_QUEUE 256 - -/* To handle events asynchronously */ -#ifdef HAS_ASYNC_IO -#define USE_ASYNC_IO -#define EVENT_SIGNAL SIGIO -#else -#ifdef HAS_SETITIMER -#define USE_INTERVAL_TIMER -#define EVENT_SIGNAL SIGALRM -#else -#define USE_ALARM -#define EVENT_SIGNAL SIGALRM -#endif -#endif - -extern void gr_fail(char *fmt, char *arg); -extern void gr_check_open(void); -extern unsigned long gr_pixel_rgb(int rgb); -extern int gr_rgb_pixel(long unsigned int pixel); -extern void gr_handle_event(XEvent *e); -extern void gr_init_color_cache(void); -extern void gr_init_direct_rgb_to_pixel(void); -extern value id_of_window( Window w ); diff --git a/otherlibs/graph/make_img.c b/otherlibs/graph/make_img.c deleted file mode 100644 index a0d15a824f..0000000000 --- a/otherlibs/graph/make_img.c +++ /dev/null @@ -1,95 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "libgraph.h" -#include "image.h" -#include <memory.h> - -value gr_make_image(value m) -{ - int width, height; - value im; - Bool has_transp; - XImage * idata, * imask; - char * bdata, * bmask; - int i, j, rgb; - value line; - GC gc; - - gr_check_open(); - height = Wosize_val(m); - if (height == 0) return gr_new_image(0, 0); - width = Wosize_val(Field(m, 0)); - for (i = 1; i < height; i++) - if (Wosize_val(Field(m, i)) != width) - gr_fail("make_image: lines of different lengths", NULL); - - /* Build an XImage for the data part of the image */ - idata = - XCreateImage(grdisplay, DefaultVisual(grdisplay, grscreen), - XDefaultDepth(grdisplay, grscreen), - ZPixmap, 0, NULL, width, height, - BitmapPad(grdisplay), 0); - - bdata = (char *) stat_alloc(height * idata->bytes_per_line); - idata->data = bdata; - has_transp = False; - - for (i = 0; i < height; i++) { - line = Field(m, i); - for (j = 0; j < width; j++) { - rgb = Int_val(Field(line, j)); - if (rgb == Transparent) { has_transp = True; rgb = 0; } - XPutPixel(idata, j, i, gr_pixel_rgb(rgb)); - } - } - - /* If the matrix contains transparent points, - build an XImage for the mask part of the image */ - if (has_transp) { - imask = - XCreateImage(grdisplay, DefaultVisual(grdisplay, grscreen), - 1, ZPixmap, 0, NULL, width, height, - BitmapPad(grdisplay), 0); - bmask = (char *) stat_alloc(height * imask->bytes_per_line); - imask->data = bmask; - - for (i = 0; i < height; i++) { - line = Field(m, i); - for (j = 0; j < width; j++) { - rgb = Int_val(Field(line, j)); - XPutPixel(imask, j, i, rgb != Transparent); - } - } - } else { - imask = NULL; - } - - /* Allocate the image and store the XImages into the Pixmaps */ - im = gr_new_image(width, height); - gc = XCreateGC(grdisplay, Data_im(im), 0, NULL); - XPutImage(grdisplay, Data_im(im), gc, idata, 0, 0, 0, 0, width, height); - XDestroyImage(idata); - XFreeGC(grdisplay, gc); - if (has_transp) { - Mask_im(im) = XCreatePixmap(grdisplay, grwindow.win, width, height, 1); - gc = XCreateGC(grdisplay, Mask_im(im), 0, NULL); - XPutImage(grdisplay, Mask_im(im), gc, imask, 0, 0, 0, 0, width, height); - XDestroyImage(imask); - XFreeGC(grdisplay, gc); - } - XFlush(grdisplay); - return im; -} diff --git a/otherlibs/graph/open.c b/otherlibs/graph/open.c deleted file mode 100644 index 3bc034ec36..0000000000 --- a/otherlibs/graph/open.c +++ /dev/null @@ -1,366 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <string.h> -#include <fcntl.h> -#include <signal.h> -#include "libgraph.h" -#include <alloc.h> -#include <callback.h> -#include <fail.h> -#include <memory.h> -#ifdef HAS_UNISTD -#include <unistd.h> -#endif -#ifdef HAS_SETITIMER -#include <sys/time.h> -#endif - -Display * grdisplay = NULL; -int grscreen; -Colormap grcolormap; -int grwhite, grblack, grbackground; -struct canvas grwindow; -struct canvas grbstore; -Bool grdisplay_mode; -Bool grremember_mode; -int grx, gry; -int grcolor; -extern XFontStruct * grfont; -long grselected_events; -static Bool gr_initialized = False; -static char * window_name = NULL; - -static int gr_error_handler(Display *display, XErrorEvent *error); -static int gr_ioerror_handler(Display *display); -value gr_clear_graph(void); - -value gr_open_graph(value arg) -{ - char display_name[256], geometry_spec[64]; - char * p, * q; - XSizeHints hints; - int ret; - XEvent event; - int x, y, w, h; - XWindowAttributes attributes; - - if (gr_initialized) { - gr_clear_graph(); - } else { - - /* Parse the argument */ - for (p = String_val(arg), q = display_name; *p != 0 && *p != ' '; p++) - if (q < display_name + sizeof(display_name) - 1) *q++ = *p; - *q = 0; - while (*p == ' ') p++; - for (q = geometry_spec; *p != 0; p++) - if (q < geometry_spec + sizeof(geometry_spec) - 1) *q++ = *p; - *q = 0; - - /* Open the display */ - if (grdisplay == NULL) { - grdisplay = XOpenDisplay(display_name); - if (grdisplay == NULL) - gr_fail("Cannot open display %s", XDisplayName(display_name)); - grscreen = DefaultScreen(grdisplay); - grblack = BlackPixel(grdisplay, grscreen); - grwhite = WhitePixel(grdisplay, grscreen); - grbackground = grwhite; - grcolormap = DefaultColormap(grdisplay, grscreen); - } - - /* Set up the error handlers */ - XSetErrorHandler(gr_error_handler); - XSetIOErrorHandler(gr_ioerror_handler); - - /* Parse the geometry specification */ - hints.x = 0; - hints.y = 0; - hints.width = DEFAULT_SCREEN_WIDTH; - hints.height = DEFAULT_SCREEN_HEIGHT; - hints.flags = PPosition | PSize; - hints.win_gravity = 0; - - ret = XWMGeometry(grdisplay, grscreen, geometry_spec, "", BORDER_WIDTH, - &hints, &x, &y, &w, &h, &hints.win_gravity); - if (ret & (XValue | YValue)) { - hints.x = x; hints.y = y; hints.flags |= USPosition; - } - if (ret & (WidthValue | HeightValue)) { - hints.width = w; hints.height = h; hints.flags |= USSize; - } - - /* Initial drawing color is black */ - grcolor = 0; /* CAML COLOR */ - - /* Create the on-screen window */ - grwindow.w = hints.width; - grwindow.h = hints.height; - grwindow.win = - XCreateSimpleWindow(grdisplay, DefaultRootWindow(grdisplay), - hints.x, hints.y, hints.width, hints.height, - BORDER_WIDTH, grblack, grbackground); - p = window_name; - if (p == NULL) p = DEFAULT_WINDOW_NAME; - XSetStandardProperties(grdisplay, grwindow.win, p, p, - None, NULL, 0, &hints); - grwindow.gc = XCreateGC(grdisplay, grwindow.win, 0, NULL); - XSetBackground(grdisplay, grwindow.gc, grbackground); - XSetForeground(grdisplay, grwindow.gc, grblack); - - /* Require exposure, resize and keyboard events */ - grselected_events = DEFAULT_SELECTED_EVENTS; - XSelectInput(grdisplay, grwindow.win, grselected_events); - - /* Map the window on the screen and wait for the first Expose event */ - XMapWindow(grdisplay, grwindow.win); - do { XNextEvent(grdisplay, &event); } while (event.type != Expose); - - /* Get the actual window dimensions */ - XGetWindowAttributes(grdisplay, grwindow.win, &attributes); - grwindow.w = attributes.width; - grwindow.h = attributes.height; - - /* Create the pixmap used for backing store */ - grbstore.w = grwindow.w; - grbstore.h = grwindow.h; - grbstore.win = - XCreatePixmap(grdisplay, grwindow.win, grbstore.w, grbstore.h, - XDefaultDepth(grdisplay, grscreen)); - grbstore.gc = XCreateGC(grdisplay, grbstore.win, 0, NULL); - XSetBackground(grdisplay, grbstore.gc, grbackground); - - /* Clear the pixmap */ - XSetForeground(grdisplay, grbstore.gc, grbackground); - XFillRectangle(grdisplay, grbstore.win, grbstore.gc, - 0, 0, grbstore.w, grbstore.h); - XSetForeground(grdisplay, grbstore.gc, grblack); - - /* Set the display and remember modes on */ - grdisplay_mode = True ; - grremember_mode = True ; - - /* The global data structures are now correctly initialized. - In particular, gr_sigio_handler can now handle events safely. */ - gr_initialized = True; - - /* If possible, request that system calls be restarted after - the EVENT_SIGNAL signal. */ -#ifdef POSIX_SIGNALS -#ifdef SA_RESTART - { struct sigaction action; - sigaction(EVENT_SIGNAL, NULL, &action); - action.sa_flags |= SA_RESTART; - sigaction(EVENT_SIGNAL, &action, NULL); - } -#endif -#endif - -#ifdef USE_ASYNC_IO - /* If BSD-style asynchronous I/O are supported: - arrange for I/O on the connection to trigger the SIGIO signal */ - ret = fcntl(ConnectionNumber(grdisplay), F_GETFL, 0); - fcntl(ConnectionNumber(grdisplay), F_SETFL, ret | FASYNC); - fcntl(ConnectionNumber(grdisplay), F_SETOWN, getpid()); -#endif - } -#ifdef USE_INTERVAL_TIMER - /* If BSD-style interval timers are provided, use the real-time timer - to poll events. */ - { struct itimerval it; - it.it_interval.tv_sec = 0; - it.it_interval.tv_usec = 250000; - it.it_value.tv_sec = 0; - it.it_value.tv_usec = 250000; - setitimer(ITIMER_REAL, &it, NULL); - } -#endif -#ifdef USE_ALARM - /* The poor man's solution: use alarm to poll events. */ - alarm(1); -#endif - /* Position the current point at origin */ - grx = 0; - gry = 0; - /* Reset the color cache */ - gr_init_color_cache(); - gr_init_direct_rgb_to_pixel(); - return Val_unit; -} - -value gr_close_graph(void) -{ - if (gr_initialized) { -#ifdef USE_INTERVAL_TIMER - struct itimerval it; - it.it_value.tv_sec = 0; - it.it_value.tv_usec = 0; - setitimer(ITIMER_REAL, &it, NULL); -#endif - gr_initialized = False; - if (grfont != NULL) { XFreeFont(grdisplay, grfont); grfont = NULL; } - XFreeGC(grdisplay, grwindow.gc); - XDestroyWindow(grdisplay, grwindow.win); - XFreeGC(grdisplay, grbstore.gc); - XFreePixmap(grdisplay, grbstore.win); - XFlush(grdisplay); - } - return Val_unit; -} - -value id_of_window(Window win) -{ - char tmp[256]; - - sprintf(tmp, "%lu", (unsigned long)win); - return copy_string( tmp ); -} - -value gr_window_id(void) -{ - gr_check_open(); - return id_of_window(grwindow.win); -} - -value gr_set_window_title(value n) -{ - if (window_name != NULL) stat_free(window_name); - window_name = stat_alloc(strlen(String_val(n))); - strcpy(window_name, String_val(n)); - if (gr_initialized) { - XStoreName(grdisplay, grwindow.win, window_name); - XSetIconName(grdisplay, grwindow.win, window_name); - XFlush(grdisplay); - } - return Val_unit; -} - -value gr_clear_graph(void) -{ - gr_check_open(); - if(grremember_mode) { - XSetForeground(grdisplay, grbstore.gc, grwhite); - XFillRectangle(grdisplay, grbstore.win, grbstore.gc, - 0, 0, grbstore.w, grbstore.h); - XSetForeground(grdisplay, grbstore.gc, grcolor); - } - if(grdisplay_mode) { - XSetForeground(grdisplay, grwindow.gc, grwhite); - XFillRectangle(grdisplay, grwindow.win, grwindow.gc, - 0, 0, grwindow.w, grwindow.h); - XSetForeground(grdisplay, grwindow.gc, grcolor); - XFlush(grdisplay); - } - gr_init_color_cache(); - gr_init_direct_rgb_to_pixel(); - return Val_unit; -} - -value gr_size_x(void) -{ - gr_check_open(); - return Val_int(grwindow.w); -} - -value gr_size_y(void) -{ - gr_check_open(); - return Val_int(grwindow.h); -} - -value gr_synchronize(void) -{ - gr_check_open(); - XCopyArea(grdisplay, grbstore.win, grwindow.win, grwindow.gc, - 0, grbstore.h - grwindow.h, - grwindow.w, grwindow.h, - 0, 0); - XFlush(grdisplay); - return Val_unit ; -} - -value gr_display_mode(value flag) -{ - grdisplay_mode = Bool_val (flag); - return Val_unit ; -} - -value gr_remember_mode(value flag) -{ - grremember_mode = Bool_val(flag); - return Val_unit ; -} - -/* The gr_sigio_handler is called via the signal machinery in the bytecode - interpreter. The signal system ensures that this function will be - called either between two bytecode instructions, or during a blocking - primitive. In either case, not in the middle of an Xlib call. */ - -value gr_sigio_signal(value unit) -{ - return Val_int(EVENT_SIGNAL); -} - -value gr_sigio_handler(void) -{ - XEvent grevent; - - if (gr_initialized) { - while (XCheckMaskEvent(grdisplay, -1 /*all events*/, &grevent)) { - gr_handle_event(&grevent); - } - } -#ifdef USE_ALARM - alarm(1); -#endif - return Val_unit; -} - -/* Processing of graphic errors */ - -static value * graphic_failure_exn = NULL; - -void gr_fail(char *fmt, char *arg) -{ - char buffer[1024]; - - if (graphic_failure_exn == NULL) { - graphic_failure_exn = caml_named_value("Graphics.Graphic_failure"); - if (graphic_failure_exn == NULL) - invalid_argument("Exception Graphics.Graphic_failure not initialized, must link graphics.cma"); - } - sprintf(buffer, fmt, arg); - raise_with_string(*graphic_failure_exn, buffer); -} - -void gr_check_open(void) -{ - if (!gr_initialized) gr_fail("graphic screen not opened", NULL); -} - -static int gr_error_handler(Display *display, XErrorEvent *error) -{ - char errmsg[512]; - XGetErrorText(error->display, error->error_code, errmsg, sizeof(errmsg)); - gr_fail("Xlib error: %s", errmsg); - return 0; -} - -static int gr_ioerror_handler(Display *display) -{ - gr_fail("fatal I/O error", NULL); - return 0; -} diff --git a/otherlibs/graph/point_col.c b/otherlibs/graph/point_col.c deleted file mode 100644 index 8df0dfaf01..0000000000 --- a/otherlibs/graph/point_col.c +++ /dev/null @@ -1,32 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "libgraph.h" - -value gr_point_color(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - XImage * im; - int rgb; - - gr_check_open(); - im = XGetImage(grdisplay, grbstore.win, x, Bcvt(y), 1, 1, (-1), ZPixmap); - rgb = gr_rgb_pixel(XGetPixel(im, 0, 0)); - XDestroyImage(im); - return Val_int(rgb); -} - - diff --git a/otherlibs/graph/sound.c b/otherlibs/graph/sound.c deleted file mode 100644 index 4b30622068..0000000000 --- a/otherlibs/graph/sound.c +++ /dev/null @@ -1,34 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "libgraph.h" - -value gr_sound(value vfreq, value vdur) -{ - XKeyboardControl kbdcontrol; - - gr_check_open(); - kbdcontrol.bell_pitch = Int_val(vfreq); - kbdcontrol.bell_duration = Int_val(vdur); - XChangeKeyboardControl(grdisplay, KBBellPitch | KBBellDuration, - &kbdcontrol); - XBell(grdisplay, 0); - kbdcontrol.bell_pitch = -1; /* restore default value */ - kbdcontrol.bell_duration = -1; /* restore default value */ - XChangeKeyboardControl(grdisplay, KBBellPitch | KBBellDuration, - &kbdcontrol); - XFlush(grdisplay); - return Val_unit; -} diff --git a/otherlibs/graph/subwindow.c b/otherlibs/graph/subwindow.c deleted file mode 100644 index a97242de0b..0000000000 --- a/otherlibs/graph/subwindow.c +++ /dev/null @@ -1,45 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Jun Furuse, projet Cristal, INRIA Rocquencourt */ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "libgraph.h" - -value gr_open_subwindow(value vx, value vy, value width, value height) -{ - Window win; - - int h = Int_val(height); - int w = Int_val(width); - int x = Int_val(vx); - int y = Int_val(vy); - - gr_check_open(); - win = XCreateSimpleWindow(grdisplay, grwindow.win, - x, Wcvt(y + h), w, h, - 0, grblack, grbackground); - XMapWindow(grdisplay, win); - XFlush(grdisplay); - return (id_of_window (win)); -} - -value gr_close_subwindow(value wid) -{ - Window win; - - gr_check_open(); - sscanf( String_val(wid), "%lu", (unsigned long *)(&win) ); - XDestroyWindow(grdisplay, win); - XFlush(grdisplay); - return Val_unit; -} diff --git a/otherlibs/graph/text.c b/otherlibs/graph/text.c deleted file mode 100644 index ad41f2ff2a..0000000000 --- a/otherlibs/graph/text.c +++ /dev/null @@ -1,84 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "libgraph.h" -#include <alloc.h> - -XFontStruct * grfont = NULL; - -static void gr_font(char *fontname) -{ - XFontStruct * font = XLoadQueryFont(grdisplay, fontname); - if (font == NULL) gr_fail("cannot find font %s", fontname); - if (grfont != NULL) XFreeFont(grdisplay, grfont); - grfont = font; - XSetFont(grdisplay, grwindow.gc, grfont->fid); - XSetFont(grdisplay, grbstore.gc, grfont->fid); -} - -value gr_set_font(value fontname) -{ - gr_check_open(); - gr_font(String_val(fontname)); - return Val_unit; -} - -value gr_set_text_size (value sz) -{ - return Val_unit; -} - -static void gr_draw_text(char *txt, int len) -{ - if (grfont == NULL) gr_font(DEFAULT_FONT); - if (grremember_mode) - XDrawString(grdisplay, grbstore.win, grbstore.gc, - grx, Bcvt(gry) - grfont->descent + 1, txt, len); - if (grdisplay_mode) { - XDrawString(grdisplay, grwindow.win, grwindow.gc, - grx, Wcvt(gry) - grfont->descent + 1, txt, len); - XFlush(grdisplay); - } - grx += XTextWidth(grfont, txt, len); -} - -value gr_draw_char(value chr) -{ - char str[1]; - gr_check_open(); - str[0] = Int_val(chr); - gr_draw_text(str, 1); - return Val_unit; -} - -value gr_draw_string(value str) -{ - gr_check_open(); - gr_draw_text(String_val(str), string_length(str)); - return Val_unit; -} - -value gr_text_size(value str) -{ - int width; - value res; - gr_check_open(); - if (grfont == NULL) gr_font(DEFAULT_FONT); - width = XTextWidth(grfont, String_val(str), string_length(str)); - res = alloc_small(2, 0); - Field(res, 0) = Val_int(width); - Field(res, 1) = Val_int(grfont->ascent + grfont->descent); - return res; -} diff --git a/otherlibs/labltk/.cvsignore b/otherlibs/labltk/.cvsignore deleted file mode 100644 index f58b0734b6..0000000000 --- a/otherlibs/labltk/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -labltklink -labltkopt -Makefile.config -config.status diff --git a/otherlibs/labltk/Changes b/otherlibs/labltk/Changes deleted file mode 100644 index bd671fdb67..0000000000 --- a/otherlibs/labltk/Changes +++ /dev/null @@ -1,13 +0,0 @@ -version 1.0a1 - -General Changes -* Merging CamlTk and LablTk API interfaces -* Activate and Deactivate Events are added -* Virtual events support -* Added UTF conversion - -Incompatibilities between the previous camltk/labltk versions -* CamlTk's bind_tag and bind_class superseded tag_bind and class_bind. -* added optional arguments to some functions of CamlTk. -* The library name libfrx and libjpf are changed to frxlib and jpflib - respectively, to avoid the library name confusion. diff --git a/otherlibs/labltk/Makefile b/otherlibs/labltk/Makefile deleted file mode 100644 index 4e4fbd159c..0000000000 --- a/otherlibs/labltk/Makefile +++ /dev/null @@ -1,80 +0,0 @@ -# Top Makefile for mlTk - -SUBDIRS=compiler support lib jpf frx tkanim examples_labltk \ - examples_camltk browser -SUBDIRS_GENERATED=camltk labltk - - -all: - cd support; $(MAKE) - cd compiler; $(MAKE) - cd labltk; $(MAKE) -f Makefile.gen - cd labltk; $(MAKE) - cd camltk; $(MAKE) -f Makefile.gen - cd camltk; $(MAKE) - cd lib; $(MAKE) - cd jpf; $(MAKE) - cd frx; $(MAKE) - cd tkanim; $(MAKE) - cd browser; $(MAKE) - -allopt: - cd support; $(MAKE) opt - cd labltk; $(MAKE) -f Makefile.gen - cd labltk; $(MAKE) opt - cd camltk; $(MAKE) -f Makefile.gen - cd camltk; $(MAKE) opt - cd lib; $(MAKE) opt - cd jpf; $(MAKE) opt - cd frx; $(MAKE) opt - cd tkanim; $(MAKE) opt - -byte: all -opt: allopt - -.PHONY: labltk camltk examples_labltk examples_camltk - -labltk: Widgets.src - compiler/tkcompiler -outdir labltk - cd labltk; $(MAKE) - -camltk: Widgets.src - compiler/tkcompiler -camltk -outdir camltk - cd camltk; $(MAKE) - -examples: examples_labltk examples_camltk - -examples_labltk: - cd examples_labltk; $(MAKE) all - -examples_camltk: - cd examples_camltk; $(MAKE) all - -install: - cd labltk; $(MAKE) install - cd camltk; $(MAKE) install - cd lib; $(MAKE) install - cd support; $(MAKE) install - cd compiler; $(MAKE) install - cd jpf; $(MAKE) install - cd frx; $(MAKE) install - cd tkanim; $(MAKE) install - cd browser; $(MAKE) install - -installopt: - cd labltk; $(MAKE) installopt - cd camltk; $(MAKE) installopt - cd lib; $(MAKE) installopt - cd jpf; $(MAKE) installopt - cd frx; $(MAKE) installopt - cd tkanim; $(MAKE) installopt - -partialclean clean: - for d in $(SUBDIRS); do \ - cd $$d; $(MAKE) -f Makefile clean; cd ..; \ - done - for d in $(SUBDIRS_GENERATED); do \ - cd $$d; $(MAKE) -f Makefile.gen clean; cd ..; \ - done - -depend: diff --git a/otherlibs/labltk/Makefile.nt b/otherlibs/labltk/Makefile.nt deleted file mode 100644 index 0f91c1ace7..0000000000 --- a/otherlibs/labltk/Makefile.nt +++ /dev/null @@ -1,59 +0,0 @@ -# Top Makefile for LablTk - -include ../../config/Makefile - -SUBDIRS=compiler support lib labltk camltk jpf frx tkanim examples_labltk examples_camltk browser - -all: - cd support ; $(MAKEREC) - cd compiler ; $(MAKEREC) - cd labltk ; $(MAKECMD) -f Makefile.gen.nt - cd labltk ; $(MAKEREC) - cd camltk ; $(MAKECMD) -f Makefile.gen.nt - cd camltk ; $(MAKEREC) - cd lib ; $(MAKEREC) - cd jpf ; $(MAKEREC) - cd frx ; $(MAKEREC) - cd tkanim ; $(MAKEREC) - cd browser ; $(MAKEREC) - -allopt: - cd support ; $(MAKEREC) opt - cd labltk ; $(MAKECMD) -f Makefile.gen.nt - cd labltk ; $(MAKEREC) opt - cd camltk ; $(MAKECMD) -f Makefile.gen.nt - cd camltk ; $(MAKEREC) opt - cd lib ; $(MAKEREC) opt - cd jpf ; $(MAKEREC) opt - cd frx ; $(MAKEREC) opt - cd tkanim ; $(MAKEREC) opt - -example: examples_labltk/all examples_camltk/all - -examples_labltk/all: - cd examples_labltk ; $(MAKEREC) all - -examples_camltk/all: - cd examples_camltk ; $(MAKEREC) all - -install: - cd labltk ; $(MAKEREC) install - cd camltk ; $(MAKEREC) install - cd lib ; $(MAKEREC) install - cd support ; $(MAKEREC) install - cd compiler ; $(MAKEREC) install - cd jpf ; $(MAKEREC) install - cd frx ; $(MAKEREC) install - cd tkanim ; $(MAKEREC) install - cd browser ; $(MAKEREC) install - -installopt: - cd labltk ; $(MAKEREC) installopt - cd camltk ; $(MAKEREC) installopt - cd lib ; $(MAKEREC) installopt - cd jpf ; $(MAKEREC) installopt - cd frx ; $(MAKEREC) installopt - cd tkanim ; $(MAKEREC) installopt - -partialclean clean: - for d in $(SUBDIRS); do $(MAKEREC) -C $$d clean; done diff --git a/otherlibs/labltk/README b/otherlibs/labltk/README deleted file mode 100644 index 6f63b4a4dd..0000000000 --- a/otherlibs/labltk/README +++ /dev/null @@ -1,152 +0,0 @@ -INTRODUCTION -============ -mlTk is a library for interfacing Objective Caml with the scripting -language Tcl/Tk (all versions since 8.0.3, but no betas). - -In addition to the basic interface with Tcl/Tk, this package contains - * the OCamlBrowser code editor / library browser written by Jacques - Garrigue. - * the "jpf" library, written by Jun P. Furuse; it contains a "file - selector" and "balloon help" support - * the "frx" library, written by Francois Rouaix - * the "tkanim" library, which supports animated gif loading/display - -mlTk = CamlTk + LablTk -====================== -There existed two parallel Tcl/Tk interfaces for O'Caml, CamlTk and LablTk. - -CamlTk uses classical features only, therefore it is easy to understand for -the beginners of ML. It makes many conservative O'Caml gurus also happy. -LablTk, on the other hand, uses rather newer features of O'Caml, the labeled -optional arguments and polymorphic variants. Its syntax has much more Tcl/Tk -script flavor, but provides more powerful typing than CamlTk at the same time -(i.e. less run time type checking of widgets). -Until now, these two interfaces have been distributed and maintained -independently. - -mlTk unifies these libraries into one. Since mlTk provides the both API's, -both CamlTk and LablTk users can compile their applications with mlTk, -just with little fixes. - -REQUIREMENTS -============ -You must have already installed - * Objective Caml source, version 3.04+8 or later - - * Tcl/Tk 8.0.3 or later - http://www.scriptics.com/ or various mirrors - -PLATFORMS: -Essentially any Unix/X Window System platform. We have tested -releases on Linux (ELF x86), FreeBSD (x86), SunOS4.1.x (sparc), DEC -OSF/1 V4.0 (alpha), DGUX SVR4 (m88k) and Windows (VC++ and Cygwin). - -INSTALLATION -============ - -0. Check-out the O'Caml CVS source code tree. - -1. Compile O'Caml (= make world). If you want, also make opt. - -2. Untar this mlTk distribution in the otherlibs directory, just like - the labltk source tree. - -3. change directory to otherlibs/mltk, and make (and make opt) - -4. To install the library, make install (and make installopt) - -To compile mlTk, you need the O'Caml source tree, since mltk/camlbrowser -requires some modules of O'Caml. If you are not interested in camlbrowser, -you can compile mlTk without the O'Caml source tree, but you have to modify -support/Makefile.common. - - -Compile your CamlTk/LablTk applications with mlTk -================================================= - -* General - -The names of the additional libraries libjpf and libfrx are changed -to jpflib and frxlib respectively, to avoid the library name space confusion. - -* LablTk users - -Just change the occurrences of labltk in your Makefiles to mltk -(i.e. -I +labltk => -I +mltk, labltk.cma => mltk.cma, and so on) -Since the API functions are 100% compatible, you need not to change -your .ml files. - -* CamlTk users - - - Makefiles : apply the same modification explained above for LablTk users. - - - open Camltk : The API modules and functions are stored in the modules - Camltk. Therefore you need to replace the module name Tk to Camltk. - For example, open Tk => open Camltk. - - open Camltk (* instead of open Tk *) - - let t = openTk ();; - let b = Button.create t [];; - - - You may also need to open the Camltk module explicitly, when your - original module source contain no open Tk phrase. Widget and the other - Tcl/Tk related types are now under Camltk. (e.g. Widget.widget is now - Camltk.Widget.widget) Add open Camltk at the beginning of .mli files, - if these types are used: - - open Camltk (* added for compiling under mlTk *) - - val create_progress_bar : Widget.widget -> Widget.widget - - - Eta expansion to flush optional arguments at registering callbacks. - Functions with the _displayof suffix are unified with their non-displayof - versions, using optional labeled arguments. For example, Bell.ring - had/have the following types: - - before: Bell.ring : unit -> unit - now: Bell.ring : ?displayof:Camltk.widget -> unit -> unit - - If you use these functions as callbacks directly like Command Bell.ring, - you need eta-expansions to flush these new optional arguments: - - Button.create w [Command Bell.ring] - - => Button.create w [Command (fun () -> Bell.ring ())] - -Use the both API's at the same time -=================================== -It is possible to use the both API's in one program. If you want to use -a widget library written in the different API from you use, you need to -do it. (It will be confusing, but easier than porting the library itself -from one to the other API.) - -For the users who mainly use LablTk API, CamlTk API is available -in the modules start with 'C'. For example, the source file of -the CamlTk button widget functions is CButton (and exported also as -Camltk.Button). - -For the users who mainly use CamlTk API, LablTk API modules are exported -inside Labltk module. For example, LablTk's Button module can be also -accessible as Labltk.Button. - -In CamlTk, we have only one widget type, [widget]. This type is equivalent -to the LablTk's type [any widget]. Therefore, if you want to apply CamlTk -functions to LablTk widget, you can use [coe] function to coerce it to -[any widget]. - -To do the converse, the "widget-typers" are available inside the module Labltk. -For example, to recover the type of a button widget, use Labltk.button. -These widget-typers checks the types of widgets at run-time. If the widget -type is different from the context type, a run-time exception is raised. - - open Tk (* open LablTk API *) - - let t = openTk ();; (* t is LablTk widget, toplevel widget *) - (* CButton.create takes [any widget]; [t] must be coerced to the type. *) - let caml_b = CButton.create (coe t) [];; - (* caml_b is [any widget], must be explicitly typed as [button widget], - when it is used with LablTk API functions *) - let b = Labltk.button caml_b in (* recover the type [button widget] *) - ... - diff --git a/otherlibs/labltk/Widgets.src b/otherlibs/labltk/Widgets.src deleted file mode 100644 index e011bbe30f..0000000000 --- a/otherlibs/labltk/Widgets.src +++ /dev/null @@ -1,2271 +0,0 @@ -%%%%%%%%%%%%%% Standard Tk8.0.3 Widgets and functions %%%%%%%%%%%%%% -type Widget external - -% cget will probably never be implemented with verifications -function (string) cgets [widget; "cget"; string] -% another version with some hack is -type options_constrs external -function (string) cget [widget; "cget"; options_constrs] -% constructors of type options_constrs are of the form C<c> -% where <c> is an option constructor (e.g. CBackground) - -%%%%% Some types for standard options of widgets -type Anchor { - NW ["nw"] N ["n"] NE ["ne"] - W ["w"] Center ["center"] E ["e"] - SW ["sw"] S ["s"] SE ["se"] -} - -type Bitmap external % builtin_GetBitmap.ml -type Cursor external % builtin_GetCursor.ml -type Color external % builtin_GetCursor.ml - -##ifdef CAMLTK - -type ImageBitmap { - BitmapImage [string] - } -type ImagePhoto { - PhotoImage [string] - } - -##else - -variant type ImageBitmap { - Bitmap [string] - } -variant type ImagePhoto { - Photo [string] - } -variant type Image { - Bitmap [string] - Photo [string] -} - -##endif - -type Justification { - Justify_Left ["left"] - Justify_Center ["center"] - Justify_Right ["right"] -} - -type Orientation { - Vertical ["vertical"] - Horizontal ["horizontal"] -} - -type Relief { - Raised ["raised"] - Sunken ["sunken"] - Flat ["flat"] - Ridge ["ridge"] - Groove ["groove"] -} - -type TextVariable external % textvariable.ml -type Units external % builtin_GetPixel.ml - -%%%%% The standard options, as defined in man page options(n) -%%%%% The subtype is never used -subtype option(standard) { - ActiveBackground ["-activebackground"; Color] - ActiveBorderWidth ["-activeborderwidth"; Units/int] - ActiveForeground ["-activeforeground"; Color] - Anchor ["-anchor"; Anchor] - Background ["-background"; Color] - Bitmap ["-bitmap"; Bitmap] - BorderWidth ["-borderwidth"; Units/int] - Cursor ["-cursor"; Cursor] - DisabledForeground ["-disabledforeground"; Color] - ExportSelection ["-exportselection"; bool] - Font ["-font"; string] - Foreground ["-foreground"; Color] -% Geometry is not one of standard options... - Geometry ["-geometry"; string] % Too variable to encode - HighlightBackground ["-highlightbackground"; Color] - HighlightColor ["-highlightcolor"; Color] - HighlightThickness ["-highlightthickness"; Units/int] -##ifdef CAMLTK - % images are split, to do additionnal static typing - ImageBitmap (ImageBitmap) ["-image"; ImageBitmap] - ImagePhoto (ImagePhoto) ["-image"; ImagePhoto] -##else - Image ["-image"; Image] -##endif - InsertBackground ["-insertbackground"; Color] - InsertBorderWidth ["-insertborderwidth"; Units/int] - InsertOffTime ["-insertofftime"; int] % Positive only - InsertOnTime ["-insertontime"; int] % Idem - InsertWidth ["-insertwidth"; Units/int] - Jump ["-jump"; bool] - Justify ["-justify"; Justification] - Orient ["-orient"; Orientation] - PadX ["-padx"; Units/int] - PadY ["-pady"; Units/int] - Relief ["-relief"; Relief] - RepeatDelay ["-repeatdelay"; int] - RepeatInterval ["-repeatinterval"; int] - SelectBackground ["-selectbackground"; Color] - SelectBorderWidth ["-selectborderwidth"; Units/int] - SelectForeground ["-selectforeground"; Color] - SetGrid ["-setgrid"; bool] - % incomplete description of TakeFocus - TakeFocus ["-takefocus"; bool] - Text ["-text"; string] - TextVariable ["-textvariable"; TextVariable] - TroughColor ["-troughcolor"; Color] - UnderlinedChar ["-underline"; int] - WrapLength ["-wraplength"; Units/int] - XScrollCommand ["-xscrollcommand"; function(first:float, last:float)] - YScrollCommand ["-yscrollcommand"; function(first:float, last:float)] -} - -%%%% Some other common types -type Index external % builtin_index.ml -type sequence ScrollValue external % builtin_ScrollValue.ml -% type sequence ScrollValue { -% MoveTo ["moveto"; float] -% ScrollUnit ["scroll"; int; "unit"] -% ScrollPage ["scroll"; int; "page"] -% } - - - -%%%%% bell(n) -module Bell { -##ifdef CAMLTK - function () ring ["bell"; ?displayof:["-displayof"; widget]] - function () ring_displayof ["bell"; "-displayof" ; displayof: widget] -##else - function () ring ["bell"; ?displayof:["-displayof"; widget]] -##endif - } - -%%%%% bind(n) -% builtin_bind.ml - - -%%%%% bindtags(n) -%type Bindings { -% TagBindings [string] -% WidgetBindings [widget] -% } - -type Bindings external - -function () bindtags ["bindtags"; widget; [bindings: Bindings list]] -function (Bindings list) bindtags_get ["bindtags"; widget] - -%%%%% bitmap(n) -subtype option(bitmapimage) { - Background - Data ["-data"; string] - File ["-file"; string] - Foreground - Maskdata ["-maskdata"; string] - Maskfile ["-maskfile"; string] - } - -module Imagebitmap { - function (ImageBitmap) create ["image"; "create"; "bitmap"; ?name:[ImageBitmap]; option(bitmapimage) list] -##ifdef CAMLTK - function (ImageBitmap) create_named ["image"; "create"; "bitmap"; ImageBitmap; option(bitmapimage) list] -##endif - function () delete ["image"; "delete"; ImageBitmap] - function (int) height ["image"; "height"; ImageBitmap] - function (int) width ["image"; "width"; ImageBitmap] - function () configure [ImageBitmap; "configure"; option(bitmapimage) list] - function (string) configure_get [ImageBitmap; "configure"] - % Functions inherited from the "image" TK class - } - -%%%%% button(n) - -type State { - Normal ["normal"] - Active ["active"] - Disabled ["disabled"] -} - -widget button { - % Standard options - option ActiveBackground - option ActiveForeground - option Anchor - option Background - option Bitmap - option BorderWidth - option Cursor - option DisabledForeground - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness -##ifdef CAMLTK - option ImageBitmap - option ImagePhoto -##else - option Image -##endif - option Justify - option PadX - option PadY - option Relief - option TakeFocus - option Text - option TextVariable - option UnderlinedChar - option WrapLength - % Widget specific options - option Command ["-command"; function ()] - option Default ["-default"; State] - option Height ["-height"; Units/int] - option State ["-state"; State] - option Width ["-width"; Units/int] - - function () configure [widget(button); "configure"; option(button) list] - function (string) configure_get [widget(button); "configure"] - function () flash [widget(button); "flash"] - function () invoke [widget(button); "invoke"] - } - - -%%%%%% canvas(n) -% Item ids and tags -type TagOrId { - Tag [string] - Id [int] -} - -% Indices: defined internally -% subtype Index(canvas) { -% Number End Insert SelFirst SelLast AtXY -% } - -type SearchSpec { - Above ["above"; TagOrId] - All ["all"] - Below ["below"; TagOrId] - Closest ["closest"; Units/int; Units/int] - ClosestHalo (Closesthalo) ["closest"; Units/int; Units/int; Units/int] - ClosestHaloStart (Closesthalostart) ["closest"; Units/int; Units/int; Units/int; TagOrId] - Enclosed ["enclosed"; Units/int;Units/int;Units/int;Units/int] - Overlapping ["overlapping"; int;int;int;int] - Withtag ["withtag"; TagOrId] -} - -type ColorMode { - Color ["color"] - Gray ["gray"] - Mono ["mono"] -} - -subtype option(postscript) { - % Cannot support this without array variables - % Colormap ["-colormap"; TextVariable] - Colormode ["-colormode"; ColorMode] - File ["-file"; string] - % Fontmap ["-fontmap"; TextVariable] - Height - PageAnchor ["-pageanchor"; Anchor] - PageHeight ["-pageheight"; Units/int] - PageWidth ["-pagewidth"; Units/int] - PageX ["-pagex"; Units/int] - PageY ["-pagey"; Units/int] - Rotate ["-rotate"; bool] - Width - X ["-x"; Units/int] - Y ["-y"; Units/int] - } - - -% Arc item configuration -type ArcStyle { - Arc ["arc"] - Chord ["chord"] - PieSlice ["pieslice"] -} - -subtype option(arc) { - Extent ["-extent"; float] - Dash ["-dash"; string] - % Fill is used by packer - FillColor ["-fill"; Color] - Outline ["-outline"; Color] - OutlineStipple ["-outlinestipple"; Bitmap] - Start ["-start"; float] - Stipple ["-stipple"; Bitmap] - ArcStyle ["-style"; ArcStyle] - Tags ["-tags"; [TagOrId/string list]] - Width - } - -% Bitmap item configuration -subtype option(bitmap) { - Anchor - Background - Bitmap - Foreground - Tags -} - -% Image item configuration -subtype option(image) { - Anchor -##ifdef CAMLTK - ImagePhoto - ImageBitmap -##else - Image -##endif - Tags -} - -% Line item configuration -type ArrowStyle { - Arrow_None ["none"] - Arrow_First ["first"] - Arrow_Last ["last"] - Arrow_Both ["both"] -} - -type CapStyle { - Cap_Butt ["butt"] - Cap_Projecting ["projecting"] - Cap_Round ["round"] -} - -type JoinStyle { - Join_Bevel ["bevel"] - Join_Miter ["miter"] - Join_Round ["round"] -} - -subtype option(line) { - ArrowStyle ["-arrow"; ArrowStyle] - ArrowShape ["-arrowshape"; [Units/int; Units/int; Units/int]] - CapStyle ["-capstyle"; CapStyle] - Dash - FillColor - JoinStyle ["-joinstyle"; JoinStyle] - Smooth ["-smooth"; bool] - SplineSteps ["-splinesteps"; int] - Stipple - Tags - Width - } - -% Oval item configuration -subtype option(oval) { - Dash FillColor Outline Stipple Tags Width - } - -% Polygon item configuration -subtype option(polygon) { - Dash FillColor Outline Smooth SplineSteps - Stipple Tags Width - } - -% Rectangle item configuration -subtype option(rectangle) { - Dash FillColor Outline Stipple Tags Width - } - -% Text item configuration -subtype option(canvastext) { - Anchor FillColor Font Justify - Stipple Tags Text Width - } - -% Window item configuration -subtype option(window) { - Anchor Height Tags Width - Window ["-window"; widget] - Dash - } - -% Types of items -type CanvasItem { - Arc_item ["arc"] - Bitmap_item ["bitmap"] - Image_item ["image"] - Line_item ["line"] - Oval_item ["oval"] - Polygon_item ["polygon"] - Rectangle_item ["rectangle"] - Text_item ["text"] - Window_item ["window"] - User_item [string] -} - -widget canvas { - % Standard options - option Background - option BorderWidth - option Cursor - option HighlightBackground - option HighlightColor - option HighlightThickness - option InsertBackground - option InsertBorderWidth - option InsertOffTime - option InsertOnTime - option InsertWidth - option Relief - option SelectBackground - option SelectBorderWidth - option SelectForeground - option TakeFocus - option XScrollCommand - option YScrollCommand - % Widget specific options - option CloseEnough ["-closeenough"; float] - option Confine ["-confine"; bool] - option Height ["-height"; Units/int] - option ScrollRegion ["-scrollregion"; [Units/int;Units/int;Units/int;Units/int]] - option Width ["-width"; Units/int] - option XScrollIncrement ["-xscrollincrement"; Units/int] - option YScrollIncrement ["-yscrollincrement"; Units/int] - - - function () addtag [widget(canvas); "addtag"; tag: TagOrId/string; specs: SearchSpec list] % Tag only - % bbox not fully supported. should be builtin because of ambiguous result - % will raise Protocol.TkError if no items match TagOrId - function (int,int,int,int) bbox [widget(canvas); "bbox"; TagOrId list] - external bind "builtin/canvas_bind" -##ifdef CAMLTK - function (float) canvasx [widget(canvas); "canvasx"; ?spacing:[Units]; Units] - function (float) canvasy [widget(canvas); "canvasy"; ?spacing:[Units]; Units] - function (float) canvasx_grid [widget(canvas); "canvasx"; Units; Units] - function (float) canvasy_grid [widget(canvas); "canvasy"; Units; Units] -##else - function (float) canvasx [widget(canvas); "canvasx"; x:int; ?spacing:[int]] - function (float) canvasy [widget(canvas); "canvasy"; y:int; ?spacing:[int]] -##endif - function () configure [widget(canvas); "configure"; option(canvas) list] - function (string) configure_get [widget(canvas); "configure"] - % TODO: check result - function (float list) coords_get [widget(canvas); "coords"; TagOrId] -##ifdef CAMLTK - function () coords_set [widget(canvas); "coords"; TagOrId; xys: Units list] -##else - function () coords_set [widget(canvas); "coords"; TagOrId; xys: {int, int} list] -##endif - % create variations (see below) - function () dchars [widget(canvas); "dchars"; TagOrId; first: Index(canvas); last: Index(canvas)] - function () delete [widget(canvas); "delete"; TagOrId list] - function () dtag [widget(canvas); "dtag"; TagOrId; tag: TagOrId/string] - function (TagOrId list) find [widget(canvas); "find"; specs: SearchSpec list] - % focus variations - function () focus_reset [widget(canvas); "focus"; ""] - function (TagOrId) focus_get [widget(canvas); "focus"] - function () focus [widget(canvas); "focus"; TagOrId] - function (TagOrId/string list) gettags [widget(canvas); "gettags"; TagOrId] - function () icursor [widget(canvas); "icursor"; TagOrId; index: Index(canvas)] - function (int) index [widget(canvas); "index"; TagOrId; index: Index(canvas)] - function () insert [widget(canvas); "insert"; TagOrId; before: Index(canvas); text: string] - % itemcget, itemconfigure are defined later - function () lower [widget(canvas); "lower"; TagOrId; ?below: [TagOrId]] -##ifdef CAMLTK - function () lower_below [widget(canvas); "lower"; TagOrId; TagOrId] - function () lower_bot [widget(canvas); "lower"; TagOrId] -##endif - function () move [widget(canvas); "move"; TagOrId; x: Units/int; y: Units/int] - unsafe function (string) postscript [widget(canvas); "postscript"; option(postscript) list] - % We use raise with Module name - function () raise [widget(canvas); "raise"; TagOrId; ?above:[TagOrId]] -##ifdef CAMLTK - function () raise_above [widget(canvas); "raise"; TagOrId; TagOrId] - function () raise_top [widget(canvas); "raise"; TagOrId] -##endif - function () scale [widget(canvas); "scale"; TagOrId; xorigin: Units/int; yorigin: Units/int; xscale: float; yscale: float] - % For scan, use x:int and y:int since common usage is with mouse coordinates - function () scan_mark [widget(canvas); "scan"; "mark"; x: int; y: int] - function () scan_dragto [widget(canvas); "scan"; "dragto"; x: int; y: int] - % select variations - function () select_adjust [widget(canvas); "select"; "adjust"; TagOrId; index: Index(canvas)] - function () select_clear [widget(canvas); "select"; "clear"] - function () select_from [widget(canvas); "select"; "from"; TagOrId; index: Index(canvas)] - function (TagOrId) select_item [widget(canvas); "select"; "item"] - function () select_to [widget(canvas); "select"; "to"; TagOrId; index: Index(canvas)] - - function (CanvasItem) typeof [widget(canvas); "type"; TagOrId] - function (float,float) xview_get [widget(canvas); "xview"] - function (float,float) yview_get [widget(canvas); "yview"] - function () xview [widget(canvas); "xview"; scroll: ScrollValue] - function () yview [widget(canvas); "yview"; scroll: ScrollValue] - - % create and configure variations - function (TagOrId) create_arc [widget(canvas); "create"; "arc"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(arc) list] - function (TagOrId) create_bitmap [widget(canvas); "create"; "bitmap"; x: Units/int; y: Units/int; option(bitmap) list] - function (TagOrId) create_image [widget(canvas); "create"; "image"; x: Units/int; y: Units/int; option(image) list] -##ifdef CAMLTK - function (TagOrId) create_line [widget(canvas); "create"; "line"; Units list; option(line) list] - function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; Units list; option(polygon) list] -##else - function (TagOrId) create_line [widget(canvas); "create"; "line"; xys: {int, int} list; option(line) list] - function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; xys: {int, int} list; option(polygon) list] -##endif - function (TagOrId) create_oval [widget(canvas); "create"; "oval"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(oval) list] - function (TagOrId) create_rectangle [widget(canvas); "create"; "rectangle"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(rectangle) list] - function (TagOrId) create_text [widget(canvas); "create"; "text"; x: Units/int; y: Units/int; option(canvastext) list] - function (TagOrId) create_window [widget(canvas); "create"; "window"; x: Units/int; y: Units/int; option(window) list] - - function (string) itemconfigure_get [widget(canvas); "itemconfigure"; TagOrId] - - function () configure_arc [widget(canvas); "itemconfigure"; TagOrId; option(arc) list] - function () configure_bitmap [widget(canvas); "itemconfigure"; TagOrId; option(bitmap) list] - function () configure_image [widget(canvas); "itemconfigure"; TagOrId; option(image) list] - function () configure_line [widget(canvas); "itemconfigure"; TagOrId; option(line) list] - function () configure_oval [widget(canvas); "itemconfigure"; TagOrId; option(oval) list] - function () configure_polygon [widget(canvas); "itemconfigure"; TagOrId; option(polygon) list] - function () configure_rectangle [widget(canvas); "itemconfigure"; TagOrId; option(rectangle) list] - function () configure_text [widget(canvas); "itemconfigure"; TagOrId; option(canvastext) list] - function () configure_window [widget(canvas); "itemconfigure"; TagOrId; option(window) list] - } - - -%%%%% checkbutton(n) -widget checkbutton { - % Standard options - option ActiveBackground - option ActiveForeground - option Anchor - option Background - option Bitmap - option BorderWidth - option Cursor - option DisabledForeground - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness -##ifdef CAMLTK - option ImageBitmap - option ImagePhoto -##else - option Image -##endif - option Justify - option PadX - option PadY - option Relief - option TakeFocus - option Text - option TextVariable - option UnderlinedChar - option WrapLength - % Widget specific options - option Command - option Height - option IndicatorOn ["-indicatoron"; bool] - option OffValue ["-offvalue"; string] - option OnValue ["-onvalue"; string] - option SelectColor ["-selectcolor"; Color] -##ifdef CAMLTK - option SelectImageBitmap (SelectImageBitmap) ["-selectimage"; ImageBitmap] - option SelectImagePhoto (SelectImagePhoto) ["-selectimage"; ImagePhoto] -##else - option SelectImage ["-selectimage"; Image] -##endif - option State - option Variable ["-variable"; TextVariable] - option Width - - function () configure [widget(checkbutton); "configure"; option(checkbutton) list] - function (string) configure_get [widget(checkbutton); "configure"] - function () deselect [widget(checkbutton); "deselect"] - function () flash [widget(checkbutton); "flash"] - function () invoke [widget(checkbutton); "invoke"] - function () select [widget(checkbutton); "select"] - function () toggle [widget(checkbutton); "toggle"] - } - -%%%%% clipboard(n) -subtype icccm(clipboard_append) { - ICCCMFormat ["-format"; string] - ICCCMType ["-type"; string] - } - -module Clipboard { - function () clear ["clipboard"; "clear"; ?displayof:["-displayof"; widget]] - function () append ["clipboard"; "append"; ?displayof:["-displayof"; widget]; icccm(clipboard_append) list; "--"; data: string] - } - -%%%%% destroy(n) -function () destroy ["destroy"; widget] - -%%%%% tk_dialog(n) -module Dialog { - external create "builtin/dialog" - } - -%%%%% entry(n) -% Defined internally -% subtype Index(entry) { -% Number End Insert SelFirst SelLast At AnchorPoint -% } - -##ifndef CAMLTK -% Only for Labltk. InputState is unified as State in Camltk -type InputState { - Normal ["normal"] - Disabled ["disabled"] -} -##endif - -widget entry { - % Standard options - option Background - option BorderWidth - option Cursor - option ExportSelection - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness - option InsertBackground - option InsertBorderWidth - option InsertOffTime - option InsertOnTime - option InsertWidth - option Justify - option Relief - option SelectBackground - option SelectBorderWidth - option SelectForeground - option TakeFocus - option TextVariable - option XScrollCommand - - % Widget specific options - option Show ["-show"; char] -##ifdef CAMLTK - option State -##else - option EntryState ["-state"; InputState] -##endif - option TextWidth (Textwidth) ["-width"; int] - - function (int,int,int,int) bbox [widget(entry); "bbox"; Index(entry)] - function () configure [widget(entry); "configure"; option(entry) list] - function (string) configure_get [widget(entry); "configure"] - function () delete_single [widget(entry); "delete"; index: Index(entry)] - function () delete_range [widget(entry); "delete"; start: Index(entry); stop: Index(entry)] - function (string) get [widget(entry); "get"] - function () icursor [widget(entry); "icursor"; index: Index(entry)] - function (int) index [widget(entry); "index"; index: Index(entry)] - function () insert [widget(entry); "insert"; index: Index(entry); text: string] - function () scan_mark [widget(entry); "scan"; "mark"; x: int] - function () scan_dragto [widget(entry); "scan"; "dragto"; x: int] - % selection variation - function () selection_adjust [widget(entry); "selection"; "adjust"; index: Index(entry)] - function () selection_clear [widget(entry); "selection"; "clear"] - function () selection_from [widget(entry); "selection"; "from"; index: Index(entry)] - function (bool) selection_present [widget(entry); "selection"; "present"] - function () selection_range [widget(entry); "selection"; "range"; start: Index(entry) ; stop: Index(entry)] - function () selection_to [widget(entry); "selection"; "to"; index: Index(entry)] - - function (float,float) xview_get [widget(entry); "xview"] - function () xview [widget(entry); "xview"; scroll: ScrollValue] - function () xview_index [widget(entry); "xview"; index: Index(entry)] - function (float, float) xview_get [widget(entry); "xview"] - } - - -%%%%% focus(n) -%%%%% tk_focusNext(n) -module Focus { - unsafe function (widget) get ["focus"; ?displayof:["-displayof"; widget]] - unsafe function (widget) displayof ["focus"; "-displayof"; widget] - function () set ["focus"; widget] - function () force ["focus"; "-force"; widget] - unsafe function (widget) lastfor ["focus"; "-lastfor"; widget] - unsafe function (widget) next ["tk_focusNext"; widget] - unsafe function (widget) prev ["tk_focusPrev"; widget] - function () follows_mouse ["tk_focusFollowsMouse"] -} - -type font external % builtin/builtin_font.ml - -type weight { - Weight_Normal(Normal) ["normal"] - Weight_Bold(Bold) ["bold"] -} - -type slant { - Slant_Roman(Roman) ["roman"] - Slant_Italic(Italic) ["italic"] -} - -type fontMetrics { - Ascent ["-ascent"] - Descent ["-descent"] - Linespace ["-linespace"] - Fixed ["-fixed"] -} - -subtype options(font) { - Font_Family ["-family"; string] - Font_Size ["-size"; int] - Font_Weight ["-weight"; weight] - Font_Slant ["-slant"; slant] - Font_Underline ["-underline"; bool] - Font_Overstrike ["-overstrike"; bool] -% later, JP only -% Charset ["-charset"; string] -%% Beware of the order of Compound ! Put it as the first option -% Compound ["-compound"; [font list]] -% Copy ["-copy"; string] -} - -module Font { - function (string) actual_family ["font"; "actual"; font; - ?displayof:["-displayof"; widget]; - "-family"] - function (int) actual_size ["font"; "actual"; font; - ?displayof:["-displayof"; widget]; - "-size"] - function (string) actual_weight ["font"; "actual"; font; - ?displayof:["-displayof"; widget]; - "-weight"] - function (string) actual_slant ["font"; "actual"; font; - ?displayof:["-displayof"; widget]; - "-slant"] - function (bool) actual_underline ["font"; "actual"; font; - ?displayof:["-displayof"; widget]; - "-underline"] - function (bool) actual_overstrike ["font"; "actual"; font; - ?displayof:["-displayof"; widget]; - "-overstrike"] - - function () configure ["font"; "configure"; font; options(font) list] - function (font) create ["font"; "create"; ?name:[string]; options(font) list] -##ifdef CAMLTK - function (font) create_named ["font"; "create"; string; options(font) list] -##endif - function () delete ["font"; "delete"; font] - function (string list) families ["font"; "families"; - ?displayof:["-displayof"; widget]] -##ifdef CAMLTK - function (string list) families_displayof ["font"; "families"; - "-displayof"; widget] -##endif - function (int) measure ["font"; "measure"; font; string; - ?displayof:["-displayof"; widget]] -##ifdef CAMLTK - function (int) measure_displayof ["font"; "measure"; font; - "-displayof"; widget; string ] -##endif - function (int) metrics ["font"; "metrics"; font; - ?displayof:["-displayof"; widget]; - fontMetrics ] -##ifdef CAMLTK - function (int) metrics_displayof ["font"; "metrics"; font; - "-displayof"; widget; - fontMetrics ] -##endif - function (string list) names ["font"; "names"] -% JP -% function () failsafe ["font"; "failsafe"; string] -} - -%%%%% frame(n) -type Colormap { - NewColormap (New) ["new"] - WidgetColormap (Widget) [widget] - } - -% Visual classes are: directcolor, grayscale, greyscale, pseudocolor, -% staticcolor, staticgray, staticgrey, truecolor -type Visual { - ClassVisual (Clas) [[string; int]] - DefaultVisual ["default"] - WidgetVisual (Widget) [widget] - BestDepth (Bestdepth) [["best"; int]] - Best ["best"] - } - -widget frame { - % Standard options - option BorderWidth - option Cursor - option HighlightBackground - option HighlightColor - option HighlightThickness - option Relief - option TakeFocus - - % Widget specific options - option Background -##ifdef CAMLTK - option Class ["-class"; string] -##else - option Clas ["-class"; string] -##endif - option Colormap ["-colormap"; Colormap] - option Container ["-container"; bool] - option Height - option Visual ["-visual"; Visual] - option Width - - % Class and Colormap and Visual cannot be changed - function () configure [widget(frame); "configure"; option(frame) list] - function (string) configure_get [widget(frame); "configure"] - } - - - -%%%%% grab(n) -type GrabStatus { - GrabNone ["none"] - GrabLocal ["local"] - GrabGlobal ["global"] -} -type GrabGlobal external -module Grab { - function () set ["grab"; "set"; ?global:[GrabGlobal]; widget] -##ifdef CAMLTK - function () set_global ["grab"; "set"; "-global"; widget] -##endif - unsafe function (widget list) current ["grab"; "current"; ?displayof:[widget]] -##ifdef CAMLTK - % all_current is now current. - % The old current is now current_of - unsafe function (widget list) current_of ["grab"; "current"; widget] -##endif - function () release ["grab"; "release"; widget] - function (GrabStatus) status ["grab"; "status"; widget] -} - -subtype option(rowcolumnconfigure) { - Minsize ["-minsize"; Units/int] - Weight ["-weight"; int] - Pad ["-pad"; Units/int] -} - -subtype option(grid) { - Column ["-column"; int] - ColumnSpan ["-columnspan"; int] - In(Inside) ["-in"; widget] - IPadX ["-ipadx"; Units/int] - IPadY ["-ipady"; Units/int] - PadX - PadY - Row ["-row"; int] - RowSpan ["-rowspan"; int] - Sticky ["-sticky"; string] - } - -% Same as pack -function () grid ["grid"; widget list; option(grid) list] - -module Grid { - function (int,int,int,int) bbox ["grid"; "bbox"; widget] - function (int,int,int,int) bbox_cell ["grid"; "bbox"; widget; column: int; row: int] - function (int,int,int,int) bbox_span ["grid"; "bbox"; widget; column1: int; row1: int; column2: int; row2: int] - function () column_configure - ["grid"; "columnconfigure"; widget; int; - option(rowcolumnconfigure) list] - function () configure ["grid"; "configure"; widget list; option(grid) list] - function (string) column_configure_get ["grid"; "columnconfigure"; widget; - int] - function () forget ["grid"; "forget"; widget list] - %% info returns only a string - function (string) info ["grid"; "info"; widget] - %% TODO: check result values - function (int,int) location ["grid"; "location"; widget; x:Units/int; y:Units/int] - function (bool) propagate_get ["grid"; "propagate"; widget] - function () propagate_set ["grid"; "propagate"; widget; bool] - function () row_configure - ["grid"; "rowconfigure"; widget; int; option(rowcolumnconfigure) list] - function (string) row_configure_get ["grid"; "rowconfigure"; widget; int] - function (int,int) size ["grid"; "size"; widget] - -##ifdef CAMLTK - function (widget list) slaves ["grid"; "slaves"; widget; ?column:["-column"; int]; ?row:["-row"; int]] - function (widget list) row_slaves ["grid"; "slaves"; widget; "-row"; int] - function (widget list) column_slaves ["grid"; "slaves"; widget; "-column"; int] -##else - function (widget list) slaves ["grid"; "slaves"; widget; ?column:["-column"; int]; ?row:["-row"; int]] -##endif - } - -%%%%% image(n) -%%%%% cf Imagephoto and Imagebitmap -% Some functions on images are implemented in Imagephoto or Imagebitmap. -module Image { - external names "builtin/image" -} - -%%%%% label(n) -widget label { - % Standard options - option Anchor - option Background - option Bitmap - option BorderWidth - option Cursor - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness -##ifdef CAMLTK - option ImageBitmap - option ImagePhoto -##else - option Image -##endif - option Justify - option PadX - option PadY - option Relief - option TakeFocus - option Text - option TextVariable - option UnderlinedChar - option WrapLength - - % Widget specific options - option Height - % use according to label contents - option Width - option TextWidth - - function () configure [widget(label); "configure"; option(label) list] - function (string) configure_get [widget(label); "configure"] - } - - -%%%%% listbox(n) - -% Defined internally -% subtype Index(listbox) { -% Number Active AnchorPoint End AtXY -%} - -type SelectModeType { - Single ["single"] - Browse ["browse"] - Multiple ["multiple"] - Extended ["extended"] - } - - -widget listbox { - % Standard options - option Background - option BorderWidth - option Cursor - option ExportSelection - option Font - option Foreground - % Height is TextHeight - option HighlightBackground - option HighlightColor - option HighlightThickness - option Relief - option SelectBackground - option SelectBorderWidth - option SelectForeground - option SetGrid - option TakeFocus - % Width is TextWidth - option XScrollCommand - option YScrollCommand - % Widget specific options - option TextHeight ["-height"; int] - option TextWidth - option SelectMode ["-selectmode"; SelectModeType] - - function () activate [widget(listbox); "activate"; index: Index(listbox)] - function (int,int,int,int) bbox [widget(listbox); "bbox"; index: Index(listbox)] - function () configure [widget(listbox); "configure"; option(listbox) list] - function (string) configure_get [widget(listbox); "configure"] - function (Index(listbox) as "[>`Num of int]" list) curselection [widget(listbox); "curselection"] - function () delete [widget(listbox); "delete"; first: Index(listbox); last: Index(listbox)] - function (string) get [widget(listbox); "get"; index: Index(listbox)] - function (string list) get_range [widget(listbox); "get"; first: Index(listbox); last: Index(listbox)] - function (Index(listbox) as "[>`Num of int]") index [widget(listbox); "index"; index: Index(listbox)] - function () insert [widget(listbox); "insert"; index: Index(listbox); texts: string list] - function (Index(listbox) as "[>`Num of int]") nearest [widget(listbox); "nearest"; y: int] - function () scan_mark [widget(listbox); "scan"; "mark"; x: int; y: int] - function () scan_dragto [widget(listbox); "scan"; "dragto"; x: int; y: int] - function () see [widget(listbox); "see"; index: Index(listbox)] - function () selection_anchor [widget(listbox); "selection"; "anchor"; index: Index(listbox)] - function () selection_clear [widget(listbox); "selection"; "clear"; first: Index(listbox); last: Index(listbox)] - function (bool) selection_includes [widget(listbox); "selection"; "includes"; index: Index(listbox)] - function () selection_set [widget(listbox); "selection"; "set"; first: Index(listbox); last: Index(listbox)] - function (int) size [widget(listbox); "size"] - - function (float,float) xview_get [widget(listbox); "xview"] - function (float,float) yview_get [widget(listbox); "yview"] - function () xview_index [widget(listbox); "xview"; index: Index(listbox)] - function () yview_index [widget(listbox); "yview"; index: Index(listbox)] - function () xview [widget(listbox); "xview"; scroll: ScrollValue] - function () yview [widget(listbox); "yview"; scroll: ScrollValue] - } - -%%%%% lower(n) -function () lower_window ["lower"; widget; ?below:[widget]] -##ifdef CAMLTK -function () lower_window_below ["lower"; widget; below: widget] -##endif - - -%%%%% menu(n) -%%%%% tk_popup(n) -% defined internally -% subtype Index(menu) { -% Number Active End Last None At Pattern -% } - -type MenuItem { - Cascade_Item ["cascade"] - Checkbutton_Item ["checkbutton"] - Command_Item ["command"] - Radiobutton_Item ["radiobutton"] - Separator_Item ["separator"] - TearOff_Item ["tearoff"] -} - -% notused as a subtype. just for cleaning up the rest. -subtype option(menuentry) { - ActiveBackground - ActiveForeground - Accelerator ["-accelerator"; string] - Background - Bitmap - ColumnBreak ["-columnbreak"; bool] - Command - Font - Foreground - HideMargin ["-hidemargin"; bool] -##ifdef CAMLTK - ImageBitmap - ImagePhoto -##else - Image -##endif - IndicatorOn - Label ["-label"; string] - Menu ["-menu"; widget(menu)] - OffValue - OnValue - SelectColor -##ifdef CAMLTK - SelectImageBitmap - SelectImagePhoto -##else - SelectImage -##endif - State - UnderlinedChar - Value ["-value"; string] - Variable - } - -% Options for cascade entry -subtype option(menucascade) { - ActiveBackground ActiveForeground Accelerator - Background Bitmap ColumnBreak Command Font Foreground - HideMargin -##ifdef CAMLTK - ImageBitmap ImagePhoto -##else - Image -##endif - IndicatorOn Label Menu State UnderlinedChar - } - -% Options for radiobutton entry -subtype option(menuradio) { - ActiveBackground ActiveForeground Accelerator - Background Bitmap ColumnBreak Command Font Foreground -##ifdef CAMLTK - ImageBitmap ImagePhoto SelectImageBitmap SelectImagePhoto -##else - Image SelectImage -##endif - IndicatorOn Label SelectColor - State UnderlinedChar Value Variable - } - -% Options for checkbutton entry -subtype option(menucheck) { - ActiveBackground ActiveForeground Accelerator - Background Bitmap ColumnBreak Command Font Foreground -##ifdef CAMLTK - ImageBitmap SelectImageBitmap ImagePhoto SelectImagePhoto -##else - Image SelectImage -##endif - IndicatorOn Label - OffValue OnValue SelectColor - State UnderlinedChar Variable - } - -% Options for command entry -subtype option(menucommand) { - ActiveBackground ActiveForeground Accelerator - Background Bitmap ColumnBreak Command Font Foreground -##ifdef CAMLTK - ImageBitmap ImagePhoto -##else - Image -##endif - Label State UnderlinedChar - } - -type menuType { - Menu_Menubar ["menubar"] - Menu_Tearoff ["tearoff"] - Menu_Normal ["normal"] -} - -% Separators and tearoffs don't have options - -widget menu { - % Standard options - option ActiveBackground - option ActiveBorderWidth - option ActiveForeground - option Background - option BorderWidth - option Cursor - option DisabledForeground - option Font - option Foreground - option Relief - option TakeFocus - % Widget specific options - option PostCommand ["-postcommand"; function()] - option SelectColor - option TearOff ["-tearoff"; bool] - option TearOffCommand ["-tearoffcommand"; function(menu: widget(any), tornoff: widget(any)) ] - option MenuTitle ["-title"; string] - option MenuType ["-type"; menuType] - - function () activate [widget(menu); "activate"; index: Index(menu)] - % add variations - function () add_cascade [widget(menu); "add"; "cascade"; option(menucascade) list] - function () add_checkbutton [widget(menu); "add"; "checkbutton"; option(menucheck) list] - function () add_command [widget(menu); "add"; "command"; option(menucommand) list] - function () add_radiobutton [widget(menu); "add"; "radiobutton"; option(menuradio) list] - function () add_separator [widget(menu); "add"; "separator"] - % not for user: function clone [widget(menu); "clone"; ???; menuType] - function () configure [widget(menu); "configure"; option(menu) list] - function (string) configure_get [widget(menu); "configure"] - % beware of possible callback leak when deleting menu entries - function () delete [widget(menu); "delete"; first: Index(menu); last: Index(menu)] - function () configure_cascade [widget(menu); "entryconfigure"; Index(menu); option(menucascade) list] - function () configure_checkbutton [widget(menu); "entryconfigure"; Index(menu); option(menucheck) list] - function () configure_command [widget(menu); "entryconfigure"; Index(menu); option(menucommand) list] - function () configure_radiobutton [widget(menu); "entryconfigure"; Index(menu); option(menuradio) list] - function (string) entryconfigure_get [widget(menu); "entryconfigure"; Index(menu)] - function (int) index [widget(menu); "index"; Index(menu)] - function () insert_cascade [widget(menu); "insert"; index: Index(menu); "cascade"; option(menucascade) list] - function () insert_checkbutton [widget(menu); "insert"; index: Index(menu); "checkbutton"; option(menucheck) list] - function () insert_command [widget(menu); "insert"; index: Index(menu); "command"; option(menucommand) list] - function () insert_radiobutton [widget(menu); "insert"; index: Index(menu); "radiobutton"; option(menuradio) list] - function () insert_separator [widget(menu); "insert"; index: Index(menu); "separator"] - function (string) invoke [widget(menu); "invoke"; index: Index(menu)] - function () post [widget(menu); "post"; x: int; y: int] - function () postcascade [widget(menu); "postcascade"; index: Index(menu)] - % can't use type of course - function (MenuItem) typeof [widget(menu); "type"; index: Index(menu)] - function () unpost [widget(menu); "unpost"] - function (int) yposition [widget(menu); "yposition"; index: Index(menu)] - - function () popup ["tk_popup"; widget(menu); x: int; y: int; ?entry:[Index(menu)]] -##ifdef CAMLTK - function () popup_entry ["tk_popup"; widget(menu); x: int; y: int; index: Index(menu)] -##endif - } - - -%%%%% menubutton(n) - -type menubuttonDirection { - Dir_Above ["above"] - Dir_Below ["below"] - Dir_Left ["left"] - Dir_Right ["right"] -} - -widget menubutton { - % Standard options - option ActiveBackground - option ActiveForeground - option Anchor - option Background - option Bitmap - option BorderWidth - option Cursor - option DisabledForeground - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness -##ifdef CAMLTK - option ImageBitmap - option ImagePhoto -##else - option Image -##endif - option Justify - option PadX - option PadY - option Relief - option TakeFocus - option Text - option TextVariable - option UnderlinedChar - option WrapLength - % Widget specific options - option Direction ["-direction"; menubuttonDirection ] - option Height - option IndicatorOn - option Menu ["-menu"; widget(menu)] - option State - option Width - option TextWidth - - function () configure [widget(menubutton); "configure"; option(menubutton) list] - function (string) configure_get [widget(menubutton); "configure"] - } - - - -%%%%% message(n) -widget message { - % Standard options - option Anchor - option Background - option BorderWidth - option Cursor - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness - option PadX - option PadY - option Relief - option TakeFocus - option Text - option TextVariable - % Widget specific options - option Aspect ["-aspect"; int] - option Justify - option Width - - function () configure [widget(message); "configure"; option(message) list] - function (string) configure_get [widget(message); "configure"] - } - - -%%%%% option(n) -type OptionPriority { - WidgetDefault ["widgetDefault"] - StartupFile ["startupFile"] - UserDefault ["userDefault"] - Interactive ["interactive"] - Priority [int] - } - -##ifdef CAMLTK - -module Option { - unsafe function () add ["option"; "add"; string; string; OptionPriority] - function () clear ["option"; "clear"] - function (string) get ["option"; "get"; widget; string; string] - unsafe function () readfile ["option"; "readfile"; string; OptionPriority] - } -%% Resource is now superseded by Option -module Resource { - unsafe function () add ["option"; "add"; string; string; OptionPriority] - function () clear ["option"; "clear"] - function (string) get ["option"; "get"; widget; string; string] - unsafe function () readfile ["option"; "readfile"; string; OptionPriority] - } -##else -module Option { - unsafe function () add - ["option"; "add"; path: string; string; ?priority:[OptionPriority]] - function () clear ["option"; "clear"] - function (string) get ["option"; "get"; widget; name: string; clas: string] - unsafe function () readfile - ["option"; "readfile"; string; ?priority:[OptionPriority]] - } -##endif - -%%%%% tk_optionMenu(n) -module Optionmenu { - external create "builtin/optionmenu" - } - - -%%%%% pack(n) -type Side { - Side_Left ["left"] - Side_Right ["right"] - Side_Top ["top"] - Side_Bottom ["bottom"] -} - -type FillMode { - Fill_None ["none"] - Fill_X ["x"] - Fill_Y ["y"] - Fill_Both ["both"] -} - -subtype option(pack) { - After ["-after"; widget] - Anchor - Before ["-before"; widget] - Expand ["-expand"; bool] - Fill ["-fill"; FillMode] - In(Inside) ["-in"; widget] - IPadX ["-ipadx"; Units/int] - IPadY ["-ipady"; Units/int] - PadX - PadY - Side ["-side"; Side] -} - -function () pack ["pack"; widget list; option(pack) list] - -module Pack { - function () configure ["pack"; "configure"; widget list; option(pack) list] - function () forget ["pack"; "forget"; widget list] - function (string) info ["pack"; "info"; widget] - function (bool) propagate_get ["pack"; "propagate"; widget] - function () propagate_set ["pack"; "propagate"; widget; bool] - function (widget list) slaves ["pack"; "slaves"; widget] - } - -subtype TkPalette(any) { % Not sophisticated... - PaletteActiveBackground ["activeBackground"; Color] - PaletteActiveForeground ["activeForeground"; Color] - PaletteBackground ["background"; Color] - PaletteDisabledForeground ["disabledForeground"; Color] - PaletteForeground ["foreground"; Color] - PaletteHighlightBackground ["hilightBackground"; Color] - PaletteHighlightColor ["highlightColor"; Color] - PaletteInsertBackground ["insertBackground"; Color] - PaletteSelectColor ["selectColor"; Color] - PaletteSelectBackground ["selectBackground"; Color] - PaletteForegroundselectColor ["selectForeground"; Color] - PaletteTroughColor ["troughColor"; Color] -} - -%%%%% tk_setPalette(n) -%%%% can't simply encode general form of tk_setPalette -module Palette { - function () set_background ["tk_setPalette"; Color] - function () set ["tk_setPalette"; TkPalette(any) list] - function () bisque ["tk_bisque"] - } - -%%%%% photo(n) -type PaletteType external % builtin_palette.ml - -subtype option(photoimage) { - % Channel ["-channel"; file_descr] % removed in 8.3 ? - Data - Format ["-format"; string] - File - Gamma ["-gamma"; float] - Height - Palette ["-palette"; PaletteType] - Width - } - -subtype photo(copy) { - ImgFrom(Src_area) ["-from"; int; int; int; int] - ImgTo(Dst_area) ["-to"; int; int; int; int] - Shrink ["-shrink"] - Zoom ["-zoom"; int; int] - Subsample ["-subsample"; int; int] - } - -subtype photo(put) { - ImgTo - } - -subtype photo(read) { - ImgFormat ["-format"; string] - ImgFrom - Shrink - TopLeft(Dst_pos) ["-to"; int; int] - } - -subtype photo(write) { - ImgFormat ImgFrom - } - -module Imagephoto { - function (ImagePhoto) create ["image"; "create"; "photo"; ?name:[ImagePhoto]; option(photoimage) list] -##ifdef CAMLTK - function (ImagePhoto) create_named ["image"; "create"; "photo"; ImagePhoto; option(photoimage) list] -##endif - function () delete ["image"; "delete"; ImagePhoto] - function (int) height ["image"; "height"; ImagePhoto] - function (int) width ["image"; "width"; ImagePhoto] - -%name -%type - - function () blank [ImagePhoto; "blank"] - function () configure [ImagePhoto; "configure"; option(photoimage) list] - function (string) configure_get [ImagePhoto; "configure"] - function () copy [ImagePhoto; "copy"; src: ImagePhoto; photo(copy) list] - function (int, int, int) get [ImagePhoto; "get"; x: int; y: int] -% it is buggy ? can't express nested lists ? - function () put [ImagePhoto; "put"; [Color list list]; photo(put) list] -% external put "builtin/imagephoto_put" - function () read [ImagePhoto; "read"; file: string; photo(read) list] - function () redither [ImagePhoto; "redither"] - function () write [ImagePhoto; "write"; file: string; photo(write) list] - % Functions inherited from the "image" TK class - } - - -%%%%% place(n) -type BorderMode { - Inside ["inside"] - Outside ["outside"] - Ignore ["ignore"] -} - -subtype option(place) { - In - X - RelX ["-relx"; float] - Y - RelY ["-rely"; float] - Anchor - Width - RelWidth ["-relwidth"; float] - Height - RelHeight ["-relheight"; float] - BorderMode ["-bordermode"; BorderMode] -} - -function () place ["place"; widget; option(place) list] - -module Place { - function () configure ["place"; "configure"; widget; option(place) list] - function () forget ["place"; "forget"; widget] - function (string) info ["place"; "info"; widget] - function (widget list) slaves ["place"; "slaves"; widget] -} - - -%%%%% radiobutton(n) - -widget radiobutton { - % Standard options - option ActiveBackground - option ActiveForeground - option Anchor - option Background - option Bitmap - option BorderWidth - option Cursor - option DisabledForeground - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness -##ifdef CAMLTK - option ImageBitmap - option ImagePhoto -##else - option Image -##endif - option Justify - option PadX - option PadY - option Relief - option TakeFocus - option Text - option TextVariable - option UnderlinedChar - option WrapLength - - % Widget specific options - option Command - option Height - option IndicatorOn - option SelectColor -##ifdef CAMLTK - option SelectImageBitmap - option SelectImagePhoto -##else - option SelectImage -##endif - option State - option Value - option Variable - option Width - - function () configure [widget(radiobutton); "configure"; option(radiobutton) list] - function (string) configure_get [widget(radiobutton); "configure"] - function () deselect [widget(radiobutton); "deselect"] - function () flash [widget(radiobutton); "flash"] - function () invoke [widget(radiobutton); "invoke"] - function () select [widget(radiobutton); "select"] - } - - -%%%%% raise(n) -% We cannot use raise !! -function () raise_window ["raise"; widget; ?above:[widget]] -##ifdef CAMLTK -function () raise_window_above ["raise"; widget; widget] -##endif - -%%%%% scale(n) -%% shared with scrollbars -##ifdef CAMLTK -subtype WidgetElement(scale) { - Slider ["slider"] - Trough1 ["trough1"] - Trough2 ["trough2"] - Beyond [""] - } -##else -type ScaleElement { - Slider ["slider"] - Trough1 ["trough1"] - Trough2 ["trough2"] - Beyond [""] - } -##endif - -widget scale { - % Standard options - option ActiveBackground - option Background - option BorderWidth - option Cursor - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness - option Orient - option Relief - option RepeatDelay - option RepeatInterval - option TakeFocus - option TroughColor - - % Widget specific options - option BigIncrement ["-bigincrement"; float] - option ScaleCommand ["-command"; function (float)] - option Digits ["-digits"; int] - option From(Min) ["-from"; float] - option Label ["-label"; string] - option Length ["-length"; Units/int] - option Resolution ["-resolution"; float] - option ShowValue ["-showvalue"; bool] - option SliderLength ["-sliderlength"; Units/int] - option State - option TickInterval ["-tickinterval"; float] - option To(Max) ["-to"; float] - option Variable - option Width - -##ifdef CAMLTK - function (int,int) coords [widget(scale); "coords"] - function (int,int) coords_at [widget(scale); "coords"; at: float] -##else - function (int,int) coords [widget(scale); "coords"; ?at: [float]] -##endif - function () configure [widget(scale); "configure"; option(scale) list] - function (string) configure_get [widget(scale); "configure"] - function (float) get [widget(scale); "get"] - function (float) get_xy [widget(scale); "get"; x: int; y: int] - function (WidgetElement/ScaleElement) identify [widget(scale); x: int; y: int] - function () set [widget(scale); "set"; float] - } - - -%%%%% scrollbar(n) -##ifdef CAMLTK -subtype WidgetElement(scrollbar) { - Arrow1 ["arrow1"] - Trough1 - Trough2 - Slider - Arrow2 ["arrow2"] - Beyond - } -##else -type ScrollbarElement { - Arrow1 ["arrow1"] - Trough1 ["through1"] - Trough2 ["through2"] - Slider ["slider"] - Arrow2 ["arrow2"] - Beyond [""] - } -##endif - -widget scrollbar { - % Standard options - option ActiveBackground - option Background - option BorderWidth - option Cursor - option HighlightBackground - option HighlightColor - option HighlightThickness - option Jump - option Orient - option Relief - option RepeatDelay - option RepeatInterval - option TakeFocus - option TroughColor - % Widget specific options - option ActiveRelief ["-activerelief"; Relief] - option ScrollCommand ["-command"; function(scroll: ScrollValue)] - option ElementBorderWidth ["-elementborderwidth"; Units/int] - option Width - -##ifdef CAMLTK - function () activate [widget(scrollbar); "activate"; element: WidgetElement(scrollbar)] -##else - function () activate [widget(scrollbar); "activate"; element: ScrollbarElement] -##endif - function (WidgetElement/ScrollbarElement) activate_get [widget(scrollbar); "activate"] - function () configure [widget(scrollbar); "configure"; option(scrollbar) list] - function (string) configure_get [widget(scrollbar); "configure"] - function (float) delta [widget(scrollbar); "delta"; x: int; y: int] - function (float) fraction [widget(scrollbar); "fraction"; x: int; y: int] - function (float, float) get [widget(scrollbar); "get"] - function (int,int,int,int) old_get [widget(scrollbar); "get"] - function (WidgetElement/ScrollbarElement) identify [widget(scale); "identify"; int; int] - function () set [widget(scrollbar); "set"; first: float; last: float] - function () old_set [widget(scrollbar); "set"; total:int; window:int; first:int; last:int] - } - - -%%%%% selection(n) - -subtype icccm(selection_clear) { - DisplayOf ["-displayof"; widget] - Selection ["-selection"; string] - } - -subtype icccm(selection_get) { - DisplayOf - Selection - ICCCMType - } - -subtype icccm(selection_ownset) { - LostCommand ["-command"; function()] - Selection - } - -subtype icccm(selection_handle) { - Selection - ICCCMType - ICCCMFormat ["-format"; string] - } - -module Selection { - function () clear ["selection"; "clear"; icccm(selection_clear) list] - function (string) get ["selection"; "get"; icccm(selection_get) list] - - % function () handle_set ["selection"; "handle"; icccm(selection_handle) list; widget; function(int,int)] - external handle_set "builtin/selection_handle_set" - unsafe function (widget) own_get ["selection"; "own"; icccm(selection_clear) list] - % builtin - % function () own_set ["selection"; "own"; widget; icccm(selection_ownset) list] - external own_set "builtin/selection_own_set" - } - - -%%%%% send(n) -type SendOption { - SendDisplayOf ["-displayof"; widget] % DisplayOf is used for icccm ! - SendAsync ["-async"] -} - -unsafe function () send ["send"; SendOption list; "--"; app: string; command: string list] - -%%%%% text(n) - -type TextIndex external -type TextTag external -type TextMark external - - -type TabType { - TabLeft [Units/int; "left"] - TabRight [Units/int; "right"] - TabCenter [Units/int; "center"] - TabNumeric [Units/int; "numeric"] - } - -type WrapMode { - WrapNone ["none"] - WrapChar ["char"] - WrapWord ["word"] -} - -type Comparison { - LT (Lt) ["<"] - LE (Le) ["<="] - EQ (Eq) ["=="] - GE (Ge) [">="] - GT (Gt) [">"] - NEQ (Neq) ["!="] -} - -type MarkDirection { - Mark_Left ["left"] - Mark_Right ["right"] - } - -type AlignType { - Align_Top ["top"] - Align_Bottom ["bottom"] - Align_Center ["center"] - Align_Baseline ["baseline"] - } - -subtype option(embeddedi) { - Align ["-align"; AlignType] -##ifdef CAMLTK - ImageBitmap - ImagePhoto -##else - Image -##endif - Name ["-name"; string] - PadX - PadY - } - -subtype option(embeddedw) { - Align ["-align"; AlignType] - PadX - PadY - Stretch ["-stretch"; bool] - Window - } - -type TextSearch { - Forwards ["-forwards"] - Backwards ["-backwards"] - Exact ["-exact"] - Regexp ["-regexp"] - Nocase ["-nocase"] - Count ["-count"; TextVariable] - } - -type text_dump { - DumpAll ["-all"] - DumpCommand ["-command"; function (key: string, value: string, index: string)] - DumpMark ["-mark"] - DumpTag ["-tag"] - DumpText ["-text"] - DumpWindow ["-window"] - } - -widget text { - % Standard options - option Background - option BorderWidth - option Cursor - option ExportSelection - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness - option InsertBackground - option InsertBorderWidth - option InsertOffTime - option InsertOnTime - option InsertWidth - option PadX - option PadY - option Relief - option SelectBackground - option SelectBorderWidth - option SelectForeground - option SetGrid - option TakeFocus - option XScrollCommand - option YScrollCommand - - % Widget specific options - option TextHeight - option Spacing1 ["-spacing1"; Units/int] - option Spacing2 ["-spacing2"; Units/int] - option Spacing3 ["-spacing3"; Units/int] -##ifdef CAMLTK - option State -##else - option EntryState -##endif - option Tabs ["-tabs"; [TabType list]] - option TextWidth - option Wrap ["-wrap"; WrapMode] - - function (int,int,int,int) bbox [widget(text); "bbox"; index: TextIndex] - function (bool) compare [widget(text); "compare"; index: TextIndex; op: Comparison; index: TextIndex] - function () configure [widget(text); "configure"; option(text) list] - function (string) configure_get [widget(text); "configure"] - function () debug [widget(text); "debug"; bool] - function () delete [widget(text); "delete"; start: TextIndex; stop: TextIndex] - function () delete_char [widget(text); "delete"; index: TextIndex] - function (int, int, int, int, int) dlineinfo [widget(text); "dlineinfo"; index: TextIndex] - - % require result parser - function (string list) dump [widget(text); "dump"; text_dump list; start: TextIndex; stop: TextIndex] - function (string list) dump_char [widget(text); "dump"; text_dump list; index: TextIndex] - - function (string) get [widget(text); "get"; start: TextIndex; stop: TextIndex] - function (string) get_char [widget(text); "get"; index: TextIndex] - function () image_configure - [widget(text); "image"; "configure"; name: string; option(embeddedi) list] - function (string) image_configure_get - [widget(text); "image"; "cgets"; name: string] - function (string) image_create - [widget(text); "image"; "create"; index: TextIndex; option(embeddedi) list] - function (string list) image_names [widget(text); "image"; "names"] - function (Index(text) as "[>`Linechar of int * int]") index [widget(text); "index"; index: TextIndex] -##ifdef CAMLTK - function () insert [widget(text); "insert"; index: TextIndex; text: string; [TextTag list]] -##else - function () insert [widget(text); "insert"; index: TextIndex; text: string; ?tags: [TextTag list]] -##endif - % Mark - function () mark_gravity_set [widget(text); "mark"; "gravity"; mark: TextMark; direction: MarkDirection] - function (MarkDirection) mark_gravity_get [widget(text); "mark"; "gravity"; mark: TextMark] - function (TextMark list) mark_names [widget(text); "mark"; "names"] - function (TextMark) mark_next [widget(text); "mark"; "next"; index: TextIndex] - function (TextMark) mark_previous [widget(text); "mark"; "previous"; index: TextIndex] - function () mark_set [widget(text); "mark"; "set"; mark: TextMark; index: TextIndex] - function () mark_unset [widget(text); "mark"; "unset"; marks: TextMark list] - % Scan - function () scan_mark [widget(text); "scan"; "mark"; x: int; y: int] - function () scan_dragto [widget(text); "scan"; "dragto"; x: int; y: int] -##ifdef CAMLTK - function (Index) search [widget(text); "search"; TextSearch list; "--"; string; TextIndex; TextIndex] -##else - function (Index(text) as "[>`Linechar of int * int]") search [widget(text); "search"; switches: TextSearch list; "--"; pattern: string; start: TextIndex; ?stop: [TextIndex]] -##endif - function () see [widget(text); "see"; index: TextIndex] - % Tags - function () tag_add [widget(text); "tag"; "add"; tag: TextTag; start: TextIndex; stop: TextIndex] - function () tag_add_char [widget(text); "tag"; "add"; tag: TextTag; index: TextIndex] - external tag_bind "builtin/text_tag_bind" - function () tag_configure [widget(text); "tag"; "configure"; tag: TextTag; option(texttag) list] - function () tag_delete [widget(text); "tag"; "delete"; TextTag list] - - function () tag_lower [widget(text); "tag"; "lower"; tag: TextTag; ?below: [TextTag]] -##ifdef CAMLTK - function () tag_lower_below [widget(text); "tag"; "lower"; TextTag; TextTag] - function () tag_lower_bot [widget(text); "tag"; "lower"; TextTag] -##endif - - function (TextTag list) tag_names [widget(text); "tag"; "names"; ?index: [TextIndex]] -##ifdef CAMLTK - function (TextTag list) tag_allnames [widget(text); "tag"; "names"] - function (TextTag list) tag_indexnames [widget(text); "tag"; "names"; TextIndex] -##endif - -##ifdef CAMLTK - function (Index, Index) tag_nextrange [widget(text); "tag"; "nextrange"; TextTag; start: TextIndex; stop: TextIndex] - function (Index, Index) tag_prevrange [widget(text); "tag"; "prevrange"; TextTag; start: TextIndex; stop: TextIndex] -##else - function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_nextrange [widget(text); "tag"; "nextrange"; tag: TextTag; start: TextIndex; ?stop: [TextIndex]] - function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_prevrange [widget(text); "tag"; "prevrange"; tag: TextTag; start: TextIndex; ?stop: [TextIndex]] -##endif - - function () tag_raise [widget(text); "tag"; "raise"; tag: TextTag; ?above: [TextTag]] -##ifdef CAMLTK - function () tag_raise_above [widget(text); "tag"; "raise"; TextTag; TextTag] - function () tag_raise_top [widget(text); "tag"; "raise"; TextTag] -##endif - -##ifdef CAMLTK - function (Index list) tag_ranges [widget(text); "tag"; "ranges"; TextTag] -##else - function (Index(text) as "[>`Linechar of int * int]" list) tag_ranges [widget(text); "tag"; "ranges"; tag: TextTag] -##endif - - function () tag_remove [widget(text); "tag"; "remove"; tag: TextTag; start: TextIndex; stop: TextIndex] - function () tag_remove_char [widget(text); "tag"; "remove"; tag: TextTag; index: TextIndex] - - function () window_configure [widget(text); "window"; "configure"; tag: TextTag; option(embeddedw) list] - function () window_create [widget(text); "window"; "create"; index: TextIndex; option(embeddedw) list] - function (widget list) window_names [widget(text); "window"; "names"] - % scrolling - function (float,float) xview_get [widget(text); "xview"] - function (float,float) yview_get [widget(text); "yview"] - function () xview [widget(text); "xview"; scroll: ScrollValue] - function () yview [widget(text); "yview"; scroll: ScrollValue] - function () yview_index [widget(text); "yview"; index: TextIndex] - function () yview_index_pickplace [widget(text); "yview"; "-pickplace"; index: TextIndex] - function () yview_line [widget(text); "yview"; line: int] % obsolete - } - -subtype option(texttag) { - Background - BgStipple ["-bgstipple"; Bitmap] - BorderWidth - FgStipple ["-fgstipple"; Bitmap] - Font - Foreground - Justify - LMargin1 ["-lmargin1"; Units/int] - LMargin2 ["-lmargin2"; Units/int] - Offset ["-offset"; Units/int] - OverStrike ["-overstrike"; bool] - Relief - RMargin ["-rmargin"; Units/int] - Spacing1 - Spacing2 - Spacing3 - Tabs - Underline ["-underline"; bool] - Wrap ["-wrap"; WrapMode] - } - - -%%%%% tk(n) -unsafe function () appname_set ["tk"; "appname"; string] -unsafe function (string) appname_get ["tk"; "appname"] -function (float) scaling_get ["tk"; "scaling"; ?displayof:["-displayof"; widget]] -unsafe function () scaling_set ["tk"; "scaling"; ?displayof:["-displayof"; widget]; float] - -%%%%% tk_chooseColor(n) - -subtype option(chooseColor){ - InitialColor ["-initialcolor"; Color] - Parent ["-parent"; widget] - Title ["-title"; string] - } -function (Color) chooseColor ["tk_chooseColor"; option(chooseColor) list] - -%%%%% tkwait(n) -module Tkwait { - function () variable ["tkwait"; "variable"; TextVariable] - function () visibility ["tkwait"; "visibility"; widget] - function () window ["tkwait"; "window"; widget] - } - - -%%%%% toplevel(n) -% This module will be renamed "toplevelw" to avoid collision with -% Caml Light standard toplevel module. -widget toplevel { - % Standard options - option BorderWidth - option Cursor - option HighlightBackground - option HighlightColor - option HighlightThickness - option Relief - option TakeFocus - - % Widget specific options - option Background -##ifdef CAMLTK - option Class -##else - option Clas -##endif - option Colormap - option Container ["-container"; bool] - option Height - option Menu - option Screen ["-screen"; string] - option Use ["-use"; string] % must be hexadecimal "0x????" - option Visual - option Width - - function () configure [widget(toplevel); "configure"; option(toplevel) list] - function (string) configure_get [widget(toplevel); "configure"] - } - - -%%%%% update(n) -function () update ["update"] -function () update_idletasks ["update"; "idletasks"] - - -%%%%% winfo(n) - -type AtomId { - AtomId [int] - } - -module Winfo { - - unsafe function (AtomId) atom ["winfo"; "atom"; ?displayof:["-displayof"; widget]; string] - unsafe function (string) atomname ["winfo"; "atomname"; ?displayof:["-displayof"; widget]; AtomId] -##ifdef CAMLTK - unsafe function (AtomId) atom_displayof ["winfo"; "atom"; "-displayof"; widget; string] - unsafe function (string) atomname_displayof ["winfo"; "atomname"; "-displayof"; widget; AtomId] -##endif - function (int) cells ["winfo"; "cells"; widget] - function (widget list) children ["winfo"; "children"; widget] - function (string) class_name ["winfo"; "class"; widget] - function (bool) colormapfull ["winfo"; "colormapfull"; widget] - unsafe function (widget) containing ["winfo"; "containing"; ?displayof:["-displayof"; widget]; x: int; y: int] -##ifdef CAMLTK - unsafe function (widget) containing_displayof ["winfo"; "containing"; "-displayof"; widget; int; int] -##endif - % addition for applets - external contained "builtin/winfo_contained" - function (int) depth ["winfo"; "depth"; widget] - function (bool) exists ["winfo"; "exists"; widget] - function (float) fpixels ["winfo"; "fpixels"; widget; length: Units] - function (string) geometry ["winfo"; "geometry"; widget] - function (int) height ["winfo"; "height"; widget] - unsafe function (string) id ["winfo"; "id"; widget] - unsafe function (string list) interps ["winfo"; "interps"; ?displayof:["-displayof"; widget]] -##ifdef CAMLTK - unsafe function (string list) interps_displayof ["winfo"; "interps"; "-displayof"; widget] -##endif - function (bool) ismapped ["winfo"; "ismapped"; widget] - function (string) manager ["winfo"; "manager"; widget] - function (string) name ["winfo"; "name"; widget] - unsafe function (widget) parent ["winfo"; "parent"; widget] % bogus for top - unsafe function (widget) pathname ["winfo"; "pathname"; ?displayof:["-displayof"; widget]; string] -##ifdef CAMLTK - unsafe function (widget) pathname_displayof ["winfo"; "pathname"; "-displayof"; widget; string] -##endif - function (int) pixels ["winfo"; "pixels"; widget; length: Units] - function (int) pointerx ["winfo"; "pointerx"; widget] - function (int) pointery ["winfo"; "pointery"; widget] - function (int, int) pointerxy ["winfo"; "pointerxy"; widget] - function (int) reqheight ["winfo"; "reqheight"; widget] - function (int) reqwidth ["winfo"; "reqwidth"; widget] - function (int,int,int) rgb ["winfo"; "rgb"; widget; color: Color] - function (int) rootx ["winfo"; "rootx"; widget] - function (int) rooty ["winfo"; "rooty"; widget] - unsafe function (string) screen ["winfo"; "screen"; widget] - function (int) screencells ["winfo"; "screencells"; widget] - function (int) screendepth ["winfo"; "screendepth"; widget] - function (int) screenheight ["winfo"; "screenheight"; widget] - function (int) screenmmheight ["winfo"; "screenmmheight"; widget] - function (int) screenmmwidth ["winfo"; "screenmmwidth"; widget] - function (string) screenvisual ["winfo"; "screenvisual"; widget] - function (int) screenwidth ["winfo"; "screenwidth"; widget] - unsafe function (string) server ["winfo"; "server"; widget] - unsafe function (widget(toplevel)) toplevel ["winfo"; "toplevel"; widget] - function (bool) viewable ["winfo"; "viewable"; widget] - function (string) visual ["winfo"; "visual"; widget] - function (int) visualid ["winfo"; "visualid"; widget] - % need special parser - function (string) visualsavailable ["winfo"; "visualsavailable"; widget; ?includeids: [int list]] - function (int) vrootheight ["winfo"; "vrootheight"; widget] - function (int) vrootwidth ["winfo"; "vrootwidth"; widget] - function (int) vrootx ["winfo"; "vrootx"; widget] - function (int) vrooty ["winfo"; "vrooty"; widget] - function (int) width ["winfo"; "width"; widget] - function (int) x ["winfo"; "x"; widget] - function (int) y ["winfo"; "y"; widget] -} - - -%%%%% wm(n) - -type FocusModel { - FocusActive ["active"] - FocusPassive ["passive"] -} - -type WmFrom { - User ["user"] - Program ["program"] -} - -module Wm { -%%% Aspect - function () aspect_set ["wm"; "aspect"; widget(toplevel); minnum:int; mindenom:int; maxnum:int; maxdenom:int] - % aspect: problem with empty return - function (int,int,int,int) aspect_get ["wm"; "aspect"; widget(toplevel)] -%%% WM_CLIENT_MACHINE - function () client_set ["wm"; "client"; widget(toplevel); name: string] - function (string) client_get ["wm"; "client"; widget(toplevel)] -%%% WM_COLORMAP_WINDOWS - function () colormapwindows_set - ["wm"; "colormapwindows"; widget(toplevel); [windows: widget list]] - unsafe function (widget list) colormapwindows_get - ["wm"; "colormapwindows"; widget(toplevel)] -%%% WM_COMMAND - function () command_clear ["wm"; "command"; widget(toplevel); ""] - function () command_set ["wm"; "command"; widget(toplevel); [string list]] - function (string list) command_get ["wm"; "command"; widget(toplevel)] - - function () deiconify ["wm"; "deiconify"; widget(toplevel)] - -%%% Focus model - function () focusmodel_set ["wm"; "focusmodel"; widget(toplevel); FocusModel] - function (FocusModel) focusmodel_get ["wm"; "focusmodel"; widget(toplevel)] - - function (string) frame ["wm"; "frame"; widget(toplevel)] - -%%% Geometry - function () geometry_set ["wm"; "geometry"; widget(toplevel); string] - function (string) geometry_get ["wm"; "geometry"; widget(toplevel)] - -%%% Grid - function () grid_clear ["wm"; "grid"; widget(toplevel); ""; ""; ""; ""] - function () grid_set ["wm"; "grid"; widget(toplevel); basewidth: int; baseheight: int; widthinc: int; heightinc: int] - function (int,int,int,int) grid_get ["wm"; "grid"; widget(toplevel)] - -%%% Groups - function () group_clear ["wm"; "group"; widget(toplevel); ""] - function () group_set ["wm"; "group"; widget(toplevel); leader: widget] - unsafe function (widget) group_get ["wm"; "group"; widget(toplevel)] -%%% Icon bitmap - function () iconbitmap_clear ["wm"; "iconbitmap"; widget(toplevel); ""] - function () iconbitmap_set ["wm"; "iconbitmap"; widget(toplevel); Bitmap] - function (Bitmap) iconbitmap_get ["wm"; "iconbitmap"; widget(toplevel)] - - function () iconify ["wm"; "iconify"; widget(toplevel)] - -%%% Icon mask - function () iconmask_clear ["wm"; "iconmask"; widget(toplevel); ""] - function () iconmask_set ["wm"; "iconmask"; widget(toplevel); Bitmap] - function (Bitmap) iconmask_get ["wm"; "iconmask"; widget(toplevel)] - -%%% Icon name - function () iconname_set ["wm"; "iconname"; widget(toplevel); string] - function (string) iconname_get ["wm"; "iconname"; widget(toplevel)] -%%% Icon position - function () iconposition_clear ["wm"; "iconposition"; widget(toplevel); ""; ""] - function () iconposition_set ["wm"; "iconposition"; widget(toplevel); x: int; y: int] - function (int,int) iconposition_get ["wm"; "iconposition"; widget(toplevel)] -%%% Icon window - function () iconwindow_clear ["wm"; "iconwindow"; widget(toplevel); ""] - function () iconwindow_set ["wm"; "iconwindow"; widget(toplevel); icon: widget(toplevel)] - unsafe function (widget(toplevel)) iconwindow_get ["wm"; "iconwindow"; widget(toplevel)] - -%%% Sizes - function () maxsize_set ["wm"; "maxsize"; widget(toplevel); width: int; height: int] - function (int,int) maxsize_get ["wm"; "maxsize"; widget(toplevel)] - function () minsize_set ["wm"; "minsize"; widget(toplevel); width: int; height: int] - function (int,int) minsize_get ["wm"; "minsize"; widget(toplevel)] -%%% Override - unsafe function () overrideredirect_set ["wm"; "overrideredirect"; widget(toplevel); bool] - function (bool) overrideredirect_get ["wm"; "overrideredirect"; widget(toplevel)] -%%% Position - function () positionfrom_clear ["wm"; "positionfrom"; widget(toplevel); ""] - function () positionfrom_set ["wm"; "positionfrom"; widget(toplevel); WmFrom] - function (WmFrom) positionfrom_get ["wm"; "positionfrom"; widget(toplevel)] -%%% Protocols - function () protocol_set ["wm"; "protocol"; widget(toplevel); name: string; command: function()] - function () protocol_clear ["wm"; "protocol"; widget(toplevel); name: string; ""] - function (string list) protocols ["wm"; "protocol"; widget(toplevel)] -%%% Resize - function () resizable_set ["wm"; "resizable"; widget(toplevel); width: bool; height: bool] - function (bool, bool) resizable_get ["wm"; "resizable"; widget(toplevel)] -%%% Sizefrom - function () sizefrom_clear ["wm"; "sizefrom"; widget(toplevel); ""] - function () sizefrom_set ["wm"; "sizefrom"; widget(toplevel); WmFrom] - function (WmFrom) sizefrom_get ["wm"; "sizefrom"; widget(toplevel)] - - function (string) state ["wm"; "state"; widget(toplevel)] - -%%% Title - function (string) title_get ["wm"; "title"; widget(toplevel)] - function () title_set ["wm"; "title"; widget(toplevel); string] -%%% Transient - function () transient_clear ["wm"; "transient"; widget(toplevel); ""] - function () transient_set ["wm"; "transient"; widget(toplevel); master: widget] - unsafe function (widget) transient_get ["wm"; "transient"; widget(toplevel)] - - function () withdraw ["wm"; "withdraw"; widget(toplevel)] - -} - -%%%%% tk_getOpenFile(n) (since version 8.0) -type FilePattern external - -subtype option(getFile) { - DefaultExtension ["-defaultextension"; string] - FileTypes ["-filetypes"; [FilePattern list]] - InitialDir ["-initialdir"; string] - InitialFile ["-initialfile"; string] - Parent ["-parent"; widget] - Title ["-title"; string] -} - -function (string) getOpenFile ["tk_getOpenFile"; option(getFile) list] -function (string) getSaveFile ["tk_getSaveFile"; option(getFile) list] - -%%%%% tk_messageBox -type MessageIcon { - Error ["error"] - Info ["info"] - Question ["question"] - Warning ["warning"] -} -type MessageType { - AbortRetryIgnore ["abortretryignore"] - Ok ["ok"] - OkCancel ["okcancel"] - RetryCancel ["retrycancel"] - YesNo ["yesno"] - YesNoCancel ["yesnocancel"] -} -subtype option(messageBox) { - MessageDefault ["-default"; string] - MessageIcon ["-icon"; MessageIcon] - Message ["-message"; string] - Parent - Title - MessageType ["-type"; MessageType] -} - -function (string) messageBox ["tk_messageBox"; option(messageBox) list] - -module Tkvars { - function (string) library ["$tk_library"] - function (string) patchLevel ["$tk_patchLevel"] - function (bool) strictMotif ["$tk_strictMotif"] - function () set_strictMotif ["set"; "tk_strictMotif"; bool] - function (string) version ["$tk_version"] -} - -% Direct API calls, non Tcl-based modules - -module Pixmap { - external create "builtin/rawimg" - } - -%%% encodings : require if you want write your application international - -module Encoding { - function (string) convertfrom ["encoding"; "convertfrom"; - ?encoding: [string]; string] - function (string) convertto ["encoding"; "convertto"; - ?encoding: [string]; string] - function (string list) names ["encoding"; "names"] - function () system_set ["encoding"; "system"; string] - function (string) system_get ["encoding"; "system"] -} diff --git a/otherlibs/labltk/browser/.cvsignore b/otherlibs/labltk/browser/.cvsignore deleted file mode 100644 index 8ced21de22..0000000000 --- a/otherlibs/labltk/browser/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -ocamlbrowser -dummy.mli diff --git a/otherlibs/labltk/browser/.depend b/otherlibs/labltk/browser/.depend deleted file mode 100644 index 558ccdd268..0000000000 --- a/otherlibs/labltk/browser/.depend +++ /dev/null @@ -1,66 +0,0 @@ -editor.cmo: fileselect.cmi jg_bind.cmi jg_button.cmo jg_menu.cmo \ - jg_message.cmi jg_text.cmi jg_tk.cmo jg_toplevel.cmo lexical.cmi \ - mytypes.cmi searchid.cmi searchpos.cmi setpath.cmi shell.cmi \ - typecheck.cmi viewer.cmi editor.cmi -editor.cmx: fileselect.cmx jg_bind.cmx jg_button.cmx jg_menu.cmx \ - jg_message.cmx jg_text.cmx jg_tk.cmx jg_toplevel.cmx lexical.cmx \ - mytypes.cmi searchid.cmx searchpos.cmx setpath.cmx shell.cmx \ - typecheck.cmx viewer.cmx editor.cmi -fileselect.cmo: jg_box.cmo jg_entry.cmo jg_memo.cmi jg_toplevel.cmo list2.cmo \ - setpath.cmi useunix.cmi fileselect.cmi -fileselect.cmx: jg_box.cmx jg_entry.cmx jg_memo.cmx jg_toplevel.cmx list2.cmx \ - setpath.cmx useunix.cmx fileselect.cmi -jg_bind.cmo: jg_bind.cmi -jg_bind.cmx: jg_bind.cmi -jg_box.cmo: jg_bind.cmi jg_completion.cmi -jg_box.cmx: jg_bind.cmx jg_completion.cmx -jg_completion.cmo: jg_completion.cmi -jg_completion.cmx: jg_completion.cmi -jg_config.cmo: jg_tk.cmo jg_config.cmi -jg_config.cmx: jg_tk.cmx jg_config.cmi -jg_entry.cmo: jg_bind.cmi -jg_entry.cmx: jg_bind.cmx -jg_memo.cmo: jg_memo.cmi -jg_memo.cmx: jg_memo.cmi -jg_message.cmo: jg_bind.cmi jg_text.cmi jg_tk.cmo jg_toplevel.cmo \ - jg_message.cmi -jg_message.cmx: jg_bind.cmx jg_text.cmx jg_tk.cmx jg_toplevel.cmx \ - jg_message.cmi -jg_multibox.cmo: jg_bind.cmi jg_completion.cmi jg_multibox.cmi -jg_multibox.cmx: jg_bind.cmx jg_completion.cmx jg_multibox.cmi -jg_text.cmo: jg_bind.cmi jg_button.cmo jg_tk.cmo jg_toplevel.cmo jg_text.cmi -jg_text.cmx: jg_bind.cmx jg_button.cmx jg_tk.cmx jg_toplevel.cmx jg_text.cmi -lexical.cmo: jg_tk.cmo lexical.cmi -lexical.cmx: jg_tk.cmx lexical.cmi -main.cmo: editor.cmi jg_config.cmi searchid.cmi searchpos.cmi shell.cmi \ - viewer.cmi -main.cmx: editor.cmx jg_config.cmx searchid.cmx searchpos.cmx shell.cmx \ - viewer.cmx -searchid.cmo: list2.cmo searchid.cmi -searchid.cmx: list2.cmx searchid.cmi -searchpos.cmo: jg_bind.cmi jg_memo.cmi jg_message.cmi jg_text.cmi jg_tk.cmo \ - lexical.cmi searchid.cmi searchpos.cmi -searchpos.cmx: jg_bind.cmx jg_memo.cmx jg_message.cmx jg_text.cmx jg_tk.cmx \ - lexical.cmx searchid.cmx searchpos.cmi -setpath.cmo: jg_bind.cmi jg_box.cmo jg_button.cmo jg_toplevel.cmo list2.cmo \ - useunix.cmi setpath.cmi -setpath.cmx: jg_bind.cmx jg_box.cmx jg_button.cmx jg_toplevel.cmx list2.cmx \ - useunix.cmx setpath.cmi -shell.cmo: dummy.cmi fileselect.cmi jg_memo.cmi jg_menu.cmo jg_message.cmi \ - jg_text.cmi jg_tk.cmo jg_toplevel.cmo lexical.cmi list2.cmo shell.cmi -shell.cmx: dummy.cmi fileselect.cmx jg_memo.cmx jg_menu.cmx jg_message.cmx \ - jg_text.cmx jg_tk.cmx jg_toplevel.cmx lexical.cmx list2.cmx shell.cmi -typecheck.cmo: jg_message.cmi jg_text.cmi jg_tk.cmo mytypes.cmi typecheck.cmi -typecheck.cmx: jg_message.cmx jg_text.cmx jg_tk.cmx mytypes.cmi typecheck.cmi -useunix.cmo: useunix.cmi -useunix.cmx: useunix.cmi -viewer.cmo: help.cmo jg_bind.cmi jg_box.cmo jg_button.cmo jg_completion.cmi \ - jg_entry.cmo jg_menu.cmo jg_message.cmi jg_multibox.cmi jg_text.cmi \ - jg_tk.cmo jg_toplevel.cmo mytypes.cmi searchid.cmi searchpos.cmi \ - setpath.cmi shell.cmi useunix.cmi viewer.cmi -viewer.cmx: help.cmx jg_bind.cmx jg_box.cmx jg_button.cmx jg_completion.cmx \ - jg_entry.cmx jg_menu.cmx jg_message.cmx jg_multibox.cmx jg_text.cmx \ - jg_tk.cmx jg_toplevel.cmx mytypes.cmi searchid.cmx searchpos.cmx \ - setpath.cmx shell.cmx useunix.cmx viewer.cmi -mytypes.cmi: shell.cmi -typecheck.cmi: mytypes.cmi diff --git a/otherlibs/labltk/browser/Makefile b/otherlibs/labltk/browser/Makefile deleted file mode 100644 index c1daed9461..0000000000 --- a/otherlibs/labltk/browser/Makefile +++ /dev/null @@ -1,64 +0,0 @@ -include ../support/Makefile.common - -LABLTKLIB=-I ../labltk -I ../lib -I ../support -#OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/systhreads -I $(OTHERS)/str -OTHERSLIB=-I $(OTHERS)/unix -I $(OTHERS)/str -OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing -INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB) - -OBJ = list2.cmo useunix.cmo setpath.cmo lexical.cmo \ - fileselect.cmo searchid.cmo searchpos.cmo shell.cmo \ - help.cmo \ - viewer.cmo typecheck.cmo editor.cmo main.cmo - -JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \ - jg_box.cmo \ - jg_button.cmo jg_toplevel.cmo jg_text.cmo jg_message.cmo \ - jg_menu.cmo jg_entry.cmo jg_multibox.cmo jg_memo.cmo - -# Default rules - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.ml.cmo: - $(CAMLCOMP) $(INCLUDES) $< - -.mli.cmi: - $(CAMLCOMP) $(INCLUDES) $< - -all: ocamlbrowser$(EXE) - -ocamlbrowser$(EXE): $(TOPDIR)/toplevel/toplevellib.cma jglib.cma $(OBJ) \ - ../support/lib$(LIBNAME).a - $(CAMLC) -o ocamlbrowser$(EXE) $(INCLUDES) \ - $(TOPDIR)/toplevel/toplevellib.cma \ - unix.cma str.cma $(LIBNAME).cma jglib.cma $(OBJ) - -ocamlbrowser.cma: jglib.cma $(OBJ) - $(CAMLC) -a -o $@ -linkall jglib.cma $(OBJ) - -jglib.cma: $(JG) - $(CAMLCOMP) -a -o jglib.cma $(JG) - -help.ml: - echo 'let text = "\\' > $@ - sed -e 's/^ /\\032/' -e 's/$$/\\n\\/' help.txt >> $@ - echo '";;' >> $@ - -install: - if test -f ocamlbrowser$(EXE); then : ; \ - cp ocamlbrowser$(EXE) $(BINDIR); fi - -clean: - rm -f *.cm? ocamlbrowser$(EXE) dummy.mli *~ *.orig - -depend: - $(CAMLDEP) *.ml *.mli > .depend - -dummy.mli: - rm -f $@ - ln -s dummyUnix.mli $@ -shell.cmo: dummy.cmi -setpath.cmo fileselect.cmo lexical.cmi searchid.cmi typecheck.cmi: $(TOPDIR)/toplevel/toplevellib.cma - -include .depend diff --git a/otherlibs/labltk/browser/Makefile.nt b/otherlibs/labltk/browser/Makefile.nt deleted file mode 100644 index 6079723637..0000000000 --- a/otherlibs/labltk/browser/Makefile.nt +++ /dev/null @@ -1,70 +0,0 @@ -include ../support/Makefile.common.nt - -LABLTKLIB=-I ../labltk -I ../lib -I ../support -OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/str -I $(OTHERS)/systhreads -OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing -INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB) -CCFLAGS=-I../../../byterun $(TK_DEFS) - -ifeq ($(CCOMPTYPE),cc) -WINDOWS_APP= -else -WINDOWS_APP=-cclib "/link /subsystem:windows" -endif - -OBJS = list2.cmo useunix.cmo setpath.cmo lexical.cmo \ - fileselect.cmo searchid.cmo searchpos.cmo shell.cmo \ - help.cmo \ - viewer.cmo typecheck.cmo editor.cmo main.cmo - -JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \ - jg_box.cmo \ - jg_button.cmo jg_toplevel.cmo jg_text.cmo jg_message.cmo \ - jg_menu.cmo jg_entry.cmo jg_multibox.cmo jg_memo.cmo - -# Default rules - -.SUFFIXES: .ml .mli .cmo .cmi .cmx .c .$(O) - -.ml.cmo: - $(CAMLCOMP) $(INCLUDES) $< - -.mli.cmi: - $(CAMLCOMP) $(INCLUDES) $< - -.c.$(O): - $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< - -all: ocamlbrowser.exe - -ocamlbrowser.exe: $(TOPDIR)/toplevel/toplevellib.cma \ - ../support/lib$(LIBNAME).$(A) -ocamlbrowser.exe: jglib.cma $(OBJS) winmain.$(O) - $(CAMLC) -o ocamlbrowser.exe -custom $(INCLUDES) \ - $(TOPDIR)/toplevel/toplevellib.cma \ - unix.cma threads.cma str.cma $(LIBNAME).cma jglib.cma $(OBJS) \ - winmain.$(O) $(WINDOWS_APP) - -jglib.cma: $(JG) - $(CAMLCOMP) -a -o jglib.cma $(JG) - -help.ml: - echo 'let text = "\\' > $@ - sed -e 's/^ /\\032/' -e 's/$$/\\n\\/' help.txt >> $@ - echo '";;' >> $@ - -install: - if test -f ocamlbrowser.exe; then cp ocamlbrowser.exe $(BINDIR); fi - -clean: - rm -f *.cm? ocamlbrowser.exe dummy.mli *~ *.orig *.$(O) - -depend: - $(CAMLDEP) *.ml *.mli > .depend - -dummy.mli: - cp dummyWin.mli dummy.mli -shell.cmo: dummy.cmi -setpath.cmo fileselect.cmo lexical.cmi searchid.cmi typecheck.cmi: $(TOPDIR)/toplevel/toplevellib.cma - -include .depend diff --git a/otherlibs/labltk/browser/README b/otherlibs/labltk/browser/README deleted file mode 100644 index e8953541bf..0000000000 --- a/otherlibs/labltk/browser/README +++ /dev/null @@ -1,170 +0,0 @@ - - Installing and Using OCamlBrowser - - -INSTALLATION - If you installed it with LablTk, nothing to do. - Otherwise, the source is in labltk/browser. - After installing LablTk, simply do "make" and "make install". - The name of the command is `ocamlbrowser'. - -USE - OCamlBrowser is composed of three tools, the Viewer, to walk around - compiled modules, the Editor, which allows one to - edit/typecheck/analyse .mli and .ml files, and the Shell, to run an - OCaml subshell. You may only have one instance of Editor and - Viewer, but you may use several subshells. - - As with the compiler, you may specify a different path for the - standard library by setting CAMLLIB. You may also extend the - initial load path (only standard library by default) by using the - -I command line option, or set various other options (see -help). - - If you prefered the old GUI, it is still available with the option - -oldui, otherwise you get a new Smalltalkish user interface. - -1) Viewer - - Menus - - File - Open and File - Editor give access to the editor. - - File - Shell opens an OCaml shell. - - View - Show all defs displays all the interface of the currently - selected module - View - Search entry shows/hides the search entry at the top of the - window - - Modules - Path editor changes the load path. - Pressing [Add to path] or Insert key adds selected directories - to the load path. - Pressing [Remove from path] or Delete key removes selected - paths from the load path. - Modules - Reset cache rescans the load path and resets the module - cache. Do it if you recompile some interface, or change the load - path in a conflictual way. - - Modules - Search symbol allows to search a symbol either by its - name, like the bottom line of the viewer, or, more - interestingly, by its type. Exact type searches for a type - with exactly the same information as the pattern (variables - match only variables), included type allows to give only - partial information: the actual type may take more arguments - and return more results, and variables in the pattern match - anything. In both cases, argument and tuple order is - irrelevant (*), and unlabeled arguments in the pattern match - any label. - - (*) To avoid combinatorial explosion of the search space, optional - arguments in the actual type are ignored if (1) there are to many - of them, and (2) they do not appear explicitly in the pattern. - - Search entry - - The entry line at the top allows one to search for an identifier - in all modules, either by its name (? and * patterns allowed) or by - its type. When search by type is used, it is done in inclusion mode - (cf. Modules - search symbol) - - The Close all button at the bottom is there to dismiss the windows - created by the Detach button. By double-clicking on it you will - quit the browser. - - Module browsing - - You select a module in the leftmost box by either cliking on it or - pressing return when it is selected. Fast access is available in - all boxes pressing the first few letter of the desired - name. Double-clicking / double-return displays the whole signature - for the module. - - Defined identifiers inside the module are displayed in a box to the - right of the previous one. If you click on one, this will either - display its contents in another box (if this is a sub-module) or - display the signature for this identifier below. - - Signatures are clickable. Double clicking with the left mouse - button on an identifier in a signature brings you to its signature. - A single click on the right button pops up a menu displaying the - type declaration for the selected identifier. Its title, when - selectable, also brings you to its signature. - - At the bottom, a series of buttons, depending on the context. - * Detach copies the currently displayed signature in a new window, - to keep it. You can discard these windows with Close all. - * Impl and Intf bring you to the implementation or interface of - the currently displayed signature, if it is available. - - C-s opens a text search dialog for the displayed signature. - -2) Editor - You can edit files with it, but there is no auto-save nor undo at - the moment. Otherwise you can use it as a browser, making - occasional corrections. - - The Edit menu contains commands for jump (C-g), search (C-s), and - sending the current selection to a sub-shell (M-x). For this last - option, you may choose the shell via a dialog. - - Essential function are in the Compiler menu. - - Preferences opens a dialog to set internals of the editor and - type checker. - - Lex (M-l) adds colors according to lexical categories. - - Typecheck (M-t) verifies typing, and memorizes it to let one see an - expression's type by double-clicking on it. This is also valid for - interfaces. If an error occurs, the part of the interface preceding - the error is computed. - - After typechecking, pressing the right button pops up a menu giving - the type of the pointed expression, and eventually allowing to - follow some links. - - Clear errors dismisses type checker error messages and warnings. - - Signature shows the signature of the current file. - -3) Shell - When you create a shell, a dialog is presented to you, letting you - choose which command you want to run, and the title of the shell - (to choose it in the Editor). - - You may change the default command by setting the OLABL environment - variable. - - The executed subshell is given the current load path. - File: use a source file or load a bytecode file. - You may also import the browser's path into the subprocess. - History: M-p and M-n browse up and down. - Signal: C-c interrupts and you can kill the subprocess. - -BUGS - -* This not really a bug, but OCamlBrowser is a huge memory consumer. - Go and buy some. - -* When you quit the editor and some file was modified, a dialogue is - displayed asking wether you want to really quit or not. But 1) if - you quit directly from the viewer, there is no dialogue at all, and - 2) if you close from the window manager, the dialogue is displayed, - but you cannot cancel the destruction... Beware. - -* When you run it through xon, the shell hangs at the first error. But - its ok if you start ocamlbrowser from a remote shell... - -TODO - -* Complete cross-references. - -* Power up editor. - -* Add support for the debugger. - -* Make this a real programming environment, both for beginners an - experimented users. - - -Bug reports and comments to <garrigue@kurims.kyoto-u.ac.jp> diff --git a/otherlibs/labltk/browser/dummyUnix.mli b/otherlibs/labltk/browser/dummyUnix.mli deleted file mode 100644 index 163d14ad34..0000000000 --- a/otherlibs/labltk/browser/dummyUnix.mli +++ /dev/null @@ -1,27 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -module Mutex : sig - type t - external create : unit -> t = "%ignore" - external lock : t -> unit = "%ignore" - external unlock : t -> unit = "%ignore" -end - -module Thread : sig - type t - external create : ('a -> 'b) -> 'a -> t = "caml_input" -end diff --git a/otherlibs/labltk/browser/dummyWin.mli b/otherlibs/labltk/browser/dummyWin.mli deleted file mode 100644 index a4b75ee37b..0000000000 --- a/otherlibs/labltk/browser/dummyWin.mli +++ /dev/null @@ -1,15 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml deleted file mode 100644 index 1e6e3c0ee2..0000000000 --- a/otherlibs/labltk/browser/editor.ml +++ /dev/null @@ -1,671 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk -open Parsetree -open Location -open Jg_tk -open Mytypes - -let lex_on_load = ref true -and type_on_load = ref false - -let compiler_preferences master = - let tl = Jg_toplevel.titled "Compiler" in - Wm.transient_set tl ~master; - let mk_chkbutton ~text ~ref ~invert = - let variable = Textvariable.create ~on:tl () in - if (if invert then not !ref else !ref) then - Textvariable.set variable "1"; - Checkbutton.create tl ~text ~variable, - (fun () -> - ref := Textvariable.get variable = (if invert then "0" else "1")) - in - let use_pp = ref (!Clflags.preprocessor <> None) in - let chkbuttons, setflags = List.split - (List.map - ~f:(fun (text, ref, invert) -> mk_chkbutton ~text ~ref ~invert) - [ "No pervasives", Clflags.nopervasives, false; - "No warnings", Typecheck.nowarnings, false; - "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; - "Preprocessor", use_pp, false ]) - in - let pp_command = Entry.create tl (* ~state:(if !use_pp then `Normal else`Disabled) *) in - begin match !Clflags.preprocessor with None -> () - | Some pp -> Entry.insert pp_command ~index:(`Num 0) ~text:pp - end; - let buttons = Frame.create tl in - let ok = Button.create buttons ~text:"Ok" ~padx:20 ~command: - begin fun () -> - List.iter ~f:(fun f -> f ()) setflags; - Clflags.preprocessor := - if !use_pp then Some (Entry.get pp_command) else None; - destroy tl - end - and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" - in - pack chkbuttons ~side:`Top ~anchor:`W; - pack [pp_command] ~side:`Top ~anchor:`E; - pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true; - pack [buttons] ~side:`Bottom ~fill:`X - -let rec exclude txt = function - [] -> [] - | x :: l -> if txt.number = x.number then l else x :: exclude txt l - -let goto_line tw = - let tl = Jg_toplevel.titled "Go to" in - Wm.transient_set tl ~master:(Winfo.toplevel tw); - Jg_bind.escape_destroy tl; - let ef = Frame.create tl in - let fl = Frame.create ef - and fi = Frame.create ef in - let ll = Label.create fl ~text:"Line ~number:" - and il = Entry.create fi ~width:10 - and lc = Label.create fl ~text:"Col ~number:" - and ic = Entry.create fi ~width:10 - and get_int ew = - try int_of_string (Entry.get ew) - with Failure "int_of_string" -> 0 - in - let buttons = Frame.create tl in - let ok = Button.create buttons ~text:"Ok" ~command: - begin fun () -> - let l = get_int il - and c = get_int ic in - Text.mark_set tw ~mark:"insert" ~index:(`Linechar (l,0), [`Char c]); - Text.see tw ~index:(`Mark "insert", []); - destroy tl - end - and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in - - Focus.set il; - List.iter [il; ic] ~f: - begin fun w -> - Jg_bind.enter_focus w; - Jg_bind.return_invoke w ~button:ok - end; - pack [ll; lc] ~side:`Top ~anchor:`W; - pack [il; ic] ~side:`Top ~fill:`X ~expand:true; - pack [fl; fi] ~side:`Left ~fill:`X ~expand:true; - pack [ok; cancel] ~side:`Left ~fill:`X ~expand:true; - pack [ef; buttons] ~side:`Top ~fill:`X ~expand:true - -let select_shell txt = - let shells = Shell.get_all () 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); - let label = Label.create tl ~text:"Send to:" - and box = Listbox.create tl - and frame = Frame.create tl in - Jg_bind.enter_focus box; - let cancel = Jg_button.create_destroyer tl ~parent:frame ~text:"Cancel" - and ok = Button.create frame ~text:"Ok" ~command: - begin fun () -> - try - let name = Listbox.get box ~index:`Active in - txt.shell <- Some (name, List.assoc name shells); - destroy tl - with Not_found -> txt.shell <- None; destroy tl - end - in - Listbox.insert box ~index:`End ~texts:(List.map ~f:fst shells); - Listbox.configure box ~height:(List.length shells); - bind box ~events:[`KeyPressDetail"Return"] ~breakable:true - ~action:(fun _ -> Button.invoke ok; break ()); - bind box ~events:[`Modified([`Double],`ButtonPressDetail 1)] ~breakable:true - ~fields:[`MouseX;`MouseY] - ~action:(fun ev -> - Listbox.activate box ~index:(`Atxy (ev.ev_MouseX, ev.ev_MouseY)); - Button.invoke ok; break ()); - pack [label] ~side:`Top ~anchor:`W; - pack [box] ~side:`Top ~fill:`Both; - pack [frame] ~side:`Bottom ~fill:`X ~expand:true; - pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true - -open Parser - -let send_phrase txt = - if txt.shell = None then begin - match Shell.get_all () with [] -> () - | [sh] -> txt.shell <- Some sh - | l -> select_shell txt - end; - match txt.shell with None -> () - | Some (_,sh) -> - try - 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 (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 - let buffer = Lexing.from_string text in - let start = ref 0 - and block_start = ref [] - and pend = ref (-1) - and after = ref false in - while !pend = -1 do - let token = Lexer.token buffer in - let pos = - if token = SEMISEMI then Lexing.lexeme_end buffer - else Lexing.lexeme_start buffer - in - let bol = (pos = 0) || text.[pos-1] = '\n' in - if not !after && - Text.compare txt.tw ~index:(tpos pos) ~op:(if bol then `Gt else `Ge) - ~index:(`Mark"insert",[]) - then begin - after := true; - let anon, real = - List.partition !block_start ~f:(fun x -> x = -1) in - block_start := anon; - if real <> [] then start := List.hd real; - end; - match token with - CLASS | EXTERNAL | EXCEPTION | FUNCTOR - | LET | MODULE | OPEN | TYPE | VAL | SHARP when bol -> - if !block_start = [] then - if !after then pend := pos else start := pos - else block_start := pos :: List.tl !block_start - | SEMISEMI -> - if !block_start = [] then - if !after then pend := Lexing.lexeme_start buffer - else start := pos - else block_start := pos :: List.tl !block_start - | BEGIN | OBJECT -> - block_start := -1 :: !block_start - | STRUCT | SIG -> - block_start := Lexing.lexeme_end buffer :: !block_start - | END -> - if !block_start = [] then - if !after then pend := pos else () - else block_start := List.tl !block_start - | EOF -> - pend := pos - | _ -> - () - done; - let phrase = String.sub text ~pos:!start ~len:(!pend - !start) in - sh#send phrase; - sh#send ";;\n" - -let search_pos_window txt ~x ~y = - if txt.type_info = [] && txt.psignature = [] then () else - let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in - let text = Jg_text.get_all txt.tw in - let pos = Searchpos.lines_to_chars l ~text + c in - try if txt.type_info <> [] then begin match - Searchpos.search_pos_info txt.type_info ~pos - with [] -> () - | (kind, env, loc) :: _ -> Searchpos.view_type kind ~env - end else begin match - Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env - with [] -> () - | ((kind, lid), env, loc) :: _ -> - Searchpos.view_decl lid ~kind ~env - end - with Not_found -> () - -let search_pos_menu txt ~x ~y = - if txt.type_info = [] && txt.psignature = [] then () else - let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in - let text = Jg_text.get_all txt.tw in - let pos = Searchpos.lines_to_chars l ~text + c in - try if txt.type_info <> [] then begin match - Searchpos.search_pos_info txt.type_info ~pos - with [] -> () - | (kind, env, loc) :: _ -> - let menu = Searchpos.view_type_menu kind ~env ~parent:txt.tw in - let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in - Menu.popup menu ~x ~y - end else begin match - Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env - with [] -> () - | ((kind, lid), env, loc) :: _ -> - let menu = Searchpos.view_decl_menu lid ~kind ~env ~parent:txt.tw in - let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in - Menu.popup menu ~x ~y - end - with Not_found -> () - -let string_width s = - let width = ref 0 in - for i = 0 to String.length s - 1 do - if s.[i] = '\t' then width := (!width / 8 + 1) * 8 - else incr width - done; - !width - -let indent_line = - let ins = `Mark"insert" and reg = Str.regexp "[ \t]*" in - 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 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 - Text.mark_set tw ~mark:"insert" ~index:(ins,[`Linestart;`Char len]); - let indent = - if l <= 1 then 2 else - let previous = - Text.get tw ~start:(ins,[`Line(-1);`Linestart]) - ~stop:(ins,[`Line(-1);`Lineend]) in - 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 - in - Text.insert tw ~index:(ins,[]) ~text:(String.make indent ' ') - -(* The editor class *) - -class editor ~top ~menus = object (self) - val file_menu = new Jg_menu.c "File" ~parent:menus - val edit_menu = new Jg_menu.c "Edit" ~parent:menus - val compiler_menu = new Jg_menu.c "Compiler" ~parent:menus - val module_menu = new Jg_menu.c "Modules" ~parent:menus - val window_menu = new Jg_menu.c "Windows" ~parent:menus - val label = - Checkbutton.create menus ~state:`Disabled - ~onvalue:"modified" ~offvalue:"unchanged" - val mutable current_dir = Unix.getcwd () - val mutable error_messages = [] - val mutable windows = [] - val mutable current_tw = Text.create top - val vwindow = Textvariable.create ~on:top () - val mutable window_counter = 0 - - method has_window name = - List.exists windows ~f:(fun x -> x.name = name) - - method reset_window_menu = - Menu.delete window_menu#menu ~first:(`Num 0) ~last:`End; - List.iter - (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 - ~label:(Filename.basename txt.name) - ~variable:vwindow ~value:txt.number - ~command:(fun () -> self#set_edit txt) - end - - method set_edit txt = - if windows <> [] then - Pack.forget [(List.hd windows).frame]; - windows <- txt :: exclude txt windows; - self#reset_window_menu; - current_tw <- txt.tw; - Checkbutton.configure label ~text:(Filename.basename txt.name) - ~variable:txt.modified; - Textvariable.set vwindow txt.number; - Text.yview txt.tw ~scroll:(`Page 0); - pack [txt.frame] ~fill:`Both ~expand:true ~side:`Bottom - - method new_window name = - let tl, tw, sb = Jg_text.create_with_scrollbar top in - Text.configure tw ~background:`White; - Jg_bind.enter_focus tw; - window_counter <- window_counter + 1; - let txt = - { name = name; tw = tw; frame = tl; - number = string_of_int window_counter; - modified = Textvariable.create ~on:tw (); - shell = None; - structure = []; type_info = []; signature = []; psignature = [] } - in - let control c = Char.chr (Char.code c - 96) in - bind tw ~events:[`Modified([`Alt], `KeyPress)] ~action:ignore; - bind tw ~events:[`KeyPress] ~fields:[`Char] - ~action:(fun ev -> - if ev.ev_Char <> "" && - (ev.ev_Char.[0] >= ' ' || - List.mem ev.ev_Char.[0] - (List.map ~f:control ['d'; 'h'; 'i'; 'k'; 'o'; 't'; 'w'; 'y'])) - then Textvariable.set txt.modified "modified"); - bind tw ~events:[`KeyPressDetail"Tab"] ~breakable:true - ~action:(fun _ -> - indent_line tw; - Textvariable.set txt.modified "modified"; - break ()); - bind tw ~events:[`Modified([`Control],`KeyPressDetail"k")] - ~action:(fun _ -> - let text = - Text.get tw ~start:(`Mark"insert",[]) ~stop:(`Mark"insert",[`Lineend]) - 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 () - end); - bind tw ~events:[`KeyRelease] ~fields:[`Char] - ~action:(fun ev -> - if ev.ev_Char <> "" then - Lexical.tag tw ~start:(`Mark"insert", [`Linestart]) - ~stop:(`Mark"insert", [`Lineend])); - bind tw ~events:[`Motion] ~action:(fun _ -> Focus.set tw); - bind tw ~events:[`ButtonPressDetail 2] - ~action:(fun _ -> - Textvariable.set txt.modified "modified"; - Lexical.tag txt.tw ~start:(`Mark"insert", [`Linestart]) - ~stop:(`Mark"insert", [`Lineend])); - bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~fields:[`MouseX;`MouseY] - ~action:(fun ev -> search_pos_window txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY); - bind tw ~events:[`ButtonPressDetail 3] ~fields:[`MouseX;`MouseY] - ~action:(fun ev -> search_pos_menu txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY); - - pack [sb] ~fill:`Y ~side:`Right; - pack [tw] ~fill:`Both ~expand:true ~side:`Left; - self#set_edit txt; - Checkbutton.deselect label; - Lexical.init_tags txt.tw - - method clear_errors () = - Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend; - List.iter error_messages - ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ()); - error_messages <- [] - - method typecheck () = - self#clear_errors (); - error_messages <- Typecheck.f (List.hd windows) - - method lex () = - List.iter [ Widget.default_toplevel; top ] - ~f:(Toplevel.configure ~cursor:(`Xcursor "watch")); - Text.configure current_tw ~cursor:(`Xcursor "watch"); - ignore (Timer.add ~ms:1 ~callback: - begin fun () -> - Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend; - Lexical.tag current_tw; - Text.configure current_tw ~cursor:(`Xcursor "xterm"); - List.iter [ Widget.default_toplevel; top ] - ~f:(Toplevel.configure ~cursor:(`Xcursor "")) - end) - - method save_text ?name:l txt = - let l = match l with None -> [txt.name] | Some l -> l in - if l = [] then () else - let name = List.hd l in - if txt.name <> name then current_dir <- Filename.dirname name; - try - if Sys.file_exists name then - if txt.name = name then begin - let backup = name ^ "~" in - if Sys.file_exists backup then Sys.remove backup; - try Sys.rename name backup with Sys_error _ -> () - end else begin - match Jg_message.ask ~master:top ~title:"Save" - ("File `" ^ name ^ "' exists. Overwrite it?") - with `Yes -> Sys.remove name - | `No -> raise (Sys_error "") - | `Cancel -> raise Exit - end; - let file = open_out name in - let text = Text.get txt.tw ~start:tstart ~stop:(tposend 1) in - output_string file text; - close_out file; - Checkbutton.configure label ~text:(Filename.basename name); - Checkbutton.deselect label; - txt.name <- name - with - Sys_error _ -> - Jg_message.info ~master:top ~title:"Error" - ("Could not save `" ^ name ^ "'.") - | Exit -> () - - method load_text l = - if l = [] then () else - let name = List.hd l in - try - let index = - try - self#set_edit (List.find windows ~f:(fun x -> x.name = name)); - let txt = List.hd windows in - if Textvariable.get txt.modified = "modified" then - begin match Jg_message.ask ~master:top ~title:"Open" - ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") - with `Yes -> self#save_text txt - | `No -> () - | `Cancel -> raise Exit - end; - Checkbutton.deselect label; - (Text.index current_tw ~index:(`Mark"insert", []), []) - with Not_found -> self#new_window name; tstart - in - current_dir <- Filename.dirname name; - let file = open_in name - and tw = current_tw - and len = ref 0 - and buf = String.create 4096 in - Text.delete tw ~start:tstart ~stop:tend; - while - len := input file buf 0 4096; - !len > 0 - do - Jg_text.output tw ~buf ~pos:0 ~len:!len - done; - close_in file; - Text.mark_set tw ~mark:"insert" ~index; - Text.see tw ~index; - if Filename.check_suffix name ".ml" || - Filename.check_suffix name ".mli" - then begin - if !lex_on_load then self#lex (); - if !type_on_load then self#typecheck () - end - with - Sys_error _ | Exit -> () - - method close_window txt = - try - if Textvariable.get txt.modified = "modified" then - begin match Jg_message.ask ~master:top ~title:"Close" - ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") - with `Yes -> self#save_text txt - | `No -> () - | `Cancel -> raise Exit - end; - windows <- exclude txt windows; - if windows = [] then - self#new_window (current_dir ^ "/untitled") - else self#set_edit (List.hd windows); - destroy txt.frame - with Exit -> () - - method open_file () = - Fileselect.f ~title:"Open File" ~action:self#load_text - ~dir:current_dir ~filter:("*.{ml,mli}") ~sync:true () - - method save_file () = self#save_text (List.hd windows) - - method close_file () = self#close_window (List.hd windows) - - method quit ?(cancel=true) () = - try - List.iter windows ~f: - begin fun txt -> - if Textvariable.get txt.modified = "modified" then - match Jg_message.ask ~master:top ~title:"Quit" ~cancel - ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") - with `Yes -> self#save_text txt - | `No -> () - | `Cancel -> raise Exit - end; - bind top ~events:[`Destroy]; - destroy top - with Exit -> () - - method reopen ~file ~pos = - if not (Winfo.ismapped top) then Wm.deiconify top; - match file with None -> () - | Some file -> - self#load_text [file]; - Text.mark_set current_tw ~mark:"insert" ~index:(tpos pos); - try - let index = - Text.search current_tw ~switches:[`Backwards] ~pattern:"*)" - ~start:(tpos pos) ~stop:(tpos pos ~modi:[`Line(-1)]) in - let index = - Text.search current_tw ~switches:[`Backwards] ~pattern:"(*" - ~start:(index,[]) ~stop:(tpos pos ~modi:[`Line(-20)]) in - let s = Text.get current_tw ~start:(index,[`Line(-1);`Linestart]) - ~stop:(index,[`Line(-1);`Lineend]) in - for i = 0 to String.length s - 1 do - match s.[i] with '\t'|' ' -> () | _ -> raise Not_found - done; - Text.yview_index current_tw ~index:(index,[`Line(-1)]) - with _ -> - Text.yview_index current_tw ~index:(tpos pos ~modi:[`Line(-2)]) - - initializer - (* Create a first window *) - self#new_window (current_dir ^ "/untitled"); - - (* Bindings for the main window *) - List.iter - [ [`Control], "s", (fun () -> Jg_text.search_string current_tw); - [`Control], "g", (fun () -> goto_line current_tw); - [`Alt], "s", self#save_file; - [`Alt], "x", (fun () -> send_phrase (List.hd windows)); - [`Alt], "l", self#lex; - [`Alt], "t", self#typecheck ] - ~f:begin fun (modi,key,act) -> - bind top ~events:[`Modified(modi, `KeyPressDetail key)] ~breakable:true - ~action:(fun _ -> act (); break ()) - end; - - bind top ~events:[`Destroy] ~fields:[`Widget] ~action: - begin fun ev -> - if Widget.name ev.ev_Widget = Widget.name top - then self#quit ~cancel:false () - end; - - (* File menu *) - file_menu#add_command "Open File..." ~command:self#open_file; - file_menu#add_command "Reopen" - ~command:(fun () -> self#load_text [(List.hd windows).name]); - file_menu#add_command "Save File" ~command:self#save_file ~accelerator:"M-s"; - file_menu#add_command "Save As..." ~underline:5 ~command: - begin fun () -> - let txt = List.hd windows in - Fileselect.f ~title:"Save as File" - ~action:(fun name -> self#save_text txt ~name) - ~dir:(Filename.dirname txt.name) - ~filter:"*.{ml,mli}" - ~file:(Filename.basename txt.name) - ~sync:true ~usepath:false () - end; - file_menu#add_command "Close File" ~command:self#close_file; - file_menu#add_command "Close Window" ~command:self#quit ~underline:6; - - (* Edit menu *) - edit_menu#add_command "Paste selection" ~command: - begin fun () -> - Text.insert current_tw ~index:(`Mark"insert",[]) - ~text:(Selection.get ~displayof:top ()) - end; - edit_menu#add_command "Goto..." ~accelerator:"C-g" - ~command:(fun () -> goto_line current_tw); - edit_menu#add_command "Search..." ~accelerator:"C-s" - ~command:(fun () -> Jg_text.search_string current_tw); - edit_menu#add_command "To shell" ~accelerator:"M-x" - ~command:(fun () -> send_phrase (List.hd windows)); - edit_menu#add_command "Select shell..." - ~command:(fun () -> select_shell (List.hd windows)); - - (* Compiler menu *) - compiler_menu#add_command "Preferences..." - ~command:(fun () -> compiler_preferences top); - compiler_menu#add_command "Lex" ~accelerator:"M-l" - ~command:self#lex; - compiler_menu#add_command "Typecheck" ~accelerator:"M-t" - ~command:self#typecheck; - compiler_menu#add_command "Clear errors" - ~command:self#clear_errors; - compiler_menu#add_command "Signature..." ~command: - begin fun () -> - let txt = List.hd windows in if txt.signature <> [] then - let basename = Filename.basename txt.name in - let modname = String.capitalize - (try Filename.chop_extension basename with _ -> basename) in - let env = - Env.add_module (Ident.create modname) - (Types.Tmty_signature txt.signature) - Env.initial - in Viewer.view_defined (Longident.Lident modname) ~env ~show_all:true - end; - - (* Modules *) - module_menu#add_command "Path editor..." - ~command:(fun () -> Setpath.set ~dir:current_dir); - module_menu#add_command "Reset cache" - ~command:(fun () -> Setpath.exec_update_hooks (); Env.reset_cache ()); - module_menu#add_command "Search symbol..." - ~command:Viewer.search_symbol; - module_menu#add_command "Close all" - ~command:Viewer.close_all_views; - - (* pack everything *) - pack (List.map ~f:(fun m -> coe m#button) - [file_menu; edit_menu; compiler_menu; module_menu; window_menu] - @ [coe label]) - ~side:`Left ~ipadx:5 ~anchor:`W; - pack [menus] ~before:(List.hd windows).frame ~side:`Top ~fill:`X -end - -(* The main function starts here ! *) - -let already_open : editor list ref = ref [] - -let editor ?file ?(pos=0) ?(reuse=false) () = - - if !already_open <> [] && - let ed = List.hd !already_open - (* try - let name = match file with Some f -> f | None -> raise Not_found in - List.find !already_open ~f:(fun ed -> ed#has_window name) - with Not_found -> List.hd !already_open *) - in try - ed#reopen ~file ~pos; - true - with Protocol.TkError _ -> - already_open := [] (* List.filter !already_open ~f:((<>) ed) *); - false - then () else - let top = Jg_toplevel.titled "OCamlBrowser Editor" in - let menus = Frame.create top ~name:"menubar" in - let ed = new editor ~top ~menus in - already_open := !already_open @ [ed]; - if file <> None then ed#reopen ~file ~pos - -let f ?file ?pos ?(opendialog=false) () = - if opendialog then - Fileselect.f ~title:"Open File" - ~action:(function [file] -> editor ~file () | _ -> ()) - ~filter:("*.{ml,mli}") ~sync:true () - else editor ?file ?pos ~reuse:(file <> None) () diff --git a/otherlibs/labltk/browser/editor.mli b/otherlibs/labltk/browser/editor.mli deleted file mode 100644 index 665ee813f3..0000000000 --- a/otherlibs/labltk/browser/editor.mli +++ /dev/null @@ -1,20 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val f : ?file:string -> ?pos:int -> ?opendialog:bool -> unit -> unit - (* open the file editor *) diff --git a/otherlibs/labltk/browser/fileselect.ml b/otherlibs/labltk/browser/fileselect.ml deleted file mode 100644 index 6ca08f5aca..0000000000 --- a/otherlibs/labltk/browser/fileselect.ml +++ /dev/null @@ -1,290 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -(* file selection box *) - -open StdLabels -open Str -open Filename -open Tk - -open Useunix - -(**** Memoized rexgexp *) - -let (~!) = Jg_memo.fast ~f:Str.regexp - -(************************************************************ Path name *) - -(* Convert Windows-style directory separator '\' to caml-style '/' *) -let caml_dir path = - if Sys.os_type = "Win32" then - global_replace ~!"\\\\" "/" path - else path - -let parse_filter s = - let s = caml_dir s in - (* replace // by / *) - let s = global_replace ~!"/+" "/" s in - (* replace /./ by / *) - let s = global_replace ~!"/\\./" "/" s in - (* replace hoge/../ by "" *) - let s = global_replace - ~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./" "" s in - (* replace hoge/..$ by *) - let s = global_replace - ~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$" "" s in - (* replace ^/hoge/../ by / *) - 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 - dirs, ptrn - else "", s - -let rec fixpoint ~f v = - let v' = f v in - if v = v' then v else fixpoint ~f v' - -let unix_regexp s = - 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 ~!"\\({.*\\),\\(.*}\\)" "\\1\\|\\2") in - let s = - Str.global_replace ~!"{\\(.*\\)}" "\\(\\1\\)" s in - Str.regexp 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 - let regexp = unix_regexp pattern in - List.filter files ~f:(exact_match ~pat:regexp) - -(********************************************* Creation *) -let load_in_path = ref false - -let search_in_path ~name = Misc.find_in_path !Config.load_path name - -let f ~title ~action:proc ?(dir = Unix.getcwd ()) - ?filter:(deffilter ="*") ?file:(deffile ="") - ?(multi=false) ?(sync=false) ?(usepath=true) () = - - let current_pattern = ref "" - and current_dir = ref (caml_dir dir) in - - let may_prefix name = - if Filename.is_relative name then concat !current_dir name else name in - - let tl = Jg_toplevel.titled title in - Focus.set tl; - - let new_var () = Textvariable.create ~on:tl () in - let filter_var = new_var () - and selection_var = new_var () - and sync_var = new_var () in - Textvariable.set filter_var deffilter; - - let frm = Frame.create tl ~borderwidth:1 ~relief:`Raised in - let df = Frame.create frm in - let dfl = Frame.create df in - let dfll = Label.create dfl ~text:"Directories" in - let dflf, directory_listbox, directory_scrollbar = - Jg_box.create_with_scrollbar dfl in - let dfr = Frame.create df in - let dfrl = Label.create dfr ~text:"Files" in - let dfrf, filter_listbox, filter_scrollbar = - Jg_box.create_with_scrollbar dfr in - let cfrm = Frame.create tl ~borderwidth:1 ~relief:`Raised in - - let configure ~filter = - let filter = may_prefix filter in - let dir, pattern = parse_filter filter in - let dir = if !load_in_path && usepath then "" else - (current_dir := Filename.dirname dir; dir) - and pattern = if pattern = "" then "*" else pattern in - current_pattern := pattern; - let filter = - if !load_in_path && usepath then pattern else dir ^ pattern in - let directories = get_directories_in_files ~path:dir - (get_files_in_directory dir) in - let matched_files = (* get matched file by subshell call. *) - if !load_in_path && usepath then - List.fold_left !Config.load_path ~init:[] ~f: - begin fun acc dir -> - let files = ls ~dir ~pattern in - Sort.merge (<) files - (List.fold_left files ~init:acc - ~f:(fun acc name -> List2.exclude name acc)) - end - else - List.fold_left directories ~init:(ls ~dir ~pattern) - ~f:(fun acc dir -> List2.exclude dir acc) - in - Textvariable.set filter_var filter; - Textvariable.set selection_var (dir ^ deffile); - Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End; - Listbox.insert filter_listbox ~index:`End ~texts:matched_files; - Jg_box.recenter filter_listbox ~index:(`Num 0); - if !load_in_path && usepath then - Listbox.configure directory_listbox ~takefocus:false - else - begin - Listbox.configure directory_listbox ~takefocus:true; - Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End; - Listbox.insert directory_listbox ~index:`End ~texts:directories; - Jg_box.recenter directory_listbox ~index:(`Num 0) - end - in - - let selected_files = ref [] in (* used for synchronous mode *) - let activate l = - Grab.release tl; - destroy tl; - let l = - if !load_in_path && usepath then - List.fold_right l ~init:[] ~f: - begin fun name acc -> - if not (Filename.is_implicit name) then - may_prefix name :: acc - else try search_in_path ~name :: acc with Not_found -> acc - end - else - List.map l ~f:may_prefix - in - if sync then - begin - selected_files := l; - Textvariable.set sync_var "1" - end - else proc l - in - - (* entries *) - let fl = Label.create frm ~text:"Filter" in - let sl = Label.create frm ~text:"Selection" in - let filter_entry = Jg_entry.create frm ~textvariable:filter_var - ~command:(fun filter -> configure ~filter) in - let selection_entry = Jg_entry.create frm ~textvariable:selection_var - ~command:(fun file -> activate [file]) in - - (* and buttons *) - let set_path = Button.create dfl ~text:"Path editor" ~command: - begin fun () -> - Setpath.add_update_hook (fun () -> configure ~filter:!current_pattern); - let w = Setpath.f ~dir:!current_dir in - Grab.set w; - bind w ~events:[`Destroy] ~extend:true ~action:(fun _ -> Grab.set tl) - end in - let toggle_in_path = Checkbutton.create dfl ~text:"Use load path" - ~command: - begin fun () -> - load_in_path := not !load_in_path; - if !load_in_path then - pack [set_path] ~side:`Bottom ~fill:`X ~expand:true - else - Pack.forget [set_path]; - configure ~filter:(Textvariable.get filter_var) - end - and okb = Button.create cfrm ~text:"Ok" ~command: - begin fun () -> - let files = - List.map (Listbox.curselection filter_listbox) ~f: - begin fun x -> - !current_dir ^ Listbox.get filter_listbox ~index:x - end - in - let files = if files = [] then [Textvariable.get selection_var] - else files in - activate [Textvariable.get selection_var] - end - and flb = Button.create cfrm ~text:"Filter" - ~command:(fun () -> configure ~filter:(Textvariable.get filter_var)) - and ccb = Button.create cfrm ~text:"Cancel" - ~command:(fun () -> activate []) in - - (* binding *) - bind tl ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> activate []); - Jg_box.add_completion filter_listbox - ~action:(fun index -> activate [Listbox.get filter_listbox ~index]); - if multi then Listbox.configure filter_listbox ~selectmode:`Multiple else - bind filter_listbox ~events:[`ButtonPressDetail 1] ~fields:[`MouseY] - ~action:(fun ev -> - let name = Listbox.get filter_listbox - ~index:(Listbox.nearest filter_listbox ~y:ev.ev_MouseY) in - if !load_in_path && usepath then - try Textvariable.set selection_var (search_in_path ~name) - with Not_found -> () - else Textvariable.set selection_var (may_prefix name)); - - Jg_box.add_completion directory_listbox ~action: - begin fun index -> - let filter = - may_prefix (Listbox.get directory_listbox ~index) ^ - "/" ^ !current_pattern - in configure ~filter - end; - - pack [frm] ~fill:`Both ~expand:true; - (* filter *) - pack [fl] ~side:`Top ~anchor:`W; - pack [filter_entry] ~side:`Top ~fill:`X; - - (* directory + files *) - pack [df] ~side:`Top ~fill:`Both ~expand:true; - (* directory *) - pack [dfl] ~side:`Left ~fill:`Both ~expand:true; - pack [dfll] ~side:`Top ~anchor:`W; - if usepath then pack [toggle_in_path] ~side:`Bottom ~anchor:`W; - pack [dflf] ~side:`Top ~fill:`Both ~expand:true; - pack [directory_scrollbar] ~side:`Right ~fill:`Y; - pack [directory_listbox] ~side:`Left ~fill:`Both ~expand:true; - (* files *) - pack [dfr] ~side:`Right ~fill:`Both ~expand:true; - pack [dfrl] ~side:`Top ~anchor:`W; - pack [dfrf] ~side:`Top ~fill:`Both ~expand:true; - pack [filter_scrollbar] ~side:`Right ~fill:`Y; - pack [filter_listbox] ~side:`Left ~fill:`Both ~expand:true; - - (* selection *) - pack [sl] ~before:df ~side:`Bottom ~anchor:`W; - pack [selection_entry] ~before:sl ~side:`Bottom ~fill:`X; - - (* create OK, Filter and Cancel buttons *) - pack [okb; flb; ccb] ~side:`Left ~fill:`X ~expand:true; - pack [cfrm] ~before:frm ~side:`Bottom ~fill:`X; - - if !load_in_path && usepath then begin - load_in_path := false; - Checkbutton.invoke toggle_in_path; - Checkbutton.select toggle_in_path - end - else configure ~filter:deffilter; - - Tkwait.visibility tl; - Grab.set tl; - - if sync then - begin - Tkwait.variable sync_var; - proc !selected_files - end; - () diff --git a/otherlibs/labltk/browser/fileselect.mli b/otherlibs/labltk/browser/fileselect.mli deleted file mode 100644 index 75ee582aea..0000000000 --- a/otherlibs/labltk/browser/fileselect.mli +++ /dev/null @@ -1,39 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -val f : - title:string -> - action:(string list -> unit) -> - ?dir:string -> - ?filter:string -> - ?file:string -> - ?multi:bool -> ?sync:bool -> ?usepath:bool -> unit -> unit - -(* action - [] means canceled - if multi select is false, then the list is null or a singleton *) - -(* multi - If true then more than one file are selectable *) - -(* sync - If true then synchronous mode *) - -(* usepath - Enables/disables load path search. Defaults to true *) - -val caml_dir : string -> string -(* Convert Windows-style directory separator '\' to caml-style '/' *) diff --git a/otherlibs/labltk/browser/help.ml b/otherlibs/labltk/browser/help.ml deleted file mode 100644 index 632e762fdb..0000000000 --- a/otherlibs/labltk/browser/help.ml +++ /dev/null @@ -1,168 +0,0 @@ -let text = "\ -\032 OCamlBrowser Help\n\ -\n\ -USE\n\ -\n\ -\032 OCamlBrowser is composed of three tools, the Editor, which allows\n\ -\032 one to edit/typecheck/analyse .mli and .ml files, the Viewer, to\n\ -\032 walk around compiled modules, and the Shell, to run an OCaml\n\ -\032 subshell. You may only have one instance of Editor and Viewer, but\n\ -\032 you may use several subshells.\n\ -\n\ -\032 As with the compiler, you may specify a different path for the\n\ -\032 standard library by setting OCAMLLIB. You may also extend the\n\ -\032 initial load path (only standard library by default) by using the\n\ -\032 -I command line option. The -nolabels, -rectypes and -w options are\n\ -\032 also accepted, and inherited by subshells.\n\ -\032 The -oldui options selects the old multi-window interface. The\n\ -\032 default is now more like Smalltalk's class browser.\n\ -\n\ -1) Viewer\n\ -\n\ -\032 This is the first window you get when you start OCamlBrowser. It\n\ -\032 displays a search window, and the list of modules in the load path.\n\ -\032 At the top a row of menus.\n\ -\n\ -\032 File - Open and File - Editor give access to the editor.\n\ -\n\ -\032 File - Shell opens an OCaml shell.\n\ -\n\ -\032 View - Show all defs displays the signature of the currently\n\ -\032 selected module.\n\ -\n\ -\032 View - Search entry shows/hides the search entry just\n\ -\032 below the menu bar.\n\ -\n\ -\032 Modules - Path editor changes the load path.\n\ -\032 Pressing [Add to path] or Insert key adds selected directories\n\ -\032 to the load path.\n\ -\032 Pressing [Remove from path] or Delete key removes selected\n\ -\032 paths from the load path.\n\ -\n\ -\032 Modules - Reset cache rescans the load path and resets the module\n\ -\032 cache. Do it if you recompile some interface, or change the load\n\ -\032 path in a conflictual way.\n\ -\n\ -\032 Modules - Search symbol allows to search a symbol either by its\n\ -\032 name, like the bottom line of the viewer, or, more interestingly,\n\ -\032 by its type. Exact type searches for a type with exactly the same\n\ -\032 information as the pattern (variables match only variables),\n\ -\032 included type allows to give only partial information: the actual\n\ -\032 type may take more arguments and return more results, and variables\n\ -\032 in the pattern match anything. In both cases, argument and tuple\n\ -\032 order is irrelevant (*), and unlabeled arguments in the pattern\n\ -\032 match any label.\n\ -\n\ -\032 (*) To avoid combinatorial explosion of the search space, optional\n\ -\032 arguments in the actual type are ignored if (1) there are to many\n\ -\032 of them, and (2) they do not appear explicitly in the pattern.\n\ -\n\ -\032 The Search entry just below the menu bar allows one to search for\n\ -\032 an identifier in all modules, either by its name (? and * patterns\n\ -\032 allowed) or by its type (if there is an arrow in the input). When\n\ -\032 search by type is used, it is done in inclusion mode (cf. Modules -\n\ -\032 search symbol)\n\ -\n\ -\032 The Close all button is there to dismiss the windows created\n\ -\032 by the Detach button. By double-clicking on it you will quit the\n\ -\032 browser.\n\ -\n\ -\n\ -2) Module browsing\n\ -\n\ -\032 You select a module in the leftmost box by either cliking on it or\n\ -\032 pressing return when it is selected. Fast access is available in\n\ -\032 all boxes pressing the first few letter of the desired name.\n\ -\032 Double-clicking / double-return displays the whole signature for\n\ -\032 the module.\n\ -\n\ -\032 Defined identifiers inside the module are displayed in a box to the\n\ -\032 right of the previous one. If you click on one, this will either\n\ -\032 display its contents in another box (if this is a sub-module) or\n\ -\032 display the signature for this identifier below.\n\ -\n\ -\032 Signatures are clickable. Double clicking with the left mouse\n\ -\032 button on an identifier in a signature brings you to its signature,\n\ -\032 inside its module box.\n\ -\032 A single click on the right button pops up a menu displaying the\n\ -\032 type declaration for the selected identifier. Its title, when\n\ -\032 selectable, also brings you to its signature.\n\ -\n\ -\032 At the bottom, a series of buttons, depending on the context.\n\ -\032 * Detach copies the currently displayed signature in a new window,\n\ -\032 to keep it.\n\ -\032 * Impl and Intf bring you to the implementation or interface of\n\ -\032 the currently displayed signature, if it is available.\n\ -\n\ -\032 C-s opens a text search dialog for the displayed signature.\n\ -\n\ -3) File editor\n\ -\n\ -\032 You can edit files with it, but there is no auto-save nor undo at\n\ -\032 the moment. Otherwise you can use it as a browser, making\n\ -\032 occasional corrections.\n\ -\n\ -\032 The Edit menu contains commands for jump (C-g), search (C-s), and\n\ -\032 sending the current selection to a sub-shell (M-x). For this last\n\ -\032 option, you may choose the shell via a dialog.\n\ -\n\ -\032 Essential function are in the Compiler menu.\n\ -\n\ -\032 Preferences opens a dialog to set internals of the editor and\n\ -\032 type checker.\n\ -\n\ -\032 Lex (M-l) adds colors according to lexical categories.\n\ -\n\ -\032 Typecheck (M-t) verifies typing, and memorizes it to let one see an\n\ -\032 expression's type by double-clicking on it. This is also valid for\n\ -\032 interfaces. If an error occurs, the part of the interface preceding\n\ -\032 the error is computed.\n\ -\n\ -\032 After typechecking, pressing the right button pops up a menu giving\n\ -\032 the type of the pointed expression, and eventually allowing to\n\ -\032 follow some links.\n\ -\n\ -\032 Clear errors dismisses type checker error messages and warnings.\n\ -\n\ -\032 Signature shows the signature of the current file.\n\ -\n\ -4) Shell\n\ -\n\ -\032 When you create a shell, a dialog is presented to you, letting you\n\ -\032 choose which command you want to run, and the title of the shell\n\ -\032 (to choose it in the Editor).\n\ -\n\ -\032 You may change the default command by setting the OLABL environment\n\ -\032 variable.\n\ -\n\ -\032 The executed subshell is given the current load path.\n\ -\032 File: use a source file or load a bytecode file.\n\ -\032 You may also import the browser's path into the subprocess.\n\ -\032 History: M-p and M-n browse up and down.\n\ -\032 Signal: C-c interrupts and you can kill the subprocess.\n\ -\n\ -BUGS\n\ -\n\ -* When you quit the editor and some file was modified, a dialogue is\n\ -\032 displayed asking wether you want to really quit or not. But 1) if\n\ -\032 you quit directly from the viewer, there is no dialogue at all, and\n\ -\032 2) if you close from the window manager, the dialogue is displayed,\n\ -\032 but you cannot cancel the destruction... Beware.\n\ -\n\ -* When you run it through xon, the shell hangs at the first error. But\n\ -\032 its ok if you start ocamlbrowser from a remote shell...\n\ -\n\ -TODO\n\ -\n\ -* Complete cross-references.\n\ -\n\ -* Power up editor.\n\ -\n\ -* Add support for the debugger.\n\ -\n\ -* Make this a real programming environment, both for beginners an\n\ -\032 experimented users.\n\ -\n\ -\n\ -Bug reports and comments to <garrigue@kurims.kyoto-u.ac.jp>\n\ -";; diff --git a/otherlibs/labltk/browser/help.txt b/otherlibs/labltk/browser/help.txt deleted file mode 100644 index 62bfc59211..0000000000 --- a/otherlibs/labltk/browser/help.txt +++ /dev/null @@ -1,166 +0,0 @@ - OCamlBrowser Help - -USE - - OCamlBrowser is composed of three tools, the Editor, which allows - one to edit/typecheck/analyse .mli and .ml files, the Viewer, to - walk around compiled modules, and the Shell, to run an OCaml - subshell. You may only have one instance of Editor and Viewer, but - you may use several subshells. - - As with the compiler, you may specify a different path for the - standard library by setting OCAMLLIB. You may also extend the - initial load path (only standard library by default) by using the - -I command line option. The -nolabels, -rectypes and -w options are - also accepted, and inherited by subshells. - The -oldui options selects the old multi-window interface. The - default is now more like Smalltalk's class browser. - -1) Viewer - - This is the first window you get when you start OCamlBrowser. It - displays a search window, and the list of modules in the load path. - At the top a row of menus. - - File - Open and File - Editor give access to the editor. - - File - Shell opens an OCaml shell. - - View - Show all defs displays the signature of the currently - selected module. - - View - Search entry shows/hides the search entry just - below the menu bar. - - Modules - Path editor changes the load path. - Pressing [Add to path] or Insert key adds selected directories - to the load path. - Pressing [Remove from path] or Delete key removes selected - paths from the load path. - - Modules - Reset cache rescans the load path and resets the module - cache. Do it if you recompile some interface, or change the load - path in a conflictual way. - - Modules - Search symbol allows to search a symbol either by its - name, like the bottom line of the viewer, or, more interestingly, - by its type. Exact type searches for a type with exactly the same - information as the pattern (variables match only variables), - included type allows to give only partial information: the actual - type may take more arguments and return more results, and variables - in the pattern match anything. In both cases, argument and tuple - order is irrelevant (*), and unlabeled arguments in the pattern - match any label. - - (*) To avoid combinatorial explosion of the search space, optional - arguments in the actual type are ignored if (1) there are to many - of them, and (2) they do not appear explicitly in the pattern. - - The Search entry just below the menu bar allows one to search for - an identifier in all modules, either by its name (? and * patterns - allowed) or by its type (if there is an arrow in the input). When - search by type is used, it is done in inclusion mode (cf. Modules - - search symbol) - - The Close all button is there to dismiss the windows created - by the Detach button. By double-clicking on it you will quit the - browser. - - -2) Module browsing - - You select a module in the leftmost box by either cliking on it or - pressing return when it is selected. Fast access is available in - all boxes pressing the first few letter of the desired name. - Double-clicking / double-return displays the whole signature for - the module. - - Defined identifiers inside the module are displayed in a box to the - right of the previous one. If you click on one, this will either - display its contents in another box (if this is a sub-module) or - display the signature for this identifier below. - - Signatures are clickable. Double clicking with the left mouse - button on an identifier in a signature brings you to its signature, - inside its module box. - A single click on the right button pops up a menu displaying the - type declaration for the selected identifier. Its title, when - selectable, also brings you to its signature. - - At the bottom, a series of buttons, depending on the context. - * Detach copies the currently displayed signature in a new window, - to keep it. - * Impl and Intf bring you to the implementation or interface of - the currently displayed signature, if it is available. - - C-s opens a text search dialog for the displayed signature. - -3) File editor - - You can edit files with it, but there is no auto-save nor undo at - the moment. Otherwise you can use it as a browser, making - occasional corrections. - - The Edit menu contains commands for jump (C-g), search (C-s), and - sending the current selection to a sub-shell (M-x). For this last - option, you may choose the shell via a dialog. - - Essential function are in the Compiler menu. - - Preferences opens a dialog to set internals of the editor and - type checker. - - Lex (M-l) adds colors according to lexical categories. - - Typecheck (M-t) verifies typing, and memorizes it to let one see an - expression's type by double-clicking on it. This is also valid for - interfaces. If an error occurs, the part of the interface preceding - the error is computed. - - After typechecking, pressing the right button pops up a menu giving - the type of the pointed expression, and eventually allowing to - follow some links. - - Clear errors dismisses type checker error messages and warnings. - - Signature shows the signature of the current file. - -4) Shell - - When you create a shell, a dialog is presented to you, letting you - choose which command you want to run, and the title of the shell - (to choose it in the Editor). - - You may change the default command by setting the OLABL environment - variable. - - The executed subshell is given the current load path. - File: use a source file or load a bytecode file. - You may also import the browser's path into the subprocess. - History: M-p and M-n browse up and down. - Signal: C-c interrupts and you can kill the subprocess. - -BUGS - -* When you quit the editor and some file was modified, a dialogue is - displayed asking wether you want to really quit or not. But 1) if - you quit directly from the viewer, there is no dialogue at all, and - 2) if you close from the window manager, the dialogue is displayed, - but you cannot cancel the destruction... Beware. - -* When you run it through xon, the shell hangs at the first error. But - its ok if you start ocamlbrowser from a remote shell... - -TODO - -* Complete cross-references. - -* Power up editor. - -* Add support for the debugger. - -* Make this a real programming environment, both for beginners an - experimented users. - - -Bug reports and comments to <garrigue@kurims.kyoto-u.ac.jp> diff --git a/otherlibs/labltk/browser/jg_bind.ml b/otherlibs/labltk/browser/jg_bind.ml deleted file mode 100644 index 128a88ae55..0000000000 --- a/otherlibs/labltk/browser/jg_bind.ml +++ /dev/null @@ -1,28 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -let enter_focus w = - bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w) - -let escape_destroy ?destroy:tl w = - let tl = match tl with Some w -> w | None -> w in - bind w ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> destroy tl) - -let return_invoke w ~button = - bind w ~events:[`KeyPressDetail "Return"] - ~action:(fun _ -> Button.invoke button) diff --git a/otherlibs/labltk/browser/jg_bind.mli b/otherlibs/labltk/browser/jg_bind.mli deleted file mode 100644 index e09c2ba460..0000000000 --- a/otherlibs/labltk/browser/jg_bind.mli +++ /dev/null @@ -1,21 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val enter_focus : 'a widget -> unit -val escape_destroy : ?destroy:'a widget -> 'a widget ->unit -val return_invoke : 'a widget -> button:button widget -> unit diff --git a/otherlibs/labltk/browser/jg_box.ml b/otherlibs/labltk/browser/jg_box.ml deleted file mode 100644 index ac0cb82121..0000000000 --- a/otherlibs/labltk/browser/jg_box.ml +++ /dev/null @@ -1,82 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -let add_scrollbar lb = - let sb = - Scrollbar.create (Winfo.parent lb) ~command:(Listbox.yview lb) in - Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb); sb - -let create_with_scrollbar ?selectmode parent = - let frame = Frame.create parent in - let lb = Listbox.create frame ?selectmode in - frame, lb, add_scrollbar lb - -(* from frx_listbox,adapted *) - -let recenter lb ~index = - Listbox.selection_clear lb ~first:(`Num 0) ~last:`End; - (* Activate it, to keep consistent with Up/Down. - You have to be in Extended or Browse mode *) - Listbox.activate lb ~index; - Listbox.selection_anchor lb ~index; - Listbox.yview_index lb ~index - -class timed ?wait ?nocase get_texts = object - val get_texts = get_texts - inherit Jg_completion.timed [] ?wait ?nocase as super - method reset = - texts <- get_texts (); - super#reset -end - -let add_completion ?action ?wait ?nocase ?(double=true) lb = - let comp = - new timed ?wait ?nocase - (fun () -> Listbox.get_range lb ~first:(`Num 0) ~last:`End) in - - Jg_bind.enter_focus lb; - - bind lb ~events:[`KeyPress] ~fields:[`Char] ~action: - begin fun ev -> - (* consider only keys producing characters. The callback is called - even if you press Shift. *) - if ev.ev_Char <> "" then - recenter lb ~index:(`Num (comp#add ev.ev_Char)) - end; - - begin match action with - Some action -> - bind lb ~events:[`KeyPressDetail "Return"] - ~action:(fun _ -> action `Active); - let bmod = if double then [`Double] else [] in - bind lb ~events:[`Modified(bmod, `ButtonPressDetail 1)] - ~breakable:true ~fields:[`MouseY] - ~action: - begin fun ev -> - let index = Listbox.nearest lb ~y:ev.ev_MouseY in - if not double then begin - Listbox.selection_clear lb ~first:(`Num 0) ~last:`End; - Listbox.selection_set lb ~first:index ~last:index; - end; - action index; - break () - end - | None -> () - end; - - recenter lb ~index:(`Num 0) (* so that first item is active *) diff --git a/otherlibs/labltk/browser/jg_button.ml b/otherlibs/labltk/browser/jg_button.ml deleted file mode 100644 index 11abd68aba..0000000000 --- a/otherlibs/labltk/browser/jg_button.ml +++ /dev/null @@ -1,25 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -let create_destroyer ~parent ?(text="Ok") tl = - Button.create parent ~text ~command:(fun () -> destroy tl) - -let add_destroyer ?text tl = - let b = create_destroyer tl ~parent:tl ?text in - pack [b] ~side:`Bottom ~fill:`X; - b diff --git a/otherlibs/labltk/browser/jg_completion.ml b/otherlibs/labltk/browser/jg_completion.ml deleted file mode 100644 index feb03c42f2..0000000000 --- a/otherlibs/labltk/browser/jg_completion.ml +++ /dev/null @@ -1,53 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -let lt_string ?(nocase=false) s1 s2 = - if nocase then String.lowercase s1 < String.lowercase s2 else s1 < s2 - -class completion ?nocase texts = object - val mutable texts = texts - val nocase = nocase - val mutable prefix = "" - val mutable current = 0 - method add c = - prefix <- prefix ^ c; - while current < List.length texts - 1 && - lt_string (List.nth texts current) prefix ?nocase - do - current <- current + 1 - done; - current - method current = current - method get_current = List.nth texts current - method reset = - prefix <- ""; - current <- 0 -end - -class timed ?nocase ?wait texts = object (self) - inherit completion texts ?nocase as super - val wait = match wait with None -> 500 | Some n -> n - val mutable timer = None - method add c = - begin match timer with - None -> self#reset - | Some t -> Timer.remove t - end; - timer <- Some (Timer.add ~ms:wait ~callback:(fun () -> self#reset)); - super#add c - method reset = - timer <- None; super#reset -end diff --git a/otherlibs/labltk/browser/jg_completion.mli b/otherlibs/labltk/browser/jg_completion.mli deleted file mode 100644 index 69c7a134c2..0000000000 --- a/otherlibs/labltk/browser/jg_completion.mli +++ /dev/null @@ -1,25 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -val lt_string : ?nocase:bool -> string -> string -> bool - -class timed : ?nocase:bool -> ?wait:int -> string list -> object - val mutable texts : string list - method add : string -> int - method current : int - method get_current : string - method reset : unit -end diff --git a/otherlibs/labltk/browser/jg_config.ml b/otherlibs/labltk/browser/jg_config.ml deleted file mode 100644 index bce0e50e76..0000000000 --- a/otherlibs/labltk/browser/jg_config.ml +++ /dev/null @@ -1,40 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Jg_tk - -let fixed = if wingui then "{Courier New} 8" else "fixed" -let variable = if wingui then "Arial 9" else "variable" - -let init () = - if wingui then Option.add ~path:"*font" fixed; - let font = - let font = - Option.get Widget.default_toplevel ~name:"variableFont" ~clas:"Font" in - if font = "" then variable else font - in - List.iter ["Button"; "Label"; "Menu"; "Menubutton"; "Radiobutton"] - ~f:(fun cl -> Option.add ~path:("*" ^ cl ^ ".font") font); - Option.add ~path:"*Menu.tearOff" "0" ~priority:`StartupFile; - Option.add ~path:"*Button.padY" "0" ~priority:`StartupFile; - Option.add ~path:"*Text.highlightThickness" "0" ~priority:`StartupFile; - Option.add ~path:"*interface.background" "gray85" ~priority:`StartupFile; - let foreground = - Option.get Widget.default_toplevel - ~name:"disabledForeground" ~clas:"Foreground" in - if foreground = "" then - Option.add ~path:"*disabledForeground" "black" diff --git a/otherlibs/labltk/browser/jg_config.mli b/otherlibs/labltk/browser/jg_config.mli deleted file mode 100644 index 511e2b3a67..0000000000 --- a/otherlibs/labltk/browser/jg_config.mli +++ /dev/null @@ -1,17 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -val init: unit -> unit diff --git a/otherlibs/labltk/browser/jg_entry.ml b/otherlibs/labltk/browser/jg_entry.ml deleted file mode 100644 index c09a273e82..0000000000 --- a/otherlibs/labltk/browser/jg_entry.ml +++ /dev/null @@ -1,27 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -let create ?command ?width ?textvariable parent = - let ew = Entry.create parent ?width ?textvariable in - Jg_bind.enter_focus ew; - begin match command with Some command -> - bind ew ~events:[`KeyPressDetail "Return"] - ~action:(fun _ -> command (Entry.get ew)) - | None -> () - end; - ew diff --git a/otherlibs/labltk/browser/jg_memo.ml b/otherlibs/labltk/browser/jg_memo.ml deleted file mode 100644 index c6d7634ac6..0000000000 --- a/otherlibs/labltk/browser/jg_memo.ml +++ /dev/null @@ -1,35 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -type ('a, 'b) assoc_list = - Nil - | Cons of 'a * 'b * ('a, 'b) assoc_list - -let rec assq key = function - Nil -> raise Not_found - | Cons (a, b, l) -> - if key == a then b else assq key l - -let fast ~f = - let memo = ref Nil in - fun key -> - try assq key !memo - with Not_found -> - let data = f key in - memo := Cons(key, data, !memo); - data - - diff --git a/otherlibs/labltk/browser/jg_memo.mli b/otherlibs/labltk/browser/jg_memo.mli deleted file mode 100644 index 5491dee32f..0000000000 --- a/otherlibs/labltk/browser/jg_memo.mli +++ /dev/null @@ -1,19 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -val fast : f:('a -> 'b) -> 'a -> 'b -(* "fast" memoizer: uses a List.assq like function *) -(* Good for a smallish number of keys, phisically equal *) diff --git a/otherlibs/labltk/browser/jg_menu.ml b/otherlibs/labltk/browser/jg_menu.ml deleted file mode 100644 index 62712f36db..0000000000 --- a/otherlibs/labltk/browser/jg_menu.ml +++ /dev/null @@ -1,42 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -class c ~parent ?underline:(n=0) text = object (self) - val pair = - let button = - Menubutton.create parent ~text ~underline:n in - let menu = Menu.create button in - Menubutton.configure button ~menu; - button, menu - method button = fst pair - method menu = snd pair - method virtual add_command : - ?underline:int -> - ?accelerator:string -> ?activebackground:color -> - ?activeforeground:color -> ?background:color -> - ?bitmap:bitmap -> ?command:(unit -> unit) -> - ?font:string -> ?foreground:color -> - ?image:image -> ?state:state -> - string -> unit - method add_command ?underline:(n=0) ?accelerator ?activebackground - ?activeforeground ?background ?bitmap ?command ?font ?foreground - ?image ?state label = - Menu.add_command (self#menu) ~label ~underline:n ?accelerator - ?activebackground ?activeforeground ?background ?bitmap - ?command ?font ?foreground ?image ?state -end diff --git a/otherlibs/labltk/browser/jg_message.ml b/otherlibs/labltk/browser/jg_message.ml deleted file mode 100644 index 811c52b15b..0000000000 --- a/otherlibs/labltk/browser/jg_message.ml +++ /dev/null @@ -1,111 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk -open Jg_tk - -(* -class formatted ~parent ~width ~maxheight ~minheight = - val parent = (parent : Widget.any Widget.widget) - val width = width - val maxheight = maxheight - val minheight = minheight - val tw = Text.create ~parent ~width ~wrap:`Word - val fof = Format.get_formatter_output_functions () - method parent = parent - method init = - pack [tw] ~side:`Left ~fill:`Both ~expand:true; - Format.print_flush (); - Format.set_margin (width - 2); - Format.set_formatter_output_functions ~out:(Jg_text.output tw) - ~flush:(fun () -> ()) - method finish = - Format.print_flush (); - Format.set_formatter_output_functions ~out:(fst fof) ~flush:(snd fof); - let `Linechar (l, _) = Text.index tw ~index:(tposend 1) in - Text.configure tw ~height:(max minheight (min l maxheight)); - if l > 5 then - pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y -end -*) - -let formatted ~title ?on ?(ppf = Format.std_formatter) - ?(width=60) ?(maxheight=10) ?(minheight=0) () = - let tl, frame = - match on with - Some frame -> -(* let label = Label.create frame ~anchor:`W ~padx:10 ~text:title in - pack [label] ~side:`Top ~fill:`X; - let frame2 = Frame.create frame in - pack [frame2] ~side:`Bottom ~fill:`Both ~expand:true; *) - coe frame, frame - | None -> - let tl = Jg_toplevel.titled title in - Jg_bind.escape_destroy tl; - let frame = Frame.create tl in - pack [frame] ~side:`Top ~fill:`Both ~expand:true; - coe tl, frame - in - let tw = Text.create frame ~width ~wrap:`Word in - pack [tw] ~side:`Left ~fill:`Both ~expand:true; - Format.pp_print_flush ppf (); - 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 - (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 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 - pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y - end - -let ask ~title ?master ?(no=true) ?(cancel=true) text = - let tl = Jg_toplevel.titled title in - begin match master with None -> () - | Some master -> Wm.transient_set tl ~master - end; - let mw = Message.create tl ~text ~padx:20 ~pady:10 - ~width:250 ~justify:`Left ~aspect:400 ~anchor:`W - and fw = Frame.create tl - and sync = Textvariable.create ~on:tl () - and r = ref (`Cancel : [`Yes|`No|`Cancel]) in - let accept = Button.create fw - ~text:(if no || cancel then "Yes" else "Dismiss") - ~command:(fun () -> r := `Yes; destroy tl) - and refuse = Button.create fw ~text:"No" - ~command:(fun () -> r := `No; destroy tl) - and cancelB = Button.create fw ~text:"Cancel" - ~command:(fun () -> r := `Cancel; destroy tl) - in - bind tl ~events:[`Destroy] ~extend:true - ~action:(fun _ -> Textvariable.set sync "1"); - pack [accept] ~side:`Left ~fill:`X ~expand:true; - if no then pack [refuse] ~side:`Left ~fill:`X ~expand:true; - if cancel then pack [cancelB] ~side:`Left ~fill:`X ~expand:true; - pack [mw] ~side:`Top ~fill:`Both; - pack [fw] ~side:`Bottom ~fill:`X ~expand:true; - Grab.set tl; - Tkwait.variable sync; - !r - -let info ~title ?master text = - ignore (ask ~title ?master ~no:false ~cancel:false text) diff --git a/otherlibs/labltk/browser/jg_message.mli b/otherlibs/labltk/browser/jg_message.mli deleted file mode 100644 index 0a83a594ff..0000000000 --- a/otherlibs/labltk/browser/jg_message.mli +++ /dev/null @@ -1,33 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val formatted : - title:string -> - ?on:frame widget -> - ?ppf:Format.formatter -> - ?width:int -> - ?maxheight:int -> - ?minheight:int -> - unit -> any widget * text widget * (unit -> unit) - -val ask : - title:string -> ?master:toplevel widget -> - ?no:bool -> ?cancel:bool -> string -> [`Cancel|`No|`Yes] - -val info : - title:string -> ?master:toplevel widget -> string -> unit diff --git a/otherlibs/labltk/browser/jg_multibox.ml b/otherlibs/labltk/browser/jg_multibox.ml deleted file mode 100644 index dc905aba6c..0000000000 --- a/otherlibs/labltk/browser/jg_multibox.ml +++ /dev/null @@ -1,185 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels - -let rec gen_list ~f:f ~len = - if len = 0 then [] else f () :: gen_list ~f:f ~len:(len - 1) - -let rec make_list ~len ~fill = - if len = 0 then [] else fill :: make_list ~len:(len - 1) ~fill - -(* By column version -let rec firsts ~len l = - if len = 0 then ([],l) else - match l with - a::l -> - let (f,l) = firsts l len:(len - 1) in - (a::f,l) - | [] -> - (l,[]) - -let rec split ~len = function - [] -> [] - | l -> - let (f,r) = firsts l ~len in - let ret = split ~len r in - f :: ret - -let extend l ~len ~fill = - if List.length l >= len then l - else l @ make_list ~fill len:(len - List.length l) -*) - -(* By row version *) - -let rec first l ~len = - if len = 0 then [], l else - match l with - [] -> make_list ~len ~fill:"", [] - | a::l -> - let (l',r) = first ~len:(len - 1) l in a::l',r - -let rec split l ~len = - if l = [] then make_list ~len ~fill:[] else - let (cars,r) = first l ~len in - let cdrs = split r ~len in - List.map2 cars cdrs ~f:(fun a l -> a::l) - - -open Tk - -class c ~cols ~texts ?maxheight ?width parent = object (self) - val parent' = coe parent - val length = List.length texts - val boxes = - let height = (List.length texts - 1) / cols + 1 in - let height = - match maxheight with None -> height - | Some max -> min max height - in - gen_list ~len:cols ~f: - begin fun () -> - Listbox.create parent ~height ?width - ~highlightthickness:0 - ~borderwidth:1 - end - val mutable current = 0 - method cols = cols - method texts = texts - method parent = parent' - method boxes = boxes - method current = current - method recenter ?(aligntop=false) n = - current <- - if n < 0 then 0 else - if n < length then n else length - 1; - (* Activate it, to keep consistent with Up/Down. - You have to be in Extended or Browse mode *) - let box = List.nth boxes (current mod cols) - and index = `Num (current / cols) in - List.iter boxes ~f: - begin fun box -> - Listbox.selection_clear box ~first:(`Num 0) ~last:`End; - Listbox.selection_anchor box ~index; - Listbox.activate box ~index - end; - Focus.set box; - if aligntop then Listbox.yview_index box ~index - else Listbox.see box ~index; - let (first,last) = Listbox.yview_get box in - List.iter boxes ~f:(Listbox.yview ~scroll:(`Moveto first)) - method init = - let textl = split ~len:cols texts in - List.iter2 boxes textl ~f: - begin fun box texts -> - Jg_bind.enter_focus box; - Listbox.insert box ~texts ~index:`End - end; - pack boxes ~side:`Left ~expand:true ~fill:`Both; - self#bind_mouse ~events:[`ButtonPressDetail 1] - ~action:(fun _ ~index:n -> self#recenter n; break ()); - let current_height () = - let (top,bottom) = Listbox.yview_get (List.hd boxes) in - truncate ((bottom -. top) *. float (Listbox.size (List.hd boxes)) - +. 0.99) - in - List.iter - [ "Right", (fun n -> n+1); - "Left", (fun n -> n-1); - "Up", (fun n -> n-cols); - "Down", (fun n -> n+cols); - "Prior", (fun n -> n - current_height () * cols); - "Next", (fun n -> n + current_height () * cols); - "Home", (fun _ -> 0); - "End", (fun _ -> List.length texts) ] - ~f:begin fun (key,f) -> - self#bind_kbd ~events:[`KeyPressDetail key] - ~action:(fun _ ~index:n -> self#recenter (f n); break ()) - end; - self#recenter 0 - method bind_mouse ~events ~action = - let i = ref 0 in - List.iter boxes ~f: - begin fun box -> - let b = !i in - bind box ~events ~breakable:true ~fields:[`MouseX;`MouseY] - ~action:(fun ev -> - let `Num n = Listbox.nearest box ~y:ev.ev_MouseY - in action ev ~index:(n * cols + b)); - incr i - end - method bind_kbd ~events ~action = - let i = ref 0 in - List.iter boxes ~f: - begin fun box -> - let b = !i in - bind box ~events ~breakable:true ~fields:[`Char] - ~action:(fun ev -> - let `Num n = Listbox.index box ~index:`Active in - action ev ~index:(n * cols + b)); - incr i - end -end - -let add_scrollbar (box : c) = - let boxes = box#boxes in - let sb = - Scrollbar.create (box#parent) - ~command:(fun ~scroll -> List.iter boxes ~f:(Listbox.yview ~scroll)) in - List.iter boxes - ~f:(fun lb -> Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb)); - pack [sb] ~before:(List.hd boxes) ~side:`Right ~fill:`Y; - sb - -let add_completion ?action ?wait (box : c) = - let comp = new Jg_completion.timed (box#texts) ?wait in - box#bind_kbd ~events:[`KeyPress] - ~action:(fun ev ~index -> - (* consider only keys producing characters. The callback is called - * even if you press Shift. *) - if ev.ev_Char <> "" then - box#recenter (comp#add ev.ev_Char) ~aligntop:true); - match action with - Some action -> - box#bind_kbd ~events:[`KeyPressDetail "space"] - ~action:(fun ev ~index -> action (box#current)); - box#bind_kbd ~events:[`KeyPressDetail "Return"] - ~action:(fun ev ~index -> action (box#current)); - box#bind_mouse ~events:[`ButtonPressDetail 1] - ~action:(fun ev ~index -> - box#recenter index; action (box#current); break ()) - | None -> () diff --git a/otherlibs/labltk/browser/jg_multibox.mli b/otherlibs/labltk/browser/jg_multibox.mli deleted file mode 100644 index 6dfe7d8fb3..0000000000 --- a/otherlibs/labltk/browser/jg_multibox.mli +++ /dev/null @@ -1,35 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -class c : - cols:int -> texts:string list -> - ?maxheight:int -> ?width:int -> 'a Widget.widget -> -object - method cols : int - method texts : string list - method parent : Widget.any Widget.widget - method boxes : Widget.listbox Widget.widget list - method current : int - method init : unit - method recenter : ?aligntop:bool -> int -> unit - method bind_mouse : - events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit - method bind_kbd : - events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit -end - -val add_scrollbar : c -> Widget.scrollbar Widget.widget -val add_completion : ?action:(int -> unit) -> ?wait:int -> c -> unit diff --git a/otherlibs/labltk/browser/jg_text.ml b/otherlibs/labltk/browser/jg_text.ml deleted file mode 100644 index 067b9dac55..0000000000 --- a/otherlibs/labltk/browser/jg_text.ml +++ /dev/null @@ -1,104 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk -open Jg_tk - -let get_all tw = Text.get tw ~start:tstart ~stop:(tposend 1) - -let tag_and_see tw ~tag ~start ~stop = - Text.tag_remove tw ~start:(tpos 0) ~stop:tend ~tag; - Text.tag_add tw ~start ~stop ~tag; - try - Text.see tw ~index:(`Tagfirst tag, []); - Text.mark_set tw ~mark:"insert" ~index:(`Tagfirst tag, []) - with Protocol.TkError _ -> () - -let output tw ~buf ~pos ~len = - Text.insert tw ~index:tend ~text:(String.sub buf ~pos ~len) - -let add_scrollbar tw = - let sb = Scrollbar.create (Winfo.parent tw) ~command:(Text.yview tw) - in Text.configure tw ~yscrollcommand:(Scrollbar.set sb); sb - -let create_with_scrollbar parent = - let frame = Frame.create parent in - let tw = Text.create frame in - frame, tw, add_scrollbar tw - -let goto_tag tw ~tag = - let index = (`Tagfirst tag, []) in - try Text.see tw ~index; - Text.mark_set tw ~index ~mark:"insert" - with Protocol.TkError _ -> () - -let search_string tw = - let tl = Jg_toplevel.titled "Search" in - Wm.transient_set tl ~master:(Winfo.toplevel tw); - let fi = Frame.create tl - and fd = Frame.create tl - and fm = Frame.create tl - and buttons = Frame.create tl - and direction = Textvariable.create ~on:tl () - and mode = Textvariable.create ~on:tl () - and count = Textvariable.create ~on:tl () - in - let label = Label.create fi ~text:"Pattern:" - and text = Entry.create fi ~width:20 - and back = Radiobutton.create fd ~variable:direction - ~text:"Backwards" ~value:"backward" - and forw = Radiobutton.create fd ~variable:direction - ~text:"Forwards" ~value:"forward" - and exact = Radiobutton.create fm ~variable:mode - ~text:"Exact" ~value:"exact" - and nocase = Radiobutton.create fm ~variable:mode - ~text:"No case" ~value:"nocase" - and regexp = Radiobutton.create fm ~variable:mode - ~text:"Regexp" ~value:"regexp" - in - let search = Button.create buttons ~text:"Search" ~command: - begin fun () -> - try - let pattern = Entry.get text in - let dir, ofs = match Textvariable.get direction with - "forward" -> `Forwards, 1 - | "backward" -> `Backwards, -1 - | _ -> assert false - and mode = match Textvariable.get mode with "exact" -> [`Exact] - | "nocase" -> [`Nocase] | "regexp" -> [`Regexp] | _ -> [] - in - let ndx = - Text.search tw ~pattern ~switches:([dir;`Count count] @ mode) - ~start:(`Mark "insert", [`Char ofs]) - in - tag_and_see tw ~tag:"sel" ~start:(ndx,[]) - ~stop:(ndx,[`Char(int_of_string (Textvariable.get count))]) - with Invalid_argument _ -> () - end - and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in - - Focus.set text; - Jg_bind.return_invoke text ~button:search; - Jg_bind.escape_destroy tl; - Textvariable.set direction "forward"; - Textvariable.set mode "nocase"; - pack [label] ~side:`Left; - pack [text] ~side:`Right ~fill:`X ~expand:true; - pack [back; forw] ~side:`Left; - pack [exact; nocase; regexp] ~side:`Left; - pack [search; ok] ~side:`Left ~fill:`X ~expand:true; - pack [fi; fd; fm; buttons] ~side:`Top ~fill:`X diff --git a/otherlibs/labltk/browser/jg_text.mli b/otherlibs/labltk/browser/jg_text.mli deleted file mode 100644 index e8646dd9d1..0000000000 --- a/otherlibs/labltk/browser/jg_text.mli +++ /dev/null @@ -1,28 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val get_all : text widget -> string -val tag_and_see : - text widget -> - tag:Tk.textTag -> start:Tk.textIndex -> stop:Tk.textIndex -> unit -val output : text widget -> buf:string -> pos:int -> len:int -> unit -val add_scrollbar : text widget -> scrollbar widget -val create_with_scrollbar : - 'a widget -> frame widget * text widget * scrollbar widget -val goto_tag : text widget -> tag:string -> unit -val search_string : text widget -> unit diff --git a/otherlibs/labltk/browser/jg_tk.ml b/otherlibs/labltk/browser/jg_tk.ml deleted file mode 100644 index 7fc77f096a..0000000000 --- a/otherlibs/labltk/browser/jg_tk.ml +++ /dev/null @@ -1,24 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -let tpos ?(modi=[]) x : textIndex = `Linechar (1,0), `Char x :: modi -and tposend ?(modi=[]) x : textIndex = `End, `Char (-x) :: modi -let tstart : textIndex = `Linechar (1,0), [] -and tend : textIndex = `End, [] - -let wingui = Sys.os_type = "Win32" || Sys.os_type = "Cygwin" diff --git a/otherlibs/labltk/browser/jg_toplevel.ml b/otherlibs/labltk/browser/jg_toplevel.ml deleted file mode 100644 index c6a2b89593..0000000000 --- a/otherlibs/labltk/browser/jg_toplevel.ml +++ /dev/null @@ -1,25 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -let titled ?iconname title = - let iconname = match iconname with None -> title | Some s -> s in - let tl = Toplevel.create Widget.default_toplevel in - Wm.title_set tl title; - Wm.iconname_set tl iconname; - Wm.group_set tl ~leader: Widget.default_toplevel; - tl diff --git a/otherlibs/labltk/browser/lexical.ml b/otherlibs/labltk/browser/lexical.ml deleted file mode 100644 index a2573ef7c2..0000000000 --- a/otherlibs/labltk/browser/lexical.ml +++ /dev/null @@ -1,143 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk -open Jg_tk -open Parser - -let tags = - ["control"; "define"; "structure"; "char"; - "infix"; "label"; "uident"] -and colors = - ["blue"; "forestgreen"; "purple"; "gray40"; - "indianred4"; "saddlebrown"; "midnightblue"] - -let init_tags tw = - List.iter2 tags colors ~f: - begin fun tag col -> - Text.tag_configure tw ~tag ~foreground:(`Color col) - end; - Text.tag_configure tw ~tag:"error" ~foreground:`Red; - Text.tag_configure tw ~tag:"error" ~relief:`Raised; - Text.tag_raise tw ~tag:"error" - -let tag ?(start=tstart) ?(stop=tend) tw = - let tpos c = (Text.index tw ~index:start, [`Char c]) in - let text = Text.get tw ~start ~stop in - let buffer = Lexing.from_string text in - List.iter tags - ~f:(fun tag -> Text.tag_remove tw ~start ~stop ~tag); - let last = ref (EOF, 0, 0) in - try - while true do - let token = Lexer.token buffer - and start = Lexing.lexeme_start buffer - and stop = Lexing.lexeme_end buffer in - let tag = - match token with - AMPERAMPER - | AMPERSAND - | BARBAR - | DO | DONE - | DOWNTO - | ELSE - | FOR - | IF - | LAZY - | MATCH - | OR - | THEN - | TO - | TRY - | WHEN - | WHILE - | WITH - -> "control" - | AND - | AS - | BAR - | CLASS - | CONSTRAINT - | EXCEPTION - | EXTERNAL - | FUN - | FUNCTION - | FUNCTOR - | IN - | INHERIT - | INITIALIZER - | LET - | METHOD - | MODULE - | MUTABLE - | NEW - | OF - | PRIVATE - | REC - | TYPE - | VAL - | VIRTUAL - -> "define" - | BEGIN - | END - | INCLUDE - | OBJECT - | OPEN - | SIG - | STRUCT - -> "structure" - | CHAR _ - | STRING _ - -> "char" - | BACKQUOTE - | INFIXOP1 _ - | INFIXOP2 _ - | INFIXOP3 _ - | INFIXOP4 _ - | PREFIXOP _ - | SHARP - -> "infix" - | LABEL _ - | OPTLABEL _ - | QUESTION - | TILDE - -> "label" - | UIDENT _ -> "uident" - | LIDENT _ -> - begin match !last with - (QUESTION | TILDE), _, _ -> "label" - | _ -> "" - end - | COLON -> - begin match !last with - LIDENT _, lstart, lstop -> - if lstop = start then - Text.tag_add tw ~tag:"label" - ~start:(tpos lstart) ~stop:(tpos stop); - "" - | _ -> "" - end - | EOF -> raise End_of_file - | _ -> "" - in - if tag <> "" then - Text.tag_add tw ~tag ~start:(tpos start) ~stop:(tpos stop); - last := (token, start, stop) - done - with - End_of_file -> () - | Lexer.Error (err, loc) -> () diff --git a/otherlibs/labltk/browser/lexical.mli b/otherlibs/labltk/browser/lexical.mli deleted file mode 100644 index 3be04d3246..0000000000 --- a/otherlibs/labltk/browser/lexical.mli +++ /dev/null @@ -1,20 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val init_tags : text widget -> unit -val tag : ?start:Tk.textIndex -> ?stop:Tk.textIndex -> text widget -> unit diff --git a/otherlibs/labltk/browser/list2.ml b/otherlibs/labltk/browser/list2.ml deleted file mode 100644 index 87b88f496a..0000000000 --- a/otherlibs/labltk/browser/list2.ml +++ /dev/null @@ -1,23 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels - -let exclude x l = List.filter l ~f:((<>) x) - -let rec flat_map ~f = function - [] -> [] - | x :: l -> f x @ flat_map ~f l diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml deleted file mode 100644 index 2ff17a5519..0000000000 --- a/otherlibs/labltk/browser/main.ml +++ /dev/null @@ -1,132 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -module Unix = UnixLabels -open Tk - -let fatal_error text = - let top = openTk ~clas:"OCamlBrowser" () in - let mw = Message.create top ~text ~padx:20 ~pady:10 - ~width:400 ~justify:`Left ~aspect:400 ~anchor:`W - and b = Button.create top ~text:"OK" ~command:(fun () -> destroy top) in - pack [mw] ~side:`Top ~fill:`Both; - pack [b] ~side:`Bottom; - mainLoop (); - exit 0 - -let rec get_incr key = function - [] -> raise Not_found - | (k, c, d) :: rem -> - if k = key then - match c with Arg.Set _ | Arg.Clear _ -> false | _ -> true - else get_incr key rem - -let check ~spec argv = - let i = ref 1 in - while !i < Array.length argv do - try - let a = get_incr argv.(!i) spec in - incr i; if a then incr i - with Not_found -> - i := Array.length argv + 1 - done; - !i = Array.length argv - -open Printf - -let usage ~spec errmsg = - let b = Buffer.create 1024 in - bprintf b "%s\n" errmsg; - List.iter (function (key, _, doc) -> bprintf b " %s %s\n" key doc) spec; - Buffer.contents b - -let _ = - let is_win32 = Sys.os_type = "Win32" in - if is_win32 then - Format.pp_set_formatter_output_functions Format.err_formatter - (fun _ _ _ -> ()) (fun _ -> ()); - - let path = ref [] in - let st = ref true in - let spec = - [ "-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"; - "-pp", Arg.String (fun s -> Clflags.preprocessor := Some s), - "<command> Pipe sources through preprocessor <command>"; - "-rectypes", Arg.Set Clflags.recursive_types, - " Allow arbitrary recursive types"; - "-oldui", Arg.Clear st, " Revert back to old UI"; - "-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 D/d enable/disable deprecated features\n\ - \032 E/e enable/disable fragile match\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 \"Ale\"\n\ - \032 (all warnings but labels and fragile match enabled)"; ] - and errmsg = "Command line: ocamlbrowser <options>" in - if not (check ~spec Sys.argv) then fatal_error (usage ~spec errmsg); - Arg.parse spec - (fun name -> raise(Arg.Bad("don't know what to do with " ^ name))) - errmsg; - Config.load_path := - Sys.getcwd () - :: List.rev_map ~f:(Misc.expand_directory Config.standard_library) !path - @ [Config.standard_library]; - Warnings.parse_options false !Shell.warnings; - Unix.putenv "TERM" "noterminal"; - begin - try Searchid.start_env := Env.open_pers_signature "Pervasives" Env.initial - with _ -> - fatal_error - (Printf.sprintf "%s\nPlease check that %s %s\nCurrent value is `%s'" - "Couldn't initialize environment." - (if is_win32 then "%OCAMLLIB%" else "$OCAMLLIB") - "points to the Objective Caml library." - Config.standard_library) - end; - - Searchpos.view_defined_ref := (fun s ~env -> Viewer.view_defined s ~env); - Searchpos.editor_ref := Editor.f; - - let top = openTk ~clas:"OCamlBrowser" () in - Jg_config.init (); - - (* bind top ~events:[`Destroy] ~action:(fun _ -> exit 0); *) - at_exit Shell.kill_all; - - - if !st then Viewer.st_viewer ~on:top () - else Viewer.f ~on:top (); - - while true do - try - if is_win32 then mainLoop () - else Printexc.print mainLoop () - with Protocol.TkError _ -> () - done diff --git a/otherlibs/labltk/browser/mytypes.mli b/otherlibs/labltk/browser/mytypes.mli deleted file mode 100644 index 6703ff1019..0000000000 --- a/otherlibs/labltk/browser/mytypes.mli +++ /dev/null @@ -1,29 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -type edit_window = - { mutable name: string; - tw: text widget; - frame: frame widget; - modified: Textvariable.textVariable; - mutable shell: (string * Shell.shell) option; - mutable structure: Typedtree.structure; - mutable type_info: Stypes.type_info list; - mutable signature: Types.signature; - mutable psignature: Parsetree.signature; - number: string } diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml deleted file mode 100644 index c285dbbced..0000000000 --- a/otherlibs/labltk/browser/searchid.ml +++ /dev/null @@ -1,532 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Location -open Longident -open Path -open Types -open Typedtree -open Env -open Btype -open Ctype - -(* only initial here, but replaced by Pervasives later *) -let start_env = ref initial -let module_list = ref [] - -type pkind = - Pvalue - | Ptype - | Plabel - | Pconstructor - | Pmodule - | Pmodtype - | Pclass - | Pcltype - -let string_of_kind = function - Pvalue -> "v" - | Ptype -> "t" - | Plabel -> "l" - | Pconstructor -> "cn" - | Pmodule -> "m" - | Pmodtype -> "s" - | Pclass -> "c" - | Pcltype -> "ct" - -let rec longident_of_path = function - Pident id -> Lident (Ident.name id) - | Pdot (path, s, _) -> Ldot (longident_of_path path, s) - | Papply (p1, p2) -> Lapply (longident_of_path p1, longident_of_path p2) - -let rec remove_prefix lid ~prefix = - let rec remove_hd lid ~name = - match lid with - Ldot (Lident s1, s2) when s1 = name -> Lident s2 - | Ldot (l, s) -> Ldot (remove_hd ~name l, s) - | _ -> raise Not_found - in - match prefix with - [] -> lid - | name :: prefix -> - try remove_prefix ~prefix (remove_hd ~name lid) - with Not_found -> lid - -let rec permutations l = match l with - [] | [_] -> [l] - | [a;b] -> [l; [b;a]] - | _ -> - let _, perms = - List.fold_left l ~init:(l,[]) ~f: - begin fun (l, perms) a -> - let l = List.tl l in - l @ [a], - List.map (permutations l) ~f:(fun l -> a :: l) @ perms - end - in perms - -let rec choose n ~card:l = - let len = List.length l in - if n = len then [l] else - if n = 1 then List.map l ~f:(fun x -> [x]) else - if n = 0 then [[]] else - if n > len then [] else - match l with [] -> [] - | a :: l -> - List.map (choose (n-1) ~card:l) ~f:(fun l -> a :: l) - @ choose n ~card:l - -let rec arr p ~card:n = - if p = 0 then 1 else n * arr (p-1) ~card:(n-1) - -let rec all_args ty = - let ty = repr ty in - match ty.desc with - Tarrow(l, ty1, ty2, _) -> let (tl,ty) = all_args ty2 in ((l,ty1)::tl, ty) - | _ -> ([], ty) - -let rec equal ~prefix t1 t2 = - match (repr t1).desc, (repr t2).desc with - Tvar, Tvar -> true - | Tvariant row1, Tvariant row2 -> - let row1 = row_repr row1 and row2 = row_repr row2 in - let fields1 = filter_row_fields false row1.row_fields - and fields2 = filter_row_fields false row1.row_fields - in - let r1, r2, pairs = merge_row_fields fields1 fields2 in - row1.row_closed = row2.row_closed && r1 = [] && r2 = [] && - List.for_all pairs ~f: - begin fun (_,f1,f2) -> - match row_field_repr f1, row_field_repr f2 with - Rpresent None, Rpresent None -> true - | Rpresent(Some t1), Rpresent (Some t2) -> equal t1 t2 ~prefix - | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) -> - c1 = c2 && List.length tl1 = List.length tl2 && - List.for_all2 tl1 tl2 ~f:(equal ~prefix) - | _ -> false - end - | Tarrow _, Tarrow _ -> - let l1, t1 = all_args t1 and l2, t2 = all_args t2 in - equal t1 t2 ~prefix && - List.length l1 = List.length l2 && - List.exists (permutations l1) ~f: - begin fun l1 -> - List.for_all2 l1 l2 ~f: - begin fun (p1,t1) (p2,t2) -> - (p1 = "" || p1 = p2) && equal t1 t2 ~prefix - end - end - | Ttuple l1, Ttuple l2 -> - List.length l1 = List.length l2 && - List.for_all2 l1 l2 ~f:(equal ~prefix) - | Tconstr (p1, l1, _), Tconstr (p2, l2, _) -> - remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2) - && List.length l1 = List.length l2 - && List.for_all2 l1 l2 ~f:(equal ~prefix) - | _ -> false - -let is_opt s = s <> "" && s.[0] = '?' -let get_options = List.filter ~f:is_opt - -let rec included ~prefix t1 t2 = - match (repr t1).desc, (repr t2).desc with - Tvar, _ -> true - | Tvariant row1, Tvariant row2 -> - let row1 = row_repr row1 and row2 = row_repr row2 in - let fields1 = filter_row_fields false row1.row_fields - and fields2 = filter_row_fields false row1.row_fields - in - let r1, r2, pairs = merge_row_fields fields1 fields2 in - r1 = [] && - List.for_all pairs ~f: - begin fun (_,f1,f2) -> - match row_field_repr f1, row_field_repr f2 with - Rpresent None, Rpresent None -> true - | Rpresent(Some t1), Rpresent (Some t2) -> included t1 t2 ~prefix - | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) -> - c1 = c2 && List.length tl1 = List.length tl2 && - List.for_all2 tl1 tl2 ~f:(included ~prefix) - | _ -> false - end - | Tarrow _, Tarrow _ -> - let l1, t1 = all_args t1 and l2, t2 = all_args t2 in - included t1 t2 ~prefix && - let len1 = List.length l1 and len2 = List.length l2 in - let l2 = if arr len1 ~card:len2 < 100 then l2 else - let ll1 = get_options (fst (List.split l1)) in - List.filter l2 - ~f:(fun (l,_) -> not (is_opt l) || List.mem l ll1) - in - len1 <= len2 && - List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f: - begin fun l2 -> - List.for_all2 l1 l2 ~f: - begin fun (p1,t1) (p2,t2) -> - (p1 = "" || p1 = p2) && included t1 t2 ~prefix - end - end - | Ttuple l1, Ttuple l2 -> - let len1 = List.length l1 in - len1 <= List.length l2 && - List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f: - begin fun l2 -> - List.for_all2 l1 l2 ~f:(included ~prefix) - end - | _, Ttuple _ -> included (newty (Ttuple [t1])) t2 ~prefix - | Tconstr (p1, l1, _), Tconstr (p2, l2, _) -> - remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2) - && List.length l1 = List.length l2 - && List.for_all2 l1 l2 ~f:(included ~prefix) - | _ -> false - -let mklid = function - [] -> raise (Invalid_argument "Searchid.mklid") - | x :: l -> - List.fold_left l ~init:(Lident x) ~f:(fun acc x -> Ldot (acc, x)) - -let mkpath = function - [] -> raise (Invalid_argument "Searchid.mklid") - | x :: l -> - List.fold_left l ~init:(Pident (Ident.create x)) - ~f:(fun acc x -> Pdot (acc, x, 0)) - -let get_fields ~prefix ~sign self = - let env = open_signature (mkpath prefix) sign initial in - match (expand_head env self).desc with - Tobject (ty_obj, _) -> - let l,_ = flatten_fields ty_obj in l - | _ -> [] - -let rec search_type_in_signature t ~sign ~prefix ~mode = - let matches = match mode with - `Included -> included t ~prefix - | `Exact -> equal t ~prefix - and lid_of_id id = mklid (prefix @ [Ident.name id]) in - List2.flat_map sign ~f: - begin fun item -> match item with - Tsig_value (id, vd) -> - if matches vd.val_type then [lid_of_id id, Pvalue] else [] - | Tsig_type (id, td) -> - if - begin match td.type_manifest with - None -> false - | Some t -> matches t - end || - begin match td.type_kind with - Type_abstract -> false - | Type_variant(l, priv) -> - List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches) - | Type_record(l, rep, priv) -> - List.exists l ~f:(fun (_, _, t) -> matches t) - end - then [lid_of_id id, Ptype] else [] - | Tsig_exception (id, l) -> - if List.exists l ~f:matches - then [lid_of_id id, Pconstructor] - else [] - | Tsig_module (id, Tmty_signature sign) -> - search_type_in_signature t ~sign ~mode - ~prefix:(prefix @ [Ident.name id]) - | Tsig_module _ -> [] - | Tsig_modtype _ -> [] - | Tsig_class (id, cl) -> - let self = self_type cl.cty_type in - if matches self - || (match cl.cty_new with None -> false | Some ty -> matches ty) - (* || List.exists (get_fields ~prefix ~sign self) - ~f:(fun (_,_,ty_field) -> matches ty_field) *) - then [lid_of_id id, Pclass] else [] - | Tsig_cltype (id, cl) -> - let self = self_type cl.clty_type in - if matches self - (* || List.exists (get_fields ~prefix ~sign self) - ~f:(fun (_,_,ty_field) -> matches ty_field) *) - then [lid_of_id id, Pclass] else [] - end - -let search_all_types t ~mode = - let tl = match mode, t.desc with - `Exact, _ -> [t] - | `Included, Tarrow _ -> [t] - | `Included, _ -> - [t; newty(Tarrow("",t,newvar(),Cok)); newty(Tarrow("",newvar(),t,Cok))] - in List2.flat_map !module_list ~f: - begin fun modname -> - let mlid = Lident modname in - try match lookup_module mlid initial with - _, Tmty_signature sign -> - List2.flat_map tl - ~f:(search_type_in_signature ~sign ~prefix:[modname] ~mode) - | _ -> [] - with Not_found | Env.Error _ -> [] - end - -exception Error of int * int - -let search_string_type text ~mode = - try - let sexp = Parse.interface (Lexing.from_string ("val z : " ^ text)) in - let sign = - try Typemod.transl_signature !start_env sexp with _ -> - let env = List.fold_left !module_list ~init:initial ~f: - begin fun acc m -> - try open_pers_signature m acc with Env.Error _ -> acc - end in - try Typemod.transl_signature env sexp - with Env.Error err -> [] - | Typemod.Error (l,_) -> - let start_c = l.loc_start.Lexing.pos_cnum in - let end_c = l.loc_end.Lexing.pos_cnum in - raise (Error (start_c - 8, end_c - 8)) - | Typetexp.Error (l,_) -> - let start_c = l.loc_start.Lexing.pos_cnum in - let end_c = l.loc_end.Lexing.pos_cnum in - raise (Error (start_c - 8, end_c - 8)) - in match sign with - [Tsig_value (_, vd)] -> - search_all_types vd.val_type ~mode - | _ -> [] - with - Syntaxerr.Error(Syntaxerr.Unclosed(l,_,_,_)) -> - let start_c = l.loc_start.Lexing.pos_cnum in - let end_c = l.loc_end.Lexing.pos_cnum in - raise (Error (start_c - 8, end_c - 8)) - | Syntaxerr.Error(Syntaxerr.Other l) -> - let start_c = l.loc_start.Lexing.pos_cnum in - let end_c = l.loc_end.Lexing.pos_cnum in - raise (Error (start_c - 8, end_c - 8)) - | Lexer.Error (_, l) -> - let start_c = l.loc_start.Lexing.pos_cnum in - let end_c = l.loc_end.Lexing.pos_cnum in - raise (Error (start_c - 8, end_c - 8)) - -let longident_of_string text = - let exploded = ref [] and l = ref 0 in - for i = 0 to String.length text - 2 do - if text.[i] ='.' then - (exploded := String.sub text ~pos:!l ~len:(i - !l) :: !exploded; l := i+1) - done; - let sym = String.sub text ~pos:!l ~len:(String.length text - !l) in - let rec mklid = function - [s] -> Lident s - | s :: l -> Ldot (mklid l, s) - | [] -> assert false in - sym, fun l -> mklid (sym :: !exploded @ l) - - -let explode s = - let l = ref [] in - for i = String.length s - 1 downto 0 do - l := s.[i] :: !l - done; !l - -let rec check_match ~pattern s = - match pattern, s with - [], [] -> true - | '*'::l, l' -> check_match ~pattern:l l' - || check_match ~pattern:('?'::'*'::l) l' - | '?'::l, _::l' -> check_match ~pattern:l l' - | x::l, y::l' when x == y -> check_match ~pattern:l l' - | _ -> false - -let search_pattern_symbol text = - if text = "" then [] else - let pattern = explode text in - let check i = check_match ~pattern (explode (Ident.name i)) in - let l = List.map !module_list ~f: - begin fun modname -> Lident modname, - try match lookup_module (Lident modname) initial with - _, Tmty_signature sign -> - List2.flat_map sign ~f: - begin function - Tsig_value (i, _) when check i -> [i, Pvalue] - | Tsig_type (i, _) when check i -> [i, Ptype] - | Tsig_exception (i, _) when check i -> [i, Pconstructor] - | Tsig_module (i, _) when check i -> [i, Pmodule] - | Tsig_modtype (i, _) when check i -> [i, Pmodtype] - | Tsig_class (i, cl) when check i - || List.exists - (get_fields ~prefix:[modname] ~sign (self_type cl.cty_type)) - ~f:(fun (name,_,_) -> check_match ~pattern (explode name)) - -> [i, Pclass] - | Tsig_cltype (i, cl) when check i - || List.exists - (get_fields ~prefix:[modname] ~sign (self_type cl.clty_type)) - ~f:(fun (name,_,_) -> check_match ~pattern (explode name)) - -> [i, Pcltype] - | _ -> [] - end - | _ -> [] - with Env.Error _ -> [] - end - in - List2.flat_map l ~f: - begin fun (m, l) -> - List.map l ~f:(fun (i, p) -> Ldot (m, Ident.name i), p) - end - -(* -let is_pattern s = - try for i = 0 to String.length s -1 do - if s.[i] = '?' || s.[i] = '*' then raise Exit - done; false - with Exit -> true -*) - -let search_string_symbol text = - if text = "" then [] else - let lid = snd (longident_of_string text) [] in - let try_lookup f k = - try let _ = f lid Env.initial in [lid, k] - with Not_found | Env.Error _ -> [] - in - try_lookup lookup_constructor Pconstructor @ - try_lookup lookup_module Pmodule @ - try_lookup lookup_modtype Pmodtype @ - try_lookup lookup_value Pvalue @ - try_lookup lookup_type Ptype @ - try_lookup lookup_label Plabel @ - try_lookup lookup_class Pclass - -open Parsetree - -let rec bound_variables pat = - match pat.ppat_desc with - Ppat_any | Ppat_constant _ | Ppat_type _ -> [] - | Ppat_var s -> [s] - | Ppat_alias (pat,s) -> s :: bound_variables pat - | Ppat_tuple l -> List2.flat_map l ~f:bound_variables - | Ppat_construct (_,None,_) -> [] - | Ppat_construct (_,Some pat,_) -> bound_variables pat - | Ppat_variant (_,None) -> [] - | Ppat_variant (_,Some pat) -> bound_variables pat - | Ppat_record l -> - List2.flat_map l ~f:(fun (_,pat) -> bound_variables pat) - | Ppat_array l -> - List2.flat_map l ~f:bound_variables - | Ppat_or (pat1,pat2) -> - bound_variables pat1 @ bound_variables pat2 - | Ppat_constraint (pat,_) -> bound_variables pat - -let search_structure str ~name ~kind ~prefix = - let loc = ref 0 in - let rec search_module str ~prefix = - match prefix with [] -> str - | modu::prefix -> - let str = - List.fold_left ~init:[] str ~f: - begin fun acc item -> - match item.pstr_desc with - Pstr_module (s, mexp) when s = modu -> - loc := mexp.pmod_loc.loc_start.Lexing.pos_cnum; - begin match mexp.pmod_desc with - Pmod_structure str -> str - | _ -> [] - end - | _ -> acc - end - in search_module str ~prefix - in - List.iter (search_module str ~prefix) ~f: - begin fun item -> - if match item.pstr_desc with - Pstr_value (_, l) when kind = Pvalue -> - List.iter l ~f: - begin fun (pat,_) -> - if List.mem name (bound_variables pat) - then loc := pat.ppat_loc.loc_start.Lexing.pos_cnum - end; - false - | Pstr_primitive (s, _) when kind = Pvalue -> name = s - | Pstr_type l when kind = Ptype -> - List.iter l ~f: - begin fun (s, td) -> - if s = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum - end; - false - | Pstr_exception (s, _) when kind = Pconstructor -> name = s - | Pstr_module (s, _) when kind = Pmodule -> name = s - | Pstr_modtype (s, _) when kind = Pmodtype -> name = s - | Pstr_class l when kind = Pclass || kind = Ptype || kind = Pcltype -> - List.iter l ~f: - begin fun c -> - if c.pci_name = name - then loc := c.pci_loc.loc_start.Lexing.pos_cnum - end; - false - | Pstr_class_type l when kind = Pcltype || kind = Ptype -> - List.iter l ~f: - begin fun c -> - if c.pci_name = name - then loc := c.pci_loc.loc_start.Lexing.pos_cnum - end; - false - | _ -> false - then loc := item.pstr_loc.loc_start.Lexing.pos_cnum - end; - !loc - -let search_signature sign ~name ~kind ~prefix = - let loc = ref 0 in - let rec search_module_type sign ~prefix = - match prefix with [] -> sign - | modu::prefix -> - let sign = - List.fold_left ~init:[] sign ~f: - begin fun acc item -> - match item.psig_desc with - Psig_module (s, mtyp) when s = modu -> - loc := mtyp.pmty_loc.loc_start.Lexing.pos_cnum; - begin match mtyp.pmty_desc with - Pmty_signature sign -> sign - | _ -> [] - end - | _ -> acc - end - in search_module_type sign ~prefix - in - List.iter (search_module_type sign ~prefix) ~f: - begin fun item -> - if match item.psig_desc with - Psig_value (s, _) when kind = Pvalue -> name = s - | Psig_type l when kind = Ptype -> - List.iter l ~f: - begin fun (s, td) -> - if s = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum - end; - false - | Psig_exception (s, _) when kind = Pconstructor -> name = s - | Psig_module (s, _) when kind = Pmodule -> name = s - | Psig_modtype (s, _) when kind = Pmodtype -> name = s - | Psig_class l when kind = Pclass || kind = Ptype || kind = Pcltype -> - List.iter l ~f: - begin fun c -> - if c.pci_name = name - then loc := c.pci_loc.loc_start.Lexing.pos_cnum - end; - false - | Psig_class_type l when kind = Ptype || kind = Pcltype -> - List.iter l ~f: - begin fun c -> - if c.pci_name = name - then loc := c.pci_loc.loc_start.Lexing.pos_cnum - end; - false - | _ -> false - then loc := item.psig_loc.loc_start.Lexing.pos_cnum - end; - !loc diff --git a/otherlibs/labltk/browser/searchid.mli b/otherlibs/labltk/browser/searchid.mli deleted file mode 100644 index 980c141d08..0000000000 --- a/otherlibs/labltk/browser/searchid.mli +++ /dev/null @@ -1,45 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -val start_env : Env.t ref -val module_list : string list ref -val longident_of_path : Path.t ->Longident.t - -type pkind = - Pvalue - | Ptype - | Plabel - | Pconstructor - | Pmodule - | Pmodtype - | Pclass - | Pcltype - -val string_of_kind : pkind -> string - -exception Error of int * int - -val search_string_type : - string -> mode:[`Exact|`Included] -> (Longident.t * pkind) list -val search_pattern_symbol : string -> (Longident.t * pkind) list -val search_string_symbol : string -> (Longident.t * pkind) list - -val search_structure : - Parsetree.structure -> - name:string -> kind:pkind -> prefix:string list -> int -val search_signature : - Parsetree.signature -> - name:string -> kind:pkind -> prefix:string list -> int diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml deleted file mode 100644 index 430d520403..0000000000 --- a/otherlibs/labltk/browser/searchpos.ml +++ /dev/null @@ -1,875 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Support -open Tk -open Jg_tk -open Parsetree -open Types -open Typedtree -open Location -open Longident -open Path -open Env -open Searchid - -(* auxiliary functions *) - -let (~!) = Jg_memo.fast ~f:Str.regexp - -let lines_to_chars n ~text:s = - let l = String.length s in - let rec ltc n ~pos = - if n = 1 || pos >= l then pos else - if s.[pos] = '\n' then ltc (n-1) ~pos:(pos+1) else ltc n ~pos:(pos+1) - in ltc n ~pos:0 - -let in_loc loc ~pos = - loc.loc_ghost || pos >= loc.loc_start.Lexing.pos_cnum - && pos < loc.loc_end.Lexing.pos_cnum - -let le_loc loc1 loc2 = - loc1.loc_start.Lexing.pos_cnum <= loc2.loc_start.Lexing.pos_cnum - && loc1.loc_end.Lexing.pos_cnum >= loc2.loc_end.Lexing.pos_cnum - -let add_found ~found sol ~env ~loc = - if loc.loc_ghost then () else - if List.exists !found ~f:(fun (_,_,loc') -> le_loc loc loc') then () - else found := (sol, env, loc) :: - List.filter !found ~f:(fun (_,_,loc') -> not (le_loc loc' loc)) - -let observe ~ref ?init f x = - let old = !ref in - begin match init with None -> () | Some x -> ref := x end; - try (f x : unit); let v = !ref in ref := old; v - with exn -> ref := old; raise exn - -let rec string_of_longident = function - Lident s -> s - | Ldot (id,s) -> string_of_longident id ^ "." ^ s - | Lapply (id1, id2) -> - string_of_longident id1 ^ "(" ^ string_of_longident id2 ^ ")" - -let string_of_path p = string_of_longident (Searchid.longident_of_path p) - -let parent_path = function - Pdot (path, _, _) -> Some path - | Pident _ | Papply _ -> None - -let ident_of_path ~default = function - Pident i -> i - | Pdot (_, s, _) -> Ident.create s - | Papply _ -> Ident.create default - -let rec head_id = function - Pident id -> id - | Pdot (path,_,_) -> head_id path - | Papply (path,_) -> head_id path (* wrong, but ... *) - -let rec list_of_path = function - Pident id -> [Ident.name id] - | Pdot (path, s, _) -> list_of_path path @ [s] - | Papply (path, _) -> list_of_path path (* wrong, but ... *) - -(* a simple wrapper *) - -class buffer ~size = object - val buffer = Buffer.create size - method out buf = Buffer.add_substring buffer buf - method get = Buffer.contents buffer -end - -(* Search in a signature *) - -type skind = [`Type|`Class|`Module|`Modtype] - -let found_sig = ref ([] : ((skind * Longident.t) * Env.t * Location.t) list) -let add_found_sig = add_found ~found:found_sig - -let rec search_pos_type t ~pos ~env = - if in_loc ~pos t.ptyp_loc then - begin match t.ptyp_desc with - Ptyp_any - | Ptyp_var _ -> () - | Ptyp_variant(tl, _, _) -> - List.iter tl ~f: - begin function - Rtag (_,_,tl) -> List.iter tl ~f:(search_pos_type ~pos ~env) - | Rinherit st -> search_pos_type ~pos ~env st - end - | Ptyp_arrow (_, t1, t2) -> - search_pos_type t1 ~pos ~env; - search_pos_type t2 ~pos ~env - | Ptyp_tuple tl -> - List.iter tl ~f:(search_pos_type ~pos ~env) - | Ptyp_constr (lid, tl) -> - List.iter tl ~f:(search_pos_type ~pos ~env); - add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc - | Ptyp_object fl -> - List.iter fl ~f: - begin function - | {pfield_desc = Pfield (_, ty)} -> search_pos_type ty ~pos ~env - | _ -> () - end - | Ptyp_class (lid, tl, _) -> - List.iter tl ~f:(search_pos_type ~pos ~env); - add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc - | Ptyp_alias (t, _) - | Ptyp_poly (_, t) -> search_pos_type ~pos ~env t - end - -let rec search_pos_class_type cl ~pos ~env = - if in_loc cl.pcty_loc ~pos then - begin match cl.pcty_desc with - Pcty_constr (lid, _) -> - add_found_sig (`Class, lid) ~env ~loc:cl.pcty_loc - | Pcty_signature (_, cfl) -> - List.iter cfl ~f: - begin function - Pctf_inher cty -> search_pos_class_type cty ~pos ~env - | Pctf_val (_, _, Some ty, loc) -> - if in_loc loc ~pos then search_pos_type ty ~pos ~env - | Pctf_val _ -> () - | Pctf_virt (_, _, ty, loc) -> - if in_loc loc ~pos then search_pos_type ty ~pos ~env - | Pctf_meth (_, _, ty, loc) -> - if in_loc loc ~pos then search_pos_type ty ~pos ~env - | Pctf_cstr (ty1, ty2, loc) -> - if in_loc loc ~pos then begin - search_pos_type ty1 ~pos ~env; - search_pos_type ty2 ~pos ~env - end - end - | Pcty_fun (_, ty, cty) -> - search_pos_type ty ~pos ~env; - search_pos_class_type cty ~pos ~env - end - -let search_pos_type_decl td ~pos ~env = - if in_loc ~pos td.ptype_loc then begin - begin match td.ptype_manifest with - Some t -> search_pos_type t ~pos ~env - | None -> () - end; - let rec search_tkind = function - Ptype_abstract -> () - | Ptype_variant (dl, _) -> - List.iter dl - ~f:(fun (_, tl) -> List.iter tl ~f:(search_pos_type ~pos ~env)) - | Ptype_record (dl, _) -> - List.iter dl ~f:(fun (_, _, t) -> search_pos_type t ~pos ~env) in - search_tkind td.ptype_kind; - List.iter td.ptype_cstrs ~f: - begin fun (t1, t2, _) -> - search_pos_type t1 ~pos ~env; - search_pos_type t2 ~pos ~env - end - end - -let rec search_pos_signature l ~pos ~env = - ignore ( - List.fold_left l ~init:env ~f: - begin fun env pt -> - let env = match pt.psig_desc with - Psig_open id -> - let path, mt = lookup_module id env in - begin match mt with - Tmty_signature sign -> open_signature path sign env - | _ -> env - end - | sign_item -> - try add_signature (Typemod.transl_signature env [pt]) env - with Typemod.Error _ | Typeclass.Error _ - | Typetexp.Error _ | Typedecl.Error _ -> env - in - if in_loc ~pos pt.psig_loc then - begin match pt.psig_desc with - Psig_value (_, desc) -> search_pos_type desc.pval_type ~pos ~env - | Psig_type l -> - List.iter l ~f:(fun (_,desc) -> search_pos_type_decl ~pos desc ~env) - | Psig_exception (_, l) -> - List.iter l ~f:(search_pos_type ~pos ~env); - add_found_sig (`Type, Lident "exn") ~env ~loc:pt.psig_loc - | Psig_module (_, t) -> - search_pos_module t ~pos ~env - | Psig_recmodule decls -> - assert false (* to be fixed *) - | Psig_modtype (_, Pmodtype_manifest t) -> - search_pos_module t ~pos ~env - | Psig_modtype _ -> () - | Psig_class l -> - List.iter l - ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env) - | Psig_class_type l -> - List.iter l - ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env) - (* The last cases should not happen in generated interfaces *) - | Psig_open lid -> add_found_sig (`Module, lid) ~env ~loc:pt.psig_loc - | Psig_include t -> search_pos_module t ~pos ~env - end; - env - end) - -and search_pos_module m ~pos ~env = - if in_loc m.pmty_loc ~pos then begin - begin match m.pmty_desc with - Pmty_ident lid -> add_found_sig (`Modtype, lid) ~env ~loc:m.pmty_loc - | Pmty_signature sg -> search_pos_signature sg ~pos ~env - | Pmty_functor (_ , m1, m2) -> - search_pos_module m1 ~pos ~env; - search_pos_module m2 ~pos ~env - | Pmty_with (m, l) -> - search_pos_module m ~pos ~env; - List.iter l ~f: - begin function - _, Pwith_type t -> search_pos_type_decl t ~pos ~env - | _ -> () - end - end - end - -let search_pos_signature l ~pos ~env = - observe ~ref:found_sig (search_pos_signature ~pos ~env) l - -(* the module display machinery *) - -type module_widgets = - { mw_frame: Widget.frame Widget.widget; - mw_title: Widget.label Widget.widget option; - mw_detach: Widget.button Widget.widget; - mw_edit: Widget.button Widget.widget; - mw_intf: Widget.button Widget.widget } - -let shown_modules = Hashtbl.create 17 -let default_frame = ref None -let set_path = ref (fun _ ~sign -> assert false) -let filter_modules () = - Hashtbl.iter - (fun key data -> - if not (Winfo.exists data.mw_frame) then - Hashtbl.remove shown_modules key) - shown_modules -let add_shown_module path ~widgets = - Hashtbl.add shown_modules path widgets -let find_shown_module path = - try - filter_modules (); - Hashtbl.find shown_modules path - with Not_found -> - match !default_frame with - None -> raise Not_found - | Some mw -> mw - -let is_shown_module path = - !default_frame <> None || - (filter_modules (); Hashtbl.mem shown_modules path) - -(* Viewing a signature *) - -(* Forward definitions of Viewer.view_defined and Editor.editor *) -let view_defined_ref = ref (fun lid ~env -> ()) -let editor_ref = ref (fun ?file ?pos ?opendialog () -> ()) - -let edit_source ~file ~path ~sign = - match sign with - [item] -> - let id, kind = - match item with - Tsig_value (id, _) -> id, Pvalue - | Tsig_type (id, _) -> id, Ptype - | Tsig_exception (id, _) -> id, Pconstructor - | Tsig_module (id, _) -> id, Pmodule - | Tsig_modtype (id, _) -> id, Pmodtype - | Tsig_class (id, _) -> id, Pclass - | Tsig_cltype (id, _) -> id, Pcltype - in - let prefix = List.tl (list_of_path path) and name = Ident.name id in - let pos = - try - let chan = open_in file in - if Filename.check_suffix file ".ml" then - let parsed = Parse.implementation (Lexing.from_channel chan) in - close_in chan; - Searchid.search_structure parsed ~name ~kind ~prefix - else - let parsed = Parse.interface (Lexing.from_channel chan) in - close_in chan; - Searchid.search_signature parsed ~name ~kind ~prefix - with _ -> 0 - in !editor_ref ~file ~pos () - | _ -> !editor_ref ~file () - -(* List of windows to destroy by Close All *) -let top_widgets = ref [] - -let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign = - let env = - match path with None -> env - | Some path -> Env.open_signature path sign env in - let title = - match title, path with Some title, _ -> title - | None, Some path -> string_of_path path - | None, None -> "Signature" - in - let tl, tw, finish = - try match path, !default_frame with - None, Some ({mw_title=Some label} as mw) when not detach -> - Button.configure mw.mw_detach - ~command:(fun () -> view_signature sign ~title ~env ~detach:true); - pack [mw.mw_detach] ~side:`Left; - Pack.forget [mw.mw_edit; mw.mw_intf]; - List.iter ~f:destroy (Winfo.children mw.mw_frame); - Label.configure label ~text:title; - pack [label] ~fill:`X ~side:`Bottom; - Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 () - | None, _ -> raise Not_found - | Some path, _ -> - let mw = - try find_shown_module path - with Not_found -> - view_module path ~env; - find_shown_module path - in - (try !set_path path ~sign with _ -> ()); - begin match mw.mw_title with None -> () - | Some label -> - Label.configure label ~text:title; - pack [label] ~fill:`X ~side:`Bottom - end; - Button.configure mw.mw_detach - ~command:(fun () -> view_signature sign ~title ~env ~detach:true); - pack [mw.mw_detach] ~side:`Left; - let repack = ref false in - List.iter2 [mw.mw_edit; mw.mw_intf] [".ml"; ".mli"] ~f: - begin fun button ext -> - try - let id = head_id path in - let file = - Misc.find_in_path_uncap !Config.load_path - ((Ident.name id) ^ ext) in - Button.configure button - ~command:(fun () -> edit_source ~file ~path ~sign); - if !repack then Pack.forget [button] else - if not (Winfo.viewable button) then repack := true; - pack [button] ~side:`Left - with Not_found -> - Pack.forget [button] - end; - let top = Winfo.toplevel mw.mw_frame in - if not (Winfo.ismapped top) then Wm.deiconify top; - List.iter ~f:destroy (Winfo.children mw.mw_frame); - Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 () - with Not_found -> - let tl, tw, finish = Jg_message.formatted ~title ~maxheight:15 () in - top_widgets := tl :: !top_widgets; - tl, tw, finish - in - Format.set_max_boxes 100; - Printtyp.signature Format.std_formatter sign; - finish (); - Lexical.init_tags tw; - Lexical.tag tw; - Text.configure tw ~state:`Disabled; - let text = Jg_text.get_all tw in - let pt = - try Parse.interface (Lexing.from_string text) - with Syntaxerr.Error e -> - let l = - match e with - Syntaxerr.Unclosed(l,_,_,_) -> l - | Syntaxerr.Other l -> l - in - Jg_text.tag_and_see tw ~start:(tpos l.loc_start.Lexing.pos_cnum) - ~stop:(tpos l.loc_end.Lexing.pos_cnum) ~tag:"error"; [] - | Lexer.Error (_, l) -> - let s = l.loc_start.Lexing.pos_cnum in - let e = l.loc_end.Lexing.pos_cnum in - Jg_text.tag_and_see tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error"; [] - in - Jg_bind.enter_focus tw; - bind tw ~events:[`Modified([`Control], `KeyPressDetail"s")] - ~action:(fun _ -> Jg_text.search_string tw); - bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~fields:[`MouseX;`MouseY] ~breakable:true - ~action:(fun ev -> - let `Linechar (l, c) = - Text.index tw ~index:(`Atxy(ev.ev_MouseX,ev.ev_MouseY), []) in - try - match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env - with [] -> break () - | ((kind, lid), env, loc) :: _ -> view_decl lid ~kind ~env - with Not_found | Env.Error _ -> ()); - bind tw ~events:[`ButtonPressDetail 3] ~breakable:true - ~fields:[`MouseX;`MouseY] - ~action:(fun ev -> - let x = ev.ev_MouseX and y = ev.ev_MouseY in - let `Linechar (l, c) = - Text.index tw ~index:(`Atxy(x,y), []) in - try - match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env - with [] -> break () - | ((kind, lid), env, loc) :: _ -> - let menu = view_decl_menu lid ~kind ~env ~parent:tw in - let x = x + Winfo.rootx tw and y = y + Winfo.rooty tw - 10 in - Menu.popup menu ~x ~y - with Not_found -> ()) - -and view_signature_item sign ~path ~env = - view_signature sign ~title:(string_of_path path) - ?path:(parent_path path) ~env - -and view_module path ~env = - match find_module path env with - Tmty_signature sign -> - !view_defined_ref (Searchid.longident_of_path path) ~env - | modtype -> - let id = ident_of_path path ~default:"M" in - view_signature_item [Tsig_module (id, modtype)] ~path ~env - -and view_module_id id ~env = - let path, _ = lookup_module id env in - view_module path ~env - -and view_type_decl path ~env = - let td = find_type path env in - try match td.type_manifest with None -> raise Not_found - | Some ty -> match Ctype.repr ty with - {desc = Tobject _} -> - let clt = find_cltype path env in - view_signature_item ~path ~env - [Tsig_cltype(ident_of_path path ~default:"ct", clt)] - | _ -> raise Not_found - with Not_found -> - view_signature_item ~path ~env - [Tsig_type(ident_of_path path ~default:"t", td)] - -and view_type_id li ~env = - let path, decl = lookup_type li env in - view_type_decl path ~env - -and view_class_id li ~env = - let path, cl = lookup_class li env in - view_signature_item ~path ~env - [Tsig_class(ident_of_path path ~default:"c", cl)] - -and view_cltype_id li ~env = - let path, clt = lookup_cltype li env in - view_signature_item ~path ~env - [Tsig_cltype(ident_of_path path ~default:"ct", clt)] - -and view_modtype_id li ~env = - let path, td = lookup_modtype li env in - view_signature_item ~path ~env - [Tsig_modtype(ident_of_path path ~default:"S", td)] - -and view_expr_type ?title ?path ?env ?(name="noname") t = - let title = - match title, path with Some title, _ -> title - | None, Some path -> string_of_path path - | None, None -> "Expression type" - and path, id = - match path with None -> None, Ident.create name - | Some path -> parent_path path, ident_of_path path ~default:name - in - view_signature ~title ?path ?env - [Tsig_value (id, {val_type = t; val_kind = Val_reg})] - -and view_decl lid ~kind ~env = - match kind with - `Type -> view_type_id lid ~env - | `Class -> view_class_id lid ~env - | `Module -> view_module_id lid ~env - | `Modtype -> view_modtype_id lid ~env - -and view_decl_menu lid ~kind ~env ~parent = - let path, kname = - try match kind with - `Type -> fst (lookup_type lid env), "Type" - | `Class -> fst (lookup_class lid env), "Class" - | `Module -> fst (lookup_module lid env), "Module" - | `Modtype -> fst (lookup_modtype lid env), "Module type" - with Env.Error _ -> raise Not_found - in - let menu = Menu.create parent ~tearoff:false in - let label = kname ^ " " ^ string_of_path path in - begin match path with - Pident _ -> - Menu.add_command menu ~label ~state:`Disabled - | _ -> - Menu.add_command menu ~label - ~command:(fun () -> view_decl lid ~kind ~env); - end; - if kind = `Type || kind = `Modtype then begin - 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 buf#out (fun () -> ()); - Format.set_margin 60; - Format.open_hbox (); - if kind = `Type then - Printtyp.type_declaration - (ident_of_path path ~default:"t") - Format.std_formatter - (find_type path env) - else - Printtyp.modtype_declaration - (ident_of_path path ~default:"S") - Format.std_formatter - (find_modtype path env); - Format.close_box (); Format.print_flush (); - Format.set_formatter_output_functions fo ff; - Format.set_margin margin; - let l = Str.split ~!"\n" buf#get in - let font = - let font = - Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in - if font = "" then "7x14" else font - in - (* Menu.add_separator menu; *) - List.iter l - ~f:(fun label -> Menu.add_command menu ~label ~font ~state:`Disabled) - end; - menu - -(* search and view in a structure *) - -type fkind = [ - `Exp of - [`Expr|`Pat|`Const|`Val of Path.t|`Var of Path.t|`New of Path.t] - * Types.type_expr - | `Class of Path.t * Types.class_type - | `Module of Path.t * Types.module_type -] - -let view_type kind ~env = - match kind with - `Exp (k, ty) -> - begin match k with - `Expr -> view_expr_type ty ~title:"Expression type" ~env - | `Pat -> view_expr_type ty ~title:"Pattern type" ~env - | `Const -> view_expr_type ty ~title:"Constant type" ~env - | `Val path -> - begin try - let vd = find_value path env in - view_signature_item ~path ~env - [Tsig_value(ident_of_path path ~default:"v", vd)] - with Not_found -> - view_expr_type ty ~path ~env - end - | `Var path -> - let vd = find_value path env in - view_expr_type vd.val_type ~env ~path ~title:"Variable type" - | `New path -> - let cl = find_class path env in - view_signature_item ~path ~env - [Tsig_class(ident_of_path path ~default:"c", cl)] - end - | `Class (path, cty) -> - let cld = { cty_params = []; cty_type = cty; - cty_path = path; cty_new = None } in - view_signature_item ~path ~env - [Tsig_class(ident_of_path path ~default:"c", cld)] - | `Module (path, mty) -> - match mty with - Tmty_signature sign -> view_signature sign ~path ~env - | modtype -> - view_signature_item ~path ~env - [Tsig_module(ident_of_path path ~default:"M", mty)] - -let view_type_menu kind ~env ~parent = - let title = - match kind with - `Exp (`Expr,_) -> "Expression :" - | `Exp (`Pat, _) -> "Pattern :" - | `Exp (`Const, _) -> "Constant :" - | `Exp (`Val path, _) -> "Value " ^ string_of_path path ^ " :" - | `Exp (`Var path, _) -> - "Variable " ^ Ident.name (ident_of_path path ~default:"noname") ^ " :" - | `Exp (`New path, _) -> "Class " ^ string_of_path path ^ " :" - | `Class (path, _) -> "Class " ^ string_of_path path ^ " :" - | `Module (path,_) -> "Module " ^ string_of_path path in - let menu = Menu.create parent ~tearoff:false in - begin match kind with - `Exp((`Expr | `Pat | `Const | `Val (Pident _)),_) -> - Menu.add_command menu ~label:title ~state:`Disabled - | `Exp _ | `Class _ | `Module _ -> - Menu.add_command menu ~label:title - ~command:(fun () -> view_type kind ~env) - end; - begin match kind with `Module _ | `Class _ -> () - | `Exp(_, ty) -> - 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 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 fo ff; - Format.set_margin margin; - let l = Str.split ~!"\n" buf#get in - let font = - let font = - Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in - if font = "" then "7x14" else font - in - (* Menu.add_separator menu; *) - List.iter l ~f: - begin fun label -> match (Ctype.repr ty).desc with - Tconstr (path,_,_) -> - Menu.add_command menu ~label ~font - ~command:(fun () -> view_type_decl path ~env) - | Tvariant {row_name = Some (path, _)} -> - Menu.add_command menu ~label ~font - ~command:(fun () -> view_type_decl path ~env) - | _ -> - Menu.add_command menu ~label ~font ~state:`Disabled - end - end; - menu - -let found_str = ref ([] : (fkind * Env.t * Location.t) list) -let add_found_str = add_found ~found:found_str - -let rec search_pos_structure ~pos str = - List.iter str ~f: - begin function - Tstr_eval exp -> search_pos_expr exp ~pos - | Tstr_value (rec_flag, l) -> - List.iter l ~f: - begin fun (pat, exp) -> - let env = - if rec_flag = Asttypes.Recursive then exp.exp_env else Env.empty in - search_pos_pat pat ~pos ~env; - search_pos_expr exp ~pos - end - | Tstr_primitive (_, vd) ->() - | Tstr_type _ -> () - | Tstr_exception _ -> () - | Tstr_exn_rebind(_, _) -> () - | Tstr_module (_, m) -> search_pos_module_expr m ~pos - | Tstr_recmodule bindings -> assert false (* to be fixed *) - | Tstr_modtype _ -> () - | Tstr_open _ -> () - | Tstr_class l -> - List.iter l ~f:(fun (id, _, _, cl) -> search_pos_class_expr cl ~pos) - | Tstr_cltype _ -> () - | Tstr_include (m, _) -> search_pos_module_expr m ~pos - end - -and search_pos_class_structure ~pos cls = - List.iter cls.cl_field ~f: - begin function - Cf_inher (cl, _, _) -> - search_pos_class_expr cl ~pos - | Cf_val (_, _, exp) -> search_pos_expr exp ~pos - | Cf_meth (_, exp) -> search_pos_expr exp ~pos - | Cf_let (_, pel, iel) -> - List.iter pel ~f: - begin fun (pat, exp) -> - search_pos_pat pat ~pos ~env:exp.exp_env; - search_pos_expr exp ~pos - end; - List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos) - | Cf_init exp -> search_pos_expr exp ~pos - end - -and search_pos_class_expr ~pos cl = - if in_loc cl.cl_loc ~pos then begin - begin match cl.cl_desc with - Tclass_ident path -> - add_found_str (`Class (path, cl.cl_type)) - ~env:!start_env ~loc:cl.cl_loc - | Tclass_structure cls -> - search_pos_class_structure ~pos cls - | Tclass_fun (pat, iel, cl, _) -> - search_pos_pat pat ~pos ~env:pat.pat_env; - List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos); - search_pos_class_expr cl ~pos - | Tclass_apply (cl, el) -> - search_pos_class_expr cl ~pos; - List.iter el ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x) - | Tclass_let (_, pel, iel, cl) -> - List.iter pel ~f: - begin fun (pat, exp) -> - search_pos_pat pat ~pos ~env:exp.exp_env; - search_pos_expr exp ~pos - end; - List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos); - search_pos_class_expr cl ~pos - | Tclass_constraint (cl, _, _, _) -> - search_pos_class_expr cl ~pos - end; - add_found_str (`Class (Pident (Ident.create "c"), cl.cl_type)) - ~env:!start_env ~loc:cl.cl_loc - end - -and search_pos_expr ~pos exp = - if in_loc exp.exp_loc ~pos then begin - begin match exp.exp_desc with - Texp_ident (path, _) -> - add_found_str (`Exp(`Val path, exp.exp_type)) - ~env:exp.exp_env ~loc:exp.exp_loc - | Texp_constant v -> - add_found_str (`Exp(`Const, exp.exp_type)) - ~env:exp.exp_env ~loc:exp.exp_loc - | Texp_let (_, expl, exp) -> - List.iter expl ~f: - begin fun (pat, exp') -> - search_pos_pat pat ~pos ~env:exp.exp_env; - search_pos_expr exp' ~pos - end; - search_pos_expr exp ~pos - | Texp_function (l, _) -> - List.iter l ~f: - begin fun (pat, exp) -> - search_pos_pat pat ~pos ~env:exp.exp_env; - search_pos_expr exp ~pos - end - | Texp_apply (exp, l) -> - List.iter l ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x); - search_pos_expr exp ~pos - | Texp_match (exp, l, _) -> - search_pos_expr exp ~pos; - List.iter l ~f: - begin fun (pat, exp) -> - search_pos_pat pat ~pos ~env:exp.exp_env; - search_pos_expr exp ~pos - end - | Texp_try (exp, l) -> - search_pos_expr exp ~pos; - List.iter l ~f: - begin fun (pat, exp) -> - search_pos_pat pat ~pos ~env:exp.exp_env; - search_pos_expr exp ~pos - end - | Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos) - | Texp_construct (_, l) -> List.iter l ~f:(search_pos_expr ~pos) - | Texp_variant (_, None) -> () - | Texp_variant (_, Some exp) -> search_pos_expr exp ~pos - | Texp_record (l, opt) -> - List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos); - (match opt with None -> () | Some exp -> search_pos_expr exp ~pos) - | Texp_field (exp, _) -> search_pos_expr exp ~pos - | Texp_setfield (a, _, b) -> - search_pos_expr a ~pos; search_pos_expr b ~pos - | Texp_array l -> List.iter l ~f:(search_pos_expr ~pos) - | Texp_ifthenelse (a, b, c) -> - search_pos_expr a ~pos; search_pos_expr b ~pos; - begin match c with None -> () - | Some exp -> search_pos_expr exp ~pos - end - | Texp_sequence (a,b) -> - search_pos_expr a ~pos; search_pos_expr b ~pos - | Texp_while (a,b) -> - search_pos_expr a ~pos; search_pos_expr b ~pos - | Texp_for (_, a, b, _, c) -> - List.iter [a;b;c] ~f:(search_pos_expr ~pos) - | Texp_when (a, b) -> - search_pos_expr a ~pos; search_pos_expr b ~pos - | Texp_send (exp, _) -> search_pos_expr exp ~pos - | Texp_new (path, _) -> - add_found_str (`Exp(`New path, exp.exp_type)) - ~env:exp.exp_env ~loc:exp.exp_loc - | Texp_instvar (_,path) -> - add_found_str (`Exp(`Var path, exp.exp_type)) - ~env:exp.exp_env ~loc:exp.exp_loc - | Texp_setinstvar (_, path, exp) -> - search_pos_expr exp ~pos; - add_found_str (`Exp(`Var path, exp.exp_type)) - ~env:exp.exp_env ~loc:exp.exp_loc - | Texp_override (_, l) -> - List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos) - | Texp_letmodule (id, modexp, exp) -> - search_pos_module_expr modexp ~pos; - search_pos_expr exp ~pos - | Texp_assertfalse -> () - | Texp_assert exp -> - search_pos_expr exp ~pos - | Texp_lazy exp -> - search_pos_expr exp ~pos - | Texp_object (cls, _, _) -> - search_pos_class_structure ~pos cls - - end; - add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc - end - -and search_pos_pat ~pos ~env pat = - if in_loc pat.pat_loc ~pos then begin - begin match pat.pat_desc with - Tpat_any -> () - | Tpat_var id -> - add_found_str (`Exp(`Val (Pident id), pat.pat_type)) - ~env ~loc:pat.pat_loc - | Tpat_alias (pat, _) -> search_pos_pat pat ~pos ~env - | Tpat_constant _ -> - add_found_str (`Exp(`Const, pat.pat_type)) ~env ~loc:pat.pat_loc - | Tpat_tuple l -> - List.iter l ~f:(search_pos_pat ~pos ~env) - | Tpat_construct (_, l) -> - List.iter l ~f:(search_pos_pat ~pos ~env) - | Tpat_variant (_, None, _) -> () - | Tpat_variant (_, Some pat, _) -> search_pos_pat pat ~pos ~env - | Tpat_record l -> - List.iter l ~f:(fun (_, pat) -> search_pos_pat pat ~pos ~env) - | Tpat_array l -> - List.iter l ~f:(search_pos_pat ~pos ~env) - | Tpat_or (a, b, None) -> - search_pos_pat a ~pos ~env; search_pos_pat b ~pos ~env - | Tpat_or (_, _, Some _) -> - () - end; - add_found_str (`Exp(`Pat, pat.pat_type)) ~env ~loc:pat.pat_loc - end - -and search_pos_module_expr ~pos m = - if in_loc m.mod_loc ~pos then begin - begin match m.mod_desc with - Tmod_ident path -> - add_found_str (`Module (path, m.mod_type)) - ~env:m.mod_env ~loc:m.mod_loc - | Tmod_structure str -> search_pos_structure str ~pos - | Tmod_functor (_, _, m) -> search_pos_module_expr m ~pos - | Tmod_apply (a, b, _) -> - search_pos_module_expr a ~pos; search_pos_module_expr b ~pos - | Tmod_constraint (m, _, _) -> search_pos_module_expr m ~pos - end; - add_found_str (`Module (Pident (Ident.create "M"), m.mod_type)) - ~env:m.mod_env ~loc:m.mod_loc - end - -let search_pos_structure ~pos str = - observe ~ref:found_str (search_pos_structure ~pos) str - -open Stypes - -let search_pos_ti ~pos = function - Ti_pat p -> search_pos_pat ~pos ~env:p.pat_env p - | Ti_expr e -> search_pos_expr ~pos e - | Ti_class c -> search_pos_class_expr ~pos c - | Ti_mod m -> search_pos_module_expr ~pos m - -let rec search_pos_info ~pos = function - [] -> [] - | ti :: l -> - if in_loc ~pos (get_location ti) - then observe ~ref:found_str (search_pos_ti ~pos) ti - else search_pos_info ~pos l diff --git a/otherlibs/labltk/browser/searchpos.mli b/otherlibs/labltk/browser/searchpos.mli deleted file mode 100644 index 1da1a877ab..0000000000 --- a/otherlibs/labltk/browser/searchpos.mli +++ /dev/null @@ -1,78 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val top_widgets : any widget list ref - -type module_widgets = - { mw_frame: frame widget; - mw_title: label widget option; - mw_detach: button widget; - mw_edit: button widget; - mw_intf: button widget } - -val add_shown_module : Path.t -> widgets:module_widgets -> unit -val find_shown_module : Path.t -> module_widgets -val is_shown_module : Path.t -> bool -val default_frame : module_widgets option ref -val set_path : (Path.t -> sign:Types.signature -> unit) ref - -val view_defined_ref : (Longident.t -> env:Env.t -> unit) ref -val editor_ref : - (?file:string -> ?pos:int -> ?opendialog:bool -> unit -> unit) ref - -val view_signature : - ?title:string -> - ?path:Path.t -> ?env:Env.t -> ?detach:bool -> Types.signature -> unit -val view_signature_item : - Types.signature -> path:Path.t -> env:Env.t -> unit -val view_module_id : Longident.t -> env:Env.t -> unit -val view_type_id : Longident.t -> env:Env.t -> unit -val view_class_id : Longident.t -> env:Env.t -> unit -val view_cltype_id : Longident.t -> env:Env.t -> unit -val view_modtype_id : Longident.t -> env:Env.t -> unit -val view_type_decl : Path.t -> env:Env.t -> unit - -type skind = [`Type|`Class|`Module|`Modtype] -val search_pos_signature : - Parsetree.signature -> pos:int -> env:Env.t -> - ((skind * Longident.t) * Env.t * Location.t) list -val view_decl : Longident.t -> kind:skind -> env:Env.t -> unit -val view_decl_menu : - Longident.t -> - kind:skind -> env:Env.t -> parent:text widget -> menu widget - -type fkind = [ - `Exp of - [`Expr|`Pat|`Const|`Val of Path.t|`Var of Path.t|`New of Path.t] - * Types.type_expr - | `Class of Path.t * Types.class_type - | `Module of Path.t * Types.module_type -] -val search_pos_structure : - pos:int -> Typedtree.structure_item list -> - (fkind * Env.t * Location.t) list -val search_pos_info : - pos:int -> Stypes.type_info list -> (fkind * Env.t * Location.t) list -val view_type : fkind -> env:Env.t -> unit -val view_type_menu : fkind -> env:Env.t -> parent:'a widget -> menu widget - -val parent_path : Path.t -> Path.t option -val string_of_path : Path.t -> string -val string_of_longident : Longident.t -> string -val lines_to_chars : int -> text:string -> int - diff --git a/otherlibs/labltk/browser/setpath.ml b/otherlibs/labltk/browser/setpath.ml deleted file mode 100644 index 3e7470dfc3..0000000000 --- a/otherlibs/labltk/browser/setpath.ml +++ /dev/null @@ -1,162 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk - -(* Listboxes *) - -let update_hooks = ref [] - -let add_update_hook f = update_hooks := f :: !update_hooks - -let exec_update_hooks () = - update_hooks := List.filter !update_hooks ~f: - begin fun f -> - try f (); true - with Protocol.TkError _ -> false - end - -let set_load_path l = - Config.load_path := l; - exec_update_hooks () - -let get_load_path () = !Config.load_path - -let renew_dirs box ~var ~dir = - Textvariable.set var dir; - Listbox.delete box ~first:(`Num 0) ~last:`End; - Listbox.insert box ~index:`End - ~texts:(Useunix.get_directories_in_files ~path:dir - (Useunix.get_files_in_directory dir)); - Jg_box.recenter box ~index:(`Num 0) - -let renew_path box = - Listbox.delete box ~first:(`Num 0) ~last:`End; - Listbox.insert box ~index:`End ~texts:!Config.load_path; - Jg_box.recenter box ~index:(`Num 0) - -let add_to_path ~dirs ?(base="") box = - let dirs = - if base = "" then dirs else - if dirs = [] then [base] else - List.map dirs ~f: - begin function - "." -> base - | ".." -> Filename.dirname base - | x -> Filename.concat base x - end - in - set_load_path - (dirs @ List.fold_left dirs ~init:(get_load_path ()) - ~f:(fun acc x -> List2.exclude x acc)) - -let remove_path box ~dirs = - set_load_path - (List.fold_left dirs ~init:(get_load_path ()) - ~f:(fun acc x -> List2.exclude x acc)) - -(* main function *) - -let f ~dir = - let current_dir = ref dir in - let tl = Jg_toplevel.titled "Edit Load Path" in - Jg_bind.escape_destroy tl; - let var_dir = Textvariable.create ~on:tl () in - let caplab = Label.create tl ~text:"Path" - and dir_name = Entry.create tl ~textvariable:var_dir - and browse = Frame.create tl in - let dirs = Frame.create browse - and path = Frame.create browse in - let dirframe, dirbox, dirsb = Jg_box.create_with_scrollbar dirs - and pathframe, pathbox, pathsb = Jg_box.create_with_scrollbar path - in - add_update_hook (fun () -> renew_path pathbox); - Listbox.configure pathbox ~width:40 ~selectmode:`Multiple; - Listbox.configure dirbox ~selectmode:`Multiple; - Jg_box.add_completion dirbox ~action: - begin fun index -> - begin match Listbox.get dirbox ~index with - "." -> () - | ".." -> current_dir := Filename.dirname !current_dir - | x -> current_dir := !current_dir ^ "/" ^ x - end; - renew_dirs dirbox ~var:var_dir ~dir:!current_dir; - Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End - end; - Jg_box.add_completion pathbox ~action: - begin fun index -> - current_dir := Listbox.get pathbox ~index; - renew_dirs dirbox ~var:var_dir ~dir:!current_dir - end; - - bind dir_name ~events:[`KeyPressDetail"Return"] - ~action:(fun _ -> - let dir = Textvariable.get var_dir in - if Useunix.is_directory dir then begin - current_dir := dir; - renew_dirs dirbox ~var:var_dir ~dir - end); - - (* Avoid space being used by the completion mechanism *) - let bind_space_toggle lb = - bind lb ~events:[`KeyPressDetail "space"] ~extend:true ~action:ignore in - bind_space_toggle dirbox; - bind_space_toggle pathbox; - - let add_paths _ = - add_to_path pathbox ~base:!current_dir - ~dirs:(List.map (Listbox.curselection dirbox) - ~f:(fun x -> Listbox.get dirbox ~index:x)); - Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End - and remove_paths _ = - remove_path pathbox - ~dirs:(List.map (Listbox.curselection pathbox) - ~f:(fun x -> Listbox.get pathbox ~index:x)) - in - bind dirbox ~events:[`KeyPressDetail "Insert"] ~action:add_paths; - bind pathbox ~events:[`KeyPressDetail "Delete"] ~action:remove_paths; - - let dirlab = Label.create dirs ~text:"Directories" - and pathlab = Label.create path ~text:"Load path" - and addbutton = Button.create dirs ~text:"Add to path" ~command:add_paths - and pathbuttons = Frame.create path in - let removebutton = - Button.create pathbuttons ~text:"Remove from path" ~command:remove_paths - and ok = - Jg_button.create_destroyer tl ~parent:pathbuttons - in - renew_dirs dirbox ~var:var_dir ~dir:!current_dir; - renew_path pathbox; - pack [dirsb] ~side:`Right ~fill:`Y; - pack [dirbox] ~side:`Left ~fill:`Y ~expand:true; - pack [pathsb] ~side:`Right ~fill:`Y; - pack [pathbox] ~side:`Left ~fill:`Both ~expand:true; - pack [dirlab] ~side:`Top ~anchor:`W ~padx:10; - pack [addbutton] ~side:`Bottom ~fill:`X; - pack [dirframe] ~fill:`Y ~expand:true; - pack [pathlab] ~side:`Top ~anchor:`W ~padx:10; - pack [removebutton; ok] ~side:`Left ~fill:`X ~expand:true; - pack [pathbuttons] ~fill:`X ~side:`Bottom; - pack [pathframe] ~fill:`Both ~expand:true; - pack [dirs] ~side:`Left ~fill:`Y; - pack [path] ~side:`Right ~fill:`Both ~expand:true; - pack [caplab] ~side:`Top ~anchor:`W ~padx:10; - pack [dir_name] ~side:`Top ~anchor:`W ~fill:`X; - pack [browse] ~side:`Bottom ~expand:true ~fill:`Both; - tl - -let set ~dir = ignore (f ~dir);; diff --git a/otherlibs/labltk/browser/setpath.mli b/otherlibs/labltk/browser/setpath.mli deleted file mode 100644 index f5e70090fd..0000000000 --- a/otherlibs/labltk/browser/setpath.mli +++ /dev/null @@ -1,25 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val add_update_hook : (unit -> unit) -> unit -val exec_update_hooks : unit -> unit - (* things to do when Config.load_path changes *) - -val set : dir:string -> unit -val f : dir:string -> toplevel widget - (* edit the load path *) diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml deleted file mode 100644 index 18e1f34945..0000000000 --- a/otherlibs/labltk/browser/shell.ml +++ /dev/null @@ -1,367 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -module Unix = UnixLabels -open Tk -open Jg_tk -open Dummy - -(* Here again, memoize regexps *) - -let (~!) = Jg_memo.fast ~f:Str.regexp - -(* Nice history class. May reuse *) - -class ['a] history () = object - val mutable history = ([] : 'a list) - val mutable count = 0 - method empty = history = [] - method add s = count <- 0; history <- s :: history - method previous = - let s = List.nth history count in - count <- (count + 1) mod List.length history; - s - method next = - let l = List.length history in - count <- (l + count - 1) mod l; - List.nth history ((l + count - 1) mod l) -end - -let dump_handle (h : Unix.file_descr) = - let obj = Obj.repr h in - if Obj.is_int obj || Obj.tag obj <> Obj.custom_tag then - invalid_arg "Shell.dump_handle"; - Nativeint.format "%x" (Obj.obj obj) - -(* The shell class. Now encapsulated *) - -let protect f x = try f x with _ -> () - -let is_win32 = Sys.os_type = "Win32" -let use_threads = is_win32 -let use_sigpipe = is_win32 - -class shell ~textw ~prog ~args ~env ~history = - let (in2,out1) = Unix.pipe () - and (in1,out2) = Unix.pipe () - and (err1,err2) = Unix.pipe () - and (sig2,sig1) = Unix.pipe () in -object (self) - val pid = - let env = - if use_sigpipe then - let sigdef = "CAMLSIGPIPE=" ^ dump_handle sig2 in - Array.append env [|sigdef|] - else env - in - Unix.create_process_env ~prog ~args ~env - ~stdin:in2 ~stdout:out2 ~stderr:err2 - val out = Unix.out_channel_of_descr out1 - val h : _ history = history - val mutable alive = true - val mutable reading = false - val ibuffer = Buffer.create 1024 - val imutex = Mutex.create () - val mutable ithreads = [] - method alive = alive - method kill = - if Winfo.exists textw then Text.configure textw ~state:`Disabled; - if alive then begin - alive <- false; - protect close_out out; - try - if use_sigpipe then ignore (Unix.write sig1 ~buf:"T" ~pos:0 ~len:1); - List.iter ~f:(protect Unix.close) [in1; err1; sig1; sig2]; - if not use_threads then begin - Fileevent.remove_fileinput ~fd:in1; - Fileevent.remove_fileinput ~fd:err1; - end; - if not use_sigpipe then begin - Unix.kill ~pid ~signal:Sys.sigkill; - ignore (Unix.waitpid ~mode:[] pid) - end - with _ -> () - end - method interrupt = - if alive then try - reading <- false; - if use_sigpipe then begin - ignore (Unix.write sig1 ~buf:"C" ~pos:0 ~len:1); - self#send " " - end else - Unix.kill ~pid ~signal:Sys.sigint - with Unix.Unix_error _ -> () - method send s = - if alive then try - output_string out s; - flush out - with Sys_error _ -> () - method private read ~fd ~len = - begin try - let buf = String.create len in - let len = Unix.read fd ~buf ~pos:0 ~len in - if len > 0 then begin - self#insert (String.sub buf ~pos:0 ~len); - Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) - end; - len - with Unix.Unix_error _ -> 0 - end; - method history (dir : [`Next|`Previous]) = - if not h#empty then begin - if reading then begin - Text.delete textw ~start:(`Mark"input",[`Char 1]) - ~stop:(`Mark"insert",[]) - end else begin - reading <- true; - Text.mark_set textw ~mark:"input" - ~index:(`Mark"insert",[`Char(-1)]) - end; - self#insert (if dir = `Previous then h#previous else h#next) - end - method private lex ?(start = `Mark"insert",[`Linestart]) - ?(stop = `Mark"insert",[`Lineend]) () = - Lexical.tag textw ~start ~stop - method insert text = - let idx = Text.index textw - ~index:(`Mark"insert",[`Char(-1);`Linestart]) in - Text.insert textw ~text ~index:(`Mark"insert",[]); - self#lex ~start:(idx,[`Linestart]) (); - Text.see textw ~index:(`Mark"insert",[]) - method private keypress c = - if not reading && c > " " then begin - reading <- true; - Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) - end - method private keyrelease c = if c <> "" then self#lex () - method private return = - if reading then reading <- false - else Text.mark_set textw ~mark:"input" - ~index:(`Mark"insert",[`Linestart;`Char 1]); - Text.mark_set textw ~mark:"insert"~index:(`Mark"insert",[`Line 1]); - self#lex ~start:(`Mark"input",[`Linestart]) (); - let s = - (* input is one character before real input *) - Text.get textw ~start:(`Mark"input",[`Char 1]) - ~stop:(`Mark"insert",[]) in - h#add s; - Text.insert textw ~index:(`Mark"insert",[]) ~text:"\n"; - Text.yview_index textw ~index:(`Mark"insert",[]); - self#send s; - self#send "\n" - method private paste ev = - if not reading then begin - reading <- true; - Text.mark_set textw ~mark:"input" - ~index:(`Atxy(ev.ev_MouseX, ev.ev_MouseY),[`Char(-1)]) - end - initializer - Lexical.init_tags textw; - let rec bindings = - [ ([], `KeyPress, [`Char], fun ev -> self#keypress ev.ev_Char); - ([], `KeyRelease, [`Char], fun ev -> self#keyrelease ev.ev_Char); - (* [], `KeyPressDetail"Return", [], fun _ -> self#return; *) - ([], `ButtonPressDetail 2, [`MouseX; `MouseY], self#paste); - ([`Alt], `KeyPressDetail"p", [], fun _ -> self#history `Previous); - ([`Alt], `KeyPressDetail"n", [], fun _ -> self#history `Next); - ([`Meta], `KeyPressDetail"p", [], fun _ -> self#history `Previous); - ([`Meta], `KeyPressDetail"n", [], fun _ -> self#history `Next); - ([`Control], `KeyPressDetail"c", [], fun _ -> self#interrupt); - ([], `Destroy, [], fun _ -> self#kill) ] - in - List.iter bindings ~f: - begin fun (modif,event,fields,action) -> - bind textw ~events:[`Modified(modif,event)] ~fields ~action - end; - bind textw ~events:[`KeyPressDetail"Return"] ~breakable:true - ~action:(fun _ -> self#return; break()); - List.iter ~f:Unix.close [in2;out2;err2]; - if use_threads then begin - let fileinput_thread fd = - let buf = String.create 1024 in - let len = ref 0 in - try while len := Unix.read fd ~buf ~pos:0 ~len:1024; !len > 0 do - Mutex.lock imutex; - Buffer.add_substring ibuffer buf 0 !len; - Mutex.unlock imutex - done with Unix.Unix_error _ -> () - in - ithreads <- List.map [in1; err1] ~f:(Thread.create fileinput_thread); - let rec read_buffer () = - Mutex.lock imutex; - if Buffer.length ibuffer > 0 then begin - 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)]) - end; - Mutex.unlock imutex; - Timer.set ~ms:100 ~callback:read_buffer - in - read_buffer () - end else begin - try - List.iter [in1;err1] ~f: - begin fun fd -> - Fileevent.add_fileinput ~fd - ~callback:(fun () -> ignore (self#read ~fd ~len:1024)) - end - with _ -> () - end -end - -(* Specific use of shell, for OCamlBrowser *) - -let shells : (string * shell) list ref = ref [] - -(* Called before exiting *) -let kill_all () = - List.iter !shells ~f:(fun (_,sh) -> if sh#alive then sh#kill); - shells := [] - -let get_all () = - let all = List.filter !shells ~f:(fun (_,sh) -> sh#alive) in - shells := all; - all - -let may_exec_unix prog = - try Unix.access prog ~perm:[Unix.X_OK]; prog - with Unix.Unix_error _ -> "" - -let may_exec_win prog = - let has_ext = - List.exists ~f:(Filename.check_suffix prog) ["exe"; "com"; "bat"] in - if has_ext then may_exec_unix prog else - List.fold_left [prog^".bat"; prog^".exe"; prog^".com"] ~init:"" - ~f:(fun res prog -> if res = "" then may_exec_unix prog else res) - -let may_exec = - if is_win32 then may_exec_win else may_exec_unix - -let path_sep = if is_win32 then ";" else ":" - -let warnings = ref "Al" - -let program_not_found prog = - Jg_message.info ~title:"Error" - ("Program \"" ^ prog ^ "\"\nwas not found in path") - -let protect_arg s = - if String.contains s ' ' then "\"" ^ s ^ "\"" else s - -let f ~prog ~title = - let progargs = - 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 ~!path_sep path in - let exec_path = if is_win32 then "."::exec_path else exec_path in - let progpath = - if not (Filename.is_implicit prog) then may_exec prog else - List.fold_left exec_path ~init:"" ~f: - (fun res dir -> - if res = "" then may_exec (Filename.concat dir prog) else res) in - if progpath = "" then program_not_found prog else - let tl = Jg_toplevel.titled title in - let menus = Frame.create tl ~name:"menubar" in - let file_menu = new Jg_menu.c "File" ~parent:menus - and history_menu = new Jg_menu.c "History" ~parent:menus - and signal_menu = new Jg_menu.c "Signal" ~parent:menus in - pack [menus] ~side:`Top ~fill:`X; - pack [file_menu#button; history_menu#button; signal_menu#button] - ~side:`Left ~ipadx:5 ~anchor:`W; - let frame, tw, sb = Jg_text.create_with_scrollbar tl in - Text.configure tw ~background:`White; - pack [sb] ~fill:`Y ~side:`Right; - pack [tw] ~fill:`Both ~expand:true ~side:`Left; - pack [frame] ~fill:`Both ~expand:true; - let env = Array.map (Unix.environment ()) ~f: - begin fun 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 - let load_path = - if is_win32 then List.map ~f:protect_arg load_path else load_path in - let labels = if !Clflags.classic then ["-nolabels"] else [] in - let rectypes = if !Clflags.recursive_types then ["-rectypes"] else [] in - let warnings = - if List.mem "-w" progargs || !warnings = "Al" then [] - else ["-w"; !warnings] - in - let args = - Array.of_list (progargs @ labels @ warnings @ rectypes @ load_path) in - let history = new history () in - let start_shell () = - let sh = new shell ~textw:tw ~prog:progpath ~env ~args ~history in - shells := (title, sh) :: !shells; - sh - in - let sh = ref (start_shell ()) in - let current_dir = ref (Unix.getcwd ()) in - file_menu#add_command "Restart" ~command: - begin fun () -> - (!sh)#kill; - Text.configure tw ~state:`Normal; - Text.insert tw ~index:(`End,[]) ~text:"\n"; - Text.see tw ~index:(`End,[]); - Text.mark_set tw ~mark:"insert" ~index:(`End,[]); - sh := start_shell (); - end; - file_menu#add_command "Use..." ~command: - begin fun () -> - Fileselect.f ~title:"Use File" ~filter:"*.ml" - ~sync:true ~dir:!current_dir () - ~action:(fun l -> - if l = [] then () else - let name = Fileselect.caml_dir (List.hd l) in - current_dir := Filename.dirname name; - if Filename.check_suffix name ".ml" - then - let cmd = "#use \"" ^ String.escaped name ^ "\";;\n" in - (!sh)#insert cmd; (!sh)#send cmd) - end; - file_menu#add_command "Load..." ~command: - begin fun () -> - Fileselect.f ~title:"Load File" ~filter:"*.cm[oa]" ~sync:true () - ~dir:!current_dir - ~action:(fun l -> - if l = [] then () else - let name = Fileselect.caml_dir (List.hd l) in - current_dir := Filename.dirname name; - if Filename.check_suffix name ".cmo" || - Filename.check_suffix name ".cma" - then - let cmd = "#load \"" ^ String.escaped name ^ "\";;\n" in - (!sh)#insert cmd; (!sh)#send cmd) - end; - file_menu#add_command "Import path" ~command: - begin fun () -> - List.iter (List.rev !Config.load_path) ~f: - (fun dir -> - (!sh)#send ("#directory \"" ^ String.escaped dir ^ "\";;\n")) - end; - file_menu#add_command "Close" ~command:(fun () -> destroy tl); - history_menu#add_command "Previous " ~accelerator:"M-p" - ~command:(fun () -> (!sh)#history `Previous); - history_menu#add_command "Next" ~accelerator:"M-n" - ~command:(fun () -> (!sh)#history `Next); - signal_menu#add_command "Interrupt " ~accelerator:"C-c" - ~command:(fun () -> (!sh)#interrupt); - signal_menu#add_command "Kill" ~command:(fun () -> (!sh)#kill) diff --git a/otherlibs/labltk/browser/shell.mli b/otherlibs/labltk/browser/shell.mli deleted file mode 100644 index ac94f43d7c..0000000000 --- a/otherlibs/labltk/browser/shell.mli +++ /dev/null @@ -1,46 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -class ['a] history : - unit -> - object - val mutable count : int - val mutable history : 'a list - method add : 'a -> unit - method empty : bool - method next : 'a - method previous : 'a - end - -(* toplevel shell *) - -class shell : - textw:Widget.text Widget.widget -> prog:string -> - args:string array -> env:string array -> history:string history -> - object - method alive : bool - method kill : unit - method interrupt : unit - method insert : string -> unit - method send : string -> unit - method history : [`Next|`Previous] -> unit - end - -val kill_all : unit -> unit -val get_all : unit -> (string * shell) list -val warnings : string ref - -val f : prog:string -> title:string -> unit diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml deleted file mode 100644 index 8199e46103..0000000000 --- a/otherlibs/labltk/browser/typecheck.ml +++ /dev/null @@ -1,181 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk -open Parsetree -open Location -open Jg_tk -open Mytypes - -(* Optionally preprocess a source file *) - -let preprocess ~pp ~ext text = - let sourcefile = Filename.temp_file "caml" ext in - begin try - let oc = open_out_bin sourcefile in - output_string oc text; - flush oc; - close_out oc - with _ -> - failwith "Preprocessing error" - end; - let tmpfile = Filename.temp_file "camlpp" ext in - let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in - if Ccomp.command comm <> 0 then begin - Sys.remove sourcefile; - Sys.remove tmpfile; - failwith "Preprocessing error" - end; - Sys.remove sourcefile; - tmpfile - -exception Outdated_version - -let parse_pp ~parse ~wrap ~ext text = - match !Clflags.preprocessor with - None -> parse (Lexing.from_string text) - | Some pp -> - let tmpfile = preprocess ~pp ~ext text in - let ast_magic = - if ext = ".ml" then Config.ast_impl_magic_number - else Config.ast_intf_magic_number in - let ic = open_in_bin tmpfile in - let ast = - try - let buffer = String.create (String.length ast_magic) in - really_input ic buffer 0 (String.length ast_magic); - if buffer = ast_magic then begin - ignore (input_value ic); - wrap (input_value ic) - end else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then - raise Outdated_version - else - raise Exit - with - Outdated_version -> - close_in ic; - Sys.remove tmpfile; - failwith "Ocaml and preprocessor have incompatible versions" - | _ -> - seek_in ic 0; - parse (Lexing.from_channel ic) - in - close_in ic; - Sys.remove tmpfile; - ast - -let nowarnings = ref false - -let f txt = - let error_messages = ref [] in - let text = Jg_text.get_all txt.tw - and env = ref (Env.open_pers_signature "Pervasives" Env.initial) in - let tl, ew, end_message = - Jg_message.formatted ~title:"Warnings" ~ppf:Format.err_formatter () in - Text.tag_remove txt.tw ~tag:"error" ~start:tstart ~stop:tend; - txt.structure <- []; - txt.type_info <- []; - txt.signature <- []; - txt.psignature <- []; - ignore (Stypes.get_info ()); - Clflags.save_types := true; - - begin try - - if Filename.check_suffix txt.name ".mli" then - let psign = parse_pp text ~ext:".mli" - ~parse:Parse.interface ~wrap:(fun x -> x) in - txt.psignature <- psign; - txt.signature <- Typemod.transl_signature !env psign - - else (* others are interpreted as .ml *) - - let psl = parse_pp text ~ext:".ml" - ~parse:Parse.use_file ~wrap:(fun x -> [Parsetree.Ptop_def x]) in - List.iter psl ~f: - begin function - Ptop_def pstr -> - let str, sign, env' = Typemod.type_structure !env pstr in - txt.structure <- txt.structure @ str; - txt.signature <- txt.signature @ sign; - env := env' - | Ptop_dir _ -> () - end; - txt.type_info <- Stypes.get_info (); - - with - Lexer.Error _ | Syntaxerr.Error _ - | Typecore.Error _ | Typemod.Error _ - | Typeclass.Error _ | Typedecl.Error _ - | Typetexp.Error _ | Includemod.Error _ - | Env.Error _ | Ctype.Tags _ | Failure _ as exn -> - txt.type_info <- Stypes.get_info (); - let et, ew, end_message = Jg_message.formatted ~title:"Error !" () in - error_messages := et :: !error_messages; - let range = match exn with - Lexer.Error (err, l) -> - Lexer.report_error Format.std_formatter err; l - | Syntaxerr.Error err -> - Syntaxerr.report_error Format.std_formatter err; - begin match err with - Syntaxerr.Unclosed(l,_,_,_) -> l - | Syntaxerr.Other l -> l - end - | Typecore.Error (l,err) -> - Typecore.report_error Format.std_formatter err; l - | Typeclass.Error (l,err) -> - Typeclass.report_error Format.std_formatter err; l - | Typedecl.Error (l, err) -> - Typedecl.report_error Format.std_formatter err; l - | Typemod.Error (l,err) -> - Typemod.report_error Format.std_formatter err; l - | Typetexp.Error (l,err) -> - Typetexp.report_error Format.std_formatter err; l - | Includemod.Error errl -> - Includemod.report_error Format.std_formatter errl; Location.none - | Env.Error err -> - Env.report_error Format.std_formatter err; Location.none - | Ctype.Tags(l, l') -> - Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value.@." l l'; - Location.none - | Failure s -> - Format.printf "%s.@." s; Location.none - | _ -> assert false - in - end_message (); - let s = range.loc_start.Lexing.pos_cnum in - let e = range.loc_end.Lexing.pos_cnum in - if s < e then - Jg_text.tag_and_see txt.tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error" - end; - end_message (); - if !nowarnings || Text.index ew ~index:tend = `Linechar (2,0) - then destroy tl - else begin - error_messages := tl :: !error_messages; - Text.configure ew ~state:`Disabled; - bind ew ~events:[`Modified([`Double], `ButtonReleaseDetail 1)] - ~action:(fun _ -> - try - let start, ende = Text.tag_nextrange ew ~tag:"sel" ~start:(tpos 0) in - let s = Text.get ew ~start:(start,[]) ~stop:(ende,[]) in - let n = int_of_string s in - Text.mark_set txt.tw ~index:(tpos n) ~mark:"insert"; - Text.see txt.tw ~index:(`Mark "insert", []) - with _ -> ()) - end; - !error_messages diff --git a/otherlibs/labltk/browser/typecheck.mli b/otherlibs/labltk/browser/typecheck.mli deleted file mode 100644 index d61fce62e3..0000000000 --- a/otherlibs/labltk/browser/typecheck.mli +++ /dev/null @@ -1,23 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget -open Mytypes - -val nowarnings : bool ref - -val f : edit_window -> any widget list - (* Typechecks the window as much as possible *) diff --git a/otherlibs/labltk/browser/useunix.ml b/otherlibs/labltk/browser/useunix.ml deleted file mode 100644 index 4998bbd66c..0000000000 --- a/otherlibs/labltk/browser/useunix.ml +++ /dev/null @@ -1,69 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open UnixLabels - -let get_files_in_directory dir = - let len = String.length dir in - let dir = - if len > 0 && Sys.os_type = "Win32" && - (dir.[len-1] = '/' || dir.[len-1] = '\\') - then String.sub dir ~pos:0 ~len:(len-1) - else dir - in match - try Some(opendir dir) with Unix_error _ -> None - with - None -> [] - | Some dirh -> - let rec get_them l = - match - try Some(readdir dirh) with _ -> None - with - | Some x -> - get_them (x::l) - | None -> - closedir dirh; l - in - List.sort ~cmp:compare (get_them []) - -let is_directory name = - try - (stat name).st_kind = S_DIR - with _ -> false - -let concat dir name = - let len = String.length dir in - if len = 0 then name else - if dir.[len-1] = '/' then dir ^ name - else dir ^ "/" ^ name - -let get_directories_in_files ~path = - List.filter ~f:(fun x -> is_directory (concat path x)) - -(************************************************** Subshell call *) -let subshell ~cmd = - let rc = open_process_in cmd in - let rec it l = - match - try Some(input_line rc) with _ -> None - with - Some x -> it (x::l) - | None -> List.rev l - in - let answer = it [] in - ignore (close_process_in rc); - answer diff --git a/otherlibs/labltk/browser/useunix.mli b/otherlibs/labltk/browser/useunix.mli deleted file mode 100644 index 2850c0d2da..0000000000 --- a/otherlibs/labltk/browser/useunix.mli +++ /dev/null @@ -1,23 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -(* Unix utilities *) - -val get_files_in_directory : string -> string list -val is_directory : string -> bool -val concat : string -> string -> string -val get_directories_in_files : path:string -> string list -> string list -val subshell : cmd:string -> string list diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml deleted file mode 100644 index 2d21f42f00..0000000000 --- a/otherlibs/labltk/browser/viewer.ml +++ /dev/null @@ -1,636 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk -open Jg_tk -open Mytypes -open Longident -open Types -open Typedtree -open Env -open Searchpos -open Searchid - -(* Managing the module list *) - -let list_modules ~path = - List.fold_left path ~init:[] ~f: - begin fun modules dir -> - let l = - List.filter (Useunix.get_files_in_directory dir) - ~f:(fun x -> Filename.check_suffix x ".cmi") in - let l = List.map l ~f: - begin fun x -> - String.capitalize (Filename.chop_suffix x ".cmi") - end in - List.fold_left l ~init:modules - ~f:(fun modules item -> - if List.mem item modules then modules else item :: modules) - end - -let reset_modules box = - Listbox.delete box ~first:(`Num 0) ~last:`End; - 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) - - -(* How to display a symbol *) - -let view_symbol ~kind ~env ?path id = - let name = match id with - Lident x -> x - | Ldot (_, x) -> x - | _ -> match kind with Pvalue | Ptype | Plabel -> "z" | _ -> "Z" - in - match kind with - Pvalue -> - let path, vd = lookup_value id env in - view_signature_item ~path ~env [Tsig_value (Ident.create name, vd)] - | Ptype -> view_type_id id ~env - | Plabel -> let ld = lookup_label id env in - begin match ld.lbl_res.desc with - Tconstr (path, _, _) -> view_type_decl path ~env - | _ -> () - end - | Pconstructor -> - let cd = lookup_constructor id env in - begin match cd.cstr_res.desc with - Tconstr (cpath, _, _) -> - if Path.same cpath Predef.path_exn then - view_signature ~title:(string_of_longident id) ~env ?path - [Tsig_exception (Ident.create name, cd.cstr_args)] - else - view_type_decl cpath ~env - | _ -> () - end - | Pmodule -> view_module_id id ~env - | Pmodtype -> view_modtype_id id ~env - | Pclass -> view_class_id id ~env - | Pcltype -> view_cltype_id id ~env - - -(* Create a list of symbols you can choose from *) - -let choose_symbol ~title ~env ?signature ?path l = - if match path with - None -> false - | Some path -> is_shown_module path - then () else - let tl = Jg_toplevel.titled title in - Jg_bind.escape_destroy tl; - top_widgets := coe tl :: !top_widgets; - let buttons = Frame.create tl in - let all = Button.create buttons ~text:"Show all" ~padx:20 - and ok = Jg_button.create_destroyer tl ~parent:buttons - and detach = Button.create buttons ~text:"Detach" - and edit = Button.create buttons ~text:"Impl" - and intf = Button.create buttons ~text:"Intf" 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 ^ ")" - end in - let fb = Frame.create tl in - let box = - new Jg_multibox.c fb ~cols:3 ~texts:nl ~maxheight:3 ~width:21 in - box#init; - box#bind_kbd ~events:[`KeyPressDetail"Escape"] - ~action:(fun _ ~index -> destroy tl; break ()); - if List.length nl > 9 then ignore (Jg_multibox.add_scrollbar box); - Jg_multibox.add_completion box ~action: - begin fun pos -> - let li, k = List.nth l pos in - let path = - match path, li with - None, Ldot (lip, _) -> - begin try - Some (fst (lookup_module lip env)) - with Not_found -> None - end - | _ -> path - in view_symbol li ~kind:k ~env ?path - end; - pack [buttons] ~side:`Bottom ~fill:`X; - pack [fb] ~side:`Top ~fill:`Both ~expand:true; - begin match signature with - None -> pack [ok] ~fill:`X ~expand:true - | Some signature -> - Button.configure all ~command: - begin fun () -> - view_signature signature ~title ~env ?path - end; - pack [ok; all] ~side:`Right ~fill:`X ~expand:true - end; - begin match path with None -> () - | Some path -> - let frame = Frame.create tl in - pack [frame] ~side:`Bottom ~fill:`X; - add_shown_module path - ~widgets:{ mw_frame = frame; mw_title = None; mw_detach = detach; - mw_edit = edit; mw_intf = intf } - end - -let choose_symbol_ref = ref choose_symbol - - -(* Search, both by type and name *) - -let guess_search_mode s : [`Type | `Long | `Pattern] = - let is_type = ref false and is_long = ref false in - for i = 0 to String.length s - 2 do - if s.[i] = '-' && s.[i+1] = '>' then is_type := true; - if s.[i] = '.' then is_long := true - done; - if !is_type then `Type else if !is_long then `Long else `Pattern - - -let search_string ?(mode="symbol") ew = - let text = Entry.get ew in - try - if text = "" then () else - let l = match mode with - "Name" -> - begin match guess_search_mode text with - `Long -> search_string_symbol text - | `Pattern -> search_pattern_symbol text - | `Type -> search_string_type text ~mode:`Included - end - | "Type" -> search_string_type text ~mode:`Included - | "Exact" -> search_string_type text ~mode:`Exact - | _ -> assert false - in - match l with [] -> () - | [lid,kind] -> view_symbol lid ~kind ~env:!start_env - | l -> choose_symbol ~title:"Choose symbol" ~env:!start_env l - with Searchid.Error (s,e) -> - Entry.icursor ew ~index:(`Num s) - -let search_which = ref "Name" - -let search_symbol () = - if !module_list = [] then - 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 - let choice = Frame.create tl - and which = Textvariable.create ~on:tl () in - let itself = Radiobutton.create choice ~text:"Itself" - ~variable:which ~value:"Name" - and extype = Radiobutton.create choice ~text:"Exact type" - ~variable:which ~value:"Exact" - and iotype = Radiobutton.create choice ~text:"Included type" - ~variable:which ~value:"Type" - and buttons = Frame.create tl in - let search = Button.create buttons ~text:"Search" ~command: - begin fun () -> - search_which := Textvariable.get which; - search_string ew ~mode:!search_which - end - and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in - - Focus.set ew; - Jg_bind.return_invoke ew ~button:search; - Textvariable.set which !search_which; - pack [itself; extype; iotype] ~side:`Left ~anchor:`W; - pack [search; ok] ~side:`Left ~fill:`X ~expand:true; - pack [coe ew; coe choice; coe buttons] - ~side:`Top ~fill:`X ~expand:true - - -(* Display the contents of a module *) - -let ident_of_decl ~modlid = function - Tsig_value (id, _) -> Lident (Ident.name id), Pvalue - | Tsig_type (id, _) -> Lident (Ident.name id), Ptype - | Tsig_exception (id, _) -> Ldot (modlid, Ident.name id), Pconstructor - | Tsig_module (id, _) -> Lident (Ident.name id), Pmodule - | Tsig_modtype (id, _) -> Lident (Ident.name id), Pmodtype - | Tsig_class (id, _) -> Lident (Ident.name id), Pclass - | Tsig_cltype (id, _) -> Lident (Ident.name id), Pcltype - -let view_defined ~env ?(show_all=false) modlid = - try match lookup_module modlid env with path, Tmty_signature sign -> - let rec iter_sign sign idents = - match sign with - [] -> List.rev idents - | decl :: rem -> - let rem = match decl, rem with - Tsig_class _, cty :: ty1 :: ty2 :: rem -> rem - | Tsig_cltype _, ty1 :: ty2 :: rem -> rem - | _, rem -> rem - in iter_sign rem (ident_of_decl ~modlid decl :: idents) - in - let l = iter_sign sign [] in - let title = string_of_path path in - let env = open_signature path sign env in - !choose_symbol_ref l ~title ~signature:sign ~env ~path; - if show_all then view_signature sign ~title ~env ~path - | _ -> () - with Not_found -> () - | Env.Error err -> - let tl, tw, finish = Jg_message.formatted ~title:"Error!" () in - Env.report_error Format.std_formatter err; - finish () - - -(* Manage toplevel windows *) - -let close_all_views () = - List.iter !top_widgets - ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ()); - top_widgets := [] - - -(* Launch a shell *) - -let shell_counter = ref 1 -let default_shell = ref "ocaml" - -let start_shell master = - let tl = Jg_toplevel.titled "Start New Shell" in - Wm.transient_set tl ~master; - let input = Frame.create tl - and buttons = Frame.create tl in - let ok = Button.create buttons ~text:"Ok" - and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" - and labels = Frame.create input - and entries = Frame.create input in - let l1 = Label.create labels ~text:"Command:" - and l2 = Label.create labels ~text:"Title:" - and e1 = - Jg_entry.create entries ~command:(fun _ -> Button.invoke ok) - and e2 = - Jg_entry.create entries ~command:(fun _ -> Button.invoke ok) - and names = List.map ~f:fst (Shell.get_all ()) in - Entry.insert e1 ~index:`End ~text:!default_shell; - let shell_name () = "Shell #" ^ string_of_int !shell_counter in - while List.mem (shell_name ()) names do - incr shell_counter - done; - Entry.insert e2 ~index:`End ~text:(shell_name ()); - Button.configure ok ~command:(fun () -> - if not (List.mem (Entry.get e2) names) then begin - default_shell := Entry.get e1; - Shell.f ~prog:!default_shell ~title:(Entry.get e2); - destroy tl - end); - pack [l1;l2] ~side:`Top ~anchor:`W; - pack [e1;e2] ~side:`Top ~fill:`X ~expand:true; - pack [labels;entries] ~side:`Left ~fill:`X ~expand:true; - pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true; - pack [input;buttons] ~side:`Top ~fill:`X ~expand:true - - -(* Help window *) - -let show_help () = - let tl = Jg_toplevel.titled "OCamlBrowser Help" in - Jg_bind.escape_destroy tl; - let fw, tw, sb = Jg_text.create_with_scrollbar tl in - let ok = Jg_button.create_destroyer ~parent:tl ~text:"Ok" tl in - Text.insert tw ~index:tend ~text:Help.text; - Text.configure tw ~state:`Disabled; - Jg_bind.enter_focus tw; - pack [tw] ~side:`Left ~fill:`Both ~expand:true; - pack [sb] ~side:`Right ~fill:`Y; - pack [fw] ~side:`Top ~expand:true ~fill:`Both; - pack [ok] ~side:`Bottom ~fill:`X - -(* Launch the classical viewer *) - -let f ?(dir=Unix.getcwd()) ?on () = - let tl = match on with - None -> - let tl = Jg_toplevel.titled "Module viewer" in - ignore (Jg_bind.escape_destroy tl); coe tl - | Some top -> - Wm.title_set top "OCamlBrowser"; - Wm.iconname_set top "OCamlBrowser"; - let tl = Frame.create top in - bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0); - pack [tl] ~expand:true ~fill:`Both; - coe tl - in - let menus = Frame.create tl ~name:"menubar" in - let filemenu = new Jg_menu.c "File" ~parent:menus - and modmenu = new Jg_menu.c "Modules" ~parent:menus in - let fmbox, mbox, msb = Jg_box.create_with_scrollbar tl in - - Jg_box.add_completion mbox ~nocase:true ~action: - begin fun index -> - view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env - end; - Setpath.add_update_hook (fun () -> reset_modules mbox); - - let ew = Entry.create tl in - let buttons = Frame.create tl in - let search = Button.create buttons ~text:"Search" ~pady:1 - ~command:(fun () -> search_string ew) - and close = - Button.create buttons ~text:"Close all" ~pady:1 ~command:close_all_views - in - (* bindings *) - Jg_bind.enter_focus ew; - Jg_bind.return_invoke ew ~button:search; - bind close ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~action:(fun _ -> destroy tl); - - (* File menu *) - filemenu#add_command "Open..." - ~command:(fun () -> !editor_ref ~opendialog:true ()); - filemenu#add_command "Editor..." ~command:(fun () -> !editor_ref ()); - filemenu#add_command "Shell..." ~command:(fun () -> start_shell tl); - filemenu#add_command "Quit" ~command:(fun () -> destroy tl); - - (* modules menu *) - modmenu#add_command "Path editor..." - ~command:(fun () -> Setpath.set ~dir); - modmenu#add_command "Reset cache" - ~command:(fun () -> reset_modules mbox; Env.reset_cache ()); - modmenu#add_command "Search symbol..." ~command:search_symbol; - - pack [filemenu#button; modmenu#button] ~side:`Left ~ipadx:5 ~anchor:`W; - pack [menus] ~side:`Top ~fill:`X; - pack [close; search] ~fill:`X ~side:`Right ~expand:true; - pack [coe buttons; coe ew] ~fill:`X ~side:`Bottom; - pack [msb] ~side:`Right ~fill:`Y; - pack [mbox] ~side:`Left ~fill:`Both ~expand:true; - pack [fmbox] ~fill:`Both ~expand:true ~side:`Top; - reset_modules mbox - -(* Smalltalk-like version *) - -class st_viewer ?(dir=Unix.getcwd()) ?on () = - let tl = match on with - None -> - let tl = Jg_toplevel.titled "Module viewer" in - ignore (Jg_bind.escape_destroy tl); coe tl - | Some top -> - Wm.title_set top "OCamlBrowser"; - Wm.iconname_set top "OCamlBrowser"; - let tl = Frame.create top in - bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0); - pack [tl] ~expand:true ~fill:`Both; - coe tl - in - let menus = Frame.create tl ~name:"menubar" in - let filemenu = new Jg_menu.c "File" ~parent:menus - and modmenu = new Jg_menu.c "Modules" ~parent:menus - and viewmenu = new Jg_menu.c "View" ~parent:menus - and helpmenu = new Jg_menu.c "Help" ~parent:menus in - let search_frame = Frame.create tl in - let boxes_frame = Frame.create tl ~name:"boxes" in - let label = Label.create tl ~anchor:`W ~padx:5 in - let view = Frame.create tl in - let buttons = Frame.create tl in - let all = Button.create buttons ~text:"Show all" ~padx:20 - and close = Button.create buttons ~text:"Close all" ~command:close_all_views - and detach = Button.create buttons ~text:"Detach" - and edit = Button.create buttons ~text:"Impl" - and intf = Button.create buttons ~text:"Intf" in -object (self) - val mutable boxes = [] - val mutable show_all = fun () -> () - - method create_box = - let fmbox, mbox, sb = Jg_box.create_with_scrollbar boxes_frame in - bind mbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~action:(fun _ -> show_all ()); - bind mbox ~events:[`Modified([`Double], `KeyPressDetail "Return")] - ~action:(fun _ -> show_all ()); - boxes <- boxes @ [fmbox, mbox]; - pack [sb] ~side:`Right ~fill:`Y; - pack [mbox] ~side:`Left ~fill:`Both ~expand:true; - pack [fmbox] ~side:`Left ~fill:`Both ~expand:true; - fmbox, mbox - - initializer - (* Search *) - let ew = Entry.create search_frame - and searchtype = Textvariable.create ~on:tl () in - bind ew ~events:[`KeyPressDetail "Return"] ~action: - (fun _ -> search_string ew ~mode:(Textvariable.get searchtype)); - Jg_bind.enter_focus ew; - let search_button ?value text = - Radiobutton.create search_frame - ~text ~variable:searchtype ~value:text in - let symbol = search_button "Name" - and atype = search_button "Type" in - Radiobutton.select symbol; - pack [Label.create search_frame ~text:"Search"] ~side:`Left ~ipadx:5; - pack [ew] ~fill:`X ~expand:true ~side:`Left; - pack [Label.create search_frame ~text:"by"] ~side:`Left ~ipadx:5; - pack [symbol; atype] ~side:`Left; - pack [Label.create search_frame] ~side:`Right - - initializer - (* Boxes *) - let fmbox, mbox = self#create_box in - Jg_box.add_completion mbox ~nocase:true ~double:false ~action: - begin fun index -> - view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env - end; - Setpath.add_update_hook (fun () -> reset_modules mbox; self#hide_after 1); - List.iter [1;2] ~f:(fun _ -> ignore self#create_box); - Searchpos.default_frame := Some - { mw_frame = view; mw_title = Some label; - mw_detach = detach; mw_edit = edit; mw_intf = intf }; - Searchpos.set_path := self#set_path; - - (* Buttons *) - pack [close] ~side:`Right ~fill:`X ~expand:true; - bind close ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~action:(fun _ -> destroy tl); - - (* File menu *) - filemenu#add_command "Open..." - ~command:(fun () -> !editor_ref ~opendialog:true ()); - filemenu#add_command "Editor..." ~command:(fun () -> !editor_ref ()); - filemenu#add_command "Shell..." ~command:(fun () -> start_shell tl); - filemenu#add_command "Quit" ~command:(fun () -> destroy tl); - - (* View menu *) - viewmenu#add_command "Show all defs" ~command:(fun () -> show_all ()); - let show_search = Textvariable.create ~on:tl () in - Textvariable.set show_search "1"; - Menu.add_checkbutton viewmenu#menu ~label:"Search Entry" - ~variable:show_search ~indicatoron:true ~state:`Active - ~command: - begin fun () -> - let v = Textvariable.get show_search in - if v = "1" then begin - pack [search_frame] ~after:menus ~fill:`X - end else Pack.forget [search_frame] - end; - - (* modules menu *) - modmenu#add_command "Path editor..." - ~command:(fun () -> Setpath.set ~dir); - modmenu#add_command "Reset cache" - ~command:(fun () -> reset_modules mbox; Env.reset_cache ()); - modmenu#add_command "Search symbol..." ~command:search_symbol; - - (* Help menu *) - helpmenu#add_command "Manual..." ~command:show_help; - - pack [filemenu#button; viewmenu#button; modmenu#button] - ~side:`Left ~ipadx:5 ~anchor:`W; - pack [helpmenu#button] ~side:`Right ~anchor:`E ~ipadx:5; - pack [menus] ~fill:`X; - pack [search_frame] ~fill:`X; - pack [boxes_frame] ~fill:`Both ~expand:true; - pack [buttons] ~fill:`X ~side:`Bottom; - pack [view] ~fill:`Both ~side:`Bottom ~expand:true; - reset_modules mbox - - val mutable shown_paths = [] - - method hide_after n = - for i = n to List.length boxes - 1 do - let fm, box = List.nth boxes i in - if i < 3 then Listbox.delete box ~first:(`Num 0) ~last:`End - else destroy fm - done; - let rec firsts n = function [] -> [] - | a :: l -> if n > 0 then a :: firsts (pred n) l else [] in - shown_paths <- firsts (n-1) shown_paths; - boxes <- firsts (max 3 n) boxes - - method get_box ~path = - let rec path_index p = function - [] -> raise Not_found - | a :: l -> if Path.same p a then 1 else path_index p l + 1 in - try - let n = path_index path shown_paths in - self#hide_after (n+1); - n - with Not_found -> - match path with - Path.Pdot (path', _, _) -> - let n = self#get_box ~path:path' in - shown_paths <- shown_paths @ [path]; - if n + 1 >= List.length boxes then ignore self#create_box; - n+1 - | _ -> - self#hide_after 2; - shown_paths <- [path]; - 1 - - method set_path path ~sign = - let rec path_elems l path = - match path with - Path.Pdot (path, _, _) -> path_elems (path::l) path - | _ -> [] - in - let path_elems path = - match path with - | Path.Pident _ -> [path] - | _ -> path_elems [] path - in - let see_path ~box:n ?(sign=[]) path = - let (_, box) = List.nth boxes n in - let texts = Listbox.get_range box ~first:(`Num 0) ~last:`End in - let rec index s = function - [] -> raise Not_found - | a :: l -> if a = s then 0 else 1 + index s l - in - try - let modlid, s = - match path with - Path.Pdot (p, s, _) -> longident_of_path p, s - | Path.Pident i -> Longident.Lident "M", Ident.name i - | _ -> assert false - in - let li, k = - if sign = [] then Longident.Lident s, Pmodule else - ident_of_decl ~modlid (List.hd sign) in - let s = - if n = 0 then string_of_longident li else - string_of_longident li ^ " (" ^ string_of_kind k ^ ")" in - let n = index s texts in - Listbox.see box (`Num n); - Listbox.activate box (`Num n) - with Not_found -> () - in - let l = path_elems path in - if l <> [] then begin - List.iter l ~f: - begin fun path -> - if not (List.mem path shown_paths) then - view_symbol (longident_of_path path) ~kind:Pmodule - ~env:Env.initial ~path; - let n = self#get_box path - 1 in - see_path path ~box:n - end; - see_path path ~box:(self#get_box path) ~sign - end - - method choose_symbol ~title ~env ?signature ?path l = - let n = - match path with None -> 1 - | Some path -> self#get_box ~path - 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 ^ ")" - end in - let _, box = List.nth boxes n in - Listbox.delete box ~first:(`Num 0) ~last:`End; - Listbox.insert box ~index:`End ~texts:nl; - - let current = ref None in - let display index = - let `Num pos = Listbox.index box ~index in - try - let li, k = List.nth l pos in - self#hide_after (n+1); - if !current = Some (li,k) then () else - let path = - match path, li with - None, Ldot (lip, _) -> - begin try - Some (fst (lookup_module lip env)) - with Not_found -> None - end - | _ -> path - in - current := Some (li,k); - view_symbol li ~kind:k ~env ?path - with Failure "nth" -> () - in - Jg_box.add_completion box ~double:false ~action:display; - bind box ~events:[`KeyRelease] ~fields:[`Char] - ~action:(fun ev -> display `Active); - - begin match signature with - None -> () - | Some signature -> - show_all <- - begin fun () -> - current := None; - view_signature signature ~title ~env ?path - end - end -end - -let st_viewer ?dir ?on () = - let viewer = new st_viewer ?dir ?on () in - choose_symbol_ref := viewer#choose_symbol diff --git a/otherlibs/labltk/browser/viewer.mli b/otherlibs/labltk/browser/viewer.mli deleted file mode 100644 index d8bec671df..0000000000 --- a/otherlibs/labltk/browser/viewer.mli +++ /dev/null @@ -1,31 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -(* Module viewer *) -open Widget - -val search_symbol : unit -> unit - (* search a symbol in all modules in the path *) - -val f : ?dir:string -> ?on:toplevel widget -> unit -> unit - (* open then module viewer *) -val st_viewer : ?dir:string -> ?on:toplevel widget -> unit -> unit - (* one-box viewer *) - -val view_defined : env:Env.t -> ?show_all:bool -> Longident.t -> unit - (* displays a signature, found in environment *) - -val close_all_views : unit -> unit diff --git a/otherlibs/labltk/browser/winmain.c b/otherlibs/labltk/browser/winmain.c deleted file mode 100644 index d36f6786f9..0000000000 --- a/otherlibs/labltk/browser/winmain.c +++ /dev/null @@ -1,18 +0,0 @@ -#include <windows.h> -#include <mlvalues.h> -#include <callback.h> -#include <sys.h> - -extern int __argc; -extern char **__argv; -extern void expand_command_line(int * argcp, char *** argvp); -extern void caml_main (char **); - -int WINAPI WinMain(HINSTANCE h, HINSTANCE HPrevInstance, - LPSTR lpCmdLine, int nCmdShow) -{ - expand_command_line(&__argc, &__argv); - caml_main(__argv); - sys_exit(Val_int(0)); - return 0; -} diff --git a/otherlibs/labltk/builtin/LICENSE b/otherlibs/labltk/builtin/LICENSE deleted file mode 100644 index c006f51d5c..0000000000 --- a/otherlibs/labltk/builtin/LICENSE +++ /dev/null @@ -1,19 +0,0 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -All the files in this directory are subject to the above copyright notice.
\ No newline at end of file diff --git a/otherlibs/labltk/builtin/builtin_FilePattern.ml b/otherlibs/labltk/builtin/builtin_FilePattern.ml deleted file mode 100644 index f7dd1d60e6..0000000000 --- a/otherlibs/labltk/builtin/builtin_FilePattern.ml +++ /dev/null @@ -1,20 +0,0 @@ -(* File patterns *) -(* type *) -type filePattern = { - typename : string; - extensions : string list; - mactypes : string list - } -(* /type *) - -let cCAMLtoTKfilePattern fp = - let typename = TkQuote (TkToken fp.typename) in - let extensions = - TkQuote (TkTokenList (List.map (fun x -> TkToken x) fp.extensions)) in - let mactypes = - match fp.mactypes with - | [] -> [] - | [s] -> [TkToken s] - | _ -> [TkQuote (TkTokenList (List.map (fun x -> TkToken x) fp.mactypes))] - in - TkQuote (TkTokenList (typename :: extensions :: mactypes)) diff --git a/otherlibs/labltk/builtin/builtin_GetBitmap.ml b/otherlibs/labltk/builtin/builtin_GetBitmap.ml deleted file mode 100644 index bf02d20f86..0000000000 --- a/otherlibs/labltk/builtin/builtin_GetBitmap.ml +++ /dev/null @@ -1,22 +0,0 @@ -(* Tk_GetBitmap emulation *) - -##ifdef CAMLTK - -(* type *) -type bitmap = - | BitmapFile of string (* path of file *) - | Predefined of string (* bitmap name *) -;; -(* /type *) - -##else - -(* type *) -type bitmap = [ - | `File of string (* path of file *) - | `Predefined of string (* bitmap name *) -] -;; -(* /type *) - -##endif diff --git a/otherlibs/labltk/builtin/builtin_GetCursor.ml b/otherlibs/labltk/builtin/builtin_GetCursor.ml deleted file mode 100644 index 6c7034b166..0000000000 --- a/otherlibs/labltk/builtin/builtin_GetCursor.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* Color *) - -##ifdef CAMLTK - -(* type *) -type color = - | NamedColor of string - | Black (* tk keyword: black *) - | White (* tk keyword: white *) - | Red (* tk keyword: red *) - | Green (* tk keyword: green *) - | Blue (* tk keyword: blue *) - | Yellow (* tk keyword: yellow *) -;; -(* /type *) - -##else - -(* type *) -type color = [ - | `Color of string - | `Black (* tk keyword: black *) - | `White (* tk keyword: white *) - | `Red (* tk keyword: red *) - | `Green (* tk keyword: green *) - | `Blue (* tk keyword: blue *) - | `Yellow (* tk keyword: yellow *) -] -;; -(* /type *) - -##endif - -##ifdef CAMLTK - -(* type *) -type cursor = - | XCursor of string - | XCursorFg of string * color - | XCursortFgBg of string * color * color - | CursorFileFg of string * color - | CursorMaskFile of string * string * color * color -;; -(* /type *) - -##else - -(* Tk_GetCursor emulation *) -(* type *) -type cursor = [ - | `Xcursor of string - | `Xcursorfg of string * color - | `Xcursorfgbg of string * color * color - | `Cursorfilefg of string * color - | `Cursormaskfile of string * string * color * color -] -;; -(* /type *) - -##endif - diff --git a/otherlibs/labltk/builtin/builtin_GetPixel.ml b/otherlibs/labltk/builtin/builtin_GetPixel.ml deleted file mode 100644 index 772a2c2842..0000000000 --- a/otherlibs/labltk/builtin/builtin_GetPixel.ml +++ /dev/null @@ -1,28 +0,0 @@ -(* Tk_GetPixels emulation *) - -##ifdef CAMLTK - -(* type *) -type units = - | Pixels of int (* specified as floating-point, but inconvenient *) - | Centimeters of float - | Inches of float - | Millimeters of float - | PrinterPoint of float -;; -(* /type *) - -##else - -(* type *) -type units = [ - | `Pix of int - | `Cm of float - | `In of float - | `Mm of float - | `Pt of float -] -;; -(* /type *) - -##endif diff --git a/otherlibs/labltk/builtin/builtin_ScrollValue.ml b/otherlibs/labltk/builtin/builtin_ScrollValue.ml deleted file mode 100644 index 75a509e69a..0000000000 --- a/otherlibs/labltk/builtin/builtin_ScrollValue.ml +++ /dev/null @@ -1,22 +0,0 @@ -##ifdef CAMLTK - -(* type *) -type scrollValue = - | ScrollPage of int (* tk option: scroll <int> page *) - | ScrollUnit of int (* tk option: scroll <int> unit *) - | MoveTo of float (* tk option: moveto <float> *) -;; -(* /type *) - -##else - -(* type *) -type scrollValue = [ - | `Page of int (* tk option: scroll <int> page *) - | `Unit of int (* tk option: scroll <int> unit *) - | `Moveto of float (* tk option: moveto <float> *) -] -;; -(* /type *) - -##endif diff --git a/otherlibs/labltk/builtin/builtin_bind.ml b/otherlibs/labltk/builtin/builtin_bind.ml deleted file mode 100644 index 35d0d3c1a4..0000000000 --- a/otherlibs/labltk/builtin/builtin_bind.ml +++ /dev/null @@ -1,469 +0,0 @@ -##ifdef CAMLTK - -open Widget;; - -(* Events and bindings *) -(* Builtin types *) -(* type *) -type xEvent = - | Activate - | ButtonPress (* also Button, but we omit it *) - | ButtonPressDetail of int - | ButtonRelease - | ButtonReleaseDetail of int - | Circulate - | ColorMap (* not Colormap, avoiding confusion between the Colormap option *) - | Configure - | Deactivate - | Destroy - | Enter - | Expose - | FocusIn - | FocusOut - | Gravity - | KeyPress (* also Key, but we omit it *) - | KeyPressDetail of string (* /usr/include/X11/keysymdef.h *) - | KeyRelease - | KeyReleaseDetail of string - | Leave - | Map - | Motion - | Property - | Reparent - | Unmap - | Visibility - | Virtual of string (* Virtual event. Must be without modifiers *) -;; -(* /type *) - -(* type *) -type modifier = - | Control - | Shift - | Lock - | Button1 - | Button2 - | Button3 - | Button4 - | Button5 - | Double - | Triple - | Mod1 - | Mod2 - | Mod3 - | Mod4 - | Mod5 - | Meta - | Alt -;; -(* /type *) - -(* Event structure, passed to bounded functions *) - -(* type *) -type eventInfo = - { - (* %# : event serial number is unsupported *) - mutable ev_Above : int; (* tk: %a *) - mutable ev_ButtonNumber : int; (* tk: %b *) - mutable ev_Count : int; (* tk: %c *) - mutable ev_Detail : string; (* tk: %d *) - mutable ev_Focus : bool; (* tk: %f *) - mutable ev_Height : int; (* tk: %h *) - mutable ev_KeyCode : int; (* tk: %k *) - mutable ev_Mode : string; (* tk: %m *) - mutable ev_OverrideRedirect : bool; (* tk: %o *) - mutable ev_Place : string; (* tk: %p *) - mutable ev_State : string; (* tk: %s *) - mutable ev_Time : int; (* tk: %t *) - mutable ev_Width : int; (* tk: %w *) - mutable ev_MouseX : int; (* tk: %x *) - mutable ev_MouseY : int; (* tk: %y *) - mutable ev_Char : string; (* tk: %A *) - mutable ev_BorderWidth : int; (* tk: %B *) - mutable ev_SendEvent : bool; (* tk: %E *) - mutable ev_KeySymString : string; (* tk: %K *) - mutable ev_KeySymInt : int; (* tk: %N *) - mutable ev_RootWindow : int; (* tk: %R *) - mutable ev_SubWindow : int; (* tk: %S *) - mutable ev_Type : int; (* tk: %T *) - mutable ev_Widget : widget; (* tk: %W *) - mutable ev_RootX : int; (* tk: %X *) - mutable ev_RootY : int (* tk: %Y *) - } -;; -(* /type *) - - -(* To avoid collision with other constructors (Width, State), - use Ev_ prefix *) -(* type *) -type eventField = - | Ev_Above - | Ev_ButtonNumber - | Ev_Count - | Ev_Detail - | Ev_Focus - | Ev_Height - | Ev_KeyCode - | Ev_Mode - | Ev_OverrideRedirect - | Ev_Place - | Ev_State - | Ev_Time - | Ev_Width - | Ev_MouseX - | Ev_MouseY - | Ev_Char - | Ev_BorderWidth - | Ev_SendEvent - | Ev_KeySymString - | Ev_KeySymInt - | Ev_RootWindow - | Ev_SubWindow - | Ev_Type - | Ev_Widget - | Ev_RootX - | Ev_RootY -;; -(* /type *) - -let filleventInfo ev v = function - | Ev_Above -> ev.ev_Above <- int_of_string v - | Ev_ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v - | Ev_Count -> ev.ev_Count <- int_of_string v - | Ev_Detail -> ev.ev_Detail <- v - | Ev_Focus -> ev.ev_Focus <- v = "1" - | Ev_Height -> ev.ev_Height <- int_of_string v - | Ev_KeyCode -> ev.ev_KeyCode <- int_of_string v - | Ev_Mode -> ev.ev_Mode <- v - | Ev_OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1" - | Ev_Place -> ev.ev_Place <- v - | Ev_State -> ev.ev_State <- v - | Ev_Time -> ev.ev_Time <- int_of_string v - | Ev_Width -> ev.ev_Width <- int_of_string v - | Ev_MouseX -> ev.ev_MouseX <- int_of_string v - | Ev_MouseY -> ev.ev_MouseY <- int_of_string v - | Ev_Char -> ev.ev_Char <- v - | Ev_BorderWidth -> ev.ev_BorderWidth <- int_of_string v - | Ev_SendEvent -> ev.ev_SendEvent <- v = "1" - | Ev_KeySymString -> ev.ev_KeySymString <- v - | Ev_KeySymInt -> ev.ev_KeySymInt <- int_of_string v - | Ev_RootWindow -> ev.ev_RootWindow <- int_of_string v - | Ev_SubWindow -> ev.ev_SubWindow <- int_of_string v - | Ev_Type -> ev.ev_Type <- int_of_string v - | Ev_Widget -> ev.ev_Widget <- cTKtoCAMLwidget v - | Ev_RootX -> ev.ev_RootX <- int_of_string v - | Ev_RootY -> ev.ev_RootY <- int_of_string v -;; - -let wrapeventInfo f what = - let ev = { - ev_Above = 0; - ev_ButtonNumber = 0; - ev_Count = 0; - ev_Detail = ""; - ev_Focus = false; - ev_Height = 0; - ev_KeyCode = 0; - ev_Mode = ""; - ev_OverrideRedirect = false; - ev_Place = ""; - ev_State = ""; - ev_Time = 0; - ev_Width = 0; - ev_MouseX = 0; - ev_MouseY = 0; - ev_Char = ""; - ev_BorderWidth = 0; - ev_SendEvent = false; - ev_KeySymString = ""; - ev_KeySymInt = 0; - ev_RootWindow = 0; - ev_SubWindow = 0; - ev_Type = 0; - ev_Widget = Widget.default_toplevel; - ev_RootX = 0; - ev_RootY = 0 } in - function args -> - let l = ref args in - List.iter (function field -> - match !l with - [] -> () - | v::rest -> filleventInfo ev v field; l:=rest) - what; - f ev -;; - -let rec writeeventField = function - | [] -> "" - | field::rest -> - begin - match field with - | Ev_Above -> " %a" - | Ev_ButtonNumber ->" %b" - | Ev_Count -> " %c" - | Ev_Detail -> " %d" - | Ev_Focus -> " %f" - | Ev_Height -> " %h" - | Ev_KeyCode -> " %k" - | Ev_Mode -> " %m" - | Ev_OverrideRedirect -> " %o" - | Ev_Place -> " %p" - | Ev_State -> " %s" - | Ev_Time -> " %t" - | Ev_Width -> " %w" - | Ev_MouseX -> " %x" - | Ev_MouseY -> " %y" - (* Quoting is done by Tk *) - | Ev_Char -> " %A" - | Ev_BorderWidth -> " %B" - | Ev_SendEvent -> " %E" - | Ev_KeySymString -> " %K" - | Ev_KeySymInt -> " %N" - | Ev_RootWindow ->" %R" - | Ev_SubWindow -> " %S" - | Ev_Type -> " %T" - | Ev_Widget ->" %W" - | Ev_RootX -> " %X" - | Ev_RootY -> " %Y" - end - ^ writeeventField rest -;; - -##else - -open Widget;; - -(* Events and bindings *) -(* Builtin types *) - -(* type *) -type event = [ - | `Activate - | `ButtonPress (* also Button, but we omit it *) - | `ButtonPressDetail of int - | `ButtonRelease - | `ButtonReleaseDetail of int - | `Circulate - | `Colormap - | `Configure - | `Deactivate - | `Destroy - | `Enter - | `Expose - | `FocusIn - | `FocusOut - | `Gravity - | `KeyPress (* also Key, but we omit it *) - | `KeyPressDetail of string (* /usr/include/X11/keysymdef.h *) - | `KeyRelease - | `KeyReleaseDetail of string - | `Leave - | `Map - | `Motion - | `Property - | `Reparent - | `Unmap - | `Visibility - | `Virtual of string (* Virtual event. Must be without modifiers *) - | `Modified of modifier list * event -] - -and modifier = [ - | `Control - | `Shift - | `Lock - | `Button1 - | `Button2 - | `Button3 - | `Button4 - | `Button5 - | `Double - | `Triple - | `Mod1 - | `Mod2 - | `Mod3 - | `Mod4 - | `Mod5 - | `Meta - | `Alt -] -;; -(* /type *) - -(* Event structure, passed to bounded functions *) - -(* type *) -type eventInfo = { - (* %# : event serial number is unsupported *) - mutable ev_Above : int; (* tk: %a *) - mutable ev_ButtonNumber : int; (* tk: %b *) - mutable ev_Count : int; (* tk: %c *) - mutable ev_Detail : string; (* tk: %d *) - mutable ev_Focus : bool; (* tk: %f *) - mutable ev_Height : int; (* tk: %h *) - mutable ev_KeyCode : int; (* tk: %k *) - mutable ev_Mode : string; (* tk: %m *) - mutable ev_OverrideRedirect : bool; (* tk: %o *) - mutable ev_Place : string; (* tk: %p *) - mutable ev_State : string; (* tk: %s *) - mutable ev_Time : int; (* tk: %t *) - mutable ev_Width : int; (* tk: %w *) - mutable ev_MouseX : int; (* tk: %x *) - mutable ev_MouseY : int; (* tk: %y *) - mutable ev_Char : string; (* tk: %A *) - mutable ev_BorderWidth : int; (* tk: %B *) - mutable ev_SendEvent : bool; (* tk: %E *) - mutable ev_KeySymString : string; (* tk: %K *) - mutable ev_KeySymInt : int; (* tk: %N *) - mutable ev_RootWindow : int; (* tk: %R *) - mutable ev_SubWindow : int; (* tk: %S *) - mutable ev_Type : int; (* tk: %T *) - mutable ev_Widget : any widget; (* tk: %W *) - mutable ev_RootX : int; (* tk: %X *) - mutable ev_RootY : int (* tk: %Y *) - } -;; -(* /type *) - - -(* To avoid collision with other constructors (Width, State), - use Ev_ prefix *) -(* type *) -type eventField = [ - | `Above - | `ButtonNumber - | `Count - | `Detail - | `Focus - | `Height - | `KeyCode - | `Mode - | `OverrideRedirect - | `Place - | `State - | `Time - | `Width - | `MouseX - | `MouseY - | `Char - | `BorderWidth - | `SendEvent - | `KeySymString - | `KeySymInt - | `RootWindow - | `SubWindow - | `Type - | `Widget - | `RootX - | `RootY -] -;; -(* /type *) - -let filleventInfo ev v : eventField -> unit = function - | `Above -> ev.ev_Above <- int_of_string v - | `ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v - | `Count -> ev.ev_Count <- int_of_string v - | `Detail -> ev.ev_Detail <- v - | `Focus -> ev.ev_Focus <- v = "1" - | `Height -> ev.ev_Height <- int_of_string v - | `KeyCode -> ev.ev_KeyCode <- int_of_string v - | `Mode -> ev.ev_Mode <- v - | `OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1" - | `Place -> ev.ev_Place <- v - | `State -> ev.ev_State <- v - | `Time -> ev.ev_Time <- int_of_string v - | `Width -> ev.ev_Width <- int_of_string v - | `MouseX -> ev.ev_MouseX <- int_of_string v - | `MouseY -> ev.ev_MouseY <- int_of_string v - | `Char -> ev.ev_Char <- v - | `BorderWidth -> ev.ev_BorderWidth <- int_of_string v - | `SendEvent -> ev.ev_SendEvent <- v = "1" - | `KeySymString -> ev.ev_KeySymString <- v - | `KeySymInt -> ev.ev_KeySymInt <- int_of_string v - | `RootWindow -> ev.ev_RootWindow <- int_of_string v - | `SubWindow -> ev.ev_SubWindow <- int_of_string v - | `Type -> ev.ev_Type <- int_of_string v - | `Widget -> ev.ev_Widget <- cTKtoCAMLwidget v - | `RootX -> ev.ev_RootX <- int_of_string v - | `RootY -> ev.ev_RootY <- int_of_string v -;; - -let wrapeventInfo f (what : eventField list) = - let ev = { - ev_Above = 0; - ev_ButtonNumber = 0; - ev_Count = 0; - ev_Detail = ""; - ev_Focus = false; - ev_Height = 0; - ev_KeyCode = 0; - ev_Mode = ""; - ev_OverrideRedirect = false; - ev_Place = ""; - ev_State = ""; - ev_Time = 0; - ev_Width = 0; - ev_MouseX = 0; - ev_MouseY = 0; - ev_Char = ""; - ev_BorderWidth = 0; - ev_SendEvent = false; - ev_KeySymString = ""; - ev_KeySymInt = 0; - ev_RootWindow = 0; - ev_SubWindow = 0; - ev_Type = 0; - ev_Widget = forget_type default_toplevel; - ev_RootX = 0; - ev_RootY = 0 } in - function args -> - let l = ref args in - List.iter what ~f: - begin fun field -> - match !l with - | [] -> () - | v :: rest -> filleventInfo ev v field; l := rest - end; - f ev -;; - -let rec writeeventField : eventField list -> string = function - | [] -> "" - | field :: rest -> - begin - match field with - | `Above -> " %a" - | `ButtonNumber ->" %b" - | `Count -> " %c" - | `Detail -> " %d" - | `Focus -> " %f" - | `Height -> " %h" - | `KeyCode -> " %k" - | `Mode -> " %m" - | `OverrideRedirect -> " %o" - | `Place -> " %p" - | `State -> " %s" - | `Time -> " %t" - | `Width -> " %w" - | `MouseX -> " %x" - | `MouseY -> " %y" - (* Quoting is done by Tk *) - | `Char -> " %A" - | `BorderWidth -> " %B" - | `SendEvent -> " %E" - | `KeySymString -> " %K" - | `KeySymInt -> " %N" - | `RootWindow ->" %R" - | `SubWindow -> " %S" - | `Type -> " %T" - | `Widget -> " %W" - | `RootX -> " %X" - | `RootY -> " %Y" - end - ^ writeeventField rest -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtin_bindtags.ml b/otherlibs/labltk/builtin/builtin_bindtags.ml deleted file mode 100644 index 4529fcdfea..0000000000 --- a/otherlibs/labltk/builtin/builtin_bindtags.ml +++ /dev/null @@ -1,21 +0,0 @@ -##ifdef CAMLTK - -(* type *) -type bindings = - | TagBindings of string (* tk option: <string> *) - | WidgetBindings of widget (* tk option: <widget> *) -;; -(* /type *) - -##else - -(* type *) -type bindings = [ - | `Tag of string (* tk option: <string> *) - | `Widget of any widget (* tk option: <widget> *) -] -;; -(* /type *) - -##endif - diff --git a/otherlibs/labltk/builtin/builtin_font.ml b/otherlibs/labltk/builtin/builtin_font.ml deleted file mode 100644 index 3425391bbf..0000000000 --- a/otherlibs/labltk/builtin/builtin_font.ml +++ /dev/null @@ -1,4 +0,0 @@ -(* type *) -type font = string -(* /type *) - diff --git a/otherlibs/labltk/builtin/builtin_grab.ml b/otherlibs/labltk/builtin/builtin_grab.ml deleted file mode 100644 index 256926821d..0000000000 --- a/otherlibs/labltk/builtin/builtin_grab.ml +++ /dev/null @@ -1,3 +0,0 @@ -(* type *) -type grabGlobal = bool -(* /type *) diff --git a/otherlibs/labltk/builtin/builtin_index.ml b/otherlibs/labltk/builtin/builtin_index.ml deleted file mode 100644 index a42af55390..0000000000 --- a/otherlibs/labltk/builtin/builtin_index.ml +++ /dev/null @@ -1,92 +0,0 @@ -(* Various indexes - canvas - entry - listbox -*) - -##ifdef CAMLTK - -(* A large type for all indices in all widgets *) -(* a bit overkill though *) - -(* type *) -type index = - | Number of int (* no keyword *) - | ActiveElement (* tk keyword: active *) - | End (* tk keyword: end *) - | Last (* tk keyword: last *) - | NoIndex (* tk keyword: none *) - | Insert (* tk keyword: insert *) - | SelFirst (* tk keyword: sel.first *) - | SelLast (* tk keyword: sel.last *) - | At of int (* tk keyword: @n *) - | AtXY of int * int (* tk keyword: @x,y *) - | AnchorPoint (* tk keyword: anchor *) - | Pattern of string (* no keyword *) - | LineChar of int * int (* tk keyword: l.c *) - | Mark of string (* no keyword *) - | TagFirst of string (* tk keyword: tag.first *) - | TagLast of string (* tk keyword: tag.last *) - | Embedded of widget (* no keyword *) -;; -(* /type *) - -##else - -type canvas_index = [ - | `Num of int - | `End - | `Insert - | `Selfirst - | `Sellast - | `Atxy of int * int -] -;; - -type entry_index = [ - | `Num of int - | `End - | `Insert - | `Selfirst - | `Sellast - | `At of int - | `Anchor -] -;; - -type listbox_index = [ - | `Num of int - | `Active - | `Anchor - | `End - | `Atxy of int * int -] -;; - -type menu_index = [ - | `Num of int - | `Active - | `End - | `Last - | `None - | `At of int - | `Pattern of string -] -;; - -type text_index = [ - | `Linechar of int * int - | `Atxy of int * int - | `End - | `Mark of string - | `Tagfirst of string - | `Taglast of string - | `Window of any widget - | `Image of string -] -;; - -type linechar_index = int * int;; -type num_index = int;; - -##endif diff --git a/otherlibs/labltk/builtin/builtin_palette.ml b/otherlibs/labltk/builtin/builtin_palette.ml deleted file mode 100644 index 4eab69a0f9..0000000000 --- a/otherlibs/labltk/builtin/builtin_palette.ml +++ /dev/null @@ -1,20 +0,0 @@ -##ifdef CAMLTK - -(* type *) -type paletteType = - | GrayShades of int - | RGBShades of int * int * int -;; -(* /type *) - -##else - -(* type *) -type paletteType = [ - | `Gray of int - | `Rgb of int * int * int -] -;; -(* /type *) - -##endif diff --git a/otherlibs/labltk/builtin/builtin_text.ml b/otherlibs/labltk/builtin/builtin_text.ml deleted file mode 100644 index b2d69589ba..0000000000 --- a/otherlibs/labltk/builtin/builtin_text.ml +++ /dev/null @@ -1,50 +0,0 @@ -(* Not a string as such, more like a symbol *) - -(* type *) -type textMark = string;; -(* /type *) - -(* type *) -type textTag = string;; -(* /type *) - -##ifdef CAMLTK - -(* type *) -type textModifier = - | CharOffset of int (* tk keyword: +/- Xchars *) - | LineOffset of int (* tk keyword: +/- Xlines *) - | LineStart (* tk keyword: linestart *) - | LineEnd (* tk keyword: lineend *) - | WordStart (* tk keyword: wordstart *) - | WordEnd (* tk keyword: wordend *) -;; -(* /type *) - -(* type *) -type textIndex = - | TextIndex of index * textModifier list - | TextIndexNone -;; -(* /type *) - -##else - -(* type *) -type textModifier = [ - | `Char of int (* tk keyword: +/- Xchars *) - | `Line of int (* tk keyword: +/- Xlines *) - | `Linestart (* tk keyword: linestart *) - | `Lineend (* tk keyword: lineend *) - | `Wordstart (* tk keyword: wordstart *) - | `Wordend (* tk keyword: wordend *) -] -;; -(* /type *) - -(* type *) -type textIndex = text_index * textModifier list -;; -(* /type *) - -##endif diff --git a/otherlibs/labltk/builtin/builtinf_GetPixel.ml b/otherlibs/labltk/builtin/builtinf_GetPixel.ml deleted file mode 100644 index 7e7c596bca..0000000000 --- a/otherlibs/labltk/builtin/builtinf_GetPixel.ml +++ /dev/null @@ -1,23 +0,0 @@ -##ifdef CAMLTK - -let pixels units = - let res = - tkEval - [|TkToken"winfo"; - TkToken"pixels"; - cCAMLtoTKwidget widget_any_table default_toplevel; - cCAMLtoTKunits units|] in - int_of_string res - -##else - -let pixels units = - let res = - tkEval - [|TkToken"winfo"; - TkToken"pixels"; - cCAMLtoTKwidget default_toplevel; - cCAMLtoTKunits units|] in - int_of_string res - -##endif diff --git a/otherlibs/labltk/builtin/builtinf_bind.ml b/otherlibs/labltk/builtin/builtinf_bind.ml deleted file mode 100644 index d78541e1d0..0000000000 --- a/otherlibs/labltk/builtin/builtinf_bind.ml +++ /dev/null @@ -1,133 +0,0 @@ -##ifdef CAMLTK - -(* type *) -type bindAction = - | BindSet of eventField list * (eventInfo -> unit) - | BindSetBreakable of eventField list * (eventInfo -> unit) - | BindRemove - | BindExtend of eventField list * (eventInfo -> unit) -(* /type *) - -(* -FUNCTION - val bind: - widget -> (modifier list * xEvent) list -> bindAction -> unit -/FUNCTION -*) -let bind widget eventsequence action = - tkCommand [| TkToken "bind"; - TkToken (Widget.name widget); - cCAMLtoTKeventSequence eventsequence; - begin match action with - BindRemove -> TkToken "" - | BindSet (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) - in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | BindSetBreakable (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) - in - TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0") - | BindExtend (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) - in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - end |] -;; - -(* FUNCTION -(* unsafe *) - val bind_class : - string -> (modifier list * xEvent) list -> bindAction -> unit -(* /unsafe *) -/FUNCTION class arg is not constrained *) - -let bind_class clas eventsequence action = - tkCommand [| TkToken "bind"; - TkToken clas; - cCAMLtoTKeventSequence eventsequence; - begin match action with - BindRemove -> TkToken "" - | BindSet (what, f) -> - let cbId = register_callback Widget.dummy - (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | BindSetBreakable (what, f) -> - let cbId = register_callback Widget.dummy - (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" ) - | BindExtend (what, f) -> - let cbId = register_callback Widget.dummy - (wrapeventInfo f what) in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - end |] -;; - -(* FUNCTION -(* unsafe *) - val bind_tag : - string -> (modifier list * xEvent) list -> bindAction -> unit -(* /unsafe *) -/FUNCTION *) - -let bind_tag = bind_class -;; - -(* -FUNCTION - val break : unit -> unit -/FUNCTION -*) -let break = function () -> - Textvariable.set (Textvariable.coerce "BreakBindingsSequence") "1" -;; - -(* Legacy functions *) -let tag_bind = bind_tag;; -let class_bind = bind_class;; - -##else - -let bind_class ~events ?(extend = false) ?(breakable = false) ?(fields = []) - ?action ?on:widget name = - let widget = match widget with None -> Widget.dummy | Some w -> coe w in - tkCommand - [| TkToken "bind"; - TkToken name; - cCAMLtoTKeventSequence events; - begin match action with None -> TkToken "" - | Some f -> - let cbId = - register_callback widget ~callback: (wrapeventInfo f fields) in - let cb = if extend then "+camlcb " else "camlcb " in - let cb = cb ^ cbId ^ writeeventField fields in - let cb = - if breakable then - cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" - ^ " ; set BreakBindingsSequence 0" - else cb in - TkToken cb - end - |] -;; - -let bind ~events ?extend ?breakable ?fields ?action widget = - bind_class ~events ?extend ?breakable ?fields ?action ~on:widget - (Widget.name widget) -;; - -let bind_tag = bind_class -;; - -(* -FUNCTION - val break : unit -> unit -/FUNCTION -*) -let break = function () -> - tkCommand [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |] -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_GetBitmap.ml b/otherlibs/labltk/builtin/builtini_GetBitmap.ml deleted file mode 100644 index 1afa0cd91c..0000000000 --- a/otherlibs/labltk/builtin/builtini_GetBitmap.ml +++ /dev/null @@ -1,28 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKbitmap = function - BitmapFile s -> TkToken ("@" ^ s) -| Predefined s -> TkToken s -;; - -let cTKtoCAMLbitmap s = - if s = "" then Predefined "" - else if String.get s 0 = '@' - then BitmapFile (String.sub s 1 (String.length s - 1)) - else Predefined s -;; - -##else - -let cCAMLtoTKbitmap : bitmap -> tkArgs = function - | `File s -> TkToken ("@" ^ s) - | `Predefined s -> TkToken s -;; - -let cTKtoCAMLbitmap s = - if String.get s 0 = '@' - then `File (String.sub s ~pos:1 ~len:(String.length s - 1)) - else `Predefined s -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_GetCursor.ml b/otherlibs/labltk/builtin/builtini_GetCursor.ml deleted file mode 100644 index 8f4e3971fa..0000000000 --- a/otherlibs/labltk/builtin/builtini_GetCursor.ml +++ /dev/null @@ -1,55 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKcolor = function - NamedColor x -> TkToken x - | Black -> TkToken "black" - | White -> TkToken "white" - | Red -> TkToken "red" - | Green -> TkToken "green" - | Blue -> TkToken "blue" - | Yellow -> TkToken "yellow" -;; - -let cTKtoCAMLcolor = function s -> NamedColor s -;; - -let cCAMLtoTKcursor = function - XCursor s -> TkToken s - | XCursorFg (s,fg) -> - TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg]) - | XCursortFgBg (s,fg,bg) -> - TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) - | CursorFileFg (s,fg) -> - TkQuote(TkTokenList [TkToken ("@"^s); cCAMLtoTKcolor fg]) - | CursorMaskFile (s,m,fg,bg) -> - TkQuote(TkTokenList [TkToken ("@"^s); TkToken m; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) -;; - -##else - -let cCAMLtoTKcolor : color -> tkArgs = function - | `Color x -> TkToken x - | `Black -> TkToken "black" - | `White -> TkToken "white" - | `Red -> TkToken "red" - | `Green -> TkToken "green" - | `Blue -> TkToken "blue" - | `Yellow -> TkToken "yellow" -;; - -let cTKtoCAMLcolor = function s -> `Color s -;; - -let cCAMLtoTKcursor : cursor -> tkArgs = function - | `Xcursor s -> TkToken s - | `Xcursorfg (s,fg) -> - TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg]) - | `Xcursorfgbg (s,fg,bg) -> - TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) - | `Cursorfilefg (s,fg) -> - TkQuote(TkTokenList [TkToken ("@"^s); cCAMLtoTKcolor fg]) - | `Cursormaskfile (s,m,fg,bg) -> - TkQuote(TkTokenList [TkToken ("@"^s); TkToken m; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_GetPixel.ml b/otherlibs/labltk/builtin/builtini_GetPixel.ml deleted file mode 100644 index 12e7890f45..0000000000 --- a/otherlibs/labltk/builtin/builtini_GetPixel.ml +++ /dev/null @@ -1,43 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKunits = function - Pixels (foo) -> TkToken (string_of_int foo) - | Millimeters (foo) -> TkToken(Printf.sprintf "%gm" foo) - | Inches (foo) -> TkToken(Printf.sprintf "%gi" foo) - | PrinterPoint (foo) -> TkToken(Printf.sprintf "%gp" foo) - | Centimeters (foo) -> TkToken(Printf.sprintf "%gc" foo) -;; - -let cTKtoCAMLunits str = - let len = String.length str in - let num_part str = String.sub str 0 (len - 1) in - match String.get str (pred len) with - 'c' -> Centimeters (float_of_string (num_part str)) - | 'i' -> Inches (float_of_string (num_part str)) - | 'm' -> Millimeters (float_of_string (num_part str)) - | 'p' -> PrinterPoint (float_of_string (num_part str)) - | _ -> Pixels(int_of_string str) -;; - -##else - -let cCAMLtoTKunits : units -> tkArgs = function - | `Pix (foo) -> TkToken (string_of_int foo) - | `Mm (foo) -> TkToken(Printf.sprintf "%gm" foo) - | `In (foo) -> TkToken(Printf.sprintf "%gi" foo) - | `Pt (foo) -> TkToken(Printf.sprintf "%gp" foo) - | `Cm (foo) -> TkToken(Printf.sprintf "%gc" foo) -;; - -let cTKtoCAMLunits str = - let len = String.length str in - let num_part str = String.sub str ~pos:0 ~len:(len - 1) in - match String.get str (pred len) with - | 'c' -> `Cm (float_of_string (num_part str)) - | 'i' -> `In (float_of_string (num_part str)) - | 'm' -> `Mm (float_of_string (num_part str)) - | 'p' -> `Pt (float_of_string (num_part str)) - | _ -> `Pix(int_of_string str) -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_ScrollValue.ml b/otherlibs/labltk/builtin/builtini_ScrollValue.ml deleted file mode 100644 index 08498a00d2..0000000000 --- a/otherlibs/labltk/builtin/builtini_ScrollValue.ml +++ /dev/null @@ -1,45 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKscrollValue = function - ScrollPage v1 -> - TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"pages"] - | ScrollUnit v1 -> - TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"units"] - | MoveTo v1 -> - TkTokenList [TkToken"moveto"; TkToken (Printf.sprintf "%g" v1)] -;; - -(* str l -> scrllv -> str l *) -let cTKtoCAMLscrollValue = function - "scroll"::n::"pages"::l -> - ScrollPage (int_of_string n), l - | "scroll"::n::"units"::l -> - ScrollUnit (int_of_string n), l - | "moveto"::f::l -> - MoveTo (float_of_string f), l - | _ -> raise (Invalid_argument "TKtoCAMLscrollValue") -;; - -##else - -let cCAMLtoTKscrollValue : scrollValue -> tkArgs = function - | `Page v1 -> - TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"pages"] - | `Unit v1 -> - TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"units"] - | `Moveto v1 -> - TkTokenList [TkToken"moveto"; TkToken (Printf.sprintf "%g" v1)] -;; - -(* str l -> scrllv -> str l *) -let cTKtoCAMLscrollValue = function - | "scroll" :: n :: "pages" :: l -> - `Page (int_of_string n), l - | "scroll" :: n :: "units" :: l -> - `Unit (int_of_string n), l - | "moveto" :: f :: l -> - `Moveto (float_of_string f), l - | _ -> raise (Invalid_argument "TKtoCAMLscrollValue") -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_bind.ml b/otherlibs/labltk/builtin/builtini_bind.ml deleted file mode 100644 index 13109cb0a9..0000000000 --- a/otherlibs/labltk/builtin/builtini_bind.ml +++ /dev/null @@ -1,136 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKxEvent = function - | Activate -> "Activate" - | ButtonPress -> "ButtonPress" - | ButtonPressDetail n -> "ButtonPress-"^string_of_int n - | ButtonRelease -> "ButtonRelease" - | ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n - | Circulate -> "Circulate" - | ColorMap -> "Colormap" - | Configure -> "Configure" - | Deactivate -> "Deactivate" - | Destroy -> "Destroy" - | Enter -> "Enter" - | Expose -> "Expose" - | FocusIn -> "FocusIn" - | FocusOut -> "FocusOut" - | Gravity -> "Gravity" - | KeyPress -> "KeyPress" - | KeyPressDetail s -> "KeyPress-"^s - | KeyRelease -> "KeyRelease" - | KeyReleaseDetail s -> "KeyRelease-"^s - | Leave -> "Leave" - | Map -> "Map" - | Motion -> "Motion" - | Property -> "Property" - | Reparent -> "Reparent" - | Unmap -> "Unmap" - | Visibility -> "Visibility" - | Virtual s -> "<"^s^">" -;; - -let cCAMLtoTKmodifier = function - | Control -> "Control-" - | Shift -> "Shift-" - | Lock -> "Lock-" - | Button1 -> "Button1-" - | Button2 -> "Button2-" - | Button3 -> "Button3-" - | Button4 -> "Button4-" - | Button5 -> "Button5-" - | Double -> "Double-" - | Triple -> "Triple-" - | Mod1 -> "Mod1-" - | Mod2 -> "Mod2-" - | Mod3 -> "Mod3-" - | Mod4 -> "Mod4-" - | Mod5 -> "Mod5-" - | Meta -> "Meta-" - | Alt -> "Alt-" -;; - -exception IllegalVirtualEvent - -(* type event = modifier list * xEvent *) -let cCAMLtoTKevent (ml, xe) = - match xe with - | Virtual s -> - if ml = [] then "<<"^s^">>" - else raise IllegalVirtualEvent - | _ -> - "<" ^ (String.concat " " (List.map cCAMLtoTKmodifier ml)) - ^ (cCAMLtoTKxEvent xe) ^ ">" -;; - -(* type eventSequence == (modifier list * xEvent) list *) -let cCAMLtoTKeventSequence l = - TkToken(List.fold_left (^) "" (List.map cCAMLtoTKevent l)) - -##else - -let cCAMLtoTKmodifier : modifier -> string = function - | `Control -> "Control-" - | `Shift -> "Shift-" - | `Lock -> "Lock-" - | `Button1 -> "Button1-" - | `Button2 -> "Button2-" - | `Button3 -> "Button3-" - | `Button4 -> "Button4-" - | `Button5 -> "Button5-" - | `Double -> "Double-" - | `Triple -> "Triple-" - | `Mod1 -> "Mod1-" - | `Mod2 -> "Mod2-" - | `Mod3 -> "Mod3-" - | `Mod4 -> "Mod4-" - | `Mod5 -> "Mod5-" - | `Meta -> "Meta-" - | `Alt -> "Alt-" -;; - -exception IllegalVirtualEvent - -let cCAMLtoTKevent (ev : event) = - let modified = ref false in - let rec convert = function - | `Activate -> "Activate" - | `ButtonPress -> "ButtonPress" - | `ButtonPressDetail n -> "ButtonPress-"^string_of_int n - | `ButtonRelease -> "ButtonRelease" - | `ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n - | `Circulate -> "Circulate" - | `Colormap -> "Colormap" - | `Configure -> "Configure" - | `Deactivate -> "Deactivate" - | `Destroy -> "Destroy" - | `Enter -> "Enter" - | `Expose -> "Expose" - | `FocusIn -> "FocusIn" - | `FocusOut -> "FocusOut" - | `Gravity -> "Gravity" - | `KeyPress -> "KeyPress" - | `KeyPressDetail s -> "KeyPress-"^s - | `KeyRelease -> "KeyRelease" - | `KeyReleaseDetail s -> "KeyRelease-"^s - | `Leave -> "Leave" - | `Map -> "Map" - | `Motion -> "Motion" - | `Property -> "Property" - | `Reparent -> "Reparent" - | `Unmap -> "Unmap" - | `Visibility -> "Visibility" - | `Virtual s -> - if !modified then raise IllegalVirtualEvent else "<"^s^">" - | `Modified(ml, ev) -> - modified := true; - String.concat ~sep:"" (List.map ~f:cCAMLtoTKmodifier ml) - ^ convert ev - in "<" ^ convert ev ^ ">" -;; - -let cCAMLtoTKeventSequence (l : event list) = - TkToken(String.concat ~sep:"" (List.map ~f:cCAMLtoTKevent l)) -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_bindtags.ml b/otherlibs/labltk/builtin/builtini_bindtags.ml deleted file mode 100644 index e09734870c..0000000000 --- a/otherlibs/labltk/builtin/builtini_bindtags.ml +++ /dev/null @@ -1,29 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKbindings = function - | WidgetBindings v1 -> cCAMLtoTKwidget widget_any_table v1 - | TagBindings v1 -> TkToken v1 -;; - -(* this doesn't really belong here *) -let cTKtoCAMLbindings s = - if String.length s > 0 && s.[0] = '.' then - WidgetBindings (cTKtoCAMLwidget s) - else TagBindings s -;; - -##else - -let cCAMLtoTKbindings = function -| `Widget v1 -> cCAMLtoTKwidget v1 -| `Tag v1 -> TkToken v1 -;; - -(* this doesn't really belong here *) -let cTKtoCAMLbindings s = - if String.length s > 0 && s.[0] = '.' then - `Widget (cTKtoCAMLwidget s) - else `Tag s -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_font.ml b/otherlibs/labltk/builtin/builtini_font.ml deleted file mode 100644 index 521b24d6d5..0000000000 --- a/otherlibs/labltk/builtin/builtini_font.ml +++ /dev/null @@ -1,3 +0,0 @@ -let cCAMLtoTKfont (s : font) = TkToken s -let cTKtoCAMLfont (s : font) = s - diff --git a/otherlibs/labltk/builtin/builtini_grab.ml b/otherlibs/labltk/builtin/builtini_grab.ml deleted file mode 100644 index 9007d04fa7..0000000000 --- a/otherlibs/labltk/builtin/builtini_grab.ml +++ /dev/null @@ -1,2 +0,0 @@ -let cCAMLtoTKgrabGlobal x = - if x then TkToken "-global" else TkTokenList [] diff --git a/otherlibs/labltk/builtin/builtini_index.ml b/otherlibs/labltk/builtin/builtini_index.ml deleted file mode 100644 index 7718cab952..0000000000 --- a/otherlibs/labltk/builtin/builtini_index.ml +++ /dev/null @@ -1,140 +0,0 @@ -##ifdef CAMLTK - -(* sp to avoid being picked up by doc scripts *) - type index_constrs = - CNumber - | CActiveElement - | CEnd - | CLast - | CNoIndex - | CInsert - | CSelFirst - | CSelLast - | CAt - | CAtXY - | CAnchorPoint - | CPattern - | CLineChar - | CMark - | CTagFirst - | CTagLast - | CEmbedded -;; - -let index_any_table = - [CNumber; CActiveElement; CEnd; CLast; CNoIndex; CInsert; CSelFirst; - CSelLast; CAt; CAtXY; CAnchorPoint; CPattern; CLineChar; - CMark; CTagFirst; CTagLast; CEmbedded] -;; - -let index_canvas_table = - [CNumber; CEnd; CInsert; CSelFirst; CSelLast; CAtXY] -;; -let index_entry_table = - [CNumber; CAnchorPoint; CEnd; CInsert; CSelFirst; CSelLast; CAt] -;; -let index_listbox_table = - [CNumber; CActiveElement; CAnchorPoint; CEnd; CAtXY] -;; -let index_menu_table = - [CNumber; CActiveElement; CEnd; CLast; CNoIndex; CAt; CPattern] -;; -let index_text_table = - [CLineChar; CAtXY; CEnd; CMark; CTagFirst; CTagLast; CEmbedded] -;; - -let cCAMLtoTKindex table = function - Number x -> chk_sub "Number" table CNumber; TkToken (string_of_int x) - | ActiveElement -> chk_sub "ActiveElement" table CActiveElement; TkToken "active" - | End -> chk_sub "End" table CEnd; TkToken "end" - | Last -> chk_sub "Last" table CLast; TkToken "last" - | NoIndex -> chk_sub "NoIndex" table CNoIndex; TkToken "none" - | Insert -> chk_sub "Insert" table CInsert; TkToken "insert" - | SelFirst -> chk_sub "SelFirst" table CSelFirst; TkToken "sel.first" - | SelLast -> chk_sub "SelLast" table CSelLast; TkToken "sel.last" - | At n -> chk_sub "At" table CAt; TkToken ("@"^string_of_int n) - | AtXY (x,y) -> chk_sub "AtXY" table CAtXY; - TkToken ("@"^string_of_int x^","^string_of_int y) - | AnchorPoint -> chk_sub "AnchorPoint" table CAnchorPoint; TkToken "anchor" - | Pattern s -> chk_sub "Pattern" table CPattern; TkToken s - | LineChar (l,c) -> chk_sub "LineChar" table CLineChar; - TkToken (string_of_int l^"."^string_of_int c) - | Mark s -> chk_sub "Mark" table CMark; TkToken s - | TagFirst t -> chk_sub "TagFirst" table CTagFirst; - TkToken (t^".first") - | TagLast t -> chk_sub "TagLast" table CTagLast; - TkToken (t^".last") - | Embedded w -> chk_sub "Embedded" table CEmbedded; - cCAMLtoTKwidget widget_any_table w -;; - -let char_index c s = - let rec find i = - if i >= String.length s - then raise Not_found - else if String.get s i = c then i - else find (i+1) in - find 0 -;; - -(* Assume returned values are only numerical and l.c *) -(* .menu index returns none if arg is none, but blast it *) -let cTKtoCAMLindex s = - try - let p = char_index '.' s in - LineChar(int_of_string (String.sub s 0 p), - int_of_string (String.sub s (p+1) (String.length s - p - 1))) - with - Not_found -> - try Number (int_of_string s) - with _ -> raise (Invalid_argument ("TKtoCAMLindex: "^s)) -;; - -##else - -let cCAMLtoTKindex (* Don't put explicit typing *) = function - | `Num x -> TkToken (string_of_int x) - | `Active -> TkToken "active" - | `End -> TkToken "end" - | `Last -> TkToken "last" - | `None -> TkToken "none" - | `Insert -> TkToken "insert" - | `Selfirst -> TkToken "sel.first" - | `Sellast -> TkToken "sel.last" - | `At n -> TkToken ("@" ^ string_of_int n) - | `Atxy (x,y) -> TkToken ("@" ^ string_of_int x ^ "," ^ string_of_int y) - | `Anchor -> TkToken "anchor" - | `Pattern s -> TkToken s - | `Linechar (l,c) -> TkToken (string_of_int l ^ "." ^ string_of_int c) - | `Mark s -> TkToken s - | `Tagfirst t -> TkToken (t ^ ".first") - | `Taglast t -> TkToken (t ^ ".last") - | `Window (w : any widget) -> cCAMLtoTKwidget w - | `Image s -> TkToken s -;; - -let cCAMLtoTKcanvas_index = (cCAMLtoTKindex : canvas_index -> tkArgs);; -let cCAMLtoTKentry_index = (cCAMLtoTKindex : entry_index -> tkArgs);; -let cCAMLtoTKlistbox_index = (cCAMLtoTKindex : listbox_index -> tkArgs);; -let cCAMLtoTKmenu_index = (cCAMLtoTKindex : menu_index -> tkArgs);; -let cCAMLtoTKtext_index = (cCAMLtoTKindex : text_index -> tkArgs);; - -(* Assume returned values are only numerical and l.c *) - -let cTKtoCAMLtext_index s = - try - let p = String.index s '.' in - `Linechar (int_of_string (String.sub s ~pos:0 ~len:p), - int_of_string (String.sub s ~pos:(p + 1) - ~len:(String.length s - p - 1))) - with - Not_found -> - raise (Invalid_argument ("TKtoCAMLtext_index: " ^ s)) -;; - -let cTKtoCAMLlistbox_index s = - try `Num (int_of_string s) - with _ -> raise (Invalid_argument ("TKtoCAMLlistbox_index: " ^ s)) -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_palette.ml b/otherlibs/labltk/builtin/builtini_palette.ml deleted file mode 100644 index e1fe37dbe4..0000000000 --- a/otherlibs/labltk/builtin/builtini_palette.ml +++ /dev/null @@ -1,19 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKpaletteType = function - GrayShades (foo) -> TkToken (string_of_int foo) - | RGBShades (r,v,b) -> TkToken (string_of_int r^"/"^ - string_of_int v^"/"^ - string_of_int b) -;; - -##else - -let cCAMLtoTKpaletteType : paletteType -> tkArgs = function - | `Gray (foo) -> TkToken (string_of_int foo) - | `Rgb (r,v,b) -> TkToken (string_of_int r ^ "/" ^ - string_of_int v ^ "/" ^ - string_of_int b) -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_text.ml b/otherlibs/labltk/builtin/builtini_text.ml deleted file mode 100644 index 966c28a325..0000000000 --- a/otherlibs/labltk/builtin/builtini_text.ml +++ /dev/null @@ -1,64 +0,0 @@ -let cCAMLtoTKtextMark x = TkToken x;; -let cTKtoCAMLtextMark x = x;; - -let cCAMLtoTKtextTag x = TkToken x;; -let cTKtoCAMLtextTag x = x;; - -##ifdef CAMLTK - -(* TextModifiers are never returned by Tk *) -let ppTextModifier = function - CharOffset n -> - if n > 0 then "+" ^ (string_of_int n) ^ "chars" - else if n = 0 then "" - else (string_of_int n) ^ "chars" - | LineOffset n -> - if n > 0 then "+" ^ (string_of_int n) ^ "lines" - else if n = 0 then "" - else (string_of_int n) ^ "lines" - | LineStart -> " linestart" - | LineEnd -> " lineend" - | WordStart -> " wordstart" - | WordEnd -> " wordend" -;; - -let ppTextIndex = function - | TextIndexNone -> "" - | TextIndex (base, ml) -> - match cCAMLtoTKindex index_text_table base with - | TkToken ppbase -> List.fold_left (^) ppbase (List.map ppTextModifier ml) - | _ -> assert false -;; - -let cCAMLtoTKtextIndex i = - TkToken (ppTextIndex i) -;; - -##else - -(* TextModifiers are never returned by Tk *) -let cCAMLtoTKtextIndex (i : textIndex) = - let ppTextModifier = function - | `Char n -> - if n > 0 then "+" ^ (string_of_int n) ^ "chars" - else if n = 0 then "" - else (string_of_int n) ^ "chars" - | `Line n -> - if n > 0 then "+" ^ (string_of_int n) ^ "lines" - else if n = 0 then "" - else (string_of_int n) ^ "lines" - | `Linestart -> " linestart" - | `Lineend -> " lineend" - | `Wordstart -> " wordstart" - | `Wordend -> " wordend" - in - let ppTextIndex (base, ml : textIndex) = - match cCAMLtoTKtext_index base with - TkToken ppbase -> - String.concat ~sep:"" (ppbase :: List.map ~f:ppTextModifier ml) - | _ -> assert false - in - TkToken (ppTextIndex i) -;; - -##endif diff --git a/otherlibs/labltk/builtin/canvas_bind.ml b/otherlibs/labltk/builtin/canvas_bind.ml deleted file mode 100644 index 1b46fae010..0000000000 --- a/otherlibs/labltk/builtin/canvas_bind.ml +++ /dev/null @@ -1,52 +0,0 @@ -##ifdef CAMLTK - -let bind widget tag eventsequence action = - tkCommand [| - cCAMLtoTKwidget widget_canvas_table widget; - TkToken "bind"; - cCAMLtoTKtagOrId tag; - cCAMLtoTKeventSequence eventsequence; - begin match action with - | BindRemove -> TkToken "" - | BindSet (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | BindSetBreakable (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \ - set BreakBindingsSequence 0") - | BindExtend (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - end - |] -;; - -##else - -let bind ~events - ?(extend = false) ?(breakable = false) ?(fields = []) - ?action widget tag = - tkCommand - [| cCAMLtoTKwidget widget; - TkToken "bind"; - cCAMLtoTKtagOrId tag; - cCAMLtoTKeventSequence events; - begin match action with None -> TkToken "" - | Some f -> - let cbId = - register_callback widget ~callback: (wrapeventInfo f fields) in - let cb = if extend then "+camlcb " else "camlcb " in - let cb = cb ^ cbId ^ writeeventField fields in - let cb = - if breakable then - cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" - ^ " ; set BreakBindingsSequence 0" - else cb in - TkToken cb - end - |] -;; - -##endif diff --git a/otherlibs/labltk/builtin/canvas_bind.mli b/otherlibs/labltk/builtin/canvas_bind.mli deleted file mode 100644 index 39ce93e7c3..0000000000 --- a/otherlibs/labltk/builtin/canvas_bind.mli +++ /dev/null @@ -1,16 +0,0 @@ -##ifdef CAMLTK - -val bind : widget -> tagOrId -> - (modifier list * xEvent) list -> bindAction -> unit - -##else - -val bind : - events: event list -> - ?extend: bool -> - ?breakable: bool -> - ?fields: eventField list -> - ?action: (eventInfo -> unit) -> - canvas widget -> tagOrId -> unit - -##endif diff --git a/otherlibs/labltk/builtin/dialog.ml b/otherlibs/labltk/builtin/dialog.ml deleted file mode 100644 index e6654d8c46..0000000000 --- a/otherlibs/labltk/builtin/dialog.ml +++ /dev/null @@ -1,45 +0,0 @@ -##ifdef CAMLTK - -let create ?name parent title mesg bitmap def buttons = - let w = Widget.new_atom "toplevel" ~parent ?name in - let res = tkEval [|TkToken"tk_dialog"; - cCAMLtoTKwidget widget_any_table w; - TkToken title; - TkToken mesg; - cCAMLtoTKbitmap bitmap; - TkToken (string_of_int def); - TkTokenList (List.map (function x -> TkToken x) buttons)|] - in - int_of_string res -;; - -let create_named parent name title mesg bitmap def buttons = - let w = Widget.new_atom "toplevel" ~parent ~name in - let res = tkEval [|TkToken"tk_dialog"; - cCAMLtoTKwidget widget_any_table w; - TkToken title; - TkToken mesg; - cCAMLtoTKbitmap bitmap; - TkToken (string_of_int def); - TkTokenList (List.map (function x -> TkToken x) buttons)|] - in - int_of_string res -;; - -##else - -let create ~parent ~title ~message ~buttons ?name - ?(bitmap = `Predefined "") ?(default = -1) () = - let w = Widget.new_atom "toplevel" ?name ~parent in - let res = tkEval [|TkToken"tk_dialog"; - cCAMLtoTKwidget w; - TkToken title; - TkToken message; - cCAMLtoTKbitmap bitmap; - TkToken (string_of_int default); - TkTokenList (List.map ~f:(fun x -> TkToken x) buttons)|] - in - int_of_string res -;; - -##endif diff --git a/otherlibs/labltk/builtin/dialog.mli b/otherlibs/labltk/builtin/dialog.mli deleted file mode 100644 index debb6ce207..0000000000 --- a/otherlibs/labltk/builtin/dialog.mli +++ /dev/null @@ -1,24 +0,0 @@ -##ifdef CAMLTK - -val create : ?name: string -> - widget -> string -> string -> bitmap -> int -> string list -> int - (* [create ~name parent title message bitmap default button_names] - cf. tk_dialog *) - -val create_named : - widget -> string -> string -> string -> bitmap -> int -> string list -> int - (* [create_named parent name title message bitmap default button_names] - cf. tk_dialog *) - -##else - -val create : - parent: 'a widget -> - title: string -> - message: string -> - buttons: string list -> - ?name: string -> ?bitmap: bitmap -> ?default: int -> unit ->int - (* [create title message bitmap default button_names parent] - cf. tk_dialog *) - -##endif diff --git a/otherlibs/labltk/builtin/image.ml b/otherlibs/labltk/builtin/image.ml deleted file mode 100644 index ac4c7238a9..0000000000 --- a/otherlibs/labltk/builtin/image.ml +++ /dev/null @@ -1,33 +0,0 @@ -##ifdef CAMLTK - -let cTKtoCAMLimage s = - let res = tkEval [|TkToken "image"; TkToken "type"; TkToken s|] in - match res with - | "bitmap" -> ImageBitmap (BitmapImage s) - | "photo" -> ImagePhoto (PhotoImage s) - | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\"")) -;; - -let names () = - let res = tkEval [|TkToken "image"; TkToken "names"|] in - let names = splitlist res in - List.map cTKtoCAMLimage names -;; - -##else - -let cTKtoCAMLimage s = - let res = tkEval [|TkToken "image"; TkToken "type"; TkToken s|] in - match res with - | "bitmap" -> `Bitmap s - | "photo" -> `Photo s - | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\"")) -;; - -let names () = - let res = tkEval [|TkToken "image"; TkToken "names"|] in - let names = splitlist res in - List.map cTKtoCAMLimage names -;; - -##endif diff --git a/otherlibs/labltk/builtin/image.mli b/otherlibs/labltk/builtin/image.mli deleted file mode 100644 index a92a9f8c70..0000000000 --- a/otherlibs/labltk/builtin/image.mli +++ /dev/null @@ -1,9 +0,0 @@ -##ifdef CAMLTK - -val names : unit -> options list - -##else - -val names : unit -> image list - -##endif diff --git a/otherlibs/labltk/builtin/optionmenu.ml b/otherlibs/labltk/builtin/optionmenu.ml deleted file mode 100644 index c0a760abae..0000000000 --- a/otherlibs/labltk/builtin/optionmenu.ml +++ /dev/null @@ -1,54 +0,0 @@ -##ifdef CAMLTK - -open Protocol;; -(* Implementation of the tk_optionMenu *) - -let create ?name parent variable values = - let w = Widget.new_atom "menubutton" ~parent ?name in - let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in - let res = - tkEval [|TkToken "tk_optionMenu"; - TkToken (Widget.name w); - cCAMLtoTKtextVariable variable; - TkTokenList (List.map (function x -> TkToken x) values)|] in - if res <> Widget.name mw then - raise (TkError "internal error in Optionmenu.create") - else - w,mw -;; - -let create_named parent name variable values = - let w = Widget.new_atom "menubutton" ~parent ~name in - let mw = Widget.new_atom "menu" ~parent:w ~name: "menu" in - let res = - tkEval [|TkToken "tk_optionMenu"; - TkToken (Widget.name w); - cCAMLtoTKtextVariable variable; - TkTokenList (List.map (function x -> TkToken x) values)|] in - if res <> Widget.name mw then - raise (TkError "internal error in Optionmenu.create") - else - w,mw -;; - -##else - -open Protocol;; -(* Implementation of the tk_optionMenu *) - -let create ~parent ~variable ?name values = - let w = Widget.new_atom "menubutton" ~parent ?name in - let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in - (* assumes .menu naming *) - let res = - tkEval [|TkToken "tk_optionMenu"; - TkToken (Widget.name w); - cCAMLtoTKtextVariable variable; - TkTokenList (List.map ~f:(fun x -> TkToken x) values)|] in - if res <> Widget.name mw then - raise (TkError "internal error in Optionmenu.create") - else - w, mw -;; - -##endif diff --git a/otherlibs/labltk/builtin/optionmenu.mli b/otherlibs/labltk/builtin/optionmenu.mli deleted file mode 100644 index 0c6b5c9e13..0000000000 --- a/otherlibs/labltk/builtin/optionmenu.mli +++ /dev/null @@ -1,21 +0,0 @@ -##ifdef CAMLTK - -(* Support for tk_optionMenu *) -val create: ?name: string -> - widget -> textVariable -> string list -> widget * widget -(** [create ?name parent var options] creates a multi-option menubutton and - its associated menu. The option is also stored in the variable. - Both widgets (menubutton and menu) are returned. *) - -##else - -(* Support for tk_optionMenu *) -val create: - parent:'a widget -> - variable:textVariable -> - ?name: string -> string list -> menubutton widget * menu widget -(** [create ~parent ~var ~name options] creates a multi-option menubutton - and its associated menu. The option is also stored in the variable. - Both widgets (menubutton and menu) are returned *) - -##endif diff --git a/otherlibs/labltk/builtin/rawimg.ml b/otherlibs/labltk/builtin/rawimg.ml deleted file mode 100644 index 6bd0ad2838..0000000000 --- a/otherlibs/labltk/builtin/rawimg.ml +++ /dev/null @@ -1,142 +0,0 @@ -external rawget : string -> string - = "camltk_getimgdata" -external rawset : string -> string -> int -> int -> int -> int -> unit - = "camltk_setimgdata_bytecode" (* all int parameters MUST be positive *) - "camltk_setimgdata_native" - -type t = { - pixmap_width : int; - pixmap_height: int; - pixmap_data: string -} - -type pixel = string (* 3 chars *) - -(* pixmap will be an abstract type *) -let width pix = pix.pixmap_width -let height pix = pix.pixmap_height - - -(* note: invalid size would have been caught by String.create, but we put - * it here for documentation purpose *) -let create w h = - if w < 0 || h < 0 then invalid_arg "invalid size" - else { - pixmap_width = w; - pixmap_height = h; - pixmap_data = String.create (w * h * 3); - } - -(* - * operations on pixmaps - *) -let unsafe_copy pix_from pix_to = - String.unsafe_blit pix_from.pixmap_data 0 - pix_to.pixmap_data 0 - (String.length pix_from.pixmap_data) - -(* We check only the length. w,h might be different... *) -let copy pix_from pix_to = - let l = String.length pix_from.pixmap_data in - if l <> String.length pix_to.pixmap_data then - raise (Invalid_argument "copy: incompatible length") - else unsafe_copy pix_from pix_to - - -(* Pixel operations *) -let unsafe_get_pixel pixmap x y = - let pos = (y * pixmap.pixmap_width + x) * 3 in - let r = String.create 3 in - String.unsafe_blit pixmap.pixmap_data pos r 0 3; - r - -let unsafe_set_pixel pixmap x y pixel = - let pos = (y * pixmap.pixmap_width + x) * 3 in - String.unsafe_blit pixel 0 pixmap.pixmap_data pos 3 - -(* To get safe operations, we can either check x,y wrt [0,w[ and [0,h[ - or rely on blit checking. We choose the first for clarity. - *) -let get_pixel pix x y = - if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height - then invalid_arg "invalid pixel" - else unsafe_get_pixel pix x y - -(* same check (pixel being abstract, it must be of good size *) -let set_pixel pix x y pixel = - if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height - then invalid_arg "invalid pixel" - else unsafe_set_pixel pix x y pixel - -(* black as default_color, if at all needed *) -let default_color = "\000\000\000" - -(* Char.chr does range checking *) -let pixel r g b = - let s = String.create 3 in - s.[0] <- Char.chr r; - s.[1] <- Char.chr g; - s.[2] <- Char.chr b; - s - -##ifdef CAMLTK - -(* create pixmap from an existing image *) -let get photo = - match photo with - | PhotoImage s -> { - pixmap_width = CImagephoto.width photo; - pixmap_height = CImagephoto.height photo; - pixmap_data = rawget s; - } - -(* copy a full pixmap into an image *) -let set photo pix = - match photo with - | PhotoImage s -> - rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height - -(* general blit of pixmap into image *) -let blit photo pix x y w h = - if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument" - else match photo with - | PhotoImage s -> - rawset s pix.pixmap_data x y w h - -(* get from a file *) -let from_file filename = - let img = CImagephoto.create [File filename] in - let pix = get img in - CImagephoto.delete img; - pix - -##else - -(* create pixmap from an existing image *) -let get photo = - match photo with - | `Photo s -> { - pixmap_width = Imagephoto.width photo; - pixmap_height = Imagephoto.height photo; - pixmap_data = rawget s; - } - -(* copy a full pixmap into an image *) -let set photo pix = - match photo with - | `Photo s -> rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height - -(* general blit of pixmap into image *) -let blit photo pix x y w h = - if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument" - else match photo with - | `Photo s -> rawset s pix.pixmap_data x y w h - -(* get from a file *) -let from_file filename = - let img = Imagephoto.create ~file: filename () in - let pix = get img in - Imagephoto.delete img; - pix - -##endif diff --git a/otherlibs/labltk/builtin/rawimg.mli b/otherlibs/labltk/builtin/rawimg.mli deleted file mode 100644 index 1bb120f648..0000000000 --- a/otherlibs/labltk/builtin/rawimg.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* - * Minimal pixmap support - *) - -type t -type pixel - -val width : t -> int - (* [width pixmap] *) -val height : t -> int - (* [height pixmap] *) - -val create : int -> int -> t - (* [create width height] *) -val get : imagePhoto -> t - (* [get img] *) -val set : imagePhoto -> t -> unit - (* [set img pixmap] *) -val blit : imagePhoto -> t -> int -> int -> int -> int -> unit - (* [blit img pixmap x y w h] (all ints must be non-negative) *) -val from_file : string -> t - (* [from_file filename] *) - -val copy : t -> t -> unit - (* [copy src dst] *) - -(* - * Pixel operations - *) -val get_pixel : t -> int -> int -> pixel - (* [get_pixel pixmap x y] *) -val set_pixel : t -> int -> int -> pixel -> unit - (* [set_pixel pixmap x y pixel] *) -val default_color : pixel - -val pixel : int -> int -> int -> pixel - (* [pixel r g b] (r,g,b must be in [0..255]) *) - -(*-*) -(* unsafe *) -val unsafe_copy : t -> t -> unit -val unsafe_get_pixel : t -> int -> int -> pixel -val unsafe_set_pixel : t -> int -> int -> pixel -> unit -(* /unsafe *) diff --git a/otherlibs/labltk/builtin/report.ml b/otherlibs/labltk/builtin/report.ml deleted file mode 100644 index 852b4c141c..0000000000 --- a/otherlibs/labltk/builtin/report.ml +++ /dev/null @@ -1,17 +0,0 @@ -(* Report globals from protocol *) -let opentk = Protocol.opentk -let keywords = Protocol.keywords -let opentk_with_args = Protocol.opentk_with_args -let openTk = Protocol.openTk -let openTkClass = Protocol.openTkClass -let openTkDisplayClass = Protocol.openTkDisplayClass -let closeTk = Protocol.closeTk -let mainLoop = Protocol.mainLoop -let register = Protocol.register - -(* From support *) -let may = Support.may -let maycons = Support.maycons - -(* From widget *) -let coe = Widget.coe diff --git a/otherlibs/labltk/builtin/selection_handle_set.ml b/otherlibs/labltk/builtin/selection_handle_set.ml deleted file mode 100644 index fe19489a51..0000000000 --- a/otherlibs/labltk/builtin/selection_handle_set.ml +++ /dev/null @@ -1,41 +0,0 @@ -##ifdef CAMLTK - -(* The function *must* use tkreturn *) -let handle_set opts w cmd = - tkCommand [| - TkToken"selection"; - TkToken"handle"; - TkTokenList - (List.map - (function x -> cCAMLtoTKicccm w icccm_selection_handle_table x) - opts); - cCAMLtoTKwidget widget_any_table w; - let id = register_callback w (function args -> - let (a1,args) = int_of_string (List.hd args), List.tl args in - let (a2,args) = int_of_string (List.hd args), List.tl args in - cmd a1 a2) in - TkToken ("camlcb "^id) - |] -;; - -##else - -(* The function *must* use tkreturn *) -let handle_set ~command = -selection_handle_icccm_optionals (fun opts w -> - tkCommand [| - TkToken"selection"; - TkToken"handle"; - TkTokenList opts; - cCAMLtoTKwidget w; - let id = register_callback w ~callback: - begin fun args -> - let pos = int_of_string (List.hd args) in - let len = int_of_string (List.nth args 1) in - tkreturn (command ~pos ~len) - end - in TkToken ("camlcb " ^ id) - |]) -;; - -##endif diff --git a/otherlibs/labltk/builtin/selection_handle_set.mli b/otherlibs/labltk/builtin/selection_handle_set.mli deleted file mode 100644 index 66ae6b7349..0000000000 --- a/otherlibs/labltk/builtin/selection_handle_set.mli +++ /dev/null @@ -1,13 +0,0 @@ -##ifdef CAMLTK - -val handle_set : icccm list -> widget -> (int -> int -> unit) -> unit -(** tk invocation: selection handle <icccm list> <widget> <command> *) - -##else - -val handle_set : - command: (pos:int -> len:int -> string) -> - ?format: string -> ?selection:string -> ?typ: string -> 'a widget -> unit -(** tk invocation: selection handle <icccm list> <widget> <command> *) - -##endif diff --git a/otherlibs/labltk/builtin/selection_own_set.ml b/otherlibs/labltk/builtin/selection_own_set.ml deleted file mode 100644 index 253cdb5b64..0000000000 --- a/otherlibs/labltk/builtin/selection_own_set.ml +++ /dev/null @@ -1,29 +0,0 @@ -##ifdef CAMLTK - -(* builtin to handle callback association to widget *) -let own_set v1 v2 = - tkCommand [| - TkToken"selection"; - TkToken"own"; - TkTokenList - (List.map - (function x -> cCAMLtoTKicccm v2 icccm_selection_ownset_table x) - v1); - cCAMLtoTKwidget widget_any_table v2 - |] -;; - -##else - -(* builtin to handle callback association to widget *) -let own_set ?command = - selection_ownset_icccm_optionals ?command (fun opts w -> - tkCommand [| - TkToken"selection"; - TkToken"own"; - TkTokenList opts; - cCAMLtoTKwidget w - |]) -;; - -##endif diff --git a/otherlibs/labltk/builtin/selection_own_set.mli b/otherlibs/labltk/builtin/selection_own_set.mli deleted file mode 100644 index 95b3de363c..0000000000 --- a/otherlibs/labltk/builtin/selection_own_set.mli +++ /dev/null @@ -1,12 +0,0 @@ -##ifdef CAMLTK - -val own_set : icccm list -> widget -> unit -(** tk invocation: selection own <icccm list> <widget> *) - -##else - -val own_set : - ?command:(unit->unit) -> ?selection:string -> 'a widget -> unit -(** tk invocation: selection own <icccm list> <widget> *) - -##endif diff --git a/otherlibs/labltk/builtin/text_tag_bind.ml b/otherlibs/labltk/builtin/text_tag_bind.ml deleted file mode 100644 index 7a1bab3a5d..0000000000 --- a/otherlibs/labltk/builtin/text_tag_bind.ml +++ /dev/null @@ -1,55 +0,0 @@ -##ifdef CAMLTK - -let tag_bind widget tag eventsequence action = - check_class widget widget_text_table; - tkCommand [| - cCAMLtoTKwidget widget_text_table widget; - TkToken "tag"; - TkToken "bind"; - cCAMLtoTKtextTag tag; - cCAMLtoTKeventSequence eventsequence; - begin match action with - | BindRemove -> TkToken "" - | BindSet (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | BindSetBreakable (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \ - set BreakBindingsSequence 0") - | BindExtend (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - end - |] -;; - -##else - -let tag_bind ~tag ~events ?(extend = false) ?(breakable = false) - ?(fields = []) ?action widget = - tkCommand [| - cCAMLtoTKwidget widget; - TkToken "tag"; - TkToken "bind"; - cCAMLtoTKtextTag tag; - cCAMLtoTKeventSequence events; - begin match action with - | None -> TkToken "" - | Some f -> - let cbId = - register_callback widget ~callback: (wrapeventInfo f fields) in - let cb = if extend then "+camlcb " else "camlcb " in - let cb = cb ^ cbId ^ writeeventField fields in - let cb = - if breakable then - cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" - ^ " ; set BreakBindingsSequence 0" - else cb in - TkToken cb - end - |] -;; - -##endif diff --git a/otherlibs/labltk/builtin/text_tag_bind.mli b/otherlibs/labltk/builtin/text_tag_bind.mli deleted file mode 100644 index 1f334a796c..0000000000 --- a/otherlibs/labltk/builtin/text_tag_bind.mli +++ /dev/null @@ -1,13 +0,0 @@ -##ifdef CAMLTK - -val tag_bind: - widget -> textTag -> (modifier list * xEvent) list -> bindAction -> unit - -##else - -val tag_bind : - tag: string -> events: event list -> - ?extend: bool -> ?breakable: bool -> ?fields: eventField list -> - ?action: (eventInfo -> unit) -> text widget -> unit - -##endif diff --git a/otherlibs/labltk/builtin/winfo_contained.ml b/otherlibs/labltk/builtin/winfo_contained.ml deleted file mode 100644 index f1fb3735ca..0000000000 --- a/otherlibs/labltk/builtin/winfo_contained.ml +++ /dev/null @@ -1,13 +0,0 @@ -##ifdef CAMLTK - -let contained x y w = - w = containing x y -;; - -##else - -let contained ~x ~y w = - forget_type w = containing ~x ~y () -;; - -##endif diff --git a/otherlibs/labltk/builtin/winfo_contained.mli b/otherlibs/labltk/builtin/winfo_contained.mli deleted file mode 100644 index 41cc57c0f1..0000000000 --- a/otherlibs/labltk/builtin/winfo_contained.mli +++ /dev/null @@ -1,11 +0,0 @@ -##ifdef CAMLTK - -val contained : int -> int -> widget -> bool -(** [contained x y w] returns true if (x,y) is in w *) - -##else - -val contained : x:int -> y:int -> 'a widget -> bool -(** [contained x y w] returns true if (x,y) is in w *) - -##endif diff --git a/otherlibs/labltk/camltk/.cvsignore b/otherlibs/labltk/camltk/.cvsignore deleted file mode 100644 index 585067641e..0000000000 --- a/otherlibs/labltk/camltk/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.ml *.mli labltktop labltk -modules -.depend diff --git a/otherlibs/labltk/camltk/Makefile b/otherlibs/labltk/camltk/Makefile deleted file mode 100644 index afa6f3af26..0000000000 --- a/otherlibs/labltk/camltk/Makefile +++ /dev/null @@ -1,45 +0,0 @@ -include ../support/Makefile.common - -COMPFLAGS= -I ../support - -TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo - -all: camltkobjs - -opt: camltkobjsx - -include ./modules - -CAMLTKOBJS= $(CWIDGETOBJS) cTk.cmo camltk.cmo -CAMLTKOBJSX = $(CAMLTKOBJS:.cmo=.cmx) - -camltkobjs: $(CAMLTKOBJS) - -camltkobjsx: $(CAMLTKOBJSX) - -clean: - $(MAKE) -f Makefile.gen clean - -install: $(CAMLTKOBJS) - if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(CAMLTKOBJS:.cmo=.cmi) $(CWIDGETOBJS:.cmo=.mli) $(INSTALLDIR) - chmod 644 $(INSTALLDIR)/*.cmi - -installopt: $(CAMLTKOBJSX) - @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(CAMLTKOBJSX) $(INSTALLDIR) - chmod 644 $(INSTALLDIR)/*.cmx - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -include .depend diff --git a/otherlibs/labltk/camltk/Makefile.gen b/otherlibs/labltk/camltk/Makefile.gen deleted file mode 100644 index 1e4f50a10a..0000000000 --- a/otherlibs/labltk/camltk/Makefile.gen +++ /dev/null @@ -1,46 +0,0 @@ -include ../support/Makefile.common - -all: cTk.ml camltk.ml .depend - -_tkgen.ml: ../Widgets.src ../compiler/tkcompiler - cd ..; ../../boot/ocamlrun compiler/tkcompiler -camltk -outdir camltk - -cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../builtin/builtin_*.ml - (echo '##define CAMLTK'; \ - echo 'include Camltkwrap'; \ - echo 'open Widget'; \ - echo 'open Protocol'; \ - echo 'open Textvariable'; \ - echo ; \ - cat ../builtin/report.ml; \ - echo ; \ - cat ../builtin/builtin_*.ml; \ - echo ; \ - cat _tkgen.ml; \ - echo ; \ - echo ; \ - echo 'module Tkintf = struct'; \ - cat ../builtin/builtini_*.ml; \ - cat _tkigen.ml; \ - echo 'end (* module Tkintf *)'; \ - echo ; \ - echo ; \ - echo 'open Tkintf' ;\ - echo ; \ - echo ; \ - cat ../builtin/builtinf_*.ml; \ - cat _tkfgen.ml; \ - echo ; \ - ) > _cTk.ml - ../../../boot/ocamlrun ../compiler/pp < _cTk.ml > cTk.ml - rm -f _cTk.ml - $(CAMLDEP) -I ../support [a-z]*.mli [a-z]*.ml > .depend - -../compiler/pp: - cd ../compiler; $(MAKE) pp - -# All .{ml,mli} files are generated in this directory -clean: - rm -f *.cm* *.ml *.mli *.o *.a .depend - -# rm -f modules diff --git a/otherlibs/labltk/camltk/Makefile.gen.nt b/otherlibs/labltk/camltk/Makefile.gen.nt deleted file mode 100644 index 71a7c143f9..0000000000 --- a/otherlibs/labltk/camltk/Makefile.gen.nt +++ /dev/null @@ -1,46 +0,0 @@ -include ../support/Makefile.common.nt - -all: cTk.ml camltk.ml .depend - -_tkgen.ml: ../Widgets.src ../compiler/tkcompiler.exe - cd .. ; ../../boot/ocamlrun compiler/tkcompiler.exe -camltk -outdir camltk - -# dependencies are broken: wouldn't work with gmake 3.77 - -cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp.exe #../builtin/builtin_*.ml - (echo '##define CAMLTK'; \ - echo 'include Camltkwrap'; \ - echo 'open Widget'; \ - echo 'open Protocol'; \ - echo 'open Textvariable'; \ - echo ; \ - cat ../builtin/report.ml; \ - echo ; \ - cat ../builtin/builtin_*.ml; \ - echo ; \ - cat _tkgen.ml; \ - echo ; \ - echo ; \ - echo 'module Tkintf = struct'; \ - cat ../builtin/builtini_*.ml; \ - cat _tkigen.ml; \ - echo 'end (* module Tkintf *)'; \ - echo ; \ - echo ; \ - echo 'open Tkintf' ;\ - echo ; \ - echo ; \ - cat ../builtin/builtinf_*.ml; \ - cat _tkfgen.ml; \ - echo ; \ - ) > _cTk.ml - ../../../boot/ocamlrun ../compiler/pp < _cTk.ml > cTk.ml - rm -f _cTk.ml - $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend - -../compiler/pp.exe: - cd ../compiler; $(MAKEREC) pp.exe - -clean: - rm -f *.cm* *.ml *.mli *.$(O) *.$(A) -# rm -f modules .depend diff --git a/otherlibs/labltk/camltk/Makefile.nt b/otherlibs/labltk/camltk/Makefile.nt deleted file mode 100644 index 6c81dbc494..0000000000 --- a/otherlibs/labltk/camltk/Makefile.nt +++ /dev/null @@ -1,43 +0,0 @@ -include ../support/Makefile.common.nt - -COMPFLAGS= -I ../support - -all: camltkobjs - -opt: camltkobjsx - -# All .{ml,mli} files are generated in this directory -clean : - rm -f *.cm* *.ml *.mli *.$(A) *.$(O) - $(MAKE) -f Makefile.gen.nt clean - -include ./modules - -CAMLTKOBJS = $(WIDGETOBJS) cTk.cmo camltk.cmo -CAMLTKOBJSX = $(CAMLTKOBJS:.cmo=.cmx) - -camltkobjs: $(CAMLTKOBJS) - -camltkobjsx: $(CAMLTKOBJSX) - -install: $(CAMLTKOBJS) - mkdir -p $(INSTALLDIR) - cp *.cmi [a-z]*.mli $(INSTALLDIR) - -installopt: $(CAMLTKOBJSX) - mkdir -p $(INSTALLDIR) - cp $(CAMLTKOBJSX) $(INSTALLDIR) - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -include .depend diff --git a/otherlibs/labltk/camltk/modules b/otherlibs/labltk/camltk/modules deleted file mode 100644 index c1a2eed857..0000000000 --- a/otherlibs/labltk/camltk/modules +++ /dev/null @@ -1,80 +0,0 @@ -CWIDGETOBJS=cPlace.cmo cResource.cmo cWm.cmo cImagephoto.cmo cCanvas.cmo cButton.cmo cText.cmo cLabel.cmo cScrollbar.cmo cImage.cmo cEncoding.cmo cPixmap.cmo cPalette.cmo cFont.cmo cMessage.cmo cMenu.cmo cEntry.cmo cListbox.cmo cFocus.cmo cMenubutton.cmo cPack.cmo cOption.cmo cToplevel.cmo cFrame.cmo cDialog.cmo cImagebitmap.cmo cClipboard.cmo cRadiobutton.cmo cTkwait.cmo cGrab.cmo cSelection.cmo cScale.cmo cOptionmenu.cmo cWinfo.cmo cGrid.cmo cCheckbutton.cmo cBell.cmo cTkvars.cmo -cPlace.ml cResource.ml cWm.ml cImagephoto.ml cCanvas.ml cButton.ml cText.ml cLabel.ml cScrollbar.ml cImage.ml cEncoding.ml cPixmap.ml cPalette.ml cFont.ml cMessage.ml cMenu.ml cEntry.ml cListbox.ml cFocus.ml cMenubutton.ml cPack.ml cOption.ml cToplevel.ml cFrame.ml cDialog.ml cImagebitmap.ml cClipboard.ml cRadiobutton.ml cTkwait.ml cGrab.ml cSelection.ml cScale.ml cOptionmenu.ml cWinfo.ml cGrid.ml cCheckbutton.ml cBell.ml cTkvars.ml : _tkgen.ml - -cPlace.cmo : cPlace.ml -cPlace.cmi : cPlace.mli -cResource.cmo : cResource.ml -cResource.cmi : cResource.mli -cWm.cmo : cWm.ml -cWm.cmi : cWm.mli -cImagephoto.cmo : cImagephoto.ml -cImagephoto.cmi : cImagephoto.mli -cCanvas.cmo : cCanvas.ml -cCanvas.cmi : cCanvas.mli -cButton.cmo : cButton.ml -cButton.cmi : cButton.mli -cText.cmo : cText.ml -cText.cmi : cText.mli -cLabel.cmo : cLabel.ml -cLabel.cmi : cLabel.mli -cScrollbar.cmo : cScrollbar.ml -cScrollbar.cmi : cScrollbar.mli -cImage.cmo : cImage.ml -cImage.cmi : cImage.mli -cEncoding.cmo : cEncoding.ml -cEncoding.cmi : cEncoding.mli -cPixmap.cmo : cPixmap.ml -cPixmap.cmi : cPixmap.mli -cPalette.cmo : cPalette.ml -cPalette.cmi : cPalette.mli -cFont.cmo : cFont.ml -cFont.cmi : cFont.mli -cMessage.cmo : cMessage.ml -cMessage.cmi : cMessage.mli -cMenu.cmo : cMenu.ml -cMenu.cmi : cMenu.mli -cEntry.cmo : cEntry.ml -cEntry.cmi : cEntry.mli -cListbox.cmo : cListbox.ml -cListbox.cmi : cListbox.mli -cFocus.cmo : cFocus.ml -cFocus.cmi : cFocus.mli -cMenubutton.cmo : cMenubutton.ml -cMenubutton.cmi : cMenubutton.mli -cPack.cmo : cPack.ml -cPack.cmi : cPack.mli -cOption.cmo : cOption.ml -cOption.cmi : cOption.mli -cToplevel.cmo : cToplevel.ml -cToplevel.cmi : cToplevel.mli -cFrame.cmo : cFrame.ml -cFrame.cmi : cFrame.mli -cDialog.cmo : cDialog.ml -cDialog.cmi : cDialog.mli -cImagebitmap.cmo : cImagebitmap.ml -cImagebitmap.cmi : cImagebitmap.mli -cClipboard.cmo : cClipboard.ml -cClipboard.cmi : cClipboard.mli -cRadiobutton.cmo : cRadiobutton.ml -cRadiobutton.cmi : cRadiobutton.mli -cTkwait.cmo : cTkwait.ml -cTkwait.cmi : cTkwait.mli -cGrab.cmo : cGrab.ml -cGrab.cmi : cGrab.mli -cSelection.cmo : cSelection.ml -cSelection.cmi : cSelection.mli -cScale.cmo : cScale.ml -cScale.cmi : cScale.mli -cOptionmenu.cmo : cOptionmenu.ml -cOptionmenu.cmi : cOptionmenu.mli -cWinfo.cmo : cWinfo.ml -cWinfo.cmi : cWinfo.mli -cGrid.cmo : cGrid.ml -cGrid.cmi : cGrid.mli -cCheckbutton.cmo : cCheckbutton.ml -cCheckbutton.cmi : cCheckbutton.mli -cBell.cmo : cBell.ml -cBell.cmi : cBell.mli -cTkvars.cmo : cTkvars.ml -cTkvars.cmi : cTkvars.mli -camltk.cmo : cTk.cmo cPlace.cmo cResource.cmo cWm.cmo cImagephoto.cmo cCanvas.cmo cButton.cmo cText.cmo cLabel.cmo cScrollbar.cmo cImage.cmo cEncoding.cmo cPixmap.cmo cPalette.cmo cFont.cmo cMessage.cmo cMenu.cmo cEntry.cmo cListbox.cmo cFocus.cmo cMenubutton.cmo cPack.cmo cOption.cmo cToplevel.cmo cFrame.cmo cDialog.cmo cImagebitmap.cmo cClipboard.cmo cRadiobutton.cmo cTkwait.cmo cGrab.cmo cSelection.cmo cScale.cmo cOptionmenu.cmo cWinfo.cmo cGrid.cmo cCheckbutton.cmo cBell.cmo cTkvars.cmo diff --git a/otherlibs/labltk/compiler/.cvsignore b/otherlibs/labltk/compiler/.cvsignore deleted file mode 100644 index 060114e624..0000000000 --- a/otherlibs/labltk/compiler/.cvsignore +++ /dev/null @@ -1,11 +0,0 @@ -lexer.ml -parser.output -parser.ml -parser.mli -tkcompiler -pp -copyright.ml -pplex.ml -ppyac.ml -ppyac.output -ppyac.mli diff --git a/otherlibs/labltk/compiler/.depend b/otherlibs/labltk/compiler/.depend deleted file mode 100644 index d33149e8cf..0000000000 --- a/otherlibs/labltk/compiler/.depend +++ /dev/null @@ -1,28 +0,0 @@ -pplex.cmi: ppyac.cmi -ppyac.cmi: code.cmi -compile.cmo: code.cmi flags.cmo ppexec.cmo ppparse.cmo tables.cmo -compile.cmx: code.cmi flags.cmx ppexec.cmx ppparse.cmx tables.cmx -intf.cmo: code.cmi compile.cmo flags.cmo ppexec.cmo ppparse.cmo tables.cmo -intf.cmx: code.cmi compile.cmx flags.cmx ppexec.cmx ppparse.cmx tables.cmx -lexer.cmo: parser.cmi -lexer.cmx: parser.cmx -maincompile.cmo: code.cmi compile.cmo flags.cmo intf.cmo lexer.cmo parser.cmi \ - ppexec.cmo ppparse.cmo printer.cmo tables.cmo tsort.cmo -maincompile.cmx: code.cmi compile.cmx flags.cmx intf.cmx lexer.cmx parser.cmx \ - ppexec.cmx ppparse.cmx printer.cmx tables.cmx tsort.cmx -parser.cmo: flags.cmo tables.cmo parser.cmi -parser.cmx: flags.cmx tables.cmx parser.cmi -pp.cmo: ppexec.cmo ppparse.cmo -pp.cmx: ppexec.cmx ppparse.cmx -ppexec.cmo: code.cmi -ppexec.cmx: code.cmi -pplex.cmo: ppyac.cmi pplex.cmi -pplex.cmx: ppyac.cmx pplex.cmi -ppparse.cmo: pplex.cmi ppyac.cmi -ppparse.cmx: pplex.cmx ppyac.cmx -ppyac.cmo: code.cmi ppyac.cmi -ppyac.cmx: code.cmi ppyac.cmi -printer.cmo: tables.cmo -printer.cmx: tables.cmx -tables.cmo: tsort.cmo -tables.cmx: tsort.cmx diff --git a/otherlibs/labltk/compiler/Makefile b/otherlibs/labltk/compiler/Makefile deleted file mode 100644 index a2b8453312..0000000000 --- a/otherlibs/labltk/compiler/Makefile +++ /dev/null @@ -1,63 +0,0 @@ -include ../support/Makefile.common - -OBJS= ../support/support.cmo flags.cmo copyright.cmo \ - tsort.cmo tables.cmo printer.cmo lexer.cmo \ - pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo \ - parser.cmo compile.cmo intf.cmo maincompile.cmo - -PPOBJS= pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo pp.cmo - -all: tkcompiler$(EXE) pp$(EXE) - -tkcompiler$(EXE) : $(OBJS) - $(CAMLC) -g $(LINKFLAGS) -o tkcompiler$(EXE) $(OBJS) - -pp$(EXE): $(PPOBJS) - $(CAMLC) -g $(LINKFLAGS) -o pp$(EXE) $(PPOBJS) - -lexer.ml: lexer.mll - $(CAMLLEX) lexer.mll - -parser.ml parser.mli: parser.mly - $(CAMLYACC) -v parser.mly - -pplex.ml: pplex.mll - $(CAMLLEX) pplex.mll - -pplex.mli: ppyac.cmi - -ppyac.ml ppyac.mli: ppyac.mly - $(CAMLYACC) -v ppyac.mly - -copyright.ml: copyright - (echo "let copyright=\"\\"; \ - cat copyright; \ - echo "\""; \ - echo "let write ~w = w copyright;;") > copyright.ml - -clean : - rm -f *.cm* parser.ml parser.mli lexer.ml copyright.ml - rm -f pplex.ml ppyac.ml ppyac.mli ppyac.output - rm -f tkcompiler$(EXE) pp$(EXE) parser.output - -scratch : - rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler$(EXE) - rm -f *.cm* pplex.ml ppyac.ml ppyac.mli pp$(EXE) - -install: - cp tkcompiler$(EXE) $(INSTALLDIR) - cp pp$(EXE) $(INSTALLDIR) - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .mlp - -.mli.cmi: - $(CAMLCOMP) -g $(COMPFLAGS) -I ../support $< - -.ml.cmo: - $(CAMLCOMP) -g $(COMPFLAGS) -I ../support $< - -depend: parser.ml parser.mli lexer.ml pplex.ml ppyac.ml ppyac.mli - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/labltk/compiler/Makefile.nt b/otherlibs/labltk/compiler/Makefile.nt deleted file mode 100644 index 3c936ba4c6..0000000000 --- a/otherlibs/labltk/compiler/Makefile.nt +++ /dev/null @@ -1,63 +0,0 @@ -include ../support/Makefile.common.nt - -OBJS= ../support/support.cmo flags.cmo copyright.cmo \ - tsort.cmo tables.cmo printer.cmo lexer.cmo \ - pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo \ - parser.cmo compile.cmo intf.cmo maincompile.cmo - -PPOBJS= pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo pp.cmo - -all: tkcompiler.exe pp.exe - -tkcompiler.exe : $(OBJS) - $(CAMLC) $(LINKFLAGS) -o tkcompiler.exe $(OBJS) - -pp.exe : $(PPOBJS) - $(CAMLC) $(LINKFLAGS) -o pp.exe $(PPOBJS) - -lexer.ml: lexer.mll - $(CAMLLEX) lexer.mll - -parser.ml parser.mli: parser.mly - $(CAMLYACC) -v parser.mly - -pplex.ml: pplex.mll - $(CAMLLEX) pplex.mll - -pplex.mli: ppyac.cmi - -ppyac.ml ppyac.mli: ppyac.mly - $(CAMLYACC) -v ppyac.mly - -copyright.ml: copyright - (echo "let copyright=\"\\"; \ - cat copyright; \ - echo "\""; \ - echo "let write ~w = w copyright;;") > copyright.ml - -clean : - rm -f *.cm* parser.ml parser.mli lexer.ml copyright.ml - rm -f pplex.ml ppyac.ml ppyac.mli ppyac.output - rm -f tkcompiler.exe pp.exe parser.output - -scratch : - rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler.exe - rm -f *.cm* pplex.ml ppyac.ml ppyac.mli pp.exe - -install: - cp tkcompiler.exe $(INSTALLDIR) - cp pp.exe $(INSTALLDIR) - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .mlp - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) -I ../support $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) -I ../support $< - -depend: parser.ml parser.mli lexer.ml pplex.ml ppyac.ml ppyac.mli - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/labltk/compiler/code.mli b/otherlibs/labltk/compiler/code.mli deleted file mode 100644 index 6f3e292134..0000000000 --- a/otherlibs/labltk/compiler/code.mli +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -type code = - | Line of string - | Ifdef of bool * string * code list * code list option - | Define of string - | Undef of string -;; diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml deleted file mode 100644 index 891078e982..0000000000 --- a/otherlibs/labltk/compiler/compile.ml +++ /dev/null @@ -1,1074 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open StdLabels -open Tables - -(* CONFIGURE *) -(* if you set it true, ImagePhoto and ImageBitmap will annoy you... *) -let safetype = true - -let labeloff ~at l = match l with - "", t -> t -| l, t -> raise (Failure ("labeloff: " ^ l ^ " at " ^ at)) - -let labltk_labelstring l = - if l = "" then l else - if l.[0] = '?' then l ^ ":" else - "~" ^ l ^ ":" - -let camltk_labelstring l = - if l = "" then l else - if l.[0] = '?' then l ^ ":" else "" - -let labelstring l = - if !Flags.camltk then camltk_labelstring l - else labltk_labelstring l - -let labltk_typelabel l = - if l = "" then l else l ^ ":" - -let camltk_typelabel l = - if l = "" then l - else if l.[0] = '?' then l ^ ":" else "" - -let typelabel l = - if !Flags.camltk then camltk_typelabel l - else labltk_typelabel l - -let forbidden = [ "class"; "type"; "in"; "from"; "to" ] -let nicknames = - [ "class", "clas"; - "type", "typ" ] - -let small = String.lowercase - -let gettklabel fc = - match fc.template with - ListArg( StringArg s :: _ ) -> - let s = small s in - if s = "" then s else - let s = - if s.[0] = '-' - then String.sub s ~pos:1 ~len:(String.length s - 1) - else s - in begin - if List.mem s forbidden then - try List.assoc s nicknames - with Not_found -> small fc.var_name - else s - end - | _ -> raise (Failure "gettklabel") - -let count ~item:x l = - let count = ref 0 in - List.iter ~f:(fun y -> if x = y then incr count) l; - !count - -(* Extract all types from a template *) -let rec types_of_template = function - StringArg _ -> [] - | TypeArg (l, t) -> [l, t] - | ListArg l -> List.flatten (List.map ~f:types_of_template l) - | OptionalArgs (l, tl, _) -> - begin - match List.flatten (List.map ~f:types_of_template tl) with - ["", t] -> ["?" ^ l, t] - | [_, _] -> raise (Failure "0 label required") - | _ -> raise (Failure "0 or more than 1 args in for optionals") - end - -(* - * Pretty print a type - * used to write ML type definitions - *) -let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = - let rec ppMLtype = - function - Unit -> "unit" - | Int -> "int" - | Float -> "float" - | Bool -> "bool" - | Char -> "char" - | String -> "string" -(* new *) - | List (Subtype (sup, sub)) -> - if !Flags.camltk then "(* " ^ sub ^ " *) " ^ sup ^ " list" - else begin - if return then - sub ^ "_" ^ sup ^ " list" - else begin - try - let typdef = Hashtbl.find types_table sup in - let fcl = List.assoc sub typdef.subtypes in - let tklabels = List.map ~f:gettklabel fcl in - let l = List.map fcl ~f: - begin fun fc -> - "?" ^ begin let p = gettklabel fc in - if count ~item:p tklabels > 1 then small fc.var_name else p - end - ^ ":" ^ - let l = types_of_template fc.template in - match l with - [] -> "unit" - | [lt] -> ppMLtype (labeloff lt ~at:"ppMLtype") - | l -> - "(" ^ String.concat ~sep:"*" - (List.map l - ~f:(fun lt -> ppMLtype (labeloff lt ~at:"ppMLtype"))) - ^ ")" - end in - String.concat ~sep:" ->\n" l - with - Not_found -> Printf.eprintf "ppMLtype %s/%s\n" sup sub; exit (-1) - end - end - | List ty -> (ppMLtype ty) ^ " list" - | Product tyl -> - "(" ^ String.concat ~sep:" * " (List.map ~f:ppMLtype tyl) ^ ")" - | Record tyl -> - String.concat ~sep:" * " - (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t)) - | Subtype ("widget", sub) -> - if !Flags.camltk then "(* " ^ sub ^" *) widget" else sub ^ " widget" - | UserDefined "widget" -> - if !Flags.camltk then "widget" - else begin - if any then "any widget" else - let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in - incr counter; - "'" ^ c ^ " widget" - end - | UserDefined s -> - if !Flags.camltk then s - else begin - (* a bit dirty hack for ImageBitmap and ImagePhoto *) - try - let typdef = Hashtbl.find types_table s in - if typdef.variant then - if return then try - "[>" ^ - String.concat ~sep:"|" - (List.map typdef.constructors ~f: - begin - fun c -> - "`" ^ c.var_name ^ - (match types_of_template c.template with - [] -> "" - | l -> " of " ^ ppMLtype (Product (List.map l - ~f:(labeloff ~at:"ppMLtype UserDefined")))) - end) ^ "]" - with - Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s - else if not def && List.length typdef.constructors > 1 then - "[< " ^ s ^ "]" - else s - else s - with Not_found -> s - end - | Subtype (s, s') -> - if !Flags.camltk then "(* " ^ s' ^ " *) " ^ s else s' ^ "_" ^ s - | Function (Product tyl) -> - raise (Failure "Function (Product tyl) ? ppMLtype") - | Function (Record tyl) -> - "(" ^ String.concat ~sep:" -> " - (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t)) - ^ " -> unit)" - | Function ty -> - "(" ^ (ppMLtype ty) ^ " -> unit)" - | As (t, s) -> - if !Flags.camltk then ppMLtype t - else s - in - ppMLtype - -(* Produce a documentation version of a template *) -let rec ppTemplate = function - StringArg s -> s - | TypeArg (l, t) -> "<" ^ ppMLtype t ^ ">" - | ListArg l -> "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate l) ^ "}" - | OptionalArgs (l, tl, d) -> - "?" ^ l ^ "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate tl) - ^ "}[<" ^ String.concat ~sep:" " (List.map ~f:ppTemplate d) ^ ">]" - -let doc_of_template = function - ListArg l -> String.concat ~sep:" " (List.map ~f:ppTemplate l) - | t -> ppTemplate t - -(* - * Type definitions - *) - -(* Write an ML constructor *) -let write_constructor ~w {ml_name = mlconstr; template = t} = - w mlconstr; - begin match types_of_template t with - [] -> () - | l -> w " of "; - w (ppMLtype ~any:true (Product (List.map l - ~f:(labeloff ~at:"write_constructor")))) - end; - w " (* tk option: "; w (doc_of_template t); w " *)" - -(* Write a rhs type decl *) -let write_constructors ~w = function - [] -> fatal_error "empty type" - | x :: l -> - write_constructor ~w x; - List.iter l ~f: - begin fun x -> - w "\n | "; - write_constructor ~w x - end - -(* Write an ML variant *) -let write_variant ~w {var_name = varname; template = t} = - w "`"; - w varname; - begin match types_of_template t with - [] -> () - | l -> - w " of "; - w (ppMLtype ~any:true ~def:true - (Product (List.map l ~f:(labeloff ~at:"write_variant")))) - end; - w " (* tk option: "; w (doc_of_template t); w " *)" - -let write_variants ~w = function - [] -> fatal_error "empty variants" - | l -> - List.iter l ~f: - begin fun x -> - w "\n | "; - write_variant ~w x - end - -(* Definition of a type *) -let labltk_write_type ~intf:w ~impl:w' name ~def:typdef = - (* Only needed if no subtypes, otherwise use optionals *) - if typdef.subtypes = [] then begin - w "(* Variant type *)\n"; - w ("type " ^ name ^ " = ["); - write_variants ~w (sort_components typdef.constructors); - w "\n]\n\n" - end - -(* CamlTk: List of constructors, for runtime subtyping *) -let write_constructor_set ~w ~sep = function - | [] -> fatal_error "empty type" - | x::l -> - w ("C" ^ x.ml_name); - List.iter l ~f: (function x -> - w sep; - w ("C" ^ x.ml_name)) - -(* CamlTk: Definition of a type *) -let camltk_write_type ~intf:w ~impl:w' name ~def:typdef = - (* Put markers for extraction *) - w "(* type *)\n"; - w ("type " ^ name ^ " =\n"); - w " | "; - write_constructors ~w (sort_components typdef.constructors); - w "\n(* /type *)\n\n"; - (* Dynamic Subtyping *) - if typdef.subtypes <> [] then begin - (* The set of its constructors *) - if name = "options" then begin - w "(* type *)\n"; - w ("type "^name^"_constrs =\n\t") - end else begin - (* added some prefix to avoid being picked up in documentation *) - w ("(* no doc *) type "^name^"_constrs =\n") - end; - w " | "; - write_constructor_set ~w:w ~sep: "\n | " - (sort_components typdef.constructors); - w "\n\n"; - (* The set of all constructors *) - w' ("let "^name^"_any_table = ["); - write_constructor_set ~w:w' ~sep:"; " - (sort_components typdef.constructors); - w' ("]\n\n"); - (* The subset of constructors for each subtype *) - List.iter ~f:(function (s,l) -> - w' ("let "^name^"_"^s^"_table = ["); - write_constructor_set ~w:w' ~sep:"; " (sort_components l); - w' ("]\n\n")) - typdef.subtypes - end - -let write_type ~intf:w ~impl:w' name ~def:typdef = - (if !Flags.camltk then camltk_write_type else labltk_write_type) - ~intf:w ~impl:w' name ~def:typdef - -(************************************************************) -(* Converters *) -(************************************************************) - -let rec converterTKtoCAML ~arg = function - | Int -> "int_of_string " ^ arg - | Float -> "float_of_string " ^ arg - | Bool -> "(match " ^ arg ^ " with - | \"1\" -> true - | \"0\" -> false - | s -> Pervasives.raise (Invalid_argument (\"cTKtoCAMLbool\" ^ s)))" - | Char -> "String.get " ^ arg ^ " 0" - | String -> arg - | UserDefined s -> "cTKtoCAML" ^ s ^ " " ^ arg - | Subtype ("widget", s') when not !Flags.camltk -> - String.concat ~sep:" " - ["(Obj.magic (cTKtoCAMLwidget "; arg; ") :"; s'; "widget)"] - | Subtype (s, s') -> - if !Flags.camltk then - "cTKtoCAML" ^ s ^ " " ^ arg - else - "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg - | List ty -> - begin match type_parser_arity ty with - OneToken -> - String.concat ~sep:" " - ["(List.map (function x ->"; - converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"] - | MultipleToken -> - String.concat ~sep:" " - ["iterate_converter (function x ->"; - converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"] - end - | As (ty, _) -> converterTKtoCAML ~arg ty - | t -> - prerr_endline ("ERROR with " ^ arg ^ " " ^ ppMLtype t); - fatal_error "converterTKtoCAML" - - -(*******************************) -(* Wrappers *) -(*******************************) -let varnames ~prefix n = - let rec var i = - if i > n then [] - else (prefix ^ string_of_int i) :: var (succ i) - in var 1 - -(* - * generate wrapper source for callbacks - * transform a function ... -> unit in a function : unit -> unit - * using primitives arg_ ... from the protocol - * Warning: sequentiality is important in generated code - * TODO: remove arg_ stuff and process lists directly ? - *) - -let rec wrapper_code ~name ty = - match ty with - Unit -> "(fun _ -> " ^ name ^ " ())" - | As (ty, _) -> wrapper_code ~name ty - | ty -> - "(fun args ->\n " ^ - begin match ty with - Product tyl -> raise (Failure "Product -> record was done. ???") - | Record tyl -> - (* variables for each component of the product *) - let vnames = varnames ~prefix:"a" (List.length tyl) in - (* getting the arguments *) - let readarg = - List.map2 vnames tyl ~f: - begin fun v (l, ty) -> - match type_parser_arity ty with - OneToken -> - "let (" ^ v ^ ", args) = " ^ - converterTKtoCAML ~arg:"(List.hd args)" ty ^ - ", List.tl args in\n " - | MultipleToken -> - "let (" ^ v ^ ", args) = " ^ - converterTKtoCAML ~arg:"args" ty ^ - " in\n " - end in - String.concat ~sep:"" readarg ^ name ^ " " ^ - String.concat ~sep:" " - (List.map2 ~f:(fun v (l, _) -> - if !Flags.camltk then v - else labelstring l ^ v) vnames tyl) - - (* all other types are read in one operation *) - | List ty -> - name ^ "(" ^ converterTKtoCAML ~arg:"args" ty ^ ")" - | String -> - name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")" - | ty -> - begin match type_parser_arity ty with - OneToken -> - name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")" - | MultipleToken -> - "let (v, _) = " ^ converterTKtoCAML ~arg:"args" ty ^ - " in\n " ^ name ^ " v" - end - end ^ ")" - -(*************************************************************) -(* Parsers *) -(* are required only for values returned by commands and *) -(* functions (table is computed by the parser) *) - -(* Tuples/Lists are Ok if they don't contain strings *) -(* they will be returned as list of strings *) - -(* Can we generate a "parser" ? - -> all constructors are unit and at most one int and one string, with null constr -*) -type parser_pieces = - { mutable zeroary : (string * string) list ; (* kw string, ml name *) - mutable intpar : string list; (* one at most, mlname *) - mutable stringpar : string list (* idem *) - } - -type mini_parser = - NoParser - | ParserPieces of parser_pieces - -let can_generate_parser constructors = - let pp = {zeroary = []; intpar = []; stringpar = []} in - if List.for_all constructors ~f: - begin fun c -> - let vname = if !Flags.camltk then c.ml_name else c.var_name in - match c.template with - ListArg [StringArg s] -> - pp.zeroary <- (s, vname) :: - pp.zeroary; true - | ListArg [TypeArg(_, Int)] | ListArg[TypeArg(_, Float)] -> - if pp.intpar <> [] then false - else (pp.intpar <- [vname]; true) - | ListArg [TypeArg(_, String)] -> - if pp.stringpar <> [] then false - else (pp.stringpar <- [vname]; true) - | _ -> false - end - then ParserPieces pp - else NoParser - - -(* We can generate parsers only for simple types *) -(* we should avoid multiple walks *) -let labltk_write_TKtoCAML ~w name ~def:typdef = - if typdef.parser_arity = MultipleToken then - prerr_string ("You must write cTKtoCAML" ^ name ^ - " : string list ->" ^ name ^ " * string list\n") - else - let write ~consts ~name = - match can_generate_parser consts with - NoParser -> - prerr_string - ("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n") - | ParserPieces pp -> - w ("let cTKtoCAML" ^ name ^ " n =\n"); - (* First check integer *) - if pp.intpar <> [] then - begin - w (" try `" ^ List.hd pp.intpar ^ " (int_of_string n)\n"); - w (" with _ ->\n") - end; - w (" match n with\n"); - List.iter pp.zeroary ~f: - begin fun (tk, ml) -> - w " | \""; w tk; w "\" -> `"; w ml; w "\n" - end; - let final = if pp.stringpar <> [] then - "n -> `" ^ List.hd pp.stringpar ^ " n" - else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML" - ^ name ^ ": \" ^ s))" - in - w " | "; - w final; - w "\n\n" - in - begin - write ~name ~consts:typdef.constructors; - List.iter typdef.subtypes ~f: begin - fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts - end - end - -let camltk_write_TKtoCAML ~w name ~def:typdef = - if typdef.parser_arity = MultipleToken then - prerr_string ("You must write cTKtoCAML" ^ name ^ - " : string list ->" ^ name ^ " * string list\n") - else - let write ~consts ~name = - match can_generate_parser consts with - NoParser -> - prerr_string - ("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n") - | ParserPieces pp -> - w ("let cTKtoCAML" ^ name ^ " n =\n"); - (* First check integer *) - if pp.intpar <> [] then - begin - w (" try " ^ List.hd pp.intpar ^ " (int_of_string n)\n"); - w (" with _ ->\n") - end; - w (" match n with\n"); - List.iter pp.zeroary ~f: - begin fun (tk, ml) -> - w " | \""; w tk; w "\" -> "; w ml; w "\n" - end; - let final = if pp.stringpar <> [] then - "n -> " ^ List.hd pp.stringpar ^ " n" - else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML" - ^ name ^ ": \" ^ s))" - in - w " | "; - w final; - w "\n\n" - in - begin - write ~name ~consts:typdef.constructors; - List.iter typdef.subtypes ~f: begin - fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts - end - end - -let write_TKtoCAML ~w name ~def:typdef = - (if !Flags.camltk then camltk_write_TKtoCAML else labltk_write_TKtoCAML) - ~w name ~def: typdef - -(******************************) -(* Converters *) -(******************************) - -(* Produce an in-lined converter Caml -> Tk for simple types *) -(* the converter is a function of type: <type> -> string *) -let rec converterCAMLtoTK ~context_widget argname ty = - match ty with - Int -> "TkToken (string_of_int " ^ argname ^ ")" - | Float -> "TkToken (Printf.sprintf \"%g\" " ^ argname ^ ")" - | Bool -> "if " ^ argname ^ " then TkToken \"1\" else TkToken \"0\"" - | Char -> "TkToken (Char.escaped " ^ argname ^ ")" - | String -> "TkToken " ^ argname - | As (ty, _) -> converterCAMLtoTK ~context_widget argname ty - | UserDefined s -> - let name = "cCAMLtoTK" ^ s ^ " " in - let args = argname in - let args = - if !Flags.camltk then begin - if is_subtyped s then (* unconstraint subtype *) - s ^ "_any_table " ^ args - else args - end else args - in - let args = - if requires_widget_context s then - context_widget ^ " " ^ args - else args in - name ^ args - | Subtype ("widget", s') -> - if !Flags.camltk then - let name = "cCAMLtoTKwidget " in - let args = "widget_"^s'^"_table "^argname in - let args = - if requires_widget_context "widget" then - context_widget^" "^args - else args in - name^args - else begin - let name = "cCAMLtoTKwidget " in - let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in - name ^ args - end - | Subtype (s, s') -> - let name = - if !Flags.camltk then "cCAMLtoTK" ^ s ^ " " - else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " " - in - let args = - if !Flags.camltk then begin - s^"_"^s'^"_table "^argname - end else begin - if safetype then "(" ^ argname ^ " : [< " ^ s' ^ "_" ^ s ^ "])" - else argname - end - in - let args = - if requires_widget_context s then context_widget ^ " " ^ args - else args in - name ^ args - | Product tyl -> - let vars = varnames ~prefix:"z" (List.length tyl) in - String.concat ~sep:" " - ("let" :: String.concat ~sep:"," vars :: "=" :: argname :: - "in TkTokenList [" :: - String.concat ~sep:"; " - (List.map2 vars tyl ~f:(converterCAMLtoTK ~context_widget)) :: - ["]"]) - | List ty -> (* Just added for Imagephoto.put *) - String.concat ~sep:" " - [(if !Flags.camltk then - "TkQuote (TkTokenList (List.map (fun y -> " - else - "TkQuote (TkTokenList (List.map ~f:(fun y -> "); - converterCAMLtoTK ~context_widget "y" ty; - ")"; - argname; - "))"] - | Function _ -> fatal_error "unexpected function type in converterCAMLtoTK" - | Unit -> fatal_error "unexpected unit type in converterCAMLtoTK" - | Record _ -> fatal_error "unexpected product type in converterCAMLtoTK" - -(* - * Produce a list of arguments from a template - * The idea here is to avoid allocation as much as possible - * - *) - -let code_of_template ~context_widget ?func:(funtemplate=false) template = - let catch_opts = ref ("", "") in (* class name and first option *) - let variables = ref [] in - let variables2 = ref [] in - let varcnter = ref 0 in - let optionvar = ref None in - let newvar1 l = - match !optionvar with - Some v -> optionvar := None; v - | None -> - incr varcnter; - let v = "v" ^ (string_of_int !varcnter) in - variables := (l, v) :: !variables; v in - let newvar2 l = - match !optionvar with - Some v -> optionvar := None; v - | None -> - incr varcnter; - let v = "v" ^ (string_of_int !varcnter) in - variables2 := (l, v) :: !variables2; v in - let newvar = ref newvar1 in - let rec coderec = function - StringArg s -> "TkToken \"" ^ s ^ "\"" - | TypeArg (_, List (Subtype (sup, sub) as ty)) when not !Flags.camltk -> - begin try - let typdef = Hashtbl.find types_table sup in - let classdef = List.assoc sub typdef.subtypes in - let lbl = gettklabel (List.hd classdef) in - catch_opts := (sub ^ "_" ^ sup, lbl); - newvar := newvar2; - "TkTokenList opts" - with Not_found -> - raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub)); - end - | TypeArg (l, List ty) -> - (if !Flags.camltk then - "TkTokenList (List.map (function x -> " - else - "TkTokenList (List.map ~f:(function x -> ") - ^ converterCAMLtoTK ~context_widget "x" ty - ^ ") " ^ !newvar l ^ ")" - | TypeArg (l, Function tyarg) -> - "let id = register_callback " ^ context_widget - ^ " ~callback: " ^ wrapper_code ~name:(!newvar l) tyarg - ^ " in TkToken (\"camlcb \" ^ id)" - | TypeArg (l, ty) -> converterCAMLtoTK ~context_widget (!newvar l) ty - | ListArg l -> - "TkQuote (TkTokenList [" - ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "])" - | OptionalArgs (l, tl, d) -> - let nv = !newvar ("?" ^ l) in - optionvar := Some nv; (* Store *) - let argstr = String.concat ~sep:"; " (List.map ~f:coderec tl) in - let defstr = String.concat ~sep:"; " (List.map ~f:coderec d) in - "TkTokenList (match " ^ nv ^ " with\n" - ^ " | Some " ^ nv ^ " -> [" ^ argstr ^ "]\n" - ^ " | None -> [" ^ defstr ^ "])" - in - let code = - if funtemplate then - match template with - ListArg l -> - "[|" ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "|]" - | _ -> "[|" ^ coderec template ^ "|]" - else - match template with - ListArg [x] -> coderec x - | ListArg l -> - "TkTokenList [" ^ - String.concat ~sep:";\n " (List.map ~f:coderec l) ^ - "]" - | _ -> coderec template - in - code, List.rev !variables, List.rev !variables2, !catch_opts - -(* - * Converters for user defined types - *) - -(* For each case of a concrete type *) -let labltk_write_clause ~w ~context_widget comp = - let warrow () = w " -> " in - w "`"; - w comp.var_name; - - let code, variables, variables2, (co, _) = - code_of_template ~context_widget comp.template in - - (* no subtype I think ... *) - if co <> "" then raise (Failure "write_clause subtype ?"); - begin match variables with - | [] -> warrow() - | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow() - | l -> - w " ( "; - w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l)); - w ")"; - warrow() - end; - w code - -let camltk_write_clause ~w ~context_widget ~subtype comp = - let warrow () = - w " -> "; - if subtype then - w ("chk_sub \""^comp.ml_name^"\" table C" ^ comp.ml_name ^ "; ") - in - - w comp.ml_name; (* we use ml_name, not var_name, specialized for labltk *) - - let code, variables, variables2, (co, _) = - code_of_template ~context_widget comp.template in - - (* no subtype I think ... *) - if co <> "" then raise (Failure "write_clause subtype ?"); - begin match variables with - | [] -> warrow() - | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow() - | l -> - w " ( "; - w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l)); - w ")"; - warrow() - end; - w code - -let write_clause ~w ~context_widget ~subtype comp = - if !Flags.camltk then camltk_write_clause ~w ~context_widget ~subtype comp - else labltk_write_clause ~w ~context_widget comp - -(* The full converter *) -let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name = - let write_one name constrs = - let subtype = typdef.subtypes <> [] in - w ("let cCAMLtoTK" ^ name); - let context_widget = - if typdef.requires_widget_context then begin - w " w"; "w" - end - else - "dummy" in - if !Flags.camltk && subtype then w " table"; - if st then begin - w " : "; - if typdef.variant then w ("[< " ^ name ^ "]") else w name; - w " -> tkArgs " - end; - w (" = function"); - List.iter constrs - ~f:(fun c -> w "\n | "; write_clause ~w ~context_widget ~subtype c); - w "\n\n\n" - in - - let constrs = typdef.constructors in - if !Flags.camltk then write_one name constrs - else begin - (* Only needed if no subtypes, otherwise use optionals *) - if typdef.subtypes == [] then - write_one name constrs - else - List.iter constrs ~f: - begin fun fc -> - let code, vars, _, (co, _) = - code_of_template ~context_widget:"dummy" fc.template in - if co <> "" then fatal_error "optionals in optionals"; - let vars = List.map ~f:snd vars in - w "let ccCAMLtoTK"; w name; w "_"; w (small fc.ml_name); - w " ("; w (String.concat ~sep:", " vars); w ") =\n "; - w code; w "\n\n" - end - end - -(* Tcl does not really return "lists". It returns sp separated tokens *) -let rec write_result_parsing ~w = function - List String -> - w "(splitlist res)" - | List ty -> - if !Flags.camltk then - w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) - else - w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) - | Product tyl -> raise (Failure "Product -> record was done. ???") - | Record tyl -> (* of course all the labels are "" *) - let rnames = varnames ~prefix:"r" (List.length tyl) in - w " let l = splitlist res in"; - w ("\n if List.length l <> " ^ string_of_int (List.length tyl)); - w ("\n then Pervasives.raise (TkError (\"unexpected result: \" ^ res))"); - w ("\n else "); - List.iter2 rnames tyl ~f: - begin fun r (l, ty) -> - if l <> "" then raise (Failure "lables in return type!!!"); - w (" let " ^ r ^ ", l = "); - begin match type_parser_arity ty with - OneToken -> - w (converterTKtoCAML ~arg:"(List.hd l)" ty); w (", List.tl l") - | MultipleToken -> - w (converterTKtoCAML ~arg:"l" ty) - end; - w (" in\n") - end; - w (String.concat ~sep:", " rnames) - | String -> - w (converterTKtoCAML ~arg:"res" String) - | As (ty, _) -> write_result_parsing ~w ty - | ty -> - match type_parser_arity ty with - OneToken -> w (converterTKtoCAML ~arg:"res" ty) - | MultipleToken -> w (converterTKtoCAML ~arg:"(splitlist res)" ty) - -let labltk_write_function ~w def = - w ("let " ^ def.ml_name); - (* a bit approximative *) - let context_widget = match def.template with - ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" - | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" - | _ -> "dummy" in - - let code, variables, variables2, (co, lbl) = - code_of_template ~func:true ~context_widget def.template in - (* Arguments *) - let uv, lv, ov = - let rec replace_args ~u ~l ~o = function - [] -> u, l, o - | ("", x) :: ls -> - replace_args ~u:(x :: u) ~l ~o ls - | (p, _ as x) :: ls when p.[0] = '?' -> - replace_args ~u ~l ~o:(x :: o) ls - | x :: ls -> - replace_args ~u ~l:(x :: l) ~o ls - in - replace_args ~u:[] ~l:[] ~o:[] (List.rev (variables @ variables2)) - in - let has_opts = (ov <> [] || co <> "") in - if not has_opts then List.iter uv ~f:(fun x -> w " "; w x); - List.iter (lv@ov) ~f:(fun (l, v) -> w " "; w (labelstring l); w v); - if co <> "" then begin - if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta"); - w " =\n"; - w (co ^ "_optionals"); - if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta"); - w " (fun opts"; - if uv = [] then w " ()" else - if has_opts then List.iter uv ~f:(fun x -> w " "; w x); - w " ->\n" - end else begin - if (ov <> [] || lv = []) && uv = [] then w " ()" else - if has_opts then List.iter uv ~f:(fun x -> w " "; w x); - w " =\n" - end; - begin match def.result with - | Unit | As (Unit, _) -> w "tkCommand "; w code - | ty -> - w "let res = tkEval "; w code ; w " in \n"; - write_result_parsing ~w ty - end; - if co <> "" then w ")"; - w "\n\n" - -let camltk_write_function ~w def = - w ("let " ^ def.ml_name); - (* a bit approximative *) - let context_widget = match def.template with - ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" - | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" - | _ -> "dummy" in - - let code, variables, variables2, (co, lbl) = - code_of_template ~func:true ~context_widget def.template in - (* Arguments *) - let uv, ov = - let rec replace_args ~u ~o = function - [] -> u, o - | ("", x) :: ls -> - replace_args ~u:(x :: u) ~o ls - | (p, _ as x) :: ls when p.[0] = '?' -> - replace_args ~u ~o:(x :: o) ls - | (_,x) :: ls -> - replace_args ~u:(x::u) ~o ls - in - replace_args ~u:[] ~o:[] (List.rev (variables @ variables2)) - in - let has_opts = ov <> [] (* (ov <> [] || co <> "") *) in - if not has_opts then List.iter uv ~f:(fun x -> w " "; w x); - List.iter ov ~f:(fun (l, v) -> w " "; w (labelstring l); w v); - begin - if uv = [] then w " ()" else - if has_opts then List.iter uv ~f:(fun x -> w " "; w x); - w " =\n" - end; - begin match def.result with - | Unit | As (Unit, _) -> w "tkCommand "; w code - | ty -> - w "let res = tkEval "; w code ; w " in \n"; - write_result_parsing ~w ty - end; - w "\n\n" - -(* - w ("let " ^ def.ml_name); - (* a bit approximative *) - let context_widget = match def.template with - ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" - | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" - | _ -> "dummy" in - - let code, variables, variables2, (co, lbl) = - code_of_template ~func:true ~context_widget def.template in - let variables = variables @ variables2 in - (* Arguments *) - begin match variables with - [] -> w " () =\n" - | l -> - let has_normal_argument = ref false in - List.iter (fun (l,x) -> - w " "; - if l <> "" then - if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true - else has_normal_argument := true; - w x) l; - if not !has_normal_argument then w " ()"; - w " =\n" - end; - begin match def.result with - | Unit | As (Unit, _) -> w "tkCommand "; w code - | ty -> - w "let res = tkEval "; w code ; w " in \n"; - write_result_parsing ~w ty - end; - w "\n\n" -*) - -let write_function ~w def = - if !Flags.camltk then camltk_write_function ~w def - else labltk_write_function ~w def -;; - -let labltk_write_create ~w clas = - w ("let create ?name =\n"); - w (" " ^ clas ^ "_options_optionals (fun opts parent ->\n"); - w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n"); - w " tkCommand [|"; - w ("TkToken \"" ^ clas ^ "\";\n"); - w (" TkToken (Widget.name w);\n"); - w (" TkTokenList opts |];\n"); - w (" w)\n\n\n") - -let camltk_write_create ~w clas = - w ("let create ?name parent options =\n"); - w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n"); - w " tkCommand [|"; - w ("TkToken \"" ^ clas ^ "\";\n"); - w (" TkToken (Widget.name w);\n"); - w (" TkTokenList (List.map (function x -> "^ - converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n"); - w (" |];\n"); - w (" w\n\n") - -let camltk_write_named_create ~w clas = - w ("let create_named parent name options =\n"); - w (" let w = new_atom \"" ^ clas ^ "\" ~parent ~name in\n"); - w " tkCommand [|"; - w ("TkToken \"" ^ clas ^ "\";\n"); - w (" TkToken (Widget.name w);\n"); - w (" TkTokenList (List.map (function x -> "^ - converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n"); - w (" |];\n"); - w (" w\n\n") - -(* Search Path. *) -let search_path = ref ["."] - -(* taken from utils/misc.ml *) -let find_in_path path name = - if not (Filename.is_implicit name) then - if Sys.file_exists name then name else raise Not_found - else begin - let rec try_dir = function - [] -> raise Not_found - | dir :: rem -> - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then fullname else try_dir rem - in try_dir path - end - -(* builtin-code: the file (without suffix) is in .template... *) -(* not efficient, but hell *) -let write_external ~w def = - match def.template with - | StringArg fname -> - begin try - let realname = find_in_path !search_path (fname ^ ".ml") in - let ic = open_in_bin realname in - try - let code_list = Ppparse.parse_channel ic in - close_in ic; - List.iter (Ppexec.exec (fun _ -> ()) w) - (if !Flags.camltk then - Code.Define "CAMLTK" :: code_list else code_list ); - with - | Ppparse.Error s -> - close_in ic; - raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) - with - | Not_found -> - raise (Compiler_Error ("can't find external file: " ^ fname)) - end - | _ -> raise (Compiler_Error "invalid external definition") - -let write_catch_optionals ~w clas ~def:typdef = - if typdef.subtypes = [] then () else - List.iter typdef.subtypes ~f: - begin fun (subclass, classdefs) -> - w ("let " ^ subclass ^ "_" ^ clas ^ "_optionals f = fun\n"); - let tklabels = List.map ~f:gettklabel classdefs in - let l = - List.map classdefs ~f: - begin fun fc -> - (* - let code, vars, _, (co, _) = - code_of_template ~context_widget:"dummy" fc.template in - if co <> "" then fatal_error "optionals in optionals"; - *) - let p = gettklabel fc in - (if count ~item:p tklabels > 1 then small fc.var_name else p), - small fc.ml_name - end in - let p = List.map l ~f:(fun (si, _) -> " ?" ^ si) in - let v = - List.map l ~f: - begin fun (si, s) -> - "(maycons ccCAMLtoTK" ^ clas ^ "_" ^ s ^ " " ^ si - end in - w (String.concat ~sep:"\n" p); - w " ->\n"; - w " f "; - w (String.concat ~sep:"\n " v); - w "\n []"; - w (String.make (List.length v) ')'); - w "\n\n" - end diff --git a/otherlibs/labltk/compiler/copyright b/otherlibs/labltk/compiler/copyright deleted file mode 100644 index 23dff46dce..0000000000 --- a/otherlibs/labltk/compiler/copyright +++ /dev/null @@ -1,15 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) diff --git a/otherlibs/labltk/compiler/flags.ml b/otherlibs/labltk/compiler/flags.ml deleted file mode 100644 index 009d5e725a..0000000000 --- a/otherlibs/labltk/compiler/flags.ml +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -let camltk = ref false;; diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml deleted file mode 100644 index 58955b962b..0000000000 --- a/otherlibs/labltk/compiler/intf.ml +++ /dev/null @@ -1,191 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open StdLabels - -(* Write .mli for widgets *) - -open Tables -open Compile - -let labltk_write_create_p ~w wname = - w "val create :\n ?name:string ->\n"; - begin - try - let option = Hashtbl.find types_table "options" in - let classdefs = List.assoc wname option.subtypes in - let tklabels = List.map ~f:gettklabel classdefs in - let l = List.map classdefs ~f: - begin fun fc -> - begin let p = gettklabel fc in - if count ~item:p tklabels > 1 then small fc.var_name else p - end, - fc.template - end in - w (String.concat ~sep:" ->\n" - (List.map l ~f: - begin fun (s, t) -> - " ?" ^ s ^ ":" - ^(ppMLtype - (match types_of_template t with - | [t] -> labeloff t ~at:"write_create_p" - | [] -> fatal_error "multiple" - | l -> Product (List.map ~f:(labeloff ~at:"write_create_p") l))) - end)) - with Not_found -> fatal_error "in write_create_p" - end; - w (" ->\n 'a widget -> " ^ wname ^ " widget\n"); - w "(** [create ?name parent options...] creates a new widget with\n"; - w " parent [parent] and new patch component [name], if specified. *)\n\n" -;; - -let camltk_write_create_p ~w wname = - w "val create : ?name: string -> widget -> options list -> widget \n"; - w "(** [create ?name parent options] creates a new widget with\n"; - w " parent [parent] and new patch component [name] if specified.\n"; - w " Options are restricted to the widget class subset, and checked\n"; - w " dynamically. *)\n\n" -;; - -let camltk_write_named_create_p ~w wname = - w "val create_named : widget -> string -> options list -> widget \n"; - w "(** [create_named parent name options] creates a new widget with\n"; - w " parent [parent] and new patch component [name].\n"; - w " This function is now obsolete and unified with [create]. *)\n\n"; -;; - -(* Unsafe: write special comment *) -let labltk_write_function_type ~w def = - if not def.safe then w "(* unsafe *)\n"; - w "val "; w def.ml_name; w " : "; - let us, ls, os = - let tys = types_of_template def.template in - let rec replace_args ~u ~l ~o = function - [] -> u, l, o - | (_, List(Subtype _) as x)::ls -> - replace_args ~u ~l ~o:(x::o) ls - | ("", _ as x)::ls -> - replace_args ~u:(x::u) ~l ~o ls - | (p, _ as x)::ls when p.[0] = '?' -> - replace_args ~u ~l ~o:(x::o) ls - | x::ls -> - replace_args ~u ~l:(x::l) ~o ls - in - replace_args ~u:[] ~l:[] ~o:[] (List.rev tys) - in - let counter = ref 0 in - let params = - if os = [] then us @ ls else ls @ os @ us in - List.iter params ~f: - begin fun (l, t) -> - if l <> "" then w (l ^ ":"); - w (ppMLtype t ~counter); - w " -> " - end; - if (os <> [] || ls = []) && us = [] then w "unit -> "; - w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) - w " \n"; -(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *) - if def.safe then w "\n" - else w "\n(* /unsafe *)\n" - -let camltk_write_function_type ~w def = - if not def.safe then w "(* unsafe *)\n"; - w "val "; w def.ml_name; w " : "; - let us, os = - let tys = types_of_template def.template in - let rec replace_args ~u ~o = function - [] -> u, o - | ("", _ as x)::ls -> - replace_args ~u:(x::u) ~o ls - | (p, _ as x)::ls when p.[0] = '?' -> - replace_args ~u ~o:(x::o) ls - | x::ls -> - replace_args ~u:(x::u) ~o ls - in - replace_args ~u:[] ~o:[] (List.rev tys) - in - let counter = ref 0 in - let params = - if os = [] then us else os @ us in - List.iter params ~f: - begin fun (l, t) -> - if l <> "" then if l.[0] = '?' then w (l ^ ":"); - w (ppMLtype t ~counter); - w " -> " - end; - if us = [] then w "unit -> "; - w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) - w " \n"; -(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *) - if def.safe then w "\n" - else w "\n(* /unsafe *)\n" - -(* - if not def.safe then w "(* unsafe *)\n"; - w "val "; w def.ml_name; w " : "; - let tys = types_of_template def.template in - let counter = ref 0 in - let have_normal_arg = ref false in - List.iter tys ~f: - begin fun (l, t) -> - if l <> "" then - if l.[0] = '?' then w (l^":") - else begin - have_normal_arg := true; - w (" (* " ^ l ^ ":*)") - end - else have_normal_arg := true; - w (ppMLtype t ~counter); - w " -> " - end; - if not !have_normal_arg then w "unit -> "; - w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) - w " \n"; - if def.safe then w "\n" - else w "\n(* /unsafe *)\n" -*) - -let write_function_type ~w def = - if !Flags.camltk then camltk_write_function_type ~w def - else labltk_write_function_type ~w def - -let write_external_type ~w def = - match def.template with - | StringArg fname -> - begin try - let realname = find_in_path !search_path (fname ^ ".mli") in - let ic = open_in_bin realname in - try - let code_list = Ppparse.parse_channel ic in - close_in ic; - if not def.safe then w "(* unsafe *)\n"; - List.iter (Ppexec.exec (fun _ -> ()) w) - (if !Flags.camltk then - Code.Define "CAMLTK" :: code_list else code_list ); - if def.safe then w "\n\n" - else w "\n(* /unsafe *)\n\n" - with - | Ppparse.Error s -> - close_in ic; - raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) - with - | Not_found -> - raise (Compiler_Error ("can't find external file: " ^ fname)) - end - | _ -> raise (Compiler_Error "invalid external definition") diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll deleted file mode 100644 index c65c9a604b..0000000000 --- a/otherlibs/labltk/compiler/lexer.mll +++ /dev/null @@ -1,170 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -{ -open StdLabels -open Lexing -open Parser -open Support - -exception Lexical_error of string -let current_line = ref 1 - - -(* The table of keywords *) - -let keyword_table = (Hashtbl.create 149 : (string, token) Hashtbl.t) - -let _ = List.iter - ~f:(fun (str,tok) -> Hashtbl.add keyword_table str tok) - [ - "int", TYINT; - "float", TYFLOAT; - "bool", TYBOOL; - "char", TYCHAR; - "string", TYSTRING; - "list", LIST; - "as", AS; - "variant", VARIANT; - "widget", WIDGET; - "option", OPTION; - "type", TYPE; - "subtype", SUBTYPE; - "function", FUNCTION; - "module", MODULE; - "external", EXTERNAL; - "sequence", SEQUENCE; - "unsafe", UNSAFE -] - - -(* 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 ~src:(!string_buff) ~src_pos:0 ~dst:new_buff ~dst_pos:0 - ~len:(String.length (!string_buff)); - string_buff := new_buff - end; - String.set (!string_buff) (!string_index) c; - incr string_index - -let get_stored_string () = - let s = String.sub (!string_buff) ~pos:0 ~len:(!string_index) in - string_buff := initial_string_buffer; - s -(* To translate escape sequences *) - -let char_for_backslash = function - 'n' -> '\010' - | 'r' -> '\013' - | 'b' -> '\008' - | 't' -> '\009' - | c -> c - -let char_for_decimal_code lexbuf i = - Char.chr(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)) - -let saved_string_start = ref 0 - -} - -rule main = parse - '\010' { incr current_line; main lexbuf } - | [' ' '\013' '\009' '\026' '\012'] + - { main lexbuf } - | ['A'-'Z' 'a'-'z' '\192'-'\214' '\216'-'\246' '\248'-'\255' ] - ( '_' ? ['A'-'Z' 'a'-'z' '\192'-'\214' '\216'-'\246' '\248'-'\255' (*'*) '0'-'9' ] ) * - { let s = Lexing.lexeme lexbuf in - try - Hashtbl.find keyword_table s - with Not_found -> - IDENT s } - - | "\"" - { reset_string_buffer(); - (* Start of token is start of string. *) - saved_string_start := lexbuf.lex_start_pos; - string lexbuf; - lexbuf.lex_start_pos <- !saved_string_start; - STRING (get_stored_string()) } - | "(" { LPAREN } - | ")" { RPAREN } - | "[" { LBRACKET } - | "]" { RBRACKET } - | "{" { LBRACE } - | "}" { RBRACE } - | "," { COMMA } - | ";" { SEMICOLON } - | ":" {COLON} - | "?" {QUESTION} - | "/" {SLASH} - | "%" { comment lexbuf; main lexbuf } - | "##line" { line lexbuf; main lexbuf } - | eof { EOF } - | _ - { raise (Lexical_error("illegal character")) } - - -and string = parse - '"' - { () } - | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] + - { 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 (Lexical_error("string not terminated")) } - | '\010' - { incr current_line; - store_string_char(Lexing.lexeme_char lexbuf 0); - string lexbuf } - | _ - { store_string_char(Lexing.lexeme_char lexbuf 0); - string lexbuf } - -and comment = parse - '\010' { incr current_line } - | eof { () } - | _ { comment lexbuf } - -and linenum = parse - | ['0'-'9']+ { - let next_line = int_of_string (Lexing.lexeme lexbuf) in - current_line := next_line - 1 - } - | _ { raise (Lexical_error("illegal ##line directive: no line number"))} - -and line = parse - | [' ' '\t']* { linenum lexbuf } diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml deleted file mode 100644 index 2e0c3c3697..0000000000 --- a/otherlibs/labltk/compiler/maincompile.ml +++ /dev/null @@ -1,418 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open StdLabels -open Support -open Tables -open Printer -open Compile -open Intf - -let flag_verbose = ref false -let verbose_string s = - if !flag_verbose then prerr_string s -let verbose_endline s = - if !flag_verbose then prerr_endline s - -let input_name = ref "Widgets.src" -let output_dir = ref "" -let destfile f = Filename.concat !output_dir f - -let usage () = - prerr_string "Usage: tkcompiler input.src\n"; - flush stderr; - exit 1 - - -let prerr_error_header () = - prerr_string "File \""; prerr_string !input_name; - prerr_string "\", line "; - prerr_string (string_of_int !Lexer.current_line); - prerr_string ": " - -(* parse Widget.src config file *) -let parse_file filename = - let ic = open_in_bin filename in - let lexbuf = - try - let code_list = Ppparse.parse_channel ic in - close_in ic; - let buf = Buffer.create 50000 in - List.iter (Ppexec.exec - (fun l -> Buffer.add_string buf - (Printf.sprintf "##line %d\n" l)) - (Buffer.add_string buf)) - (if !Flags.camltk then Code.Define "CAMLTK" :: code_list - else code_list); - Lexing.from_string (Buffer.contents buf) - with - | Ppparse.Error s -> - close_in ic; - raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) - in - try - while true do - Parser.entry Lexer.main lexbuf - done - with - | Parsing.Parse_error -> - prerr_error_header(); - prerr_string "Syntax error \n"; - exit 1 - | Lexer.Lexical_error s -> - prerr_error_header(); - prerr_string "Lexical error ("; - prerr_string s; - prerr_string ")\n"; - exit 1 - | Duplicate_Definition (s,s') -> - prerr_error_header(); - prerr_string s; prerr_string " "; prerr_string s'; - prerr_string " is defined twice.\n"; - exit 1 - | Compiler_Error s -> - prerr_error_header(); - prerr_string "Internal error: "; prerr_string s; prerr_string "\n"; - prerr_string "Please report bug\n"; - exit 1 - | End_of_file -> - () - -(* The hack to provoke the production of cCAMLtoTKoptions_constrs *) - -(* Auxiliary function: the list of all the elements associated to keys - in an hash table. *) -let elements t = - let elems = ref [] in - Hashtbl.iter (fun _ d -> elems := d :: !elems) t; - !elems;; - -(* Verifies that duplicated clauses are semantically equivalent and - returns a unique set of clauses. *) -let uniq_clauses = function - | [] -> [] - | l -> - let check_constr constr1 constr2 = - if constr1.template <> constr2.template then - begin - let code1, vars11, vars12, opts1 = - code_of_template ~context_widget:"dummy" constr1.template in - let code2, vars12, vars22, opts2 = - code_of_template ~context_widget:"dummy" constr2.template in - let err = - Printf.sprintf - "uncompatible redondant clauses for variant %s:\n %s\n and\n %s" - constr1.var_name code1 code2 in - Format.print_newline(); - print_fullcomponent constr1; - Format.print_newline(); - print_fullcomponent constr2; - Format.print_newline(); - prerr_endline err; - fatal_error err - end in - let t = Hashtbl.create 11 in - List.iter l - ~f:(fun constr -> - let c = constr.var_name in - if Hashtbl.mem t c - then (check_constr constr (Hashtbl.find t c)) - else Hashtbl.add t c constr); - elements t;; - -let option_hack oc = - if Hashtbl.mem types_table "options" then - let typdef = Hashtbl.find types_table "options" in - let hack = - { parser_arity = OneToken; - constructors = begin - let constrs = - List.map typdef.constructors ~f: - begin fun c -> - { component = Constructor; - ml_name = (if !Flags.camltk then "C" ^ c.ml_name - else c.ml_name); - var_name = c.var_name; (* as variants *) - template = - begin match c.template with - ListArg (x :: _) -> x - | _ -> fatal_error "bogus hack" - end; - result = UserDefined "options_constrs"; - safe = true } - end in - if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *) - end; - subtypes = []; - requires_widget_context = false; - variant = false } - in - write_CAMLtoTK - ~w:(output_string oc) ~def:hack ~safetype:false "options_constrs" - -let realname name = - (* module name fix for camltk *) - if !Flags.camltk then "c" ^ String.capitalize name - else name -;; - -(* analize the parsed Widget.src and output source files *) -let compile () = - verbose_endline "Creating _tkgen.ml ..."; - let oc = open_out_bin (destfile "_tkgen.ml") in - let oc' = open_out_bin (destfile "_tkigen.ml") in - let oc'' = open_out_bin (destfile "_tkfgen.ml") in - let sorted_types = Tsort.sort types_order in - verbose_endline " writing types ..."; - List.iter sorted_types ~f: - begin fun typname -> - verbose_string (" " ^ typname ^ " "); - try - let typdef = Hashtbl.find types_table typname in - verbose_string "type "; - write_type ~intf:(output_string oc) - ~impl:(output_string oc') - typname ~def:typdef; - verbose_string "C2T "; - write_CAMLtoTK ~w:(output_string oc') typname ~def:typdef; - verbose_string "T2C "; - if List.mem typname !types_returned then - write_TKtoCAML ~w:(output_string oc') typname ~def:typdef; - verbose_string "CO "; - if not !Flags.camltk then (* only for LablTk *) - write_catch_optionals ~w:(output_string oc') typname ~def:typdef; - verbose_endline "." - with Not_found -> - if not (List.mem_assoc typname !types_external) then - begin - verbose_string "Type "; - verbose_string typname; - verbose_string " is undeclared external or undefined\n" - end - else verbose_endline "." - end; - verbose_endline " option hacking ..."; - option_hack oc'; - verbose_endline " writing functions ..."; - List.iter ~f:(write_function ~w:(output_string oc'')) !function_table; - close_out oc; - close_out oc'; - close_out oc''; - (* Write the interface for public functions *) - (* this interface is used only for documentation *) - verbose_endline "Creating _tkgen.mli ..."; - let oc = open_out_bin (destfile "_tkgen.mli") in - List.iter (sort_components !function_table) - ~f:(write_function_type ~w:(output_string oc)); - close_out oc; - verbose_endline "Creating other ml, mli ..."; - let write_module wname wdef = - verbose_endline (" "^wname); - let modname = realname wname in - let oc = open_out_bin (destfile (modname ^ ".ml")) - and oc' = open_out_bin (destfile (modname ^ ".mli")) in - Copyright.write ~w:(output_string oc); - Copyright.write ~w:(output_string oc'); - begin match wdef.module_type with - Widget -> output_string oc' ("(* The "^wname^" widget *)\n") - | Family -> output_string oc' ("(* The "^wname^" commands *)\n") - end; - List.iter ~f:(fun s -> output_string oc s; output_string oc' s) - begin - if !Flags.camltk then - [ "open CTk\n"; - "open Tkintf\n"; - "open Widget\n"; - "open Textvariable\n\n" ] - else - [ "open StdLabels\n"; - "open Tk\n"; - "open Tkintf\n"; - "open Widget\n"; - "open Textvariable\n\n" ] - end; - output_string oc "open Protocol\n"; - begin match wdef.module_type with - Widget -> - if !Flags.camltk then begin - camltk_write_create ~w:(output_string oc) wname; - camltk_write_named_create ~w:(output_string oc) wname; - camltk_write_create_p ~w:(output_string oc') wname; - camltk_write_named_create_p ~w:(output_string oc') wname; - end else begin - labltk_write_create ~w:(output_string oc) wname; - labltk_write_create_p ~w:(output_string oc') wname - end - | Family -> () - end; - List.iter ~f:(write_function ~w:(output_string oc)) - (sort_components wdef.commands); - List.iter ~f:(write_function_type ~w:(output_string oc')) - (sort_components wdef.commands); - List.iter ~f:(write_external ~w:(output_string oc)) - (sort_components wdef.externals); - List.iter ~f:(write_external_type ~w:(output_string oc')) - (sort_components wdef.externals); - close_out oc; - close_out oc' - in Hashtbl.iter write_module module_table; - - (* wrapper code camltk.ml and labltk.ml *) - if !Flags.camltk then begin - let oc = open_out_bin (destfile "camltk.ml") in - Copyright.write ~w:(output_string oc); - output_string oc -"(** This module Camltk provides the module name spaces of the CamlTk API. - - The users of the CamlTk API should open this module first to access - the types, functions and modules of the CamlTk API easier. - For the documentation of each sub modules such as [Button] and [Toplevel], - refer to its defintion file, [cButton.mli], [cToplevel.mli], etc. - *) - -"; - output_string oc "include CTk\n"; - output_string oc "module Tk = CTk\n"; - Hashtbl.iter (fun name _ -> - let cname = realname name in - output_string oc (Printf.sprintf "module %s = %s;;\n" - (String.capitalize name) - (String.capitalize cname))) module_table; - close_out oc - end else begin - let oc = open_out_bin (destfile "labltk.ml") in - Copyright.write ~w:(output_string oc); - output_string oc -"(** This module Labltk provides the module name spaces of the LablTk API, - useful to call LablTk functions inside CamlTk programs. 100% LablTk users - do not need to use this. *) - -"; - output_string oc "module Widget = Widget;; -module Protocol = Protocol;; -module Textvariable = Textvariable;; -module Fileevent = Fileevent;; -module Timer = Timer;; -"; - Hashtbl.iter (fun name _ -> - let cname = realname name in - output_string oc (Printf.sprintf "module %s = %s;;\n" - (String.capitalize name) - (String.capitalize name))) module_table; - (* widget typer *) - output_string oc "\n(** Widget typers *)\n\nopen Widget\n\n"; - Hashtbl.iter (fun name def -> - match def.module_type with - | Widget -> - output_string oc (Printf.sprintf - "let %s (w : any widget) =\n" name); - output_string oc (Printf.sprintf - " Rawwidget.check_class w widget_%s_table;\n" name); - output_string oc (Printf.sprintf - " (Obj.magic w : %s widget);;\n\n" name); - | _ -> () ) module_table; - close_out oc - end; - - (* write the module list for the Makefile *) - (* and hack to death until it works *) - let oc = open_out_bin (destfile "modules") in - if !Flags.camltk then output_string oc "CWIDGETOBJS=" - else output_string oc "WIDGETOBJS="; - Hashtbl.iter - (fun name _ -> - let name = realname name in - output_string oc name; - output_string oc ".cmo ") - module_table; - output_string oc "\n"; - Hashtbl.iter - (fun name _ -> - let name = realname name in - output_string oc name; - output_string oc ".ml ") - module_table; - output_string oc ": _tkgen.ml\n\n"; - Hashtbl.iter - (fun name _ -> - let name = realname name in - 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; - - (* for camltk.ml wrapper *) - if !Flags.camltk then begin - output_string oc "camltk.cmo : cTk.cmo "; - Hashtbl.iter - (fun name _ -> - let name = realname name in - output_string oc name; - output_string oc ".cmo ") module_table; - output_string oc "\n" - end; - close_out oc - -let main () = - Arg.parse - [ "-verbose", Arg.Unit (fun () -> flag_verbose := true), - "Make output verbose"; - "-camltk", Arg.Unit (fun () -> Flags.camltk := true), - "Make CamlTk interface"; - "-outdir", Arg.String (fun s -> output_dir := s), - "output directory"; - "-debugpp", Arg.Unit (fun () -> Ppexec.debug := true), - "debug preprocessor" - ] - (fun filename -> input_name := filename) - "Usage: tkcompiler <source file>" ; - if !output_dir = "" then begin - prerr_endline "specify -outdir option"; - exit 1 - end; - try - verbose_endline "Parsing..."; - parse_file !input_name; - verbose_endline "Compiling..."; - compile (); - verbose_endline "Finished"; - exit 0 - with - | Lexer.Lexical_error s -> - prerr_string "Invalid lexical character: "; - prerr_endline s; - exit 1 - | Duplicate_Definition (s, s') -> - prerr_string s; prerr_string " "; prerr_string s'; - prerr_endline " is redefined illegally"; - exit 1 - | Invalid_implicit_constructor c -> - prerr_string "Constructor "; - prerr_string c; - prerr_endline " is used implicitly before defined"; - exit 1 - | Tsort.Cyclic -> - prerr_endline "Cyclic dependency of types"; - exit 1 - -let () = Printexc.catch main () diff --git a/otherlibs/labltk/compiler/parser.mly b/otherlibs/labltk/compiler/parser.mly deleted file mode 100644 index c797f4fb5b..0000000000 --- a/otherlibs/labltk/compiler/parser.mly +++ /dev/null @@ -1,330 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -%{ - -open Tables - -%} - -/* Tokens */ -%token <string> IDENT -%token <string> STRING -%token EOF - -%token LPAREN /* "(" */ -%token RPAREN /* ")" */ -%token COMMA /* "," */ -%token SEMICOLON /* ";" */ -%token COLON /* ":" */ -%token QUESTION /* "?" */ -%token LBRACKET /* "[" */ -%token RBRACKET /* "]" */ -%token LBRACE /* "{" */ -%token RBRACE /* "}" */ -%token SLASH /* "/" */ - -%token TYINT /* "int" */ -%token TYFLOAT /* "float" */ -%token TYBOOL /* "bool" */ -%token TYCHAR /* "char" */ -%token TYSTRING /* "string" */ -%token LIST /* "list" */ - -%token AS /* "as" */ -%token VARIANT /* "variant" */ -%token WIDGET /* "widget" */ -%token OPTION /* "option" */ -%token TYPE /* "type" */ -%token SEQUENCE /* "sequence" */ -%token SUBTYPE /* "subtype" */ -%token FUNCTION /* "function" */ -%token MODULE /* "module" */ -%token EXTERNAL /* "external" */ -%token UNSAFE /* "unsafe" */ -/* Entry points */ -%start entry -%type <unit> entry - -%% -TypeName: - IDENT { String.uncapitalize $1 } - | WIDGET { "widget" } -; - -/* Atomic types */ -Type0 : - TYINT - { Int } - | TYFLOAT - { Float } - | TYBOOL - { Bool } - | TYCHAR - { Char } - | TYSTRING - { String } - | TypeName - { UserDefined $1 } -; - -/* Camltk/Labltk types */ -Type0_5: - | Type0 SLASH Type0 { if !Flags.camltk then $1 else $3 } - | Type0 { $1 } -; - -/* with subtypes */ -Type1 : - Type0_5 - { $1 } - | TypeName LPAREN IDENT RPAREN - { Subtype ($1, $3) } - | WIDGET LPAREN IDENT RPAREN - { Subtype ("widget", $3) } - | OPTION LPAREN IDENT RPAREN - { Subtype ("options", $3) } - | Type1 AS STRING - { As ($1, $3) } - | LBRACE Type_list RBRACE - { Product $2 } -; - -/* with list constructors */ -Type2 : - Type1 - { $1 } - | Type2 LIST - { List $1 } -; - -Labeled_type2 : - Type2 - { "", $1 } - | IDENT COLON Type2 - { $1, $3 } -; - -/* products */ -Type_list : - Type2 COMMA Type_list - { $1 :: $3 } - | Type2 - { [$1] } -; - -/* records */ -Type_record : - Labeled_type2 COMMA Type_record - { $1 :: $3 } - | Labeled_type2 - { [$1] } -; - -/* callback arguments or function results*/ -FType : - LPAREN RPAREN - { Unit } - | LPAREN Type2 RPAREN - { $2 } - | LPAREN Type_record RPAREN - { Record $2 } -; - -Type : - Type2 - { $1 } - | FUNCTION FType - { Function $2 } -; - - - -SimpleArg: - STRING - {StringArg $1} - | Type - {TypeArg ("", $1) } -; - -Arg: - STRING - {StringArg $1} - | Type - {TypeArg ("", $1) } - | IDENT COLON Type - {TypeArg ($1, $3)} - | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET DefaultList - {OptionalArgs ( $2, $5, $7 )} - | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET DefaultList - {OptionalArgs ( "widget", $5, $7 )} - | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET - {OptionalArgs ( $2, $5, [] )} - | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET - {OptionalArgs ( "widget", $5, [] )} - | WIDGET COLON Type - {TypeArg ("widget", $3)} - | Template - { $1 } -; - -SimpleArgList: - SimpleArg SEMICOLON SimpleArgList - { $1 :: $3} - | SimpleArg - { [$1] } -; - -ArgList: - Arg SEMICOLON ArgList - { $1 :: $3} - | Arg - { [$1] } -; - -/* DefaultList Only one TypeArg in ArgList and it must be unlabeled */ -DefaultList : - LBRACKET LBRACE ArgList RBRACE RBRACKET - {$3} - -/* Template */ -Template : - LBRACKET ArgList RBRACKET - { ListArg $2 } -; - - -/* Constructors for type declarations */ -Constructor : - IDENT Template - {{ component = Constructor; - ml_name = $1; - var_name = getvarname $1 $2; - template = $2; - result = Unit; - safe = true }} - | IDENT LPAREN IDENT RPAREN Template - {{ component = Constructor; - ml_name = $1; - var_name = $3; - template = $5; - result = Unit; - safe = true }} -; - -AbbrevConstructor : - Constructor - { Full $1 } - | IDENT - { Abbrev $1 } -; - -Constructors : - Constructor Constructors - { $1 :: $2 } -| Constructor - { [$1] } -; - -AbbrevConstructors : - AbbrevConstructor AbbrevConstructors - { $1 :: $2 } -| AbbrevConstructor - { [$1] } -; - -Safe: - /* */ - { true } - | UNSAFE - { false } - -Command : - Safe FUNCTION FType IDENT Template - {{component = Command; ml_name = $4; var_name = ""; - template = $5; result = $3; safe = $1 }} -; - -External : - Safe EXTERNAL IDENT STRING - {{component = External; ml_name = $3; var_name = ""; - template = StringArg $4; result = Unit; safe = $1}} -; - -Option : - OPTION IDENT Template - {{component = Constructor; ml_name = $2; var_name = getvarname $2 $3; - template = $3; result = Unit; safe = true }} - /* Abbreviated */ -| OPTION IDENT LPAREN IDENT RPAREN Template - {{component = Constructor; ml_name = $2; var_name = $4; - template = $6; result = Unit; safe = true }} - /* Abbreviated */ -| OPTION IDENT - { retrieve_option $2 } -; - -WidgetComponents : - /* */ - { [] } - | Command WidgetComponents - { $1 :: $2 } - | Option WidgetComponents - { $1 :: $2 } - | External WidgetComponents - { $1 :: $2 } -; - -ModuleComponents : - /* */ - { [] } - | Command ModuleComponents - { $1 :: $2 } - | External ModuleComponents - { $1 :: $2 } -; - -ParserArity : - /* */ - { OneToken } - | SEQUENCE - { MultipleToken } -; - - - -entry : - TYPE ParserArity TypeName LBRACE Constructors RBRACE - { enter_type $3 $2 $5 } -| VARIANT TYPE ParserArity TypeName LBRACE Constructors RBRACE - { enter_type $4 $3 $6 ~variant: true } -| TYPE ParserArity TypeName EXTERNAL - { enter_external_type $3 $2 } -| SUBTYPE ParserArity OPTION LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE - { enter_subtype "options" $2 $5 $8 } -| SUBTYPE ParserArity TypeName LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE - { enter_subtype $3 $2 $5 $8 } -| Command - { enter_function $1 } -| WIDGET IDENT LBRACE WidgetComponents RBRACE - { enter_widget $2 $4 } -| MODULE IDENT LBRACE ModuleComponents RBRACE - { enter_module (String.uncapitalize $2) $4 } -| EOF - { raise End_of_file } -; diff --git a/otherlibs/labltk/compiler/pp.ml b/otherlibs/labltk/compiler/pp.ml deleted file mode 100644 index 5c46766af7..0000000000 --- a/otherlibs/labltk/compiler/pp.ml +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -let _ = - try - let code_list = Ppparse.parse_channel stdin in - List.iter (Ppexec.exec (fun _ -> ()) print_string) code_list - with - | Ppparse.Error s -> prerr_endline s; exit 2 -;; diff --git a/otherlibs/labltk/compiler/ppexec.ml b/otherlibs/labltk/compiler/ppexec.ml deleted file mode 100644 index 9946882030..0000000000 --- a/otherlibs/labltk/compiler/ppexec.ml +++ /dev/null @@ -1,60 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -open Code - -let debug = ref false -let defined = ref [] -let linenum = ref 1 - -let rec nop = function - | Line _ -> incr linenum - | Ifdef (_, _, c1, c2o) -> - List.iter nop c1; - begin match c2o with - | Some c2 -> List.iter nop c2 - | None -> () - end - | _ -> () -;; - -let rec exec lp f = function - | Line line -> - if !debug then - prerr_endline (Printf.sprintf "%03d: %s" !linenum - (String.sub line 0 ((String.length line) - 1))); - f line; incr linenum - | Ifdef (sw, k, c1, c2o) -> - if List.mem k !defined = sw then begin - List.iter (exec lp f) c1; - begin match c2o with - | Some c2 -> List.iter nop c2 - | None -> () - end; - lp !linenum - end else begin - List.iter nop c1; - match c2o with - | Some c2 -> - lp !linenum; - List.iter (exec lp f) c2 - | None -> () - end - | Define k -> defined := k :: !defined - | Undef k -> - defined := List.fold_right (fun k' s -> - if k = k' then s else k' :: s) [] !defined -;; diff --git a/otherlibs/labltk/compiler/pplex.mli b/otherlibs/labltk/compiler/pplex.mli deleted file mode 100644 index 4eaa183b24..0000000000 --- a/otherlibs/labltk/compiler/pplex.mli +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -exception Error of string -val token : Lexing.lexbuf -> Ppyac.token diff --git a/otherlibs/labltk/compiler/pplex.mll b/otherlibs/labltk/compiler/pplex.mll deleted file mode 100644 index bb30c233ac..0000000000 --- a/otherlibs/labltk/compiler/pplex.mll +++ /dev/null @@ -1,57 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -{ -open Ppyac -exception Error of string -let linenum = ref 1 -} - -let blank = [' ' '\013' '\009' '\012'] -let identchar = - ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] -let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] -let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] - -rule token = parse - blank + { token lexbuf } -| "##" [' ' '\t']* { directive lexbuf } -| ("#")? [^ '#' '\n']* '\n'? { - begin - let str = Lexing.lexeme lexbuf in - let line = !linenum in - if String.length str <> 0 && str.[String.length str - 1] = '\n' then - begin - incr linenum - end; - OTHER (str) - end - } -| eof { EOF } - -and directive = parse -| "ifdef" [' ' '\t']+ { IFDEF (ident lexbuf)} -| "ifndef" [' ' '\t']+ { IFNDEF (ident lexbuf)} -| "else" { ELSE } -| "endif" { ENDIF } -| "define" [' ' '\t']+* { DEFINE (ident lexbuf)} -| "undef" [' ' '\t']+ { UNDEF (ident lexbuf)} -| _ { raise (Error (Printf.sprintf "unknown directive at line %d" !linenum))} - -and ident = parse -| lowercase identchar* | uppercase identchar* - { Lexing.lexeme lexbuf } -| _ { raise (Error (Printf.sprintf "illegal identifier at line %d" !linenum)) } diff --git a/otherlibs/labltk/compiler/ppparse.ml b/otherlibs/labltk/compiler/ppparse.ml deleted file mode 100644 index 3d1ee2af4f..0000000000 --- a/otherlibs/labltk/compiler/ppparse.ml +++ /dev/null @@ -1,36 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -exception Error of string - -let parse_channel ic = - let lexbuf = Lexing.from_channel ic in - try - Ppyac.code_list Pplex.token lexbuf - with - | Pplex.Error s -> - let loc_start = Lexing.lexeme_start lexbuf - and loc_end = Lexing.lexeme_end lexbuf - in - raise (Error (Printf.sprintf "parse error at char %d, %d: %s" - loc_start loc_end s)) - | Parsing.Parse_error -> - let loc_start = Lexing.lexeme_start lexbuf - and loc_end = Lexing.lexeme_end lexbuf - in - raise (Error (Printf.sprintf "parse error at char %d, %d" - loc_start loc_end)) -;; diff --git a/otherlibs/labltk/compiler/ppyac.mly b/otherlibs/labltk/compiler/ppyac.mly deleted file mode 100644 index da7ee681f2..0000000000 --- a/otherlibs/labltk/compiler/ppyac.mly +++ /dev/null @@ -1,52 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -%{ -open Code -%} - -%token <string> IFDEF -%token <string> IFNDEF -%token ELSE -%token ENDIF -%token <string> DEFINE -%token <string> UNDEF -%token <string> OTHER -%token EOF - -/* entry */ - -%start code_list -%type <Code.code list> code_list - -%% - -code_list: - /* empty */ { [] } - | code code_list { $1 :: $2 } -; - -code: - | DEFINE { Define $1 } - | UNDEF { Undef $1 } - | IFDEF code_list ELSE code_list ENDIF { Ifdef (true, $1, $2, Some ($4)) } - | IFNDEF code_list ELSE code_list ENDIF { Ifdef (false, $1, $2, Some ($4)) } - | IFDEF code_list ENDIF { Ifdef (true, $1, $2, None) } - | IFNDEF code_list ENDIF { Ifdef (false, $1, $2, None) } - | OTHER { Line $1 } -; - -%% diff --git a/otherlibs/labltk/compiler/printer.ml b/otherlibs/labltk/compiler/printer.ml deleted file mode 100644 index 60362d17fb..0000000000 --- a/otherlibs/labltk/compiler/printer.ml +++ /dev/null @@ -1,173 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -open Tables;; - -open Format;; - -let escape_string s = - let more = ref 0 in - for i = 0 to String.length s - 1 do - match s.[i] with - | '\\' | '"' -> incr more - | _ -> () - done; - if !more = 0 then s else - let res = String.create (String.length s + !more) in - let j = ref 0 in - for i = 0 to String.length s - 1 do - let c = s.[i] in - match c with - | '\\' | '"' -> res.[!j] <- '\\'; incr j; res.[!j] <- c; incr j - | _ -> res.[!j] <- c; incr j - done; - res;; - -let escape_char c = if c = '\'' then "\\'" else String.make 1 c;; - -let print_quoted_string s = printf "\"%s\"" (escape_string s);; -let print_quoted_char c = printf "'%s'" (escape_char c);; -let print_quoted_int i = - if i < 0 then printf "(%d)" i else printf "%d" i;; -let print_quoted_float f = - if f <= 0.0 then printf "(%f)" f else printf "%f" f;; - -(* Iterators *) -let print_list f l = - printf "@[<1>["; - let rec pl = function - | [] -> printf "@;<0 -1>]@]" - | [x] -> f x; pl [] - | x :: xs -> f x; printf ";@ "; pl xs in - pl l;; - -let print_array f v = - printf "@[<2>[|"; - let l = Array.length v in - if l >= 1 then f v.(0); - if l >= 2 then - for i = 1 to l - 1 do - printf ";@ "; f v.(i) - done; - printf "@;<0 -1>|]@]";; - -let print_option f = function - | None -> print_string "None" - | Some x -> printf "@[<1>Some@ "; f x; printf "@]";; - -let print_bool = function - | true -> print_string "true" | _ -> print_string "false";; - -let print_poly x = print_string "<poly>";; - -(* Types of the description language *) -let rec print_mltype = function - | Unit -> printf "Unit" | Int -> printf "Int" | Float -> printf "Float" - | Bool -> printf "Bool" | Char -> printf "Char" | String -> printf "String" - | List m -> printf "@[<1>(%s@ " "List"; print_mltype m; printf ")@]" - | Product l_m -> - printf "@[<1>(%s@ " "Product"; print_list print_mltype l_m; printf ")@]" - | Record l_t_s_m -> - printf "@[<1>(%s@ " "Record"; - print_list - (function (s, m) -> - printf "@[<1>("; print_quoted_string s; printf ",@ "; print_mltype m; - printf ")@]") - l_t_s_m; - printf ")@]" - | UserDefined s -> - printf "@[<1>(%s@ " "UserDefined"; print_quoted_string s; printf ")@]" - | Subtype (s, s0) -> - printf "@[<1>(%s@ " "Subtype"; printf "@[<1>("; print_quoted_string s; - printf ",@ "; print_quoted_string s0; printf ")@]"; printf ")@]" - | Function m -> - printf "@[<1>(%s@ " "Function"; print_mltype m; printf ")@]" - | As (m, s) -> - printf "@[<1>(%s@ " "As"; printf "@[<1>("; print_mltype m; printf ",@ "; - print_quoted_string s; printf ")@]"; printf ")@]";; - -let rec print_template = function - | StringArg s -> - printf "@[<1>(%s@ " "StringArg"; print_quoted_string s; printf ")@]" - | TypeArg (s, m) -> - printf "@[<1>(%s@ " "TypeArg"; printf "@[<1>("; print_quoted_string s; - printf ",@ "; print_mltype m; printf ")@]"; printf ")@]" - | ListArg l_t -> - printf "@[<1>(%s@ " "ListArg"; print_list print_template l_t; - printf ")@]" - | OptionalArgs (s, l_t, l_t0) -> - printf "@[<1>(%s@ " "OptionalArgs"; printf "@[<1>("; - print_quoted_string s; printf ",@ "; print_list print_template l_t; - printf ",@ "; print_list print_template l_t0; printf ")@]"; printf ")@]";; - -(* Sorts of components *) -let rec print_component_type = function - | Constructor -> printf "Constructor" | Command -> printf "Command" - | External -> printf "External";; - -(* Full definition of a component *) -let rec print_fullcomponent = function - {component = c; ml_name = s; var_name = s0; template = t; result = m; - safe = b; - } -> - printf "@[<1>{"; printf "@[<1>component =@ "; print_component_type c; - printf ";@]@ "; printf "@[<1>ml_name =@ "; print_quoted_string s; - printf ";@]@ "; printf "@[<1>var_name =@ "; print_quoted_string s0; - printf ";@]@ "; printf "@[<1>template =@ "; print_template t; - printf ";@]@ "; printf "@[<1>result =@ "; print_mltype m; printf ";@]@ "; - printf "@[<1>safe =@ "; print_bool b; printf ";@]@ "; printf "@,}@]";; - -(* components are given either in full or abbreviated *) -let rec print_component = function - | Full f -> printf "@[<1>(%s@ " "Full"; print_fullcomponent f; printf ")@]" - | Abbrev s -> - printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]";; - -(* A type definition *) -(* - requires_widget_context: the converter of the type MUST be passed - an additional argument of type Widget. -*) -let rec print_parser_arity = function - | OneToken -> printf "OneToken" | MultipleToken -> printf "MultipleToken";; - -let rec print_type_def = function - {parser_arity = p; constructors = l_f; subtypes = l_t_s_l_f; - requires_widget_context = b; variant = b0; - } -> - printf "@[<1>{"; printf "@[<1>parser_arity =@ "; print_parser_arity p; - printf ";@]@ "; printf "@[<1>constructors =@ "; - print_list print_fullcomponent l_f; printf ";@]@ "; - printf "@[<1>subtypes =@ "; - print_list - (function (s, l_f0) -> - printf "@[<1>("; print_quoted_string s; printf ",@ "; - print_list print_fullcomponent l_f0; printf ")@]") - l_t_s_l_f; - printf ";@]@ "; printf "@[<1>requires_widget_context =@ "; print_bool b; - printf ";@]@ "; printf "@[<1>variant =@ "; print_bool b0; printf ";@]@ "; - printf "@,}@]";; - -let rec print_module_type = function - | Widget -> printf "Widget" | Family -> printf "Family";; - -let rec print_module_def = function - {module_type = m; commands = l_f; externals = l_f0; } -> - printf "@[<1>{"; printf "@[<1>module_type =@ "; print_module_type m; - printf ";@]@ "; printf "@[<1>commands =@ "; - print_list print_fullcomponent l_f; printf ";@]@ "; - printf "@[<1>externals =@ "; print_list print_fullcomponent l_f0; - printf ";@]@ "; printf "@,}@]";; diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml deleted file mode 100644 index 0d395cdc2f..0000000000 --- a/otherlibs/labltk/compiler/tables.ml +++ /dev/null @@ -1,427 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open StdLabels -open Support - -(* Internal compiler errors *) - -exception Compiler_Error of string -let fatal_error s = raise (Compiler_Error s) - - -(* Types of the description language *) -type mltype = - Unit - | Int - | Float - | Bool - | Char - | String - | List of mltype - | Product of mltype list - | Record of (string * mltype) list - | UserDefined of string - | Subtype of string * string - | Function of mltype (* arg type only *) - | As of mltype * string - -type template = - StringArg of string - | TypeArg of string * mltype - | ListArg of template list - | OptionalArgs of string * template list * template list - -(* Sorts of components *) -type component_type = - Constructor - | Command - | External - -(* Full definition of a component *) -type fullcomponent = { - component : component_type; - ml_name : string; (* used for camltk *) - var_name : string; (* used just for labltk *) - template : template; - result : mltype; - safe : bool - } - -let sort_components = - List.sort ~cmp:(fun c1 c2 -> compare c1.ml_name c2.ml_name) - - -(* components are given either in full or abbreviated *) -type component = - Full of fullcomponent - | Abbrev of string - -(* A type definition *) -(* - requires_widget_context: the converter of the type MUST be passed - an additional argument of type Widget. -*) - -type parser_arity = - OneToken -| MultipleToken - -type type_def = { - parser_arity : parser_arity; - mutable constructors : fullcomponent list; - mutable subtypes : (string * fullcomponent list) list; - mutable requires_widget_context : bool; - mutable variant : bool -} - -type module_type = - Widget - | Family - -type module_def = { - module_type : module_type; - commands : fullcomponent list; - externals : fullcomponent list -} - -(******************** The tables ********************) - -(* the table of all explicitly defined types *) -let types_table = (Hashtbl.create 37 : (string, type_def) Hashtbl.t) -(* "builtin" types *) -let types_external = ref ([] : (string * parser_arity) list) -(* dependancy order *) -let types_order = (Tsort.create () : string Tsort.porder) -(* Types of atomic values returned by Tk functions *) -let types_returned = ref ([] : string list) -(* Function table *) -let function_table = ref ([] : fullcomponent list) -(* Widget/Module table *) -let module_table = (Hashtbl.create 37 : (string, module_def) Hashtbl.t) - - -(* variant name *) -let rec getvarname ml_name temp = - let offhypben s = - let s = String.copy s in - if (try String.sub s ~pos:0 ~len:1 with _ -> "") = "-" then - String.sub s ~pos:1 ~len:(String.length s - 1) - else s - and makecapital s = - begin - try - let cd = s.[0] in - if cd >= 'a' && cd <= 'z' then - s.[0] <- Char.chr (Char.code cd + (Char.code 'A' - Char.code 'a')) - with - _ -> () - end; - s - in - let head = makecapital (offhypben begin - match temp with - StringArg s -> s - | TypeArg (s,t) -> s - | ListArg (h::_) -> getvarname ml_name h - | OptionalArgs (s,_,_) -> s - | ListArg [] -> "" - end) - in - let varname = if head = "" then ml_name - else if head.[0] >= 'A' && head.[0] <= 'Z' then head - else ml_name - in varname - -(***** Some utilities on the various tables *****) -(* Enter a new empty type *) -let new_type typname arity = - Tsort.add_element types_order typname; - let typdef = {parser_arity = arity; - constructors = []; - subtypes = []; - requires_widget_context = false; - variant = false} in - Hashtbl.add types_table typname typdef; - typdef - - -(* Assume that types not yet defined are not subtyped *) -(* Widget is builtin and implicitly subtyped *) -let is_subtyped s = - s = "widget" || - try - let typdef = Hashtbl.find types_table s in - typdef.subtypes <> [] - with - Not_found -> false - -let requires_widget_context s = - try - (Hashtbl.find types_table s).requires_widget_context - with - Not_found -> false - -let declared_type_parser_arity s = - try - (Hashtbl.find types_table s).parser_arity - with - Not_found -> - try List.assoc s !types_external - with - Not_found -> - prerr_string "Type "; prerr_string s; - prerr_string " is undeclared external or undefined\n"; - prerr_string ("Assuming cTKtoCAML"^s^" : string -> "^s^"\n"); - OneToken - -let rec type_parser_arity = function - Unit -> OneToken - | Int -> OneToken - | Float -> OneToken - | Bool -> OneToken - | Char -> OneToken - | String -> OneToken - | List _ -> MultipleToken - | Product _ -> MultipleToken - | Record _ -> MultipleToken - | UserDefined s -> declared_type_parser_arity s - | Subtype (s,_) -> declared_type_parser_arity s - | Function _ -> OneToken - | As (ty, _) -> type_parser_arity ty - -let enter_external_type s v = - types_external := (s,v)::!types_external - -(*** Stuff for topological Sort.list of types ***) -(* Make sure all types used in commands and functions are in *) -(* the table *) -let rec enter_argtype = function - Unit | Int | Float | Bool | Char | String -> () - | List ty -> enter_argtype ty - | Product tyl -> List.iter ~f:enter_argtype tyl - | Record tyl -> List.iter tyl ~f:(fun (l,t) -> enter_argtype t) - | UserDefined s -> Tsort.add_element types_order s - | Subtype (s,_) -> Tsort.add_element types_order s - | Function ty -> enter_argtype ty - | As (ty, _) -> enter_argtype ty - -let rec enter_template_types = function - StringArg _ -> () - | TypeArg (l,t) -> enter_argtype t - | ListArg l -> List.iter ~f:enter_template_types l - | OptionalArgs (_,tl,_) -> List.iter ~f:enter_template_types tl - -(* Find type dependancies on s *) -let rec add_dependancies s = - function - List ty -> add_dependancies s ty - | Product tyl -> List.iter ~f:(add_dependancies s) tyl - | Subtype(s',_) -> if s <> s' then Tsort.add_relation types_order (s', s) - | UserDefined s' -> if s <> s' then Tsort.add_relation types_order (s', s) - | Function ty -> add_dependancies s ty - | As (ty, _) -> add_dependancies s ty - | _ -> () - -let rec add_template_dependancies s = function - StringArg _ -> () - | TypeArg (l,t) -> add_dependancies s t - | ListArg l -> List.iter ~f:(add_template_dependancies s) l - | OptionalArgs (_,tl,_) -> List.iter ~f:(add_template_dependancies s) tl - -(* Assumes functions are not nested in products, which is reasonable due to syntax*) -let rec has_callback = function - StringArg _ -> false - | TypeArg (l,Function _ ) -> true - | TypeArg _ -> false - | ListArg l -> List.exists ~f:has_callback l - | OptionalArgs (_,tl,_) -> List.exists ~f:has_callback tl - -(*** Returned types ***) -let really_add ty = - if List.mem ty !types_returned then () - else types_returned := ty :: !types_returned - -let rec add_return_type = function - Unit -> () - | Int -> () - | Float -> () - | Bool -> () - | Char -> () - | String -> () - | List ty -> add_return_type ty - | Product tyl -> List.iter ~f:add_return_type tyl - | Record tyl -> List.iter tyl ~f:(fun (l,t) -> add_return_type t) - | UserDefined s -> really_add s - | Subtype (s,_) -> really_add s - | Function _ -> fatal_error "unexpected return type (function)" (* whoah *) - | As (ty, _) -> add_return_type ty - -(*** Update tables for a component ***) -let enter_component_types {template = t; result = r} = - add_return_type r; - enter_argtype r; - enter_template_types t - - -(******************** Types and subtypes ********************) -exception Duplicate_Definition of string * string -exception Invalid_implicit_constructor of string - -(* Checking duplicate definition of constructor in subtypes *) -let rec check_duplicate_constr allowed c = - function - [] -> false (* not defined *) - | c'::rest -> - if c.ml_name = c'.ml_name then (* defined *) - if allowed then - if c.template = c'.template then true (* same arg *) - else raise (Duplicate_Definition ("constructor",c.ml_name)) - else raise (Duplicate_Definition ("constructor", c.ml_name)) - else check_duplicate_constr allowed c rest - -(* Retrieve constructor *) -let rec find_constructor cname = function - [] -> raise (Invalid_implicit_constructor cname) - | c::l -> if c.ml_name = cname then c - else find_constructor cname l - -(* Enter a type, must not be previously defined *) -let enter_type typname ?(variant = false) arity constructors = - if Hashtbl.mem types_table typname then - raise (Duplicate_Definition ("type", typname)) else - let typdef = new_type typname arity in - if variant then typdef.variant <- true; - List.iter constructors ~f: - begin fun c -> - if not (check_duplicate_constr false c typdef.constructors) - then begin - typdef.constructors <- c :: typdef.constructors; - add_template_dependancies typname c.template - end; - (* Callbacks require widget context *) - typdef.requires_widget_context <- - typdef.requires_widget_context || - has_callback c.template - end - -(* Enter a subtype *) -let enter_subtype typ arity subtyp constructors = - (* Retrieve the type if already defined, else add a new one *) - let typdef = - try Hashtbl.find types_table typ - with Not_found -> new_type typ arity - in - if List.mem_assoc subtyp typdef.subtypes - then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp)) - else begin - let real_constructors = - List.map constructors ~f: - begin function - Full c -> - if not (check_duplicate_constr true c typdef.constructors) - then begin - add_template_dependancies typ c.template; - typdef.constructors <- c :: typdef.constructors - end; - typdef.requires_widget_context <- - typdef.requires_widget_context || - has_callback c.template; - c - | Abbrev name -> find_constructor name typdef.constructors - end - in - (* TODO: duplicate def in subtype are not checked *) - typdef.subtypes <- - (subtyp , List.sort real_constructors - ~cmp:(fun c1 c2 -> compare c1.var_name c2.var_name)) :: - typdef.subtypes - end - -(******************** Widgets ********************) -(* used by the parser; when enter_widget is called, - all components are assumed to be in Full form *) -let retrieve_option optname = - let optiontyp = - try Hashtbl.find types_table "options" - with - Not_found -> raise (Invalid_implicit_constructor optname) - in find_constructor optname optiontyp.constructors - -(* Sort components by type *) -let rec add_sort l obj = - match l with - [] -> [obj.component ,[obj]] - | (s',l)::rest -> - if obj.component = s' then - (s',obj::l)::rest - else - (s',l)::(add_sort rest obj) - -let separate_components = List.fold_left ~f:add_sort ~init:[] - -let enter_widget name components = - if Hashtbl.mem module_table name then - raise (Duplicate_Definition ("widget/module", name)) else - let sorted_components = separate_components components in - List.iter sorted_components ~f: - begin function - Constructor, l -> - enter_subtype "options" MultipleToken - name (List.map ~f:(fun c -> Full c) l) - | Command, l -> - List.iter ~f:enter_component_types l - | External, _ -> () - end; - let commands = - try List.assoc Command sorted_components - with Not_found -> [] - and externals = - try List.assoc External sorted_components - with Not_found -> [] - in - Hashtbl.add module_table name - {module_type = Widget; commands = commands; externals = externals} - -(******************** Functions ********************) - -let enter_function comp = - enter_component_types comp; - function_table := comp :: !function_table - - -(******************** Modules ********************) -let enter_module name components = - if Hashtbl.mem module_table name then - raise (Duplicate_Definition ("widget/module", name)) else - let sorted_components = separate_components components in - List.iter sorted_components ~f: - begin function - Constructor, l -> fatal_error "unexpected Constructor" - | Command, l -> List.iter ~f:enter_component_types l - | External, _ -> () - end; - let commands = - try List.assoc Command sorted_components - with Not_found -> [] - and externals = - try List.assoc External sorted_components - with Not_found -> [] - in - Hashtbl.add module_table name - {module_type = Family; commands = commands; externals = externals} diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml deleted file mode 100644 index a174fb3da4..0000000000 --- a/otherlibs/labltk/compiler/tsort.ml +++ /dev/null @@ -1,89 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open StdLabels - -(* Topological Sort.list *) -(* d'apres More Programming Pearls *) - -(* node * pred count * successors *) - -type 'a entry = - {node : 'a; - mutable pred_count : int; - mutable successors : 'a entry list - } - -type 'a porder = 'a entry list ref - -exception Cyclic - -let find_entry order node = - let rec search_entry = - function - [] -> raise Not_found - | x::l -> if x.node = node then x else search_entry l - in - try - search_entry !order - with - Not_found -> let entry = {node = node; - pred_count = 0; - successors = []} in - order := entry::!order; - entry - -let create () = ref [] - -(* Inverted args because Sort.list builds list in reverse order *) -let add_relation order (succ,pred) = - let pred_entry = find_entry order pred - and succ_entry = find_entry order succ in - succ_entry.pred_count <- succ_entry.pred_count + 1; - pred_entry.successors <- succ_entry::pred_entry.successors - -(* Just add it *) -let add_element order e = - ignore (find_entry order e) - -let sort order = - let q = Queue.create () - and result = ref [] in - List.iter !order - ~f:(function {pred_count = n} as node -> - if n = 0 then Queue.add node q); - begin try - while true do - let t = Queue.take q in - result := t.node :: !result; - List.iter t.successors ~f: - begin fun s -> - let n = s.pred_count - 1 in - s.pred_count <- n; - if n = 0 then Queue.add s q - end - done - with - Queue.Empty -> - List.iter !order - ~f:(fun node -> if node.pred_count <> 0 - then raise Cyclic) - end; - !result - - diff --git a/otherlibs/labltk/builtin/builtina_empty.ml b/otherlibs/labltk/example/.gitignore index e69de29bb2..e69de29bb2 100644 --- a/otherlibs/labltk/builtin/builtina_empty.ml +++ b/otherlibs/labltk/example/.gitignore diff --git a/otherlibs/labltk/examples_camltk/.cvsignore b/otherlibs/labltk/examples_camltk/.cvsignore deleted file mode 100644 index 801812fd38..0000000000 --- a/otherlibs/labltk/examples_camltk/.cvsignore +++ /dev/null @@ -1,8 +0,0 @@ -addition -eyes -fileinput -fileopen -helloworld -tetris -winskel -mytext diff --git a/otherlibs/labltk/examples_camltk/Makefile b/otherlibs/labltk/examples_camltk/Makefile deleted file mode 100644 index 42613054b4..0000000000 --- a/otherlibs/labltk/examples_camltk/Makefile +++ /dev/null @@ -1,52 +0,0 @@ -include ../support/Makefile.common - -# We are using the non-installed library ! -COMPFLAGS=-I ../lib -I ../camltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support - - -all: addition$(EXE) helloworld$(EXE) winskel$(EXE) fileinput$(EXE) \ - eyes$(EXE) tetris$(EXE) mytext$(EXE) fileopen$(EXE) - -addition$(EXE): addition.cmo - $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma addition.cmo - -helloworld$(EXE): helloworld.cmo - $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma helloworld.cmo - -winskel$(EXE): winskel.cmo - $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma winskel.cmo - -fileinput$(EXE): fileinput.cmo - $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma fileinput.cmo - -socketinput$(EXE): socketinput.cmo - $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma socketinput.cmo - -eyes$(EXE): eyes.cmo - $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma eyes.cmo - -tetris$(EXE): tetris.cmo - $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma tetris.cmo - -mytext$(EXE): mytext.cmo - $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma mytext.cmo - -# graph$(EXE): graphics.cmo graphics_test.cmo -# $(CAMLC) -o $@ graphics.cmo graphics_test.cmo -# -# graphics_test.cmo: graphics.cmo - -fileopen$(EXE): fileopen.cmo - $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma fileopen.cmo - -clean : - rm -f *.cm? $(EXECS) addition eyes fileinput fileopen helloworld jptest mytext tetris winskel - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< diff --git a/otherlibs/labltk/examples_camltk/Makefile.nt b/otherlibs/labltk/examples_camltk/Makefile.nt deleted file mode 100644 index 13f27a01da..0000000000 --- a/otherlibs/labltk/examples_camltk/Makefile.nt +++ /dev/null @@ -1,38 +0,0 @@ -include ../support/Makefile.common.nt - -# We are using the non-installed library ! -COMPFLAGS= -I ../lib -I ../camltk -I ../support -LINKFLAGS= -I ../lib -I ../camltk -I ../support - -# Use pieces of Makefile.config -TKLINKOPT=$(LIBNAME).cma $(TKLIBS) - -all: addition.exe helloworld.exe winskel.exe socketinput.exe - -addition.exe: addition.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ addition.cmo - -helloworld.exe: helloworld.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ helloworld.cmo - -winskel.exe: winskel.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ winskel.cmo - -socketinput.exe: socketinput.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \ - -o $@ socketinput.cmo - -clean : - rm -f *.cm? *.exe - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< diff --git a/otherlibs/labltk/examples_camltk/addition.ml b/otherlibs/labltk/examples_camltk/addition.ml deleted file mode 100644 index d4b333dcd4..0000000000 --- a/otherlibs/labltk/examples_camltk/addition.ml +++ /dev/null @@ -1,53 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let main () = - let top = opentk () in - (* The widgets. They all have "top" as parent widget. *) - let en1 = Entry.create top [TextWidth 6; Relief Sunken] in - let lab1 = Label.create top [Text "plus"] in - let en2 = Entry.create top [TextWidth 6 ; Relief Sunken] in - let lab2 = Label.create top [Text "="] in - let result_display = Label.create top [] in - (* References holding values of entry widgets *) - let n1 = ref 0 - and n2 = ref 0 in - (* Refresh result *) - let refresh () = - Label.configure result_display [Text (string_of_int (!n1 + !n2))] in - (* Electric *) - let get_and_refresh (w,r) = - fun _ _ -> - try - r := int_of_string (Entry.get w); - refresh () - with - Failure "int_of_string" -> - Label.configure result_display [Text "error"] - in - (* Set the callbacks *) - Entry.configure en1 [XScrollCommand (get_and_refresh (en1,n1)) ]; - Entry.configure en2 [XScrollCommand (get_and_refresh (en2,n2)) ]; - (* Map the widgets *) - pack [en1;lab1;en2;lab2;result_display] []; - (* Make the window resizable *) - Wm.minsize_set top 1 1; - (* Start interaction (event-driven program) *) - mainLoop () -;; - -let _ = Printexc.catch main () ;; diff --git a/otherlibs/labltk/examples_camltk/eyes.ml b/otherlibs/labltk/examples_camltk/eyes.ml deleted file mode 100644 index 5666c69c55..0000000000 --- a/otherlibs/labltk/examples_camltk/eyes.ml +++ /dev/null @@ -1,67 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* The eyes of Caml (CamlTk) *) - -open Camltk;; - -let _ = - let top = opentk () in - - let fw = Frame.create top [] in - pack [fw] []; - let c = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in - let create_eye cx cy wx wy ewx ewy bnd = - let o2 = - Canvas.create_oval c - (Pixels (cx - wx)) (Pixels (cy - wy)) - (Pixels (cx + wx)) (Pixels (cy + wy)) - [Outline (NamedColor "black"); Width (Pixels 7); - FillColor (NamedColor "white")] - and o = - Canvas.create_oval c - (Pixels (cx - ewx)) (Pixels (cy - ewy)) - (Pixels (cx + ewx)) (Pixels (cy + ewy)) - [FillColor (NamedColor "black")] in - let curx = ref cx - and cury = ref cy in - bind c [[], Motion] - (BindExtend ([Ev_MouseX; Ev_MouseY], - (fun e -> - let nx, ny = - let xdiff = e.ev_MouseX - cx - and ydiff = e.ev_MouseY - cy in - let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. - (float ydiff /. (float wy *. bnd)) ** 2.0) in - if diff > 1.0 then - truncate ((float xdiff) *. (1.0 /. diff)) + cx, - truncate ((float ydiff) *. (1.0 /. diff)) + cy - else - e.ev_MouseX, e.ev_MouseY - in - Canvas.move c o (Pixels (nx - !curx)) (Pixels (ny - !cury)); - curx := nx; - cury := ny))) - in - create_eye 60 100 30 40 5 6 0.6; - create_eye 140 100 30 40 5 6 0.6; - pack [c] [] - -let _ = Printexc.print mainLoop () - - - - diff --git a/otherlibs/labltk/examples_camltk/fileinput.ml b/otherlibs/labltk/examples_camltk/fileinput.ml deleted file mode 100644 index c6190bdd49..0000000000 --- a/otherlibs/labltk/examples_camltk/fileinput.ml +++ /dev/null @@ -1,35 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk ;; - -let top_w = opentk () ;; -let buffer = String.create 256 ;; -let (fd_in, fd_out) = Unix.pipe () ;; -let text0_w = Text.create top_w [] ;; -let entry0_w = Entry.create top_w [] ;; -let button0_w = Button.create top_w [Text "Quit"; Command (fun _ -> exit 0)] ;; -Fileevent.add_fileinput fd_in (fun _ -> - let n = Unix.read fd_in buffer 0 (String.length buffer) in - let txt = String.sub buffer 0 n in - Text.insert text0_w (TextIndex (End, [])) txt []) ;; -let send _ = - let txt = Entry.get entry0_w ^ "\n" in - Entry.delete_range entry0_w (At 0) End ; - ignore (Unix.write fd_out txt 0 (String.length txt));; - -bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send)) ; -pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true] ;; -mainLoop () ;; diff --git a/otherlibs/labltk/examples_camltk/fileopen.ml b/otherlibs/labltk/examples_camltk/fileopen.ml deleted file mode 100644 index b7bd163f37..0000000000 --- a/otherlibs/labltk/examples_camltk/fileopen.ml +++ /dev/null @@ -1,56 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk;; - -let win = opentk();; - -let cvs = Canvas.create win [];; - -let t = Label.create cvs [Text "File name"];; - -let b = - Button.create cvs - [Text "Save"; - Command - (function _ -> - let s = - getSaveFile - [Title "SAVE FILE TEST"; - DefaultExtension ".foo"; - FileTypes [ { typename= "just test"; - extensions= [".foo"; ".test"]; - mactypes= ["FOOO"; "BARR"] } ]; - InitialDir "/tmp"; - InitialFile "hogehoge" ] in - Label.configure t [Text s])];; - -let bb = - Button.create cvs - [Text "Open"; - Command - (function _ -> - let s = getOpenFile [] in - Label.configure t [Text s])];; - -let q = - Button.create cvs - [Text "Quit"; - Command - (function _ -> closeTk (); exit 0)];; - -pack [cvs; q; bb; b; t] [];; - -mainLoop ();; diff --git a/otherlibs/labltk/examples_camltk/helloworld.ml b/otherlibs/labltk/examples_camltk/helloworld.ml deleted file mode 100644 index b32b515ae3..0000000000 --- a/otherlibs/labltk/examples_camltk/helloworld.ml +++ /dev/null @@ -1,37 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk;; (* Make interface functions available *) - -let top = opentk ();; (* Initialisation of the interface *) -(* top is now the toplevel widget *) - -(* Widget initialisation *) -let b = Button.create top - [Text "foobar"; - Command (function () -> - print_string "foobar"; - print_newline(); - flush stdout)];; -(* b exists but is not yet visible *) - -let q = Button.create top - [Text "quit"; - Command closeTk];; -(* q exists but is not yet visible *) - -pack [b; q][] ;; (* Make b visible *) -mainLoop() ;; (* User interaction*) -(* You can quit this program by deleting its main window *) diff --git a/otherlibs/labltk/examples_camltk/images/CamlBook.gif b/otherlibs/labltk/examples_camltk/images/CamlBook.gif Binary files differdeleted file mode 100644 index fb7e52b100..0000000000 --- a/otherlibs/labltk/examples_camltk/images/CamlBook.gif +++ /dev/null diff --git a/otherlibs/labltk/examples_camltk/images/Lambda2.back.gif b/otherlibs/labltk/examples_camltk/images/Lambda2.back.gif Binary files differdeleted file mode 100644 index fdd1f078f4..0000000000 --- a/otherlibs/labltk/examples_camltk/images/Lambda2.back.gif +++ /dev/null diff --git a/otherlibs/labltk/examples_camltk/images/dojoji.back.gif b/otherlibs/labltk/examples_camltk/images/dojoji.back.gif Binary files differdeleted file mode 100644 index d4e07fdd7c..0000000000 --- a/otherlibs/labltk/examples_camltk/images/dojoji.back.gif +++ /dev/null diff --git a/otherlibs/labltk/examples_camltk/jptest.ml b/otherlibs/labltk/examples_camltk/jptest.ml deleted file mode 100644 index 38d9694c3f..0000000000 --- a/otherlibs/labltk/examples_camltk/jptest.ml +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Tk - -let win = opentk();; - -let b = Button.create win [ Text "¤³¤ó¤Á¤Ï" ];; -let _ = pack [b] [];; - -mainLoop();; diff --git a/otherlibs/labltk/examples_camltk/mytext.ml b/otherlibs/labltk/examples_camltk/mytext.ml deleted file mode 100644 index 0695d931aa..0000000000 --- a/otherlibs/labltk/examples_camltk/mytext.ml +++ /dev/null @@ -1,63 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let top = opentk () - -let scroll_link sb tx = - Text.configure tx [YScrollCommand (Scrollbar.set sb)]; - Scrollbar.configure sb [ScrollCommand (Text.yview tx)] - -let f = Frame.create top [] -let text = Text.create f [] -let scrollbar = Scrollbar.create f [] - -(* kill buffer *) -let buffer = ref "" - -(* Note: for the text widgets, the insertion cursor is - not TextIndex(Insert, []), - but TextIndex(Mark "insert", []) -*) -let insertMark = TextIndex(Mark "insert", []) -let eol_insertMark = TextIndex(Mark "insert", [LineEnd]) - -let kill () = - buffer := - Text.get text insertMark eol_insertMark; - prerr_endline ("Killed: " ^ !buffer); - Text.delete text insertMark eol_insertMark -;; - -let yank () = - Text.insert text insertMark !buffer []; - prerr_endline ("Yanked: " ^ !buffer) -;; - -let _ = - scroll_link scrollbar text; - - pack [text; scrollbar][Side Side_Left; Fill Fill_Y]; - pack [f][]; - - bind text [[Control], KeyPressDetail "y"] - (BindSet ([], fun _ -> yank () )); - bind text [[Control], KeyPressDetail "k"] - (BindSet ([], fun _ -> kill () )); - - mainLoop () -;; - diff --git a/otherlibs/labltk/examples_camltk/socketinput.ml b/otherlibs/labltk/examples_camltk/socketinput.ml deleted file mode 100644 index d23b8fd5e1..0000000000 --- a/otherlibs/labltk/examples_camltk/socketinput.ml +++ /dev/null @@ -1,43 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let _ = - let top_w = opentk () in - let text0_w = Text.create top_w [] in - let entry0_w = Entry.create top_w [] in - let button0_w = Button.create top_w - [Text "Quit"; Command (fun _ -> exit 0)] in - let buffer = String.create 256 in - let master_socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - Unix.bind master_socket (Unix.ADDR_INET(Unix.inet_addr_any, 6789)); - Unix.listen master_socket 3; - print_string "Please connect to port 6789..."; print_newline(); - let (sock, _) = Unix.accept master_socket in - Fileevent.add_fileinput sock - (fun _ -> - let n = Unix.recv sock buffer 0 (String.length buffer) [] in - let txt = String.sub buffer 0 n in - Text.insert text0_w (TextIndex (End, [])) txt []); - let send _ = - let txt = Entry.get entry0_w ^ "\n" in - Entry.delete_range entry0_w (At 0) End ; - Unix.send sock txt 0 (String.length txt) []; - () in - bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send)); - pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true]; - mainLoop () - diff --git a/otherlibs/labltk/examples_camltk/taddition.ml b/otherlibs/labltk/examples_camltk/taddition.ml deleted file mode 100644 index 990812d730..0000000000 --- a/otherlibs/labltk/examples_camltk/taddition.ml +++ /dev/null @@ -1,53 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Tk - -let main () = - let top = opentk () in - (* The widgets. They all have "top" as parent widget. *) - let en1 = Entry.create top [TextWidth 6; Relief Sunken] in - let lab1 = Label.create top [Text "plus"] in - let en2 = Entry.create top [TextWidth 6 ; Relief Sunken] in - let lab2 = Label.create top [Text "="] in - let result_display = Label.create top [] in - (* References holding values of entry widgets *) - let n1 = ref 0 - and n2 = ref 0 in - (* Refresh result *) - let refresh () = - Label.configure result_display [Text (string_of_int (!n1 + !n2))] in - (* Electric *) - let get_and_refresh (w,r) = - fun _ _ -> - try - r := int_of_string (Entry.get w); - refresh () - with - Failure "int_of_string" -> - Label.configure result_display [Text "error"] - in - (* Set the callbacks *) - Entry.configure en1 [XScrollCommand (get_and_refresh (en1,n1)) ]; - Entry.configure en2 [XScrollCommand (get_and_refresh (en2,n2)) ]; - (* Map the widgets *) - pack [en1;lab1;en2;lab2;result_display] []; - (* Make the window resizable *) - Wm.minsize_set top 1 1; - (* Start interaction (event-driven program) *) - Threadtk.mainLoop () -;; - -let _ = Printexc.catch main () ;; diff --git a/otherlibs/labltk/examples_camltk/tetris.ml b/otherlibs/labltk/examples_camltk/tetris.ml deleted file mode 100644 index 79d9e3f1a5..0000000000 --- a/otherlibs/labltk/examples_camltk/tetris.ml +++ /dev/null @@ -1,685 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* A Tetris game for CamlTk *) -(* written by Jun P. Furuse *) - -open Camltk - -exception Done - -type cell = {mutable color : int; - tag : tagOrId * tagOrId * tagOrId} - -type falling_block = { - mutable pattern: int array list; - mutable bcolor: int; - mutable x: int; - mutable y: int; - mutable d: int; - mutable alive: bool -} - -let stop_a_bit = 300 - -let colors = [| - NamedColor "red"; - NamedColor "yellow"; - - NamedColor "blue"; - NamedColor "orange"; - - NamedColor "magenta"; - NamedColor "green"; - - NamedColor "cyan" -|] - -let baseurl = "images/" - -let backgrounds = - List.map (fun s -> baseurl ^ s) - [ "dojoji.back.gif"; - "Lambda2back.gif"; - "CamlBook.gif"; - ] - -(* blocks *) -let block_size = 16 -let cell_border = 2 - -let blocks = [ - [ [|"0000"; - "0000"; - "1111"; - "0000" |]; - - [|"0010"; - "0010"; - "0010"; - "0010" |]; - - [|"0000"; - "0000"; - "1111"; - "0000" |]; - - [|"0010"; - "0010"; - "0010"; - "0010" |] ]; - - [ [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "0111"; - "0100"; - "0000" |]; - - [|"0000"; - "0110"; - "0010"; - "0010" |]; - - [|"0000"; - "0010"; - "1110"; - "0000" |]; - - [|"0100"; - "0100"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "0100"; - "0111"; - "0000" |]; - - [|"0000"; - "0110"; - "0100"; - "0100" |]; - - [|"0000"; - "1110"; - "0010"; - "0000" |]; - - [|"0010"; - "0010"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "1100"; - "0110"; - "0000" |]; - - [|"0010"; - "0110"; - "0100"; - "0000" |]; - - [|"0000"; - "1100"; - "0110"; - "0000" |]; - - [|"0010"; - "0110"; - "0100"; - "0000" |] ]; - - [ [|"0000"; - "0011"; - "0110"; - "0000" |]; - - [|"0100"; - "0110"; - "0010"; - "0000" |]; - - [|"0000"; - "0011"; - "0110"; - "0000" |]; - - [|"0000"; - "0100"; - "0110"; - "0010" |] ]; - - [ [|"0000"; - "0000"; - "1110"; - "0100" |]; - - [|"0000"; - "0100"; - "1100"; - "0100" |]; - - [|"0000"; - "0100"; - "1110"; - "0000" |]; - - [|"0000"; - "0100"; - "0110"; - "0100" |] ] - -] - -let line_empty = int_of_string "0b1110000000000111" -let line_full = int_of_string "0b1111111111111111" - -let decode_block dvec = - let btoi d = int_of_string ("0b"^d) in - Array.map btoi dvec - -let init fw = - let scorev = Textvariable.create () - and linev = Textvariable.create () - and levv = Textvariable.create () - and namev = Textvariable.create () - in - let f = Frame.create fw [BorderWidth (Pixels 2)] in - let c = Canvas.create f [Width (Pixels (block_size * 10)); - Height (Pixels (block_size * 20)); - BorderWidth (Pixels cell_border); - Relief Sunken; - Background Black] - and r = Frame.create f [] - and r' = Frame.create f [] in - - let nl = Label.create r [Text "Next"; Font "variable"] in - let nc = Canvas.create r [Width (Pixels (block_size * 4)); - Height (Pixels (block_size * 4)); - BorderWidth (Pixels cell_border); - Relief Sunken; - Background Black] in - let scl = Label.create r [Text "Score"; Font "variable"] in - let sc = Label.create r [TextVariable scorev; Font "variable"] in - let lnl = Label.create r [Text "Lines"; Font "variable"] in - let ln = Label.create r [TextVariable linev; Font "variable"] in - let levl = Label.create r [Text "Level"; Font "variable"] in - let lev = Label.create r [TextVariable levv; Font "Variable"] in - let newg = Button.create r [Text "New Game"; Font "variable"] in - let exitg = Button.create r [Text "Quit"; Font "variable"] in - - pack [f] []; - pack [c; r; r'] [Side Side_Left; Fill Fill_Y]; - pack [nl; nc] [Side Side_Top]; - pack [scl; sc; lnl; ln; levl; lev; newg; exitg] [Side Side_Top]; - - let cells_src = Array.create 20 (Array.create 10 ()) in - let cells = Array.map (Array.map (fun () -> - {tag= - (let t1, t2, t3 = - Canvas.create_rectangle c - (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) - (Pixels (-9)) (Pixels (-9)) [], - Canvas.create_rectangle c - (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) - (Pixels (-11)) (Pixels (-11)) [], - Canvas.create_rectangle c - (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) - (Pixels (-13)) (Pixels (-13)) [] - in - Canvas.raise_top c t1; - Canvas.raise_top c t2; - Canvas.lower_bot c t3; - t1,t2,t3); - color= 0})) cells_src - in - let nexts_src = Array.create 4 (Array.create 4 ()) in - let nexts = - Array.map (Array.map (fun () -> - {tag= - (let t1, t2, t3 = - Canvas.create_rectangle nc - (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) - (Pixels (-9)) (Pixels (-9)) [], - Canvas.create_rectangle nc - (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) - (Pixels (-11)) (Pixels (-11)) [], - Canvas.create_rectangle nc - (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) - (Pixels (-13)) (Pixels (-13)) [] - in - Canvas.raise_top nc t1; - Canvas.raise_top nc t2; - Canvas.lower_bot nc t3; - t1, t2, t3); - color= 0})) nexts_src in - let game_over () = () - in - [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg, - (c, cells), (nc, nexts), scorev, linev, levv, game_over - -let cell_get (c, cf) x y = - (Array.get (Array.get cf y) x).color - -let cell_set (c, cf) x y col = - let cur = Array.get (Array.get cf y) x in - let t1,t2,t3 = cur.tag in - if cur.color = col then () - else - if cur.color <> 0 && col = 0 then - begin - Canvas.move c t1 - (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) - (Pixels (- block_size * (y + 1) -10 - cell_border * 2)); - Canvas.move c t2 - (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) - (Pixels (- block_size * (y + 1) -10 - cell_border * 2)); - Canvas.move c t3 - (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) - (Pixels (- block_size * (y + 1) -10 - cell_border * 2)) - end - else - begin - Canvas.configure_rectangle c t2 - [FillColor (Array.get colors (col - 1)); - Outline (Array.get colors (col - 1))]; - Canvas.configure_rectangle c t1 - [FillColor Black; - Outline Black]; - Canvas.configure_rectangle c t3 - [FillColor (NamedColor "light gray"); - Outline (NamedColor "light gray")]; - if cur.color = 0 && col <> 0 then - begin - Canvas.move c t1 - (Pixels (block_size * (x+1)+10+ cell_border*2)) - (Pixels (block_size * (y+1)+10+ cell_border*2)); - Canvas.move c t2 - (Pixels (block_size * (x+1)+10+ cell_border*2)) - (Pixels (block_size * (y+1)+10+ cell_border*2)); - Canvas.move c t3 - (Pixels (block_size * (x+1)+10+ cell_border*2)) - (Pixels (block_size * (y+1)+10+ cell_border*2)) - end - end; - cur.color <- col - -let draw_block field col d x y = - for iy = 0 to 3 do - let base = ref 1 in - let xd = Array.get d iy in - for ix = 0 to 3 do - if xd land !base <> 0 then - begin - try cell_set field (ix + x) (iy + y) col with _ -> () - end - else - begin - (* cell_set field (ix + x) (iy + y) 0 *) () - end; - base := !base lsl 1 - done - done - -let timer_ref = (ref None : Timer.t option ref) -(* I know, this should be timer ref, but I'm not sure what should be - the initial value ... *) - -let remove_timer () = - match !timer_ref with - | None -> () - | Some t -> Timer.remove t (* ; prerr_endline "removed!" *) - -let do_after milli f = - timer_ref := Some (Timer.add milli f) - -let copy_block c = - { pattern= !c.pattern; - bcolor= !c.bcolor; - x= !c.x; - y= !c.y; - d= !c.d; - alive= !c.alive } - -let _ = - let top = opentk () in - let lb = Label.create top [] - and fw = Frame.create top [] - in - let set_message s = Label.configure lb [Text s] in - pack [lb; fw] [Side Side_Top]; - let score = ref 0 in - let line = ref 0 in - let level = ref 0 in - let time = ref 1000 in - let blocks = List.map (List.map decode_block) blocks in - let field = Array.create 26 0 in - let widgets, newg, exitg, cell_field, next_field, - scorev, linev, levv, game_over = - init fw in - let canvas = fst cell_field in - - let init_field () = - for i = 0 to 25 do - field.(i) <- line_empty - done; - field.(23) <- line_full; - for i = 0 to 19 do - for j = 0 to 9 do - cell_set cell_field j i 0 - done - done; - for i = 0 to 3 do - for j = 0 to 3 do - cell_set next_field j i 0 - done - done - in - - let draw_falling_block fb = - draw_block cell_field fb.bcolor - (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) - - and erase_falling_block fb = - draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) - in - - let stone fb = - for i=0 to 3 do - let cur = field.(i + fb.y) in - field.(i + fb.y) <- - cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x) - done; - for i=0 to 2 do - field.(i) <- line_empty - done - - and clear fb = - let l = ref 0 in - for i = 0 to 3 do - if i + fb.y >= 3 && i + fb.y <= 22 then - if field.(i + fb.y) = line_full then - begin - incr l; - field.(i + fb.y) <- line_empty; - for j = 0 to 9 do - cell_set cell_field j (i + fb.y - 3) 0 - done - end - done; - !l - - and fall_lines () = - let eye = ref 22 (* bottom *) - and cur = ref 22 (* bottom *) - in - try - while !eye >= 3 do - while field.(!eye) = line_empty do - decr eye; - if !eye = 2 then raise Done - done; - field.(!cur) <- field.(!eye); - for j = 0 to 9 do - cell_set cell_field j (!cur-3) (cell_get cell_field j (!eye-3)) - done; - decr eye; - decr cur - done - with Done -> (); - for i = 3 to !cur do - field.(i) <- line_empty; - for j = 0 to 9 do - cell_set cell_field j (i-3) 0 - done - done - in - - let next = ref 42 (* THE ANSWER *) - and current = - ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false} - in - - let draw_next () = - draw_block next_field (!next+1) (List.hd (List.nth blocks !next)) 0 0 - - and erase_next () = - draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0 - in - - let set_nextblock () = - current := - { pattern= (List.nth blocks !next); - bcolor= !next+1; - x=6; y= 1; d= 0; alive= true}; - erase_next (); - next := Random.int 7; - draw_next () - in - - let death_check fb = - try - for i=0 to 3 do - let cur = field.(i + fb.y) in - if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 - then raise Done - done; - false - with - Done -> true - in - - let try_to_move m = - if !current.alive then - let sub m = - if death_check m then false - else - begin - erase_falling_block !current; - draw_falling_block m; - current := m; - true - end - in - if sub m then () - else - begin - m.x <- m.x + 1; - if sub m then () - else - begin - m.x <- m.x - 2; - ignore (sub m) - end - end - else () - in - - let image_load = - let i = Canvas.create_image canvas - (Pixels (block_size * 5 + block_size / 2)) - (Pixels (block_size * 10 + block_size / 2)) - [Anchor Center] in - Canvas.lower_bot canvas i; - let img = Imagephoto.create [] in - fun file -> - try - Imagephoto.configure img [File file]; - Canvas.configure_image canvas i [ImagePhoto img] - with - _ -> - begin - Printf.eprintf "%s : No such image...\n" file; - flush stderr - end - in - - let add_score l = - let pline = !line in - if l <> 0 then - begin - line := !line + l; - score := !score + l * l; - set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2))) - end; - Textvariable.set linev (string_of_int !line); - Textvariable.set scorev (string_of_int !score); - - if !line /10 <> pline /10 then - (* update the background every 10 lines. *) - begin - let num_image = List.length backgrounds - 1 in - let n = !line/10 in - let n = if n > num_image then num_image else n in - let file = List.nth backgrounds n in - image_load file; - (* Future work: We should gain level after an image is put... *) - incr level; - Textvariable.set levv (string_of_int !level) - end - in - - let rec newblock () = - set_message "TETRIS"; - set_nextblock (); - draw_falling_block !current; - if death_check !current then - begin - !current.alive <- false; - set_message "GAME OVER"; - game_over () - end - else - begin - time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200); - if !time < 60 - !level * 3 then time := 60 - !level * 3; - do_after stop_a_bit loop - end - - and loop () = - let m = copy_block current in - m.y <- m.y + 1; - if death_check m then - begin - !current.alive <- false; - stone !current; - do_after stop_a_bit (fun () -> - let l = clear !current in - if l > 0 then - do_after stop_a_bit (fun () -> - fall_lines (); - add_score l; - do_after stop_a_bit newblock) - else - newblock ()) - end - else - begin - erase_falling_block !current; - draw_falling_block m; - current := m; - do_after !time loop - end - in - - let bind_game w = - bind w [([], KeyPress)] (BindSet ([Ev_KeySymString], - fun e -> - match e.ev_KeySymString with - | "h" -> - let m = copy_block current in - m.x <- m.x - 1; - 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 - | "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 - | "l" -> - let m = copy_block current in - m.x <- m.x + 1; - try_to_move m - | "m" -> - remove_timer (); - loop () - | "space" -> - if !current.alive then - begin - let m = copy_block current - and n = copy_block current in - while - m.y <- m.y + 1; - if death_check m then false - else begin n.y <- m.y; true end - do () done; - erase_falling_block !current; - draw_falling_block n; - current := n; - remove_timer (); - loop () - end - | _ -> () - )) - in - - let game_init () = - (* Game Initialization *) - set_message "Initializing ..."; - remove_timer (); - image_load (List.hd backgrounds); - time := 1000; - score := 0; - line := 0; - level := 1; - add_score 0; - init_field (); - next := Random.int 7; - set_message "Welcome to TETRIS"; - set_nextblock (); - draw_falling_block !current; - do_after !time loop - in - bind_game top; - Button.configure newg [Command game_init]; - Button.configure exitg [Command (fun () -> closeTk (); exit 0)]; - game_init () - -let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_camltk/text.ml b/otherlibs/labltk/examples_camltk/text.ml deleted file mode 100644 index 0001ae75ac..0000000000 --- a/otherlibs/labltk/examples_camltk/text.ml +++ /dev/null @@ -1,55 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Tk - -let top = opentk () - -let scroll_link sb tx = - Text.configure tx [YScrollCommand (Scrollbar.set sb)]; - Scrollbar.configure sb [ScrollCommand (Text.yview tx)] - -let f = Frame.create top [] -let text = Text.create f [] -let scrollbar = Scrollbar.create f [] - -let buffer = ref "" - -let kill () = - buffer := - Text.get text (TextIndex (Insert, [])) - (TextIndex (Insert, [LineEnd])); - Text.delete text (TextIndex (Insert, [])) - (TextIndex (Insert, [LineEnd])) -;; - -let yank () = - Text.insert text (TextIndex (Insert, [])) !buffer [] - -let _ = bind text [[Control], KeyPressDetail "y"] (BindSet ([], fun _ -> - yank () )) -;; -let _ = bind text [[Control], KeyPressDetail "k"] (BindSet ([], fun _ -> - kill () )) -;; - -let _ = - scroll_link scrollbar text; - - pack [text;f][]; - pack [f][]; - mainLoop () -;; - diff --git a/otherlibs/labltk/examples_camltk/winskel.ml b/otherlibs/labltk/examples_camltk/winskel.ml deleted file mode 100644 index 2ca1da1745..0000000000 --- a/otherlibs/labltk/examples_camltk/winskel.ml +++ /dev/null @@ -1,63 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -(* This examples is based on Ousterhout's book (fig 16.15) *) -open Camltk - -let main () = - let top = opentk() in - let mbar = Frame.create top [Relief Raised; BorderWidth (Pixels 2)] - and dummy = - Frame.create top [Width (Centimeters 10.); Height (Centimeters 5.)] in - pack [mbar; dummy] [Side Side_Top; Fill Fill_X]; - let file = Menubutton.create mbar [Text "File"; UnderlinedChar 0] - and edit = Menubutton.create mbar [Text "Edit"; UnderlinedChar 0] - and graphics = Menubutton.create mbar [Text "Graphics"; UnderlinedChar 0] - and text = Menubutton.create mbar [Text "Text"; UnderlinedChar 0] - and view = Menubutton.create mbar [Text "View"; UnderlinedChar 0] - and help = Menubutton.create mbar [Text "Help"; UnderlinedChar 0] in - pack [file;edit;graphics;text;view] [Side Side_Left]; - pack [help] [Side Side_Right]; - (* same code as chap16-14 *) - let m = Menu.create text [] in - let bold = Textvariable.create() - and italic = Textvariable.create() - and underline = Textvariable.create() in - Menu.add_checkbutton m [Label "Bold"; Variable bold]; - Menu.add_checkbutton m [Label "Italic"; Variable italic]; - Menu.add_checkbutton m [Label "Underline"; Variable underline]; - Menu.add_separator m; - let font = Textvariable.create() in - Menu.add_radiobutton m [Label "Times"; Variable font; Value "times"]; - Menu.add_radiobutton m [Label "Helvetica"; Variable font; Value "helvetica"] -; - Menu.add_radiobutton m [Label "Courier"; Variable font; Value "courier"]; - Menu.add_separator m; - Menu.add_command m [Label "Insert Bullet"; - Command (function () -> - print_string "Insert Bullet\n"; - flush stdout)]; - Menu.add_command m [Label "Margins and Tags..."; - Command (function () -> - print_string "margins\n"; - flush stdout)]; - Menubutton.configure text [Menu m]; - - mainLoop() - - - -let _ = - Printexc.catch main () diff --git a/otherlibs/labltk/examples_labltk/.cvsignore b/otherlibs/labltk/examples_labltk/.cvsignore deleted file mode 100644 index c1f6ec642f..0000000000 --- a/otherlibs/labltk/examples_labltk/.cvsignore +++ /dev/null @@ -1,8 +0,0 @@ -calc -clock -demo -eyes -hello -tetris -lang -taquin diff --git a/otherlibs/labltk/examples_labltk/Lambda2.back.gif b/otherlibs/labltk/examples_labltk/Lambda2.back.gif Binary files differdeleted file mode 100644 index fdd1f078f4..0000000000 --- a/otherlibs/labltk/examples_labltk/Lambda2.back.gif +++ /dev/null diff --git a/otherlibs/labltk/examples_labltk/Makefile b/otherlibs/labltk/examples_labltk/Makefile deleted file mode 100644 index 3fa02632bf..0000000000 --- a/otherlibs/labltk/examples_labltk/Makefile +++ /dev/null @@ -1,53 +0,0 @@ -include ../support/Makefile.common - -COMPFLAGS=-I ../lib -I ../labltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support - -all: hello demo eyes calc clock tetris lang - -opt: hello.opt demo.opt eyes.opt calc.opt clock.opt tetris.opt - -hello: hello.cmo - $(CAMLC) $(COMPFLAGS) -o hello $(LIBNAME).cma hello.cmo - -demo: demo.cmo - $(CAMLC) $(COMPFLAGS) -o demo $(LIBNAME).cma demo.cmo - -eyes: eyes.cmo - $(CAMLC) $(COMPFLAGS) -o eyes $(LIBNAME).cma eyes.cmo - -calc: calc.cmo - $(CAMLC) $(COMPFLAGS) -o calc $(LIBNAME).cma calc.cmo - -clock: clock.cmo - $(CAMLC) $(COMPFLAGS) -o clock $(LIBNAME).cma unix.cma clock.cmo - -clock.opt: clock.cmx - $(CAMLOPT) $(COMPFLAGS) -o clock.opt \ - $(LIBNAME).cmxa unix.cmxa clock.cmx - -tetris: tetris.cmo - $(CAMLC) $(COMPFLAGS) -o tetris $(LIBNAME).cma tetris.cmo - -taquin: taquin.cmo - $(CAMLC) $(COMPFLAGS) -o taquin $(LIBNAME).cma taquin.cmo - -lang: lang.cmo - $(CAMLC) $(COMPFLAGS) -o lang $(LIBNAME).cma lang.cmo - -clean: - rm -f hello demo eyes calc clock tetris lang *.opt *.o *.cm* - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo .opt - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.cmx.opt: - $(CAMLOPT) $(COMPFLAGS) -o $@ $(LIBNAME).cmxa $< diff --git a/otherlibs/labltk/examples_labltk/Makefile.nt b/otherlibs/labltk/examples_labltk/Makefile.nt deleted file mode 100644 index 825d9e42be..0000000000 --- a/otherlibs/labltk/examples_labltk/Makefile.nt +++ /dev/null @@ -1,50 +0,0 @@ -include ../support/Makefile.common.nt - -# We are using the non-installed library ! -COMPFLAGS= -I ../lib -I ../labltk -I ../support -LINKFLAGS= -I ../lib -I ../labltk -I ../support - -# Use pieces of Makefile.config -TKLINKOPT=$(LIBNAME).cma $(TKLIBS) - -all: hello.exe demo.exe eyes.exe calc.exe clock.exe tetris.exe lang.exe - -hello.exe: hello.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ hello.cmo - -demo.exe: demo.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ demo.cmo - -eyes.exe: eyes.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ eyes.cmo - -calc.exe: calc.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ calc.cmo - -clock.exe: clock.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \ - -o $@ clock.cmo - -tetris.exe: tetris.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ tetris.cmo - -lang.exe: lang.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ lang.cmo - -clean : - rm -f *.cm? *.exe - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< diff --git a/otherlibs/labltk/examples_labltk/README b/otherlibs/labltk/examples_labltk/README deleted file mode 100644 index ec0f20de60..0000000000 --- a/otherlibs/labltk/examples_labltk/README +++ /dev/null @@ -1,20 +0,0 @@ -$Id$ - -Some examples for LablTk. -They are written in classic mode, except testris.ml which uses label -commutation. -You may either compile them here, or just run them as scripts with - labltk example.ml - -hello.ml A very simple example of CamlTk -hello.tcl The same programme in Tcl/Tk - -demo.ml A demonstration using many widget classes - -eyes.ml A "bind" test - -calc.ml A little calculator - -clock.ml An analog clock (uses unix.cma) - -tetris.ml You NEED a game also (uses -labels) diff --git a/otherlibs/labltk/examples_labltk/calc.ml b/otherlibs/labltk/examples_labltk/calc.ml deleted file mode 100644 index 088bf192f9..0000000000 --- a/otherlibs/labltk/examples_labltk/calc.ml +++ /dev/null @@ -1,129 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* A simple calculator demonstrating OO programming with O'Labl - and LablTk. - - LablTk itself is not OO, but it is good to wrap complex - structures in objects. Even if the absence of initializers - makes things a little bit awkward. -*) - -open StdLabels -open Tk - -let mem_string ~elt:c s = - try - for i = 0 to String.length s -1 do - if s.[i] = c then raise Exit - done; false - with Exit -> true - -let ops = ['+',(+.); '-',(-.); '*',( *.); '/',(/.)] - -(* The abstract calculator class. - Does not use Tk (only Textvariable) *) - -class calc () = object (calc) - val variable = Textvariable.create () - val mutable x = 0.0 - val mutable op = None - val mutable displaying = true - - method set = Textvariable.set variable - method get = Textvariable.get variable - method insert s = calc#set (calc#get ^ s) - method get_float = float_of_string (calc#get) - - method command s = - if s <> "" then match s.[0] with - '0'..'9' -> - if displaying then (calc#set ""; displaying <- false); - calc#insert s - | '.' -> - if displaying then - (calc#set "0."; displaying <- false) - else - if not (mem_string ~elt:'.' calc#get) then calc#insert s - | '+'|'-'|'*'|'/' as c -> - displaying <- true; - begin match op with - None -> - x <- calc#get_float; - op <- Some (List.assoc c ops) - | Some f -> - x <- f x (calc#get_float); - op <- Some (List.assoc c ops); - calc#set (Printf.sprintf "%g" x) - end - | '='|'\n'|'\r' -> - displaying <- true; - begin match op with - None -> () - | Some f -> - x <- f x (calc#get_float); - op <- None; - calc#set (Printf.sprintf "%g" x) - end - | 'q' -> closeTk (); exit 0 - | _ -> () -end - -(* Buttons for the calculator *) - -let m = - [|["7";"8";"9";"+"]; - ["4";"5";"6";"-"]; - ["1";"2";"3";"*"]; - ["0";".";"=";"/"]|] - -(* The physical calculator. Inherits from the abstract one *) - -class calculator ~parent = object - inherit calc () as calc - - val label = Label.create ~anchor:`E ~relief:`Sunken ~padx:10 parent - val frame = Frame.create parent - - initializer - let buttons = - Array.map ~f: - (List.map ~f: - (fun text -> - Button.create ~text ~command:(fun () -> calc#command text) frame)) - m - in - Label.configure ~textvariable:variable label; - calc#set "0"; - bind ~events:[`KeyPress] ~fields:[`Char] - ~action:(fun ev -> calc#command ev.ev_Char) - parent; - for i = 0 to Array.length m - 1 do - Grid.configure ~row:i buttons.(i) - done; - pack ~side:`Top ~fill:`X [label]; - pack ~side:`Bottom ~fill:`Both ~expand:true [frame]; -end - -(* Finally start everything *) - -let top = openTk () - -let applet = new calculator ~parent:top - -let _ = mainLoop () diff --git a/otherlibs/labltk/examples_labltk/clock.ml b/otherlibs/labltk/examples_labltk/clock.ml deleted file mode 100644 index 57a59b825b..0000000000 --- a/otherlibs/labltk/examples_labltk/clock.ml +++ /dev/null @@ -1,133 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Clock/V, a simple clock. - Reverts every time you push the right button. - Adapted from ASCII/V May 1997 - - Uses Tk and Unix, so you must link with - labltklink unix.cma clock.ml -o clock -cclib -lunix -*) - -open Tk - -(* pi is not a constant! *) -let pi = acos (-1.) - -(* The main class: - * create it with a parent: [new clock parent:top] - * initialize with [#init] -*) - -class clock ~parent = object (self) - - (* Instance variables *) - val canvas = Canvas.create ~width:100 ~height:100 parent - val mutable height = 100 - val mutable width = 100 - val mutable rflag = -1 - - (* Convert from -1.0 .. 1.0 to actual positions on the canvas *) - method x x0 = truncate (float width *. (x0 +. 1.) /. 2.) - method y y0 = truncate (float height *. (y0 +. 1.) /. 2.) - - initializer - (* Create the oval border *) - 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 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 canvas ~events:[`Configure] ~action: - begin fun _ -> - width <- Winfo.width canvas; - height <- Winfo.height canvas; - self#redraw - end; - (* Change direction with right button *) - bind canvas ~events:[`ButtonPressDetail 3] - ~action:(fun _ -> rflag <- -rflag; self#redraw); - (* Pack, expanding in both directions *) - pack ~fill:`Both ~expand:true [canvas] - - (* Redraw everything *) - method redraw = - Canvas.coords_set canvas (`Tag "cadran") - ~xys:[ 1, 1; width - 2, height - 2 ]; - self#draw_figures; - self#draw_arrows (Unix.localtime (Unix.time ())) - - (* Delete and redraw the figures *) - method draw_figures = - Canvas.delete canvas [`Tag "figures"]; - for i = 1 to 12 do - let angle = float (rflag * i - 3) *. pi /. 6. in - 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 - done - - (* Resize and reposition the arrows *) - method draw_arrows tm = - Canvas.configure_line ~width:(min width height / 40) - canvas (`Tag "hours"); - let hangle = - float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180) - *. pi /. 360. in - Canvas.coords_set canvas (`Tag "hours") - ~xys:[ self#x 0., self#y 0.; - self#x (cos hangle /. 2.), self#y (sin hangle /. 2.) ]; - Canvas.configure_line ~width:(min width height / 50) - canvas (`Tag "minutes"); - let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in - Canvas.coords_set canvas (`Tag "minutes") - ~xys:[ self#x 0., self#y 0.; - self#x (cos mangle /. 1.5), self#y (sin mangle /. 1.5) ]; - let sangle = float (rflag * tm.Unix.tm_sec - 15) *. pi /. 30. in - Canvas.coords_set canvas (`Tag "seconds") - ~xys:[ self#x 0., self#y 0.; - self#x (cos sangle /. 1.25), self#y (sin sangle /. 1.25) ] -end - -(* Initialize the Tcl interpreter *) -let top = openTk () - -(* Create a clock on the main window *) -let clock = - new clock ~parent:top - -(* Wait for events *) -let _ = mainLoop () diff --git a/otherlibs/labltk/examples_labltk/demo.ml b/otherlibs/labltk/examples_labltk/demo.ml deleted file mode 100644 index 2ccc448b19..0000000000 --- a/otherlibs/labltk/examples_labltk/demo.ml +++ /dev/null @@ -1,167 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Some CamlTk4 Demonstration by JPF *) - -(* First, open these modules for convenience *) -open StdLabels -open Tk - -(* Dummy let *) -let _ = - -(* Initialize Tk *) -let top = openTk () in -(* Title setting *) -Wm.title_set top "LablTk demo"; - -(* Base frame *) -let base = Frame.create top in -pack [base]; - -(* Menu bar *) -let bar = Frame.create ~borderwidth:2 ~relief:`Raised base in -pack ~fill:`X [bar]; - - (* Menu and Menubutton *) - let meb = Menubutton.create ~text:"Menu" bar in - let men = Menu.create meb in - Menu.add_command ~label:"Quit" ~command:(fun () -> closeTk (); exit 0) men; - Menubutton.configure ~menu:men meb; - - (* Frames *) - let base2 = Frame.create base in - let left = Frame.create base2 in - let right = Frame.create base2 in - pack [base2]; - pack ~side:`Left [left; right]; - - (* Widgets on left and right *) - - (* Button *) - let but = Button.create ~text:"Welcome to LablTk" left in - - (* Canvas *) - let can = - Canvas.create ~width:100 ~height:100 ~borderwidth:1 ~relief:`Sunken left - in - let oval = Canvas.create_oval ~x1: 10 ~y1: 10 - ~x2: 90 ~y2: 90 - ~fill: `Red - can - in ignore oval; - - (* Check button *) - let che = Checkbutton.create ~text:"Check" left in - - (* Entry *) - let ent = Entry.create ~width:10 left in - - (* Label *) - let lab = Label.create ~text:"Welcome to LablTk" left in - - (* Listbox *) - let lis = Listbox.create left in - Listbox.insert lis ~index:`End ~texts:["This"; "is"; "Listbox"]; - - (* Message *) - let mes = Message.create - ~text: "Hello this is a message widget with very long text, but ..." - left in - - (* Radio buttons *) - let tv = Textvariable.create () in - Textvariable.set tv "One"; - let radf = Frame.create right in - let rads = List.map - ~f:(fun t -> Radiobutton.create ~text:t ~value:t ~variable:tv radf) - ["One"; "Two"; "Three"] in - - (* Scale *) - let sca = Scale.create ~label:"Scale" ~length:100 ~showvalue:true right in - - (* Text and scrollbar *) - let texf = Frame.create right in - - (* Text *) - let tex = Text.create ~width:20 ~height:8 texf in - Text.insert ~index:(`End,[]) ~text:"This is a text widget." tex; - - (* Scrollbar *) - let scr = Scrollbar.create texf in - - (* Text and Scrollbar widget link *) - let scroll_link sb tx = - Text.configure ~yscrollcommand:(Scrollbar.set sb) tx; - Scrollbar.configure ~command:(Text.yview tx) sb in - scroll_link scr tex; - - pack ~side:`Right ~fill:`Y [scr]; - pack ~side:`Left ~fill:`Both ~expand:true [tex]; - - (* Pack them *) - pack ~side:`Left [meb]; - pack [coe but; coe can; coe che; coe ent; coe lab; coe lis; coe mes]; - pack [coe radf; coe sca; coe texf]; - pack rads; - - (* Toplevel *) - let top2 = Toplevel.create top in - Wm.title_set top2 "LablTk demo control"; - let defcol = `Color "#dfdfdf" in - let selcol = `Color "#ffdfdf" in - let buttons = - List.map ~f:(fun (w, t, c, a) -> - let b = Button.create ~text:t ~command:c top2 in - bind ~events:[`Enter] ~action:(fun _ -> a selcol) b; - bind ~events:[`Leave] ~action:(fun _ -> a defcol) b; - b) - [coe bar, "Frame", (fun () -> ()), - (fun background -> Frame.configure ~background bar); - coe meb, "Menubutton", (fun () -> ()), - (fun background -> Menubutton.configure ~background meb); - coe but, "Button", (fun () -> ()), - (fun background -> Button.configure ~background but); - coe can, "Canvas", (fun () -> ()), - (fun background -> Canvas.configure ~background can); - coe che, "CheckButton", (fun () -> ()), - (fun background -> Checkbutton.configure ~background che); - coe ent, "Entry", (fun () -> ()), - (fun background -> Entry.configure ~background ent); - coe lab, "Label", (fun () -> ()), - (fun background -> Label.configure ~background lab); - coe lis, "Listbox", (fun () -> ()), - (fun background -> Listbox.configure ~background lis); - coe mes, "Message", (fun () -> ()), - (fun background -> Message.configure ~background mes); - coe radf, "Radiobox", (fun () -> ()), - (fun background -> - List.iter ~f:(fun b -> Radiobutton.configure ~background b) rads); - coe sca, "Scale", (fun () -> ()), - (fun background -> Scale.configure ~background sca); - coe tex, "Text", (fun () -> ()), - (fun background -> Text.configure ~background tex); - coe scr, "Scrollbar", (fun () -> ()), - (fun background -> Scrollbar.configure ~background scr) - ] - in - pack ~fill:`X buttons; - -(* Main Loop *) -Printexc.print mainLoop () - diff --git a/otherlibs/labltk/examples_labltk/eyes.ml b/otherlibs/labltk/examples_labltk/eyes.ml deleted file mode 100644 index ce62159dbe..0000000000 --- a/otherlibs/labltk/examples_labltk/eyes.ml +++ /dev/null @@ -1,65 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Tk - -let _ = - let top = openTk () in - let fw = Frame.create top in - pack [fw]; - let c = Canvas.create ~width: 200 ~height: 200 fw in - let create_eye cx cy wx wy ewx ewy bnd = - let o2 = Canvas.create_oval - ~x1:(cx - wx) ~y1:(cy - wy) - ~x2:(cx + wx) ~y2:(cy + wy) - ~outline: `Black ~width: 7 - ~fill: `White - c - and o = Canvas.create_oval - ~x1:(cx - ewx) ~y1:(cy - ewy) - ~x2:(cx + ewx) ~y2:(cy + ewy) - ~fill:`Black - c in - let curx = ref cx - and cury = ref cy in - bind ~events:[`Motion] ~extend:true ~fields:[`MouseX; `MouseY] - ~action:(fun e -> - let nx, ny = - let xdiff = e.ev_MouseX - cx - and ydiff = e.ev_MouseY - cy in - let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. - (float ydiff /. (float wy *. bnd)) ** 2.0) in - if diff > 1.0 then - truncate ((float xdiff) *. (1.0 /. diff)) + cx, - truncate ((float ydiff) *. (1.0 /. diff)) + cy - else - e.ev_MouseX, e.ev_MouseY - in - Canvas.move c o ~x: (nx - !curx) ~y: (ny - !cury); - curx := nx; - cury := ny) - c - in - create_eye 60 100 30 40 5 6 0.6; - create_eye 140 100 30 40 5 6 0.6; - pack [c] - -let _ = Printexc.print mainLoop () - - - diff --git a/otherlibs/labltk/examples_labltk/hello.ml b/otherlibs/labltk/examples_labltk/hello.ml deleted file mode 100644 index 4a89d48062..0000000000 --- a/otherlibs/labltk/examples_labltk/hello.ml +++ /dev/null @@ -1,38 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* LablTk4 Demonstration by JPF *) - -(* First, open this modules for convenience *) -open Tk - -(* initialization of Tk --- the result is a toplevel widget *) -let top = openTk () - -(* create a button on top *) -(* Button.create : use of create function defined in button.ml *) -(* But you shouldn't open Button module for other widget class modules use *) -let b = Button.create ~text: "Hello, LablTk!" top - -(* Lack of toplevel expressions in lsl, you must use dummy let exp. *) -let _ = pack [coe b] - -(* Last, you must call mainLoop *) -(* You can write just let _ = mainLoop () *) -(* But Printexc.print will help you *) -let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_labltk/hello.tcl b/otherlibs/labltk/examples_labltk/hello.tcl deleted file mode 100755 index 84ceccd6d1..0000000000 --- a/otherlibs/labltk/examples_labltk/hello.tcl +++ /dev/null @@ -1,5 +0,0 @@ -#!/usr/bin/wish - -button .hello -text "Hello, TclTk!" - -pack .hello diff --git a/otherlibs/labltk/examples_labltk/lang.ml b/otherlibs/labltk/examples_labltk/lang.ml deleted file mode 100644 index e92377ecc3..0000000000 --- a/otherlibs/labltk/examples_labltk/lang.ml +++ /dev/null @@ -1,75 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* language encoding using UTF-8 *) -open Tk - -let top = opentk () - -(* declare Tk that we use utf-8 to communicate *) -(* problem: Text display is highly dependent on your font installation - and configulation. The fonts with no-scale setting are selected - only if the point sizes are exactly same??? -*) -let _ = - Encoding.system_set "utf-8"; - let l = Label.create top ~text: "???" in - pack [l]; - let t = Text.create top in - pack [t]; - - let create_hello lang hello = - let b = Button.create t ~text: lang ~command: (fun () -> - Label.configure l ~text: hello) - in - Text.window_create t ~index: (`End,[]) ~window: b - in - List.iter (fun (lang, hello) -> create_hello lang hello) - ["Amharic(አማáˆáŠ›)", "ሠላáˆ"; - "Arabic", "�����������"; - "Croatian (Hrvatski)", "Bog (Bok), Dobar dan"; - "Czech (Äesky)", "Dobrý den"; - "Danish (Dansk)", "Hej, Goddag"; - "English", "Hello"; - "Esperanto", "Saluton"; - "Estonian", "Tere, Tervist"; - "FORTRAN", "PROGRAM"; - "Finnish (Suomi)", "Hei"; - "French (Français)", "Bonjour, Salut"; - "German (Deutsch Nord)", "Guten Tag"; - "German (Deutsch Süd)", "Grüß Gott"; - "Greek (Ελληνικά)", "Γειά σας"; - "Hebrew", "שלו×"; - "Italiano", "Ciao, Buon giorno"; - "Maltese", "Ciao"; - "Nederlands, Vlaams", "Hallo, Hoi, Goedendag"; - "Norwegian (Norsk)", "Hei, God dag"; - "Polish", "Cześć!"; - "Russian (РуÑÑкий)", "ЗдравÑтвуйте!"; - "Slovak", "Dobrý deň"; - "Spanish (Español)", "¡Hola!"; - "Swedish (Svenska)", "Hej, Goddag"; - "Thai (�������)", "�������, ������"; - "Tigrigna (ትáŒáˆáŠ›)", "ሰላማት"; - "Turkish (Türkçe)", "Merhaba"; - "Vietnamese (Tiếng Việt)", "Chà o bạn"; - "Japanese (日本語)", "ã“ã‚“ã«ã¡ã¯"; - "Chinese (ä¸æ–‡,普通è¯,汉è¯)", "ä½ å¥½"; - "Cantonese (粵語,廣æ±è©±)", "早晨, ä½ å¥½"; - "Hangul (한글)", "안녕하세요, 안녕하ì‹ë‹ˆê¹Œ" ] -;; - -let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_labltk/taquin.ml b/otherlibs/labltk/examples_labltk/taquin.ml deleted file mode 100644 index a3bcbb1bfb..0000000000 --- a/otherlibs/labltk/examples_labltk/taquin.ml +++ /dev/null @@ -1,143 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Tk;; - -let découpe_image img nx ny = - let l = Imagephoto.width img - and h = Imagephoto.height img in - let tx = l / nx and ty = h / ny in - let pièces = ref [] in - for x = 0 to nx - 1 do - for y = 0 to ny - 1 do - let pièce = Imagephoto.create ~width:tx ~height:ty () in - Imagephoto.copy ~src:img - ~src_area:(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty) pièce; - pièces := pièce :: !pièces - done - done; - (tx, ty, List.tl !pièces);; - -let remplir_taquin c nx ny tx ty pièces = - let trou_x = ref (nx - 1) - and trou_y = ref (ny - 1) in - let trou = - Canvas.create_rectangle - ~x1:(!trou_x * tx) ~y1:(!trou_y * ty) ~x2:tx ~y2:ty c in - let taquin = Array.make_matrix nx ny trou in - let p = ref pièces in - for x = 0 to nx - 1 do - for y = 0 to ny - 1 do - match !p with - | [] -> () - | pièce :: reste -> - taquin.(x).(y) <- - Canvas.create_image - ~x:(x * tx) ~y:(y * ty) - ~image:pièce ~anchor:`Nw ~tags:["pièce"] c; - p := reste - done - done; - let déplacer x y = - let pièce = taquin.(x).(y) in - Canvas.coords_set c pièce - ~xys:[!trou_x * tx, !trou_y * ty]; - Canvas.coords_set c trou - ~xys:[x * tx, y * ty; tx, ty]; - taquin.(!trou_x).(!trou_y) <- pièce; - taquin.(x).(y) <- trou; - trou_x := x; trou_y := y in - let jouer ei = - let x = ei.ev_MouseX / tx and y = ei.ev_MouseY / ty in - if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1) - || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1) - then déplacer x y in - Canvas.bind ~events:[`ButtonPress] - ~fields:[`MouseX; `MouseY] ~action:jouer c (`Tag "pièce");; - -let rec permutation = function - | [] -> [] - | l -> let n = Random.int (List.length l) in - let (élément, reste) = partage l n in - élément :: permutation reste - -and partage l n = - match l with - | [] -> failwith "partage" - | tête :: reste -> - if n = 0 then (tête, reste) else - let (élément, reste') = partage reste (n - 1) in - (élément, tête :: reste');; - -let create_filled_text parent lines = - let lnum = List.length lines - and lwidth = - List.fold_right - (fun line max -> - let l = String.length line in - if l > max then l else max) - lines 1 in - let txtw = Text.create ~width:lwidth ~height:lnum parent in - List.iter - (fun line -> - Text.insert ~index:(`End, []) ~text:line txtw; - Text.insert ~index:(`End, []) ~text:"\n" txtw) - lines; - txtw;; - -let give_help parent lines () = - let help_window = Toplevel.create parent in - Wm.title_set help_window "Help"; - - let help_frame = Frame.create help_window in - - let help_txtw = create_filled_text help_frame lines in - - let quit_help () = destroy help_window in - let ok_button = Button.create ~text:"Ok" ~command:quit_help help_frame in - - pack ~side:`Bottom [help_txtw]; - pack ~side:`Bottom [ok_button ]; - pack [help_frame];; - -let taquin nom_fichier nx ny = - let fp = openTk () in - Wm.title_set fp "Taquin"; - let img = Imagephoto.create ~file:nom_fichier () in - let c = - Canvas.create ~background:`Black - ~width:(Imagephoto.width img) - ~height:(Imagephoto.height img) fp in - let (tx, ty, pièces) = découpe_image img nx ny in - remplir_taquin c nx ny tx ty (permutation pièces); - pack [c]; - - let quit = Button.create ~text:"Quit" ~command:closeTk fp in - let help_lines = - ["Pour jouer, cliquer sur une des pièces"; - "entourant le trou"; - ""; - "To play, click on a part around the hole"] in - let help = - Button.create ~text:"Help" ~command:(give_help fp help_lines) fp in - pack ~side:`Left ~fill:`X [quit] ; - pack ~side:`Left ~fill:`X [help] ; - mainLoop ();; - -if !Sys.interactive then () else -begin taquin "Lambda2.back.gif" 4 4; exit 0 end;; diff --git a/otherlibs/labltk/examples_labltk/tetris.ml b/otherlibs/labltk/examples_labltk/tetris.ml deleted file mode 100644 index 3e3f1e8a4b..0000000000 --- a/otherlibs/labltk/examples_labltk/tetris.ml +++ /dev/null @@ -1,710 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* A Tetris game for LablTk *) -(* written by Jun P. Furuse *) - -open StdLabels -open Tk - -exception Done - -type falling_block = { - mutable pattern: int array list; - mutable bcolor: int; - mutable x: int; - mutable y: int; - mutable d: int; - mutable alive: bool - } - -let stop_a_bit = 300 - -let field_width = 10 -let field_height = 20 - -let colors = [| - `Color "red"; - `Color "yellow"; - - `Color "blue"; - `Color "orange"; - - `Color "magenta"; - `Color "green"; - - `Color "cyan" -|] - -(* Put here your favorite image files *) -let backgrounds = [ - "Lambda2.back.gif" -] - -(* blocks *) -let block_size = 16 -let cell_border = 2 - -let blocks = [ - [ [|"0000"; - "0000"; - "1111"; - "0000" |]; - - [|"0010"; - "0010"; - "0010"; - "0010" |]; - - [|"0000"; - "0000"; - "1111"; - "0000" |]; - - [|"0010"; - "0010"; - "0010"; - "0010" |] ]; - - [ [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "0111"; - "0100"; - "0000" |]; - - [|"0000"; - "0110"; - "0010"; - "0010" |]; - - [|"0000"; - "0010"; - "1110"; - "0000" |]; - - [|"0100"; - "0100"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "0100"; - "0111"; - "0000" |]; - - [|"0000"; - "0110"; - "0100"; - "0100" |]; - - [|"0000"; - "1110"; - "0010"; - "0000" |]; - - [|"0010"; - "0010"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "1100"; - "0110"; - "0000" |]; - - [|"0010"; - "0110"; - "0100"; - "0000" |]; - - [|"0000"; - "1100"; - "0110"; - "0000" |]; - - [|"0010"; - "0110"; - "0100"; - "0000" |] ]; - - [ [|"0000"; - "0011"; - "0110"; - "0000" |]; - - [|"0100"; - "0110"; - "0010"; - "0000" |]; - - [|"0000"; - "0011"; - "0110"; - "0000" |]; - - [|"0000"; - "0100"; - "0110"; - "0010" |] ]; - - [ [|"0000"; - "0000"; - "1110"; - "0100" |]; - - [|"0000"; - "0100"; - "1100"; - "0100" |]; - - [|"0000"; - "0100"; - "1110"; - "0000" |]; - - [|"0000"; - "0100"; - "0110"; - "0100" |] ] - -] - -let line_empty = int_of_string "0b1110000000000111" -let line_full = int_of_string "0b1111111111111111" - -let decode_block dvec = - let btoi d = int_of_string ("0b"^d) in - Array.map ~f:btoi dvec - -class cell t1 t2 t3 ~canvas ~x ~y = object - val mutable color = 0 - method get = color - method set ~color:col = - if color = col then () else - if color <> 0 && col = 0 then begin - Canvas.move canvas t1 - ~x:(- block_size * (x + 1) -10 - cell_border * 2) - ~y:(- block_size * (y + 1) -10 - cell_border * 2); - Canvas.move canvas t2 - ~x:(- block_size * (x + 1) -10 - cell_border * 2) - ~y:(- block_size * (y + 1) -10 - cell_border * 2); - Canvas.move canvas t3 - ~x:(- block_size * (x + 1) -10 - cell_border * 2) - ~y:(- block_size * (y + 1) -10 - cell_border * 2) - end else begin - Canvas.configure_rectangle canvas t2 - ~fill: colors.(col - 1) - ~outline: colors.(col - 1); - Canvas.configure_rectangle canvas t1 - ~fill: `Black - ~outline: `Black; - Canvas.configure_rectangle canvas t3 - ~fill: (`Color "light gray") - ~outline: (`Color "light gray"); - if color = 0 && col <> 0 then begin - Canvas.move canvas t1 - ~x: (block_size * (x+1)+10+ cell_border*2) - ~y: (block_size * (y+1)+10+ cell_border*2); - Canvas.move canvas t2 - ~x: (block_size * (x+1)+10+ cell_border*2) - ~y: (block_size * (y+1)+10+ cell_border*2); - Canvas.move canvas t3 - ~x: (block_size * (x+1)+10+ cell_border*2) - ~y: (block_size * (y+1)+10+ cell_border*2) - end - end; - color <- col -end - -let cell_get (c, cf) x y = cf.(y).(x) #get - -let cell_set (c, cf) ~x ~y ~color = - if x >= 0 && y >= 0 && Array.length cf > y && Array.length cf.(y) > x then - let cur = cf.(y).(x) in - if cur#get = color then () else cur#set ~color - -let create_base_matrix ~cols ~rows = - let m = Array.create_matrix ~dimx:rows ~dimy:cols (0,0) in - for x = 0 to cols - 1 do for y = 0 to rows - 1 do - m.(y).(x) <- (x,y) - done done; - m - -let init fw = - let scorev = Textvariable.create () - and linev = Textvariable.create () - and levv = Textvariable.create () - and namev = Textvariable.create () - in - let f = Frame.create fw ~borderwidth: 2 in - let c = Canvas.create f ~width: (block_size * 10) - ~height: (block_size * 20) - ~borderwidth: cell_border - ~relief: `Sunken - ~background: `Black - and r = Frame.create f - and r' = Frame.create f in - - let nl = Label.create r ~text: "Next" ~font: "variable" in - let nc = Canvas.create r ~width: (block_size * 4) - ~height: (block_size * 4) - ~borderwidth: cell_border - ~relief: `Sunken - ~background: `Black in - let scl = Label.create r ~text: "Score" ~font: "variable" in - let sc = Label.create r ~textvariable: scorev ~font: "variable" in - let lnl = Label.create r ~text: "Lines" ~font: "variable" in - let ln = Label.create r ~textvariable: linev ~font: "variable" in - let levl = Label.create r ~text: "Level" ~font: "variable" in - let lev = Label.create r ~textvariable: levv ~font: "variable" in - let newg = Button.create r ~text: "New Game" ~font: "variable" in - - pack [f]; - pack [coe c; coe r; coe r'] ~side: `Left ~fill: `Y; - pack [coe nl; coe nc] ~side: `Top; - pack [coe scl; coe sc; coe lnl; coe ln; coe levl; coe lev; coe newg] - ~side: `Top; - - let cells_src = create_base_matrix ~cols:field_width ~rows:field_height in - let cells = - Array.map cells_src ~f: - (Array.map ~f: - begin fun (x,y) -> - let t1 = - Canvas.create_rectangle c - ~x1:(-block_size - 8) ~y1:(-block_size - 8) - ~x2:(-9) ~y2:(-9) - and t2 = - Canvas.create_rectangle c - ~x1:(-block_size - 10) ~y1:(-block_size - 10) - ~x2:(-11) ~y2:(-11) - and t3 = - Canvas.create_rectangle c - ~x1:(-block_size - 12) ~y1:(-block_size - 12) - ~x2:(-13) ~y2:(-13) - in - Canvas.raise c t1; - Canvas.raise c t2; - Canvas.lower c t3; - new cell ~canvas:c ~x ~y t1 t2 t3 - end) - in - let nexts_src = create_base_matrix ~cols:4 ~rows:4 in - let nexts = - Array.map nexts_src ~f: - (Array.map ~f: - begin fun (x,y) -> - let t1 = - Canvas.create_rectangle nc - ~x1:(-block_size - 8) ~y1:(-block_size - 8) - ~x2:(-9) ~y2:(-9) - and t2 = - Canvas.create_rectangle nc - ~x1:(-block_size - 10) ~y1:(-block_size - 10) - ~x2:(-11) ~y2:(-11) - and t3 = - Canvas.create_rectangle nc - ~x1:(-block_size - 12) ~y1:(-block_size - 12) - ~x2:(-13) ~y2:(-13) - in - Canvas.raise nc t1; - Canvas.raise nc t2; - Canvas.lower nc t3; - new cell ~canvas:nc ~x ~y t1 t2 t3 - end) - in - let game_over () = () - in - (* What a mess ! *) - [ coe f; coe c; coe r; coe nl; coe nc; coe scl; coe sc; coe levl; coe lev; - coe lnl; coe ln ], - newg, (c, cells), (nc, nexts), scorev, linev, levv, game_over - - -let draw_block field ~color ~block ~x ~y = - for iy = 0 to 3 do - let base = ref 1 in - let xd = block.(iy) in - for ix = 0 to 3 do - if xd land !base <> 0 then - cell_set field ~x:(ix + x) ~y:(iy + y) ~color; - base := !base lsl 1 - done - done - -let timer_ref = (ref None : Timer.t option ref) -(* I know, this should be timer ref, but I'm not sure what should be - the initial value ... *) - -let remove_timer () = - match !timer_ref with - None -> () - | Some t -> Timer.remove t (* ; prerr_endline "removed!" *) - -let do_after ~ms ~callback = - timer_ref := Some (Timer.add ~ms ~callback) - -let copy_block c = - { pattern= !c.pattern; - bcolor= !c.bcolor; - x= !c.x; - y= !c.y; - d= !c.d; - alive= !c.alive } - -let _ = - let top = openTk () in - let lb = Label.create top - and fw = Frame.create top - in - let set_message s = Label.configure lb ~text:s in - pack [coe lb; coe fw] ~side: `Top; - let score = ref 0 in - let line = ref 0 in - let level = ref 0 in - let time = ref 1000 in - let blocks = List.map ~f:(List.map ~f:decode_block) blocks in - let field = Array.create 26 0 in - let widgets, button, cell_field, next_field, scorev, linev, levv, game_over - = init fw in - let canvas = fst cell_field in - - let init_field () = - for i = 0 to 25 do - field.(i) <- line_empty - done; - field.(23) <- line_full; - for i = 0 to 19 do - for j = 0 to 9 do - cell_set cell_field ~x:j ~y:i ~color:0 - done - done; - for i = 0 to 3 do - for j = 0 to 3 do - cell_set next_field ~x:j ~y:i ~color:0 - done - done - in - - let draw_falling_block fb = - draw_block cell_field ~color: fb.bcolor - ~block: (List.nth fb.pattern fb.d) - ~x: (fb.x - 3) - ~y: (fb.y - 3) - - and erase_falling_block fb = - draw_block cell_field ~color: 0 - ~block: (List.nth fb.pattern fb.d) - ~x: (fb.x - 3) - ~y: (fb.y - 3) - in - - let stone fb = - for i=0 to 3 do - let cur = field.(i + fb.y) in - field.(i + fb.y) <- - cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x) - done; - for i=0 to 2 do - field.(i) <- line_empty - done - - and clear fb = - let l = ref 0 in - for i = 0 to 3 do - if i + fb.y >= 3 && i + fb.y <= 22 then - if field.(i + fb.y) = line_full then - begin - incr l; - field.(i + fb.y) <- line_empty; - for j = 0 to 9 do - cell_set cell_field ~x:j ~y:(i + fb.y - 3) ~color:0 - done - end - done; - !l - - and fall_lines () = - let eye = ref 22 (* bottom *) - and cur = ref 22 (* bottom *) - in - try - while !eye >= 3 do - while field.(!eye) = line_empty do - decr eye; - if !eye = 2 then raise Done - done; - field.(!cur) <- field.(!eye); - for j = 0 to 9 do - cell_set cell_field ~x:j ~y:(!cur-3) - ~color:(cell_get cell_field j (!eye-3)) - done; - decr eye; - decr cur - done - with Done -> (); - for i = 3 to !cur do - field.(i) <- line_empty; - for j = 0 to 9 do - cell_set cell_field ~x:j ~y:(i-3) ~color:0 - done - done - in - - let next = ref 42 (* THE ANSWER *) - and current = - ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false} - in - - let draw_next () = - draw_block next_field ~color: (!next+1) - ~block: (List.hd (List.nth blocks !next)) - ~x: 0 ~y: 0 - - and erase_next () = - draw_block next_field ~color: 0 - ~block: (List.hd (List.nth blocks !next)) - ~x: 0 ~y: 0 - in - - let set_nextblock () = - current := - { pattern= (List.nth blocks !next); - bcolor= !next+1; - x=6; y= 1; d= 0; alive= true}; - erase_next (); - next := Random.int 7; - draw_next () - in - - let death_check fb = - try - for i=0 to 3 do - let cur = field.(i + fb.y) in - if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 - then raise Done - done; - false - with - Done -> true - in - - let try_to_move m = - if !current.alive then - let sub m = - if death_check m then false - else - begin - erase_falling_block !current; - draw_falling_block m; - current := m; - true - end - in - if sub m then true - else - begin - m.x <- m.x + 1; - if sub m then true - else - begin - m.x <- m.x - 2; - sub m - end - end - else false - in - - let image_load = - let i = Canvas.create_image canvas - ~x: (block_size * 5 + block_size / 2) - ~y: (block_size * 10 + block_size / 2) - ~anchor: `Center in - Canvas.lower canvas i; - let img = Imagephoto.create () in - fun file -> - try - Imagephoto.configure img ~file: file; - Canvas.configure_image canvas i ~image: img - with - _ -> - begin - Printf.eprintf "%s : No such image...\n" file; - flush stderr - end - in - - let add_score l = - let pline = !line in - if l <> 0 then - begin - line := !line + l; - score := !score + l * l; - set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2))) - end; - Textvariable.set linev (string_of_int !line); - Textvariable.set scorev (string_of_int !score); - - if !line /10 <> pline /10 then - (* update the background every 10 lines. *) - begin - let num_image = List.length backgrounds - 1 in - let n = !line/10 in - let n = if n > num_image then num_image else n in - let file = List.nth backgrounds n in - image_load file; - incr level; - Textvariable.set levv (string_of_int !level) - end - in - - let rec newblock () = - set_message "TETRIS"; - set_nextblock (); - draw_falling_block !current; - if death_check !current then - begin - !current.alive <- false; - set_message "GAME OVER"; - game_over () - end - else - begin - time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200); - if !time < 60 - !level * 3 then time := 60 - !level * 3; - do_after ~ms:stop_a_bit ~callback:loop - end - - and loop () = - let m = copy_block current in - m.y <- m.y + 1; - if death_check m then - begin - !current.alive <- false; - stone !current; - do_after ~ms:stop_a_bit ~callback: - begin fun () -> - let l = clear !current in - if l > 0 then - do_after ~ms:stop_a_bit ~callback: - begin fun () -> - fall_lines (); - add_score l; - do_after ~ms:stop_a_bit ~callback:newblock - end - else - newblock () - end - end - else - begin - erase_falling_block !current; - draw_falling_block m; - current := m; - do_after ~ms:!time ~callback:loop - end - in - - let bind_game w = - bind w ~events:[`KeyPress] ~fields:[`KeySymString] ~action: - begin fun e -> - match e.ev_KeySymString with - | "h" -> - let m = copy_block current in - m.x <- m.x - 1; - 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; - 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; - ignore (try_to_move m) - | "l" -> - let m = copy_block current in - m.x <- m.x + 1; - ignore (try_to_move m) - | "m" -> - remove_timer (); - loop () - | "space" -> - if !current.alive then - begin - let m = copy_block current - and n = copy_block current in - while - m.y <- m.y + 1; - if death_check m then false - else begin n.y <- m.y; true end - do () done; - erase_falling_block !current; - draw_falling_block n; - current := n; - remove_timer (); - loop () - end - | _ -> () - end - in - - let game_init () = - (* Game Initialization *) - set_message "Initializing ..."; - remove_timer (); - image_load (List.hd backgrounds); - time := 1000; - score := 0; - line := 0; - level := 1; - add_score 0; - init_field (); - next := Random.int 7; - set_message "Welcome to TETRIS"; - set_nextblock (); - draw_falling_block !current; - do_after ~ms:!time ~callback:loop - in - (* As an applet, it was required... *) - (* List.iter f: bind_game widgets; *) - bind_game top; - Button.configure button ~command: game_init; - game_init () - -let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/frx/.depend b/otherlibs/labltk/frx/.depend deleted file mode 100644 index d815ab0eb0..0000000000 --- a/otherlibs/labltk/frx/.depend +++ /dev/null @@ -1,38 +0,0 @@ -frx_after.cmo: frx_after.cmi -frx_after.cmx: frx_after.cmi -frx_color.cmo: frx_color.cmi -frx_color.cmx: frx_color.cmi -frx_ctext.cmo: frx_fit.cmi frx_text.cmi frx_ctext.cmi -frx_ctext.cmx: frx_fit.cmx frx_text.cmx frx_ctext.cmi -frx_dialog.cmo: frx_dialog.cmi -frx_dialog.cmx: frx_dialog.cmi -frx_entry.cmo: frx_entry.cmi -frx_entry.cmx: frx_entry.cmi -frx_fillbox.cmo: frx_fillbox.cmi -frx_fillbox.cmx: frx_fillbox.cmi -frx_fit.cmo: frx_after.cmi frx_fit.cmi -frx_fit.cmx: frx_after.cmx frx_fit.cmi -frx_focus.cmo: frx_focus.cmi -frx_focus.cmx: frx_focus.cmi -frx_font.cmo: frx_misc.cmi frx_font.cmi -frx_font.cmx: frx_misc.cmx frx_font.cmi -frx_lbutton.cmo: frx_lbutton.cmi -frx_lbutton.cmx: frx_lbutton.cmi -frx_listbox.cmo: frx_listbox.cmi -frx_listbox.cmx: frx_listbox.cmi -frx_mem.cmo: frx_mem.cmi -frx_mem.cmx: frx_mem.cmi -frx_misc.cmo: frx_misc.cmi -frx_misc.cmx: frx_misc.cmi -frx_req.cmo: frx_entry.cmi frx_listbox.cmi frx_widget.cmi frx_req.cmi -frx_req.cmx: frx_entry.cmx frx_listbox.cmx frx_widget.cmx frx_req.cmi -frx_rpc.cmo: frx_rpc.cmi -frx_rpc.cmx: frx_rpc.cmi -frx_selection.cmo: frx_selection.cmi -frx_selection.cmx: frx_selection.cmi -frx_synth.cmo: frx_synth.cmi -frx_synth.cmx: frx_synth.cmi -frx_text.cmo: frx_misc.cmi frx_text.cmi -frx_text.cmx: frx_misc.cmx frx_text.cmi -frx_widget.cmo: frx_widget.cmi -frx_widget.cmx: frx_widget.cmi diff --git a/otherlibs/labltk/frx/Makefile b/otherlibs/labltk/frx/Makefile deleted file mode 100644 index 226ba129f0..0000000000 --- a/otherlibs/labltk/frx/Makefile +++ /dev/null @@ -1,51 +0,0 @@ -include ../support/Makefile.common - -COMPFLAGS=-I ../camltk -I ../support -I $(OTHERS)/unix - -OBJS= frx_misc.cmo frx_widget.cmo frx_font.cmo frx_entry.cmo frx_text.cmo \ - frx_listbox.cmo frx_req.cmo frx_fillbox.cmo frx_focus.cmo \ - frx_dialog.cmo frx_mem.cmo frx_rpc.cmo frx_synth.cmo frx_selection.cmo \ - frx_after.cmo frx_fit.cmo frx_ctext.cmo frx_color.cmo - -OBJSX = $(OBJS:.cmo=.cmx) - -all: frxlib.cma - -opt: frxlib.cmxa - -frxlib.cma: $(OBJS) - $(CAMLLIBR) -o frxlib.cma $(OBJS) - -frxlib.cmxa: $(OBJSX) - $(CAMLOPTLIBR) -o frxlib.cmxa $(OBJSX) - -install: frxlib.cma - cp *.cmi *.mli frxlib.cma $(INSTALLDIR) - -installopt: frxlib.cmxa - cp frxlib.cmxa frxlib.a $(INSTALLDIR) - -clean: - rm -f *.cm* *.o *.a - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJSX): ../lib/$(LIBNAME).cmxa - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .cmx - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - - -depend: - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/labltk/frx/Makefile.nt b/otherlibs/labltk/frx/Makefile.nt deleted file mode 100644 index 2f37a4cb91..0000000000 --- a/otherlibs/labltk/frx/Makefile.nt +++ /dev/null @@ -1,53 +0,0 @@ -include ../support/Makefile.common.nt - -COMPFLAGS=-I ../camltk -I ../support - -OBJS= frx_misc.cmo frx_widget.cmo frx_font.cmo frx_entry.cmo frx_text.cmo \ - frx_listbox.cmo frx_req.cmo frx_fillbox.cmo frx_focus.cmo \ - frx_dialog.cmo frx_mem.cmo frx_rpc.cmo frx_synth.cmo frx_selection.cmo \ - frx_after.cmo frx_fit.cmo frx_ctext.cmo frx_color.cmo - -OBJSX = $(OBJS:.cmo=.cmx) - -all: libfrx.cma - -opt: libfrx.cmxa - -libfrx.cma: $(OBJS) - $(CAMLLIBR) -o libfrx.cma $(OBJS) - -libfrx.cmxa: $(OBJSX) - $(CAMLOPTLIBR) -o libfrx.cmxa $(OBJSX) - - -install: libfrx.cma - cp *.cmi *.mli libfrx.cma $(INSTALLDIR) - -installopt: libfrx.cmxa - cp libfrx.cmxa libfrx.$(A) $(INSTALLDIR) - - -clean: - rm -f *.cm* *.$(O) *.$(A) *~ *test - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJSX): ../lib/$(LIBNAME).cmxa - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .cmx - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - - -depend: - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/labltk/frx/README b/otherlibs/labltk/frx/README deleted file mode 100644 index b86f8dcd85..0000000000 --- a/otherlibs/labltk/frx/README +++ /dev/null @@ -1,2 +0,0 @@ -This is Francois Rouaix's widget set library, Frx. -It uses CamlTk API.
\ No newline at end of file diff --git a/otherlibs/labltk/frx/frx_after.ml b/otherlibs/labltk/frx/frx_after.ml deleted file mode 100644 index 7fe6a4f2a5..0000000000 --- a/otherlibs/labltk/frx/frx_after.ml +++ /dev/null @@ -1,24 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Protocol -let idle f = - let id = new_function_id () in - let wrapped _ = - clear_callback id; (* do it first in case f raises exception *) - f() in - Hashtbl.add callback_naming_table id wrapped; - tkCommand [| TkToken "after"; TkToken "idle"; - TkToken ("camlcb "^ string_of_cbid id) |] diff --git a/otherlibs/labltk/frx/frx_after.mli b/otherlibs/labltk/frx/frx_after.mli deleted file mode 100644 index 73c07f7bb9..0000000000 --- a/otherlibs/labltk/frx/frx_after.mli +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -val idle : (unit -> unit) -> unit - (* [idle f] is equivalent to Tk "after idle {camlcb f}" *) diff --git a/otherlibs/labltk/frx/frx_color.ml b/otherlibs/labltk/frx/frx_color.ml deleted file mode 100644 index 4df3eb6b45..0000000000 --- a/otherlibs/labltk/frx/frx_color.ml +++ /dev/null @@ -1,35 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Protocol - -module StringSet = Set.Make(struct type t = string let compare = compare end) - -(* should we keep a negative cache ? *) -let available_colors = ref (StringSet.empty) - -let check s = - if StringSet.mem s !available_colors then true - else begin - try - let f = Frame.create_named Widget.default_toplevel "frxcolorcheck" - [Background (NamedColor s)] in - available_colors := StringSet.add s !available_colors; - destroy f; - true - with - TkError _ -> false - end diff --git a/otherlibs/labltk/frx/frx_color.mli b/otherlibs/labltk/frx/frx_color.mli deleted file mode 100644 index 513cb08394..0000000000 --- a/otherlibs/labltk/frx/frx_color.mli +++ /dev/null @@ -1,16 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -val check : string -> bool diff --git a/otherlibs/labltk/frx/frx_ctext.ml b/otherlibs/labltk/frx/frx_ctext.ml deleted file mode 100644 index 0d4fd836ef..0000000000 --- a/otherlibs/labltk/frx/frx_ctext.ml +++ /dev/null @@ -1,66 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -(* A trick by Steve Ball to do pixel scrolling on text widgets *) -(* USES frx_fit *) -open Camltk - -let create top opts navigation = - let f = Frame.create top [BorderWidth (Pixels 2); Relief Raised] in - let lf = Frame.create f [] in - let rf = Frame.create f [] in - let c = Canvas.create lf [BorderWidth (Pixels 0)] - and xscroll = Scrollbar.create lf [Orient Horizontal] - and yscroll = Scrollbar.create rf [Orient Vertical] - and secret = Frame.create_named rf "secret" [] - in - let t = Text.create c (BorderWidth(Pixels 0) :: opts) in - if navigation then Frx_text.navigation_keys t; - - (* Make the text widget an embedded canvas object *) - ignore - (Canvas.create_window c (Pixels 0) (Pixels 0) - [Anchor NW; Window t; Tags [Tag "main"]]); - Canvas.focus c (Tag "main"); - (* - Canvas.configure c [Width (Pixels (Winfo.reqwidth t)); - Height(Pixels (Winfo.reqheight t))]; - *) - Canvas.configure c [YScrollCommand (Scrollbar.set yscroll)]; - (* The horizontal scrollbar is directly attached to the - * text widget, because h scrolling works properly *) - Scrollbar.configure xscroll [ScrollCommand (Text.xview t)]; - (* But vertical scroll is attached to the canvas *) - Scrollbar.configure yscroll [ScrollCommand (Canvas.yview c)]; - let scroll, check = Frx_fit.vert t in - Text.configure t [ - XScrollCommand (Scrollbar.set xscroll); - YScrollCommand (fun first last -> - scroll first last; - let x,y,w,h = Canvas.bbox c [Tag "main"] in - Canvas.configure c - [ScrollRegion (Pixels x, Pixels y, Pixels w, Pixels h)]) - ]; - - bind c [[],Configure] (BindSet ([Ev_Width], (fun ei -> - Canvas.configure_window c (Tag "main") [Width (Pixels ei.ev_Width)]))); - - pack [rf] [Side Side_Right; Fill Fill_Y]; - pack [lf] [Side Side_Left; Fill Fill_Both; Expand true]; - pack [secret] [Side Side_Bottom]; - pack [yscroll] [Side Side_Top; Fill Fill_Y; Expand true]; - pack [xscroll] [Side Side_Bottom; Fill Fill_X]; - pack [c] [Side Side_Left; Fill Fill_Both; Expand true]; - f, t diff --git a/otherlibs/labltk/frx/frx_ctext.mli b/otherlibs/labltk/frx/frx_ctext.mli deleted file mode 100644 index 157c0cad16..0000000000 --- a/otherlibs/labltk/frx/frx_ctext.mli +++ /dev/null @@ -1,25 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -val create : - Widget.widget -> Camltk.options list -> bool -> Widget.widget * Widget.widget - (* [create parent opts nav_keys] creates a text widget - with "pixel scrolling". Based on a trick learned from Steve Ball. - Returns (frame widget, text widget). - *) - - diff --git a/otherlibs/labltk/frx/frx_dialog.ml b/otherlibs/labltk/frx/frx_dialog.ml deleted file mode 100644 index 0b65b419e3..0000000000 --- a/otherlibs/labltk/frx/frx_dialog.ml +++ /dev/null @@ -1,115 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Protocol - -let rec mapi f n l = - match l with - [] -> [] - | x::l -> let v = f n x in v::(mapi f (succ n) l) - -(* Same as tk_dialog, but not sharing the tkwait variable *) -(* w IS the parent widget *) -let f w name title mesg bitmap def buttons = - let t = Toplevel.create_named w name [Class "Dialog"] in - Wm.title_set t title; - Wm.iconname_set t "Dialog"; - Wm.protocol_set t "WM_DELETE_WINDOW" (function () -> ()); - (* Wm.transient_set t (Winfo.toplevel w); *) - let ftop = - Frame.create_named t "top" [Relief Raised; BorderWidth (Pixels 1)] - and fbot = - Frame.create_named t "bot" [Relief Raised; BorderWidth (Pixels 1)] - in - pack [ftop][Side Side_Top; Fill Fill_Both]; - pack [fbot][Side Side_Bottom; Fill Fill_Both]; - - let l = - Label.create_named ftop "msg" - [Justify Justify_Left; Text mesg; WrapLength (Pixels 600)] in - pack [l][Side Side_Right; Expand true; Fill Fill_Both; - PadX (Millimeters 3.0); PadY (Millimeters 3.0)]; - begin match bitmap with - Predefined "" -> () - | _ -> - let b = - Label.create_named ftop "bitmap" [Bitmap bitmap] in - pack [b][Side Side_Left; PadX (Millimeters 3.0); PadY (Millimeters 3.0)] - end; - - let waitv = Textvariable.create_temporary t in - - let buttons = - mapi (fun i bname -> - let b = Button.create t - [Text bname; - Command (fun () -> Textvariable.set waitv (string_of_int i))] in - if i = def then begin - let f = Frame.create_named fbot "default" - [Relief Sunken; BorderWidth (Pixels 1)] in - raise_window_above b f; - pack [f][Side Side_Left; Expand true; - PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; - pack [b][In f; PadX (Millimeters 2.0); PadY (Millimeters 2.0)]; - bind t [[], KeyPressDetail "Return"] - (BindSet ([], (fun _ -> Button.flash b; Button.invoke b))) - end - else - pack [b][In fbot; Side Side_Left; Expand true; - PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; - b - ) - 0 buttons in - - Wm.withdraw t; - update_idletasks(); - let x = (Winfo.screenwidth t)/2 - (Winfo.reqwidth t)/2 - - (Winfo.vrootx (Winfo.parent t)) - and y = (Winfo.screenheight t)/2 - (Winfo.reqheight t)/2 - - (Winfo.vrooty (Winfo.parent t)) in - Wm.geometry_set t (Printf.sprintf "+%d+%d" x y); - Wm.deiconify t; - - let oldfocus = try Some (Focus.get()) with _ -> None - and oldgrab = Grab.current ~displayof: t () - and grabstatus = ref None in - begin match oldgrab with - [] -> () - | x::l -> grabstatus := Some(Grab.status x) - end; - - (* avoid errors here because it makes the entire app useless *) - (try Grab.set t with TkError _ -> ()); - Tkwait.visibility t; - Focus.set (if def >= 0 then List.nth buttons def else t); - - Tkwait.variable waitv; - begin match oldfocus with - None -> () - | Some w -> try Focus.set w with _ -> () - end; - destroy t; - begin match oldgrab with - [] -> () - | x::l -> - try - match !grabstatus with - Some(GrabGlobal) -> Grab.set_global x - | _ -> Grab.set x - with TkError _ -> () - end; - - int_of_string (Textvariable.get waitv) diff --git a/otherlibs/labltk/frx/frx_dialog.mli b/otherlibs/labltk/frx/frx_dialog.mli deleted file mode 100644 index 2124150caa..0000000000 --- a/otherlibs/labltk/frx/frx_dialog.mli +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val f : - Widget.widget -> - string -> string -> string -> Camltk.bitmap -> int -> string list -> int - (* same as Dialog.create_named, but with a local variable for - synchronisation. Makes it possible to have several dialogs - simultaneously *) diff --git a/otherlibs/labltk/frx/frx_entry.ml b/otherlibs/labltk/frx/frx_entry.ml deleted file mode 100644 index eea7362d66..0000000000 --- a/otherlibs/labltk/frx/frx_entry.ml +++ /dev/null @@ -1,42 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let version = "$Id$" - -(* - * Tk 4.0 has emacs bindings for entry widgets - *) - -let new_label_entry parent txt action = - let f = Frame.create parent [] in - let m = Label.create f [Text txt] - and e = Entry.create f [Relief Sunken; TextWidth 0] in - Camltk.bind e [[], KeyPressDetail "Return"] - (BindSet ([], fun _ -> action(Entry.get e))); - pack [m][Side Side_Left]; - pack [e][Side Side_Right; Fill Fill_X; Expand true]; - f,e - -let new_labelm_entry parent txt memo = - let f = Frame.create parent [] in - let m = Label.create f [Text txt] - and e = Entry.create f [Relief Sunken; TextVariable memo; TextWidth 0] in - pack [m][Side Side_Left]; - pack [e][Side Side_Right; Fill Fill_X; Expand true]; - f,e - - diff --git a/otherlibs/labltk/frx/frx_entry.mli b/otherlibs/labltk/frx/frx_entry.mli deleted file mode 100644 index 2f34a7e64c..0000000000 --- a/otherlibs/labltk/frx/frx_entry.mli +++ /dev/null @@ -1,31 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val new_label_entry : - Widget.widget -> - string -> (string -> unit) -> Widget.widget * Widget.widget - (* [new_label_entry parent label action] - creates a "labelled" entry widget where [action] will be invoked - when the user types Return in the widget. - Returns (frame widget, entry widget) - *) -val new_labelm_entry : - Widget.widget -> - string -> Textvariable.textVariable -> Widget.widget * Widget.widget - (* [new_labelm_entry parent label variable] - creates a "labelled" entry widget whose contents is [variable]. - Returns (frame widget, entry widget) - *) diff --git a/otherlibs/labltk/frx/frx_fileinput.ml b/otherlibs/labltk/frx/frx_fileinput.ml deleted file mode 100644 index cf59d1303b..0000000000 --- a/otherlibs/labltk/frx/frx_fileinput.ml +++ /dev/null @@ -1,40 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let version = "$Id$" - -(* - * Simple spooling for fileinput callbacks - *) - -let waiting_list = Queue. new() -and waiting = ref 0 -and max_open = ref 10 -and cur_open = ref 0 - -let add fd f = - if !cur_open < !max_open then begin - incr cur_open; - add_fileinput fd f - end - else begin - incr waiting; - Queue.add (fd,f) waiting_list - end - -let remove fd = - diff --git a/otherlibs/labltk/frx/frx_fillbox.ml b/otherlibs/labltk/frx/frx_fillbox.ml deleted file mode 100644 index d9e4741889..0000000000 --- a/otherlibs/labltk/frx/frx_fillbox.ml +++ /dev/null @@ -1,65 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -(* - * Progress indicators - *) -let okcolor = NamedColor "#3cb371" -and kocolor = NamedColor "#dc5c5c" - - -let new_vertical parent w h = - let c = Canvas.create_named parent "fillbox" - [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); - Relief Sunken] - in - let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels w) (Pixels 0) - [FillColor okcolor; Outline okcolor] - in - c, (function - 0 -> Canvas.configure_rectangle c i [FillColor okcolor; - Outline okcolor]; - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels w; Pixels 0] - | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; - Outline kocolor] - | n -> - let percent = if n > 100 then 100 else n in - let hf = percent*h/100 in - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels w; Pixels hf]) - -let new_horizontal parent w h = - let c = Canvas.create_named parent "fillbox" - [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); - Relief Sunken] - in - let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels 0) (Pixels h) - [FillColor okcolor; Outline okcolor] - in - c, (function - 0 -> Canvas.configure_rectangle c i [FillColor okcolor; - Outline okcolor]; - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels 0; Pixels h] - | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; - Outline kocolor] - | n -> - let percent = if n > 100 then 100 else n in - let wf = percent*w/100 in - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels wf; Pixels h]) diff --git a/otherlibs/labltk/frx/frx_fillbox.mli b/otherlibs/labltk/frx/frx_fillbox.mli deleted file mode 100644 index a825524cdc..0000000000 --- a/otherlibs/labltk/frx/frx_fillbox.mli +++ /dev/null @@ -1,31 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -val new_vertical : - Widget.widget -> int -> int -> Widget.widget * (int -> unit) - (* [new_vertical parent width height] - creates a vertical fillbox of [width] and [height]. - Returns a frame widget and a function to set the current value of - the fillbox. The value can be - n < 0 : the fillbox changes color (reddish) - 0 <= n <= 100: the fillbox fills up to n percent - 100 <= n : the fillbox fills up to 95% - *) - -val new_horizontal : - Widget.widget -> int -> int -> Widget.widget * (int -> unit) - (* save as above, except the widget is horizontal *) diff --git a/otherlibs/labltk/frx/frx_fit.ml b/otherlibs/labltk/frx/frx_fit.ml deleted file mode 100644 index 2011699ab7..0000000000 --- a/otherlibs/labltk/frx/frx_fit.ml +++ /dev/null @@ -1,83 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let debug = ref false - -let vert wid = - let newsize = ref 0 - and pending_resize = ref false - and last_last = ref 0.0 in - let rec resize () = - pending_resize := false; - if !debug then - (Printf.eprintf "%s Resize %d\n" - (Widget.name wid) !newsize; flush stderr); - Text.configure wid [TextHeight !newsize]; - () - and check () = - let first, last = Text.yview_get wid in - check1 first last - - and check1 first last = - let curheight = int_of_string (cget wid CHeight) in - if !debug then begin - Printf.eprintf "%s C %d %f %f\n" - (Widget.name wid) curheight first last; - flush stderr - end; - if first = 0.0 && last = 1.0 then () - (* Don't attempt anything if widget is not visible *) - else if not (Winfo.viewable wid) then begin - if !debug then - (Printf.eprintf "%s C notviewable\n" (Widget.name wid); - flush stderr); - (* Try again later *) - bind wid [[], Expose] (BindSet ([], fun _ -> - bind wid [[], Expose] BindRemove; - check())) - end - else begin - let delta = - if last = 0.0 then 1 - else if last = !last_last then - (* it didn't change since our last resize ! *) - 1 - else begin - last_last := last; - (* never to more than double *) - let visible = max 0.5 (last -. first) in - max 1 (truncate (float curheight *. (1. -. visible))) - end in - newsize := max (curheight + delta) !newsize; - if !debug then - (Printf.eprintf "%s newsize: %d\n" (Widget.name wid) !newsize; - flush stderr); - if !pending_resize then () - else begin - pending_resize := true; - Timer.set 300 (fun () -> Frx_after.idle resize) - end - end - - and scroll first last = - if !debug then - (Printf.eprintf "%s V %f %f\n" (Widget.name wid) first last; - flush stderr); - if first = 0.0 && last = 1.0 then () - else check1 first last - in - scroll, check diff --git a/otherlibs/labltk/frx/frx_fit.mli b/otherlibs/labltk/frx/frx_fit.mli deleted file mode 100644 index 29479d8013..0000000000 --- a/otherlibs/labltk/frx/frx_fit.mli +++ /dev/null @@ -1,29 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget - -val debug: bool ref -val vert: widget -> (float -> float -> unit) * (unit -> unit) - -(* [vert widget] - can be applied to a text widget so that it expands to show its full - contents. Returns [scroll] and [check]. [scroll] must be used as - the YScrollCommand of the widget. [check] can be called when some - modification occurs in the content of the widget (such as a size change - in some embedded windows. - This feature is a terrible hack and should be used with extreme caution. - *) diff --git a/otherlibs/labltk/frx/frx_focus.ml b/otherlibs/labltk/frx/frx_focus.ml deleted file mode 100644 index f33b9e6df1..0000000000 --- a/otherlibs/labltk/frx/frx_focus.ml +++ /dev/null @@ -1,26 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -(* Temporary focus *) - -(* ? use bind tag ? how about the global reference then *) -let auto w = - let old_focus = ref w in - bind w [[],Enter] - (BindSet([], fun _ -> old_focus := Focus.get (); Focus.set w)); - bind w [[],Leave] - (BindSet([], fun _ -> Focus.set !old_focus)) diff --git a/otherlibs/labltk/frx/frx_focus.mli b/otherlibs/labltk/frx/frx_focus.mli deleted file mode 100644 index 919f704754..0000000000 --- a/otherlibs/labltk/frx/frx_focus.mli +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val auto : Widget.widget -> unit - (* *) diff --git a/otherlibs/labltk/frx/frx_font.ml b/otherlibs/labltk/frx/frx_font.ml deleted file mode 100644 index 023470261f..0000000000 --- a/otherlibs/labltk/frx/frx_font.ml +++ /dev/null @@ -1,51 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget - -let version = "$Id$" - -(* - * Finding fonts. Inspired by code in Ical by Sanjay Ghemawat. - * Possibly bogus because some families use "i" for italic where others - * use "o". - * wght: bold, medium - * slant: i, o, r - * pxlsz: 8, 10, ... -*) -module StringSet = Set.Make(struct type t = string let compare = compare end) - -let available_fonts = ref (StringSet.empty) - -let get_canvas = - Frx_misc.autodef (fun () -> Canvas.create Widget.default_toplevel []) - - -let find fmly wght slant pxlsz = - let fontspec = - "-*-"^fmly^"-"^wght^"-"^slant^"-normal-*-"^string_of_int pxlsz^"-*-*-*-*-*-iso8859-1" in - if StringSet.mem fontspec !available_fonts then fontspec - else - let c = get_canvas() in - try - let tag = Canvas.create_text c (Pixels 0) (Pixels 0) - [Text "foo"; Font fontspec] in - Canvas.delete c [tag]; - available_fonts := StringSet.add fontspec !available_fonts; - fontspec - with - _ -> raise (Invalid_argument fontspec) - diff --git a/otherlibs/labltk/frx/frx_font.mli b/otherlibs/labltk/frx/frx_font.mli deleted file mode 100644 index c0b7e68067..0000000000 --- a/otherlibs/labltk/frx/frx_font.mli +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -val find : string -> string -> string -> int -> string - (* [find family weight slant pxlsz] returns the X11 full name of - the font required font, if available. - Raises Invalid_argument fullname otherwise. - *) diff --git a/otherlibs/labltk/frx/frx_group.ml b/otherlibs/labltk/frx/frx_group.ml deleted file mode 100644 index 17c8a0310d..0000000000 --- a/otherlibs/labltk/frx/frx_group.ml +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let vgroup top l = - let f = Frame.create top [] in - Pack.forget l; - Pack.configure l [In f]; - f diff --git a/otherlibs/labltk/frx/frx_lbutton.ml b/otherlibs/labltk/frx/frx_lbutton.ml deleted file mode 100644 index c4d51f7b59..0000000000 --- a/otherlibs/labltk/frx/frx_lbutton.ml +++ /dev/null @@ -1,50 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -open Widget - - -let version = "$Id$" - -(* - * Simulate a button with a bitmap AND a label - *) - -let rec sort_options but lab com = function - [] -> but,lab,com - |(Command f as o)::l -> sort_options (o::but) lab com l - |(Bitmap b as o)::l -> sort_options (o::but) lab com l - |(Text t as o)::l -> sort_options but (o::lab) com l - |o::l -> sort_options but lab (o::com) l - -let create parent options = - let but,lab,com = sort_options [] [] [] options in - let f = Frame.create parent com in - let b = Button.create f (but@com) - and l = Label.create f (lab@com) in - pack [b;l][]; - bind l [[],ButtonPressDetail 1] (BindSet ([],(function _ -> Button.invoke b))); - f - -let configure f options = - let but,lab,com = sort_options [] [] [] options in - match Pack.slaves f with - [b;l] -> - Frame.configure f com; - Button.configure b (but@com); - Label.configure l (lab@com) - | _ -> raise (Invalid_argument "lbutton configure") diff --git a/otherlibs/labltk/frx/frx_lbutton.mli b/otherlibs/labltk/frx/frx_lbutton.mli deleted file mode 100644 index d79431f345..0000000000 --- a/otherlibs/labltk/frx/frx_lbutton.mli +++ /dev/null @@ -1,24 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Widget -open Camltk - - -val version : string - -val create : Widget -> option list -> Widget -and configure : Widget -> option list -> unit - diff --git a/otherlibs/labltk/frx/frx_listbox.ml b/otherlibs/labltk/frx/frx_listbox.ml deleted file mode 100644 index 8bb2941c0b..0000000000 --- a/otherlibs/labltk/frx/frx_listbox.ml +++ /dev/null @@ -1,92 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let version = "$Id$" - -(* - * Link a scrollbar and a listbox - *) -let scroll_link sb lb = - Listbox.configure lb - [YScrollCommand (Scrollbar.set sb)]; - Scrollbar.configure sb - [ScrollCommand (Listbox.yview lb)] - -(* - * Completion for listboxes, Macintosh style. - * As long as you type fast enough, the listbox is repositioned to the - * first entry "greater" than the typed prefix. - * assumes: - * sorted list (otherwise it's stupid) - * fixed size, because we don't recompute size at each callback invocation - *) - -let add_completion lb action = - let prefx = ref "" (* current match prefix *) - and maxi = Listbox.size lb - 1 (* maximum index (doesn't matter actually) *) - and current = ref 0 (* current position *) - and lastevent = ref 0 in - - let rec move_forward () = - if Listbox.get lb (Number !current) < !prefx then - if !current < maxi then begin incr current; move_forward() end - - and recenter () = - let element = Number !current in - (* Clean the selection *) - Listbox.selection_clear lb (Number 0) End; - (* Set it to our unique element *) - Listbox.selection_set lb element element; - (* Activate it, to keep consistent with Up/Down. - You have to be in Extended or Browse mode *) - Listbox.activate lb element; - Listbox.selection_anchor lb element; - Listbox.see lb element in - - let complete time s = - if time - !lastevent < 500 then (* sorry, hard coded limit *) - prefx := !prefx ^ s - else begin (* reset *) - current := 0; - prefx := s - end; - lastevent := time; - move_forward(); - recenter() in - - - bind lb [[], KeyPress] - (BindSet([Ev_Char; Ev_Time], - (function ev -> - (* consider only keys producing characters. The callback is called - * even if you press Shift. - *) - if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char))); - (* Key specific bindings override KeyPress *) - bind lb [[], KeyPressDetail "Return"] (BindSet([], action)); - (* Finally, we have to set focus, otherwise events dont get through *) - Focus.set lb; - recenter() (* so that first item is selected *) - -let new_scrollable_listbox top options = - let f = Frame.create top [] in - let lb = Listbox.create f options - and sb = Scrollbar.create f [] in - scroll_link sb lb; - pack [lb] [Side Side_Left; Fill Fill_Both; Expand true]; - pack [sb] [Side Side_Left; Fill Fill_Y]; - f, lb diff --git a/otherlibs/labltk/frx/frx_listbox.mli b/otherlibs/labltk/frx/frx_listbox.mli deleted file mode 100644 index b44b6ee9d3..0000000000 --- a/otherlibs/labltk/frx/frx_listbox.mli +++ /dev/null @@ -1,32 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val scroll_link : Widget.widget -> Widget.widget -> unit - (* [scroll_link scrollbar listbox] links [scrollbar] and [listbox] - as expected. - *) - -val add_completion : Widget.widget -> (eventInfo -> unit) -> unit - (* [add_completion listbox action] adds Macintosh like electric navigation - in the listbox when characters are typed in. - [action] is invoked if Return is pressed - *) - -val new_scrollable_listbox : - Widget.widget -> options list -> Widget.widget * Widget.widget - (* [new_scrollable_listbox parent options] makes a scrollable listbox and - returns (frame, listbox) - *) diff --git a/otherlibs/labltk/frx/frx_mem.ml b/otherlibs/labltk/frx/frx_mem.ml deleted file mode 100644 index 4bab868624..0000000000 --- a/otherlibs/labltk/frx/frx_mem.ml +++ /dev/null @@ -1,89 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -(* Memory gauge *) -open Camltk -open Gc - -let inited = ref None -let w = ref 300 -let delay = ref 5 (* in seconds *) -let wordsize = (* officially approved *) - if 1 lsl 31 = 0 then 4 else 8 - - -let init () = - let top = Toplevel.create Widget.default_toplevel [Class "CamlGC"] in - let name = Camltk.appname_get () in - Wm.title_set top (name ^ " Memory Gauge"); - Wm.withdraw top; - inited := Some top; - (* this should be executed before the internal "all" binding *) - bind top [[], Destroy] (BindSet ([], (fun _ -> inited := None))); - let fminors = Frame.create top [] in - let lminors = Label.create fminors [Text "Minor collections"] - and vminors = Label.create fminors [] in - pack [lminors][Side Side_Left]; - pack [vminors][Side Side_Right; Fill Fill_X; Expand true]; - let fmajors = Frame.create top [] in - let lmajors = Label.create fmajors [Text "Major collections"] - and vmajors = Label.create fmajors [] in - pack [lmajors][Side Side_Left]; - pack [vmajors][Side Side_Right; Fill Fill_X; Expand true]; - let fcompacts = Frame.create top [] in - let lcompacts = Label.create fcompacts [Text "Compactions"] - and vcompacts = Label.create fcompacts [] in - pack [lcompacts][Side Side_Left]; - pack [vcompacts][Side Side_Right; Fill Fill_X; Expand true]; - let fsize = Frame.create top [] in - let lsize = Label.create fsize [Text "Heap size (bytes)"] - and vsize = Label.create fsize [] in - pack [lsize][Side Side_Left]; - pack [vsize][Side Side_Right; Fill Fill_X; Expand true]; - let fheap = Frame.create top [Width (Pixels !w); Height (Pixels 10)] in - let flive = Frame.create fheap [Background Red] - and ffree = Frame.create fheap [Background Green] - and fdead = Frame.create fheap [Background Black] in - pack [fminors; fmajors; fcompacts; fsize; fheap][Fill Fill_X]; - - let display () = - let st = Gc.stat() in - Label.configure vminors [Text (string_of_int st.minor_collections)]; - Label.configure vmajors [Text (string_of_int st.major_collections)]; - Label.configure vcompacts [Text (string_of_int st.compactions)]; - Label.configure vsize [Text (string_of_int (wordsize * st.heap_words))]; - let liver = (float st.live_words) /. (float st.heap_words) - and freer = (float st.free_words) /. (float st.heap_words) in - Place.configure flive [X (Pixels 0); Y (Pixels 0); - RelWidth liver; RelHeight 1.0]; - Place.configure ffree [RelX liver; Y (Pixels 0); - RelWidth freer; RelHeight 1.0]; - Place.configure fdead [RelX (liver +. freer); Y (Pixels 0); - RelWidth (1.0 -. freer -. liver); RelHeight 1.0] - - in - let rec tim () = - if Winfo.exists top then begin - display(); - Timer.set (!delay * 1000) tim - end - in - tim() - - -let rec f () = - match !inited with - Some w -> Wm.deiconify w - | None -> init (); f() diff --git a/otherlibs/labltk/frx/frx_mem.mli b/otherlibs/labltk/frx/frx_mem.mli deleted file mode 100644 index f3069ec28b..0000000000 --- a/otherlibs/labltk/frx/frx_mem.mli +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -(* A Garbage Collector Gauge for Caml *) - -val init : unit -> unit - (* [init ()] creates the gauge and its updater, but keeps it iconified *) - -val f : unit -> unit - (* [f ()] makes the gauge visible if it has not been destroyed *) diff --git a/otherlibs/labltk/frx/frx_misc.ml b/otherlibs/labltk/frx/frx_misc.ml deleted file mode 100644 index d2be009224..0000000000 --- a/otherlibs/labltk/frx/frx_misc.ml +++ /dev/null @@ -1,69 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -(* Delayed global, a.k.a cache&carry *) -let autodef f = - let v = ref None in - (function () -> - match !v with - None -> - let x = f() in - v := Some x; - x - | Some x -> x) - -open Camltk - -(* allows Data in options *) -let create_photo options = - let hasopt = ref None in - (* Check options *) - List.iter (function - Data s -> - begin match !hasopt with - None -> hasopt := Some (Data s) - | Some _ -> raise (Protocol.TkError "two data sources in options") - end - | File f -> - begin match !hasopt with - None -> hasopt := Some (File f) - | Some _ -> raise (Protocol.TkError "two data sources in options") - end - | o -> ()) - options; - match !hasopt with - None -> raise (Protocol.TkError "no data source in options") - | Some (Data s) -> - begin - let tmpfile = Filename.temp_file "img" "" in - let oc = open_out_bin tmpfile in - output_string oc s; - close_out oc; - let newopts = - List.map (function - | Data s -> File tmpfile - | o -> o) - options in - try - let i = Imagephoto.create newopts in - (try Sys.remove tmpfile with Sys_error _ -> ()); - i - with - e -> - (try Sys.remove tmpfile with Sys_error _ -> ()); - raise e - end - | Some (File s) -> Imagephoto.create options - | _ -> assert false diff --git a/otherlibs/labltk/frx/frx_misc.mli b/otherlibs/labltk/frx/frx_misc.mli deleted file mode 100644 index 2df8ce3d20..0000000000 --- a/otherlibs/labltk/frx/frx_misc.mli +++ /dev/null @@ -1,21 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val autodef : (unit -> 'a) -> (unit -> 'a) - (* [autodef make] is a pleasant wrapper around 'a option ref *) - -val create_photo : Camltk.options list -> Camltk.imagePhoto - (* [create_photo options] allows Data in options (by saving to tmp file) *) diff --git a/otherlibs/labltk/frx/frx_req.ml b/otherlibs/labltk/frx/frx_req.ml deleted file mode 100644 index 029f4973b6..0000000000 --- a/otherlibs/labltk/frx/frx_req.ml +++ /dev/null @@ -1,198 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -(* - * Some standard requesters (in Amiga techspeak) or dialog boxes (in Apple - * jargon). -*) - -let version = "$Id$" - -(* - * Simple requester - * an entry field, unrestricted, with emacs-like bindings - * Note: grabs focus, thus always unique at one given moment, and we - * shouldn't have to worry about toplevel widget name. - * We add a title widget in case the window manager does not decorate - * toplevel windows. -*) - -let open_simple title action notaction memory = - let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in - Focus.set t; - Wm.title_set t title; - let tit = Label.create t [Text title] in - let len = max 40 (String.length (Textvariable.get memory)) in - let e = - Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in - - let activate _ = - let v = Entry.get e in - Grab.release t; (* because of wm *) - destroy t; (* so action can call open_simple *) - action v in - - bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); - - let f = Frame.create t [] in - let bok = Button.create f [Text "Ok"; Command activate] in - let bcancel = Button.create f - [Text "Cancel"; - Command (fun () -> notaction(); Grab.release t; destroy t)] in - - bind e [[], KeyPressDetail "Escape"] - (BindSet ([], (fun _ -> Button.invoke bcancel))); - pack [bok] [Side Side_Left; Expand true]; - pack [bcancel] [Side Side_Right; Expand true]; - pack [tit;e] [Fill Fill_X]; - pack [f] [Side Side_Bottom; Fill Fill_X]; - Frx_widget.resizeable t; - Focus.set e; - Tkwait.visibility t; - Grab.set t - -(* A synchronous version *) -let open_simple_synchronous title memory = - let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in - Focus.set t; - Wm.title_set t title; - let tit = Label.create t [Text title] in - let len = max 40 (String.length (Textvariable.get memory)) in - let e = - Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in - - let waiting = Textvariable.create_temporary t in - - let activate _ = - Grab.release t; (* because of wm *) - destroy t; (* so action can call open_simple *) - Textvariable.set waiting "1" in - - bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); - - let f = Frame.create t [] in - let bok = Button.create f [Text "Ok"; Command activate] in - let bcancel = - Button.create f - [Text "Cancel"; - Command (fun () -> - Grab.release t; destroy t; Textvariable.set waiting "0")] in - - bind e [[], KeyPressDetail "Escape"] - (BindSet ([], (fun _ -> Button.invoke bcancel))); - pack [bok] [Side Side_Left; Expand true]; - pack [bcancel] [Side Side_Right; Expand true]; - pack [tit;e] [Fill Fill_X]; - pack [f] [Side Side_Bottom; Fill Fill_X]; - Frx_widget.resizeable t; - Focus.set e; - Tkwait.visibility t; - Grab.set t; - Tkwait.variable waiting; - begin match Textvariable.get waiting with - "1" -> true - | _ -> false - end - -(* - * Simple list requester - * Same remarks as in open_simple. - * focus seems to be in the listbox automatically - *) -let open_list title elements action notaction = - let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in - Wm.title_set t title; - - let tit = Label.create t [Text title] in - let fls = Frame.create t [Relief Sunken; BorderWidth (Pixels 2)] in - let lb = Listbox.create fls [SelectMode Extended] in - let sb = Scrollbar.create fls [] in - Frx_listbox.scroll_link sb lb; - Listbox.insert lb End elements; - - (* activation: we have to break() because we destroy the requester *) - let activate _ = - let l = List.map (Listbox.get lb) (Listbox.curselection lb) in - Grab.release t; - destroy t; - List.iter action l; - break() in - - - bind lb [[Double], ButtonPressDetail 1] (BindSetBreakable ([], activate)); - - Frx_listbox.add_completion lb activate; - - let f = Frame.create t [] in - let bok = Button.create f [Text "Ok"; Command activate] in - let bcancel = Button.create f - [Text "Cancel"; - Command (fun () -> notaction(); Grab.release t; destroy t)] in - - pack [bok; bcancel] [Side Side_Left; Fill Fill_X; Expand true]; - pack [lb] [Side Side_Left; Fill Fill_Both; Expand true]; - pack [sb] [Side Side_Right; Fill Fill_Y]; - pack [tit] [Fill Fill_X]; - pack [fls] [Fill Fill_Both; Expand true]; - pack [f] [Side Side_Bottom; Fill Fill_X]; - Frx_widget.resizeable t; - Tkwait.visibility t; - Grab.set t - - -(* Synchronous *) -let open_passwd title = - let username = ref "" - and password = ref "" - and cancelled = ref false in - let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in - Focus.set t; - Wm.title_set t title; - let tit = Label.create t [Text title] - and fu,eu = Frx_entry.new_label_entry t "Username" (fun s -> ()) - and fp,ep = Frx_entry.new_label_entry t "Password" (fun s -> ()) - in - let fb = Frame.create t [] in - let bok = Button.create fb - [Text "Ok"; Command (fun _ -> - username := Entry.get eu; - password := Entry.get ep; - Grab.release t; (* because of wm *) - destroy t)] (* will return from tkwait *) - and bcancel = Button.create fb - [Text "Cancel"; Command (fun _ -> - cancelled := true; - Grab.release t; (* because of wm *) - destroy t)] (* will return from tkwait *) - in - Entry.configure ep [Show '*']; - bind eu [[], KeyPressDetail "Return"] - (BindSetBreakable ([], (fun _ -> Focus.set ep; break()))); - bind ep [[], KeyPressDetail "Return"] - (BindSetBreakable ([], (fun _ -> Button.flash bok; - Button.invoke bok; - break()))); - - pack [bok] [Side Side_Left; Expand true]; - pack [bcancel] [Side Side_Right; Expand true]; - pack [tit;fu;fp;fb] [Fill Fill_X]; - Tkwait.visibility t; - Focus.set eu; - Grab.set t; - Tkwait.window t; - if !cancelled then failwith "cancelled" - else (!username, !password) diff --git a/otherlibs/labltk/frx/frx_req.mli b/otherlibs/labltk/frx/frx_req.mli deleted file mode 100644 index 815b284596..0000000000 --- a/otherlibs/labltk/frx/frx_req.mli +++ /dev/null @@ -1,43 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -(* Various dialog boxes *) -val open_simple : - string -> - (string -> unit) -> (unit -> 'a) -> Textvariable.textVariable -> unit - (* [open_simple title action cancelled memory] - A dialog with a message and an entry field (with memory between - invocations). Either [action] or [cancelled] is called when the user - answers to the dialog (with Ok or Cancel) - *) - -val open_simple_synchronous : string -> Textvariable.textVariable -> bool - (* [open_simple_synchronous title memory] - A synchronous dialog with a message and an entry field (with - memory between invocations). Returns true if the user clicks Ok - or false if the user clicks Cancel. - *) -val open_list : - string -> string list -> (string -> unit) -> (unit -> unit) -> unit - (* [open_list title elements action cancelled] - A dialog for selecting from a list of elements. [action] is called - on each selected element, or [cancelled] is called if the user clicks - Cancel. - *) - -val open_passwd : string -> string * string - (* [open_passwd title] pops up a username/password dialog and returns - (username, password). - *) diff --git a/otherlibs/labltk/frx/frx_rpc.ml b/otherlibs/labltk/frx/frx_rpc.ml deleted file mode 100644 index 5f29cbce5d..0000000000 --- a/otherlibs/labltk/frx/frx_rpc.ml +++ /dev/null @@ -1,55 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -(* Some notion of RPC *) -open Camltk -open Protocol - -(* A RPC is just a callback with a particular name, plus a Tcl procedure *) -let register name f = - let id = new_function_id() in - Hashtbl.add callback_naming_table id f; - (* For rpc_info *) - Textvariable.set (Textvariable.coerce ("camltkrpc("^name^")")) - (string_of_cbid id); - tkCommand [| TkToken "proc"; TkToken name; TkToken "args"; - TkToken ("camlcb "^(string_of_cbid id)^" $args") |] - -(* RPC *) -let invoke interp f args = - tkEval [| - TkToken "send"; - TkToken interp; - TkToken f; - TkTokenList (List.map (fun s -> TkToken s) args) - |] - -let async_invoke interp f args = - tkCommand [| - TkToken "send"; - TkToken "-async"; - TkToken interp; - TkToken f; - TkTokenList (List.map (fun s -> TkToken s) args) - |] - -let rpc_info interp = - tkEval [| - TkToken "send"; - TkToken interp; - TkToken "array"; - TkToken "names"; - TkToken "camltkrpc" - |] diff --git a/otherlibs/labltk/frx/frx_rpc.mli b/otherlibs/labltk/frx/frx_rpc.mli deleted file mode 100644 index 808fe87c75..0000000000 --- a/otherlibs/labltk/frx/frx_rpc.mli +++ /dev/null @@ -1,25 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -(* Some notion of RPC *) - -val register : string -> (string list -> unit) -> unit - (* [register external_name f] *) -val invoke : string -> string -> string list -> string - (* [invoke interp name args] *) -val async_invoke : string -> string -> string list -> unit - (* [async_invoke interp name args] *) -val rpc_info : string -> string - (* [rpc_info interp] *) diff --git a/otherlibs/labltk/frx/frx_selection.ml b/otherlibs/labltk/frx/frx_selection.ml deleted file mode 100644 index 7ef64ce860..0000000000 --- a/otherlibs/labltk/frx/frx_selection.ml +++ /dev/null @@ -1,45 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -(* A selection handler *) -open Widget -open Protocol -open Camltk - -let frame = ref None -let selection = ref "" - -let read ofs n = - let res = - if ofs < 0 then "" - else if ofs + n > String.length !selection - then String.sub !selection ofs (String.length !selection - ofs) - else String.sub !selection ofs n in - tkreturn res - -(* As long as we don't loose the selection, we keep the widget *) -(* Calling this function means that we own the selection *) -(* When we loose the selection, both cb are destroyed *) -let own () = - match !frame with - None -> - let f = Frame.create_named Widget.default_toplevel "frx_selection" [] in - let lost () = selection := ""; destroy f; frame := None in - Selection.own_set [Selection "PRIMARY"; LostCommand lost] f; - Selection.handle_set [Selection "PRIMARY"; ICCCMType "STRING"] f read; - frame := Some f - | Some f -> () - -let set s = own(); selection := s diff --git a/otherlibs/labltk/frx/frx_selection.mli b/otherlibs/labltk/frx/frx_selection.mli deleted file mode 100644 index dfb27ee249..0000000000 --- a/otherlibs/labltk/frx/frx_selection.mli +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -val set : string -> unit - (* [set s] sets the X PRIMARY selection to [s] *) diff --git a/otherlibs/labltk/frx/frx_synth.ml b/otherlibs/labltk/frx/frx_synth.ml deleted file mode 100644 index d7acf06f7e..0000000000 --- a/otherlibs/labltk/frx/frx_synth.ml +++ /dev/null @@ -1,88 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -(* Some notion of synthetic events *) -open Camltk -open Widget -open Protocol - -(* To each event is associated a table of (widget, callback) *) -let events = Hashtbl.create 37 - -(* Notes: - * "cascading" events (on the same event) are not supported - * Only one binding active at a time for each event on each widget. - *) - -(* Get the callback table associated with <name>. Initializes if required *) -let get_event name = - try Hashtbl.find events name - with - Not_found -> - let h = Hashtbl.create 37 in - Hashtbl.add events name h; - (* Initialize the callback invocation mechanism, based on - variable trace - *) - let var = "camltk_events(" ^ name ^")" in - let tkvar = Textvariable.coerce var in - let rec set () = - Textvariable.handle tkvar - (fun () -> - begin match Textvariable.get tkvar with - "all" -> (* Invoke all callbacks *) - Hashtbl.iter - (fun p f -> - try - f (cTKtoCAMLwidget p) - with _ -> ()) - h - | p -> (* Invoke callback for p *) - try - let w = cTKtoCAMLwidget p - and f = Hashtbl.find h p in - f w - with - _ -> () - end; - set ()(* reactivate the callback *) - ) in - set(); - h - -(* Remove binding for event <name> on widget <w> *) -let remove w name = - Hashtbl.remove (get_event name) (Widget.name w) - -(* Adds <f> as callback for widget <w> on event <name> *) -let bind w name f = - remove w name; - Hashtbl.add (get_event name) (Widget.name w) f - -(* Sends event <name> to all widgets *) -let broadcast name = - Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) "all" - -(* Sends event <name> to widget <w> *) -let send name w = - Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) - (Widget.name w) - -(* Remove all callbacks associated to widget <w> *) -let remove_callbacks w = - Hashtbl.iter (fun _ h -> Hashtbl.remove h (Widget.name w)) events - -let _ = - add_destroy_hook remove_callbacks diff --git a/otherlibs/labltk/frx/frx_synth.mli b/otherlibs/labltk/frx/frx_synth.mli deleted file mode 100644 index 0b8d85d85e..0000000000 --- a/otherlibs/labltk/frx/frx_synth.mli +++ /dev/null @@ -1,31 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -(* Synthetic events *) -open Camltk -open Widget - - -val send : string -> widget -> unit - (* [send event_name widget] *) - -val broadcast : string -> unit - (* [broadcase event_name] *) - -val bind : widget -> string -> (widget -> unit) -> unit - (* [bind event_name callback] *) - -val remove : widget -> string -> unit - (* [remove widget event_name] *) diff --git a/otherlibs/labltk/frx/frx_text.ml b/otherlibs/labltk/frx/frx_text.ml deleted file mode 100644 index 7c1f551b15..0000000000 --- a/otherlibs/labltk/frx/frx_text.ml +++ /dev/null @@ -1,229 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let version = "$Id$" - -(* - * convert an integer to an absolute index -*) -let abs_index n = - TextIndex (LineChar(0,0), [CharOffset n]) - -let insertMark = - TextIndex(Mark "insert", []) - -let currentMark = - TextIndex(Mark "current", []) - -let textEnd = - TextIndex(End, []) - -let textBegin = - TextIndex (LineChar(0,0), []) - -(* - * Link a scrollbar and a text widget -*) -let scroll_link sb tx = - Text.configure tx [YScrollCommand (Scrollbar.set sb)]; - Scrollbar.configure sb [ScrollCommand (Text.yview tx)] - - -(* - * Tk 4.0 has navigation in Text widgets, sometimes using scrolling - * sometimes using the insertion mark. It is a pain to add more - * compatible bindings. We do our own. - *) -let page_up tx = Text.yview tx (ScrollPage (-1)) -and page_down tx = Text.yview tx (ScrollPage 1) -and line_up tx = Text.yview tx (ScrollUnit (-1)) -and line_down tx = Text.yview tx (ScrollUnit 1) -and top tx = Text.yview_index tx textBegin -and bottom tx = Text.yview_index tx textEnd - -let navigation_keys tx = - let tags = bindtags_get tx in - match tags with - (WidgetBindings t)::l when t = tx -> - bindtags tx ((WidgetBindings tx) :: (TagBindings "TEXT_RO") :: l) - | _ -> () - -let new_scrollable_text top options navigation = - let f = Frame.create top [] in - let tx = Text.create f options - and sb = Scrollbar.create f [] in - scroll_link sb tx; - (* IN THIS ORDER -- RESIZING *) - pack [sb] [Side Side_Right; Fill Fill_Y]; - pack [tx] [Side Side_Left; Fill Fill_Both; Expand true]; - if navigation then navigation_keys tx; - f, tx - -(* - * Searching - *) -let patternv = Frx_misc.autodef Textvariable.create -and casev = Frx_misc.autodef Textvariable.create - -let topsearch t = - (* The user interface *) - let top = Toplevel.create t [Class "TextSearch"] in - Wm.title_set top "Text search"; - let f = Frame.create_named top "fpattern" [] in - let m = Label.create_named f "search" [Text "Search pattern"] - and e = Entry.create_named f "pattern" - [Relief Sunken; TextVariable (patternv()) ] in - let hgroup = Frame.create top [] - and bgroup = Frame.create top [] in - let fdir = Frame.create hgroup [] - and fmisc = Frame.create hgroup [] in - let direction = Textvariable.create_temporary fdir - and exactv = Textvariable.create_temporary fdir - in - let forw = Radiobutton.create_named fdir "forward" - [Text "Forward"; Variable direction; Value "f"] - and backw = Radiobutton.create_named fdir "backward" - [Text "Backward"; Variable direction; Value "b"] - and exact = Checkbutton.create_named fmisc "exact" - [Text "Exact match"; Variable exactv] - and case = Checkbutton.create_named fmisc "case" - [Text "Fold Case"; Variable (casev())] - and searchb = Button.create_named bgroup "search" [Text "Search"] - and contb = Button.create_named bgroup "continue" [Text "Continue"] - and dismissb = Button.create_named bgroup "dismiss" - [Text "Dismiss"; - Command (fun () -> Text.tag_delete t ["search"]; destroy top)] in - - Radiobutton.invoke forw; - pack [m][Side Side_Left]; - pack [e][Side Side_Right; Fill Fill_X; Expand true]; - pack [forw; backw] [Anchor W]; - pack [exact; case] [Anchor W]; - pack [fdir; fmisc] [Side Side_Left; Anchor Center]; - pack [searchb; contb; dismissb] [Side Side_Left; Fill Fill_X]; - pack [f;hgroup;bgroup] [Fill Fill_X; Expand true]; - - let current_index = ref textBegin in - - let search cont = fun () -> - let opts = ref [] in - if Textvariable.get direction = "f" then - opts := Forwards :: !opts - else opts := Backwards :: !opts ; - if Textvariable.get exactv = "1" then - opts := Exact :: !opts; - if Textvariable.get (casev()) = "1" then - opts := Nocase :: !opts; - try - let forward = Textvariable.get direction = "f" in - let i = Text.search t !opts (Entry.get e) - (if cont then !current_index - else if forward then textBegin - else TextIndex(End, [CharOffset (-1)])) (* does not work with end *) - (if forward then textEnd - else textBegin) in - let found = TextIndex (i, []) in - current_index := - TextIndex(i, [CharOffset (if forward then 1 else (-1))]); - Text.tag_delete t ["search"]; - Text.tag_add t "search" found (TextIndex (i, [WordEnd])); - Text.tag_configure t "search" - [Relief Raised; BorderWidth (Pixels 1); - Background Red]; - Text.see t found - with - Invalid_argument _ -> Bell.ring() in - - bind e [[], KeyPressDetail "Return"] - (BindSet ([], fun _ -> search false ())); - Button.configure searchb [Command (search false)]; - Button.configure contb [Command (search true)]; - Tkwait.visibility top; - Focus.set e - -let addsearch tx = - let tags = bindtags_get tx in - match tags with - (WidgetBindings t)::l when t = tx -> - bindtags tx ((WidgetBindings tx) :: (TagBindings "SEARCH") :: l) - | _ -> () - -(* We use Mod1 instead of Meta or Alt *) -let init () = - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> page_up ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "BackSpace"]; - [[], KeyPressDetail "Delete"]; - [[], KeyPressDetail "Prior"]; - [[], KeyPressDetail "b"]; - [[Mod1], KeyPressDetail "v"] - ]; - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> page_down ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "space"]; - [[], KeyPressDetail "Next"]; - [[Control], KeyPressDetail "v"] - ]; - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> line_up ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "Up"]; - [[Mod1], KeyPressDetail "z"] - ]; - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> line_down ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "Down"]; - [[Control], KeyPressDetail "z"] - ]; - - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> top ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "Home"]; - [[Mod1], KeyPressDetail "less"] - ]; - - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> bottom ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "End"]; - [[Mod1], KeyPressDetail "greater"] - ]; - - List.iter (function ev -> - tag_bind "SEARCH" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> topsearch ei.ev_Widget; break())))) - [ - [[Control], KeyPressDetail "s"] - ] - diff --git a/otherlibs/labltk/frx/frx_text.mli b/otherlibs/labltk/frx/frx_text.mli deleted file mode 100644 index ac03844323..0000000000 --- a/otherlibs/labltk/frx/frx_text.mli +++ /dev/null @@ -1,46 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -val abs_index : int -> textIndex - (* [abs_index offs] returns the corresponding TextIndex *) - -val insertMark : textIndex -val currentMark : textIndex -val textEnd : textIndex -val textBegin : textIndex - (* shortcuts for various positions in a text widget *) - -val scroll_link : Widget.widget -> Widget.widget -> unit - (* [scroll_link scrollbar text] links a scrollbar and a text widget - as expected - *) - -val new_scrollable_text : - Widget.widget -> options list -> bool -> Widget.widget * Widget.widget - (* [new_scrollable_text parent opts nav_keys] makes a scrollable text - widget with optional navigation keys. Returns frame and text widget. - *) -val addsearch : Widget.widget -> unit - (* [addsearch textw] adds a search dialog bound on [Control-s] - on the text widget - *) - -val navigation_keys : Widget.widget -> unit - (* [navigation_keys textw] adds common navigations functions to [textw] *) - -val init : unit -> unit - (* [init ()] must be called before any of the above features is used *) diff --git a/otherlibs/labltk/frx/frx_toplevel.mli b/otherlibs/labltk/frx/frx_toplevel.mli deleted file mode 100644 index 3608e1e578..0000000000 --- a/otherlibs/labltk/frx/frx_toplevel.mli +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Widget -val make_visible : Widget -> unit diff --git a/otherlibs/labltk/frx/frx_widget.ml b/otherlibs/labltk/frx/frx_widget.ml deleted file mode 100644 index ab7d26112d..0000000000 --- a/otherlibs/labltk/frx/frx_widget.ml +++ /dev/null @@ -1,24 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget - -let version = "$Id$" -(* Make a window (toplevel widget) resizeable *) -let resizeable t = - update_idletasks(); (* wait until layout is computed *) - Wm.minsize_set t (Winfo.width t) (Winfo.height t) - diff --git a/otherlibs/labltk/frx/frx_widget.mli b/otherlibs/labltk/frx/frx_widget.mli deleted file mode 100644 index ff26749ca2..0000000000 --- a/otherlibs/labltk/frx/frx_widget.mli +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget -val resizeable : widget -> unit diff --git a/otherlibs/labltk/jpf/Makefile b/otherlibs/labltk/jpf/Makefile deleted file mode 100644 index 1c499356d5..0000000000 --- a/otherlibs/labltk/jpf/Makefile +++ /dev/null @@ -1,77 +0,0 @@ -include ../support/Makefile.common - -COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/unix -I $(OTHERS)/str - -OBJS= fileselect.cmo balloon.cmo shell.cmo jpf_font.cmo - -OBJSX = $(OBJS:.cmo=.cmx) - -all: jpflib.cma - -opt: jpflib.cmxa - -test: balloontest - -testopt: balloontest.opt - -jpflib.cma: $(OBJS) - $(CAMLLIBR) -o jpflib.cma $(OBJS) - -jpflib.cmxa: $(OBJSX) - $(CAMLOPTLIBR) -o jpflib.cmxa $(OBJSX) - -install: jpflib.cma - cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) jpflib.cma $(INSTALLDIR) - -installopt: jpflib.cmxa - cp jpflib.cmxa jpflib.a $(OBJS:.cmo=.cmx) $(INSTALLDIR) - -clean: - rm -f *.cm* *.o *.a *~ *test - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJSX): ../lib/$(LIBNAME).cmxa - -### Tests - -balloontest: balloontest.cmo - $(CAMLC) -o balloontest -I ../support -I ../lib \ - -custom $(LIBNAME).cma jpflib.cma balloontest.cmo - -balloontest.opt: balloontest.cmx - $(CAMLOPT) -o balloontest.opt -I ../support -I ../lib \ - $(LIBNAME).cmxa jpflib.cmxa balloontest.cmx - -balloontest.cmo : balloon.cmo jpflib.cma - -balloontest.cmx : balloon.cmx jpflib.cmxa - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: - mv Makefile Makefile.bak - (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \ - $(CAMLDEP) *.mli *.ml) > Makefile - - -### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED -### DO NOT DELETE THIS LINE -balloon.cmo: balloon.cmi -balloon.cmx: balloon.cmi -fileselect.cmo: fileselect.cmi -fileselect.cmx: fileselect.cmi -jpf_font.cmo: shell.cmi jpf_font.cmi -jpf_font.cmx: shell.cmx jpf_font.cmi -shell.cmo: shell.cmi -shell.cmx: shell.cmi diff --git a/otherlibs/labltk/jpf/Makefile.nt b/otherlibs/labltk/jpf/Makefile.nt deleted file mode 100644 index 7501a01d4b..0000000000 --- a/otherlibs/labltk/jpf/Makefile.nt +++ /dev/null @@ -1,75 +0,0 @@ -include ../support/Makefile.common.nt - -COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/str - -OBJS= fileselect.cmo balloon.cmo - -OBJSX = $(OBJS:.cmo=.cmx) - -all: libjpf.cma - -opt: libjpf.cmxa - -test: balloontest - -testopt: balloontest.opt - -libjpf.cma: $(OBJS) - $(CAMLLIBR) -o libjpf.cma $(OBJS) - -libjpf.cmxa: $(OBJSX) - $(CAMLOPTLIBR) -o libjpf.cmxa $(OBJSX) - -install: libjpf.cma - cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) libjpf.cma $(INSTALLDIR) - -installopt: libjpf.cmxa - cp libjpf.cmxa libjpf.$(A) $(INSTALLDIR) - -clean: - rm -f *.cm* *.$(O) *.$(A) *~ *test - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJSX): ../lib/$(LIBNAME).cmxa - -### Tests - -balloontest: balloontest.cmo - $(CAMLC) -o balloontest -I ../support -I ../labltk -I ../lib \ - -custom $(LIBNAME).cma libjpf.cma balloontest.cmo $(TKLINKOPT) - -balloontest.opt: balloontest.cmx - $(CAMLOPT) -o balloontest.opt -I ../support -I ../labltk -I ../lib \ - $(LIBNAME).cmxa libjpf.cmxa balloontest.cmx $(TKLINKOPT) - -balloontest.cmo : balloon.cmo libjpf.cma - -balloontest.cmx : balloon.cmx libjpf.cmxa - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: - mv Makefile Makefile.bak - (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \ - $(CAMLDEP) *.mli *.ml) > Makefile - - -### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED -### DO NOT DELETE THIS LINE -balloon.cmo: balloon.cmi -balloon.cmx: balloon.cmi -balloontest.cmo: balloon.cmi -balloontest.cmx: balloon.cmx -fileselect.cmo: fileselect.cmi -fileselect.cmx: fileselect.cmi diff --git a/otherlibs/labltk/jpf/README b/otherlibs/labltk/jpf/README deleted file mode 100644 index 275c2d7803..0000000000 --- a/otherlibs/labltk/jpf/README +++ /dev/null @@ -1,2 +0,0 @@ -This is Jun Furuse's widget set library, Jpf. -It uses LablTk API. diff --git a/otherlibs/labltk/jpf/balloon.ml b/otherlibs/labltk/jpf/balloon.ml deleted file mode 100644 index 6b2f36d209..0000000000 --- a/otherlibs/labltk/jpf/balloon.ml +++ /dev/null @@ -1,102 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $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 -let debug = ref false - -(* We assume we have at most one popup label at a time *) -let topw = ref default_toplevel -and popupw = ref (Obj.magic dummy : message widget) - -let configure_cursor w cursor = - (* DDDDDDDDDIIIIIIIRRRRRRRRTTTTTTTTYYYYYYY *) - Protocol.tkCommand [| TkToken (name w); - TkToken "configure"; - TkToken "-cursor"; - TkToken cursor |] - -let put ~on: w ~ms: millisec mesg = - let t = ref None in - let cursor = ref "" in - - let reset () = - begin - match !t with - Some t -> Timer.remove t - | _ -> () - end; - (* if there is a popup label, unmap it *) - if Winfo.exists !topw && Wm.state !topw <> "withdrawn" then - begin - Wm.withdraw !topw; - if Winfo.exists w then configure_cursor w !cursor - end - and set ev = - if !flag then - t := Some (Timer.add ~ms: millisec ~callback: (fun () -> - t := None; - if !debug then - prerr_endline ("Balloon: " ^ Widget.name w); - update_idletasks(); - Message.configure !popupw ~text: mesg; - raise_window !topw; - Wm.geometry_set !topw (* 9 & 8 are some kind of magic... *) - ("+"^(string_of_int (ev.ev_RootX + 9))^ - "+"^(string_of_int (ev.ev_RootY + 8))); - Wm.deiconify !topw; - cursor := cget w `Cursor; - configure_cursor w "hand2")) - in - - List.iter [[`Leave]; [`ButtonPress]; [`ButtonRelease]; [`Destroy]; - [`KeyPress]; [`KeyRelease]] - ~f:(fun events -> bind w ~events ~extend:true ~action:(fun _ -> reset ())); - List.iter [[`Enter]; [`Motion]] ~f: - begin fun events -> - bind w ~events ~extend:true ~fields:[`RootX; `RootY] - ~action:(fun ev -> reset (); set ev) - end - -let init () = - let t = Hashtbl.create 101 in - Protocol.add_destroy_hook (fun w -> - Hashtbl.remove t w); - topw := Toplevel.create default_toplevel; - Wm.overrideredirect_set !topw true; - Wm.withdraw !topw; - popupw := Message.create !topw ~name: "balloon" - ~background: (`Color "yellow") ~aspect: 300; - pack [!popupw]; - bind_class "all" ~events: [`Enter] ~extend:true ~fields:[`Widget] ~action: - begin fun w -> - try Hashtbl.find t w.ev_Widget - with Not_found -> - Hashtbl.add t w.ev_Widget (); - 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/balloon.mli b/otherlibs/labltk/jpf/balloon.mli deleted file mode 100644 index 633796ce6b..0000000000 --- a/otherlibs/labltk/jpf/balloon.mli +++ /dev/null @@ -1,24 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* easy balloon help facility *) -open Widget - -val flag : bool ref -val init : unit -> unit -val put : on: 'a widget -> ms: int -> string -> unit diff --git a/otherlibs/labltk/jpf/balloontest.ml b/otherlibs/labltk/jpf/balloontest.ml deleted file mode 100644 index 36e6c8dbf1..0000000000 --- a/otherlibs/labltk/jpf/balloontest.ml +++ /dev/null @@ -1,32 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Tk -open Widget -open Balloon -open Protocol - -let _ = - let t = openTk () in - Balloon.init (); - let b = Button.create t ~text: "hello" in - Button.configure b ~command: (fun () -> destroy b); - pack [b]; - Balloon.put ~on: b ~ms: 1000 "Balloon"; - Printexc.catch mainLoop () - diff --git a/otherlibs/labltk/jpf/fileselect.ml b/otherlibs/labltk/jpf/fileselect.ml deleted file mode 100644 index ec0e7749f1..0000000000 --- a/otherlibs/labltk/jpf/fileselect.ml +++ /dev/null @@ -1,368 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* file selection box *) - -(* This file selecter works only under the OS with the full unix support. - For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *) - -open StdLabels -open UnixLabels -open Str -open Filename - -open Tk -open Widget - -exception Not_selected - -(********************************************************** Search directory *) -(* Default is curdir *) -let global_dir = ref (getcwd ()) - -(***************************************************** Some widgets creation *) - -(* from frx_listbox.ml *) -let scroll_link sb lb = - Listbox.configure lb ~yscrollcommand: (Scrollbar.set sb); - Scrollbar.configure sb ~command: (Listbox.yview lb) - -(* focus when enter binding *) -let bind_enter_focus w = - bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w);; - -let myentry_create p ~variable = - let w = Entry.create p ~relief: `Sunken ~textvariable: variable in - bind_enter_focus w; w - -(************************************************************* Subshell call *) - -let subshell cmd = - let r,w = pipe () in - match fork () with - 0 -> close r; dup2 ~src:w ~dst:stdout; - execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |]; - exit 127 - | id -> - close w; - let rc = in_channel_of_descr r in - let rec it l = - match - try Some(input_line rc) with _ -> None - with - Some x -> it (x::l) - | None -> List.rev l - in - let answer = it [] in - close_in rc; (* because of finalize_channel *) - let p, st = waitpid ~mode:[] id in answer - -(***************************************************************** Path name *) - -(* find directory name which doesn't contain "?*[" *) -let dirget = regexp "^\\([^\\*?[]*/\\)\\(.*\\)" - -let parse_filter src = - (* replace // by / *) - let s = global_replace (regexp "/+") "/" src in - (* replace /./ by / *) - let s = global_replace (regexp "/\\./") "/" s in - (* replace ????/../ by "" *) - let s = global_replace - (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./") - "" - s in - (* replace ????/..$ by "" *) - let s = global_replace - (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$") - "" - s in - (* replace ^/../../ by / *) - 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 - dirs, ptrn - else "", s - -let ls dir pattern = - subshell ("cd " ^ dir ^ ";/bin/ls -ad " ^ pattern ^" 2>/dev/null") - -(*************************************************************** File System *) - -let get_files_in_directory dir = - let dirh = opendir dir in - let rec get_them l = - match - try Some(Unix.readdir dirh) with _ -> None - with - | None -> - Unix.closedir dirh; l - | Some x -> - get_them (x::l) - in - List.sort ~cmp:compare (get_them []) - -let rec get_directories_in_files path = - List.filter - ~f:(fun x -> try (stat (path ^ x)).st_kind = S_DIR with _ -> false) - -let remove_directories path = - List.filter - ~f:(fun x -> try (stat (path ^ x)).st_kind <> S_DIR with _ -> false) - -(************************* a nice interface to listbox - from frx_listbox.ml *) - -let add_completion lb action = - let prefx = ref "" (* current match prefix *) - and maxi = ref 0 (* maximum index (doesn'y matter actually) *) - and current = ref 0 (* current position *) - and lastevent = ref 0 in - - let rec move_forward () = - if Listbox.get lb ~index:(`Num !current) < !prefx then - if !current < !maxi then begin incr current; move_forward() end - - and recenter () = - let element = `Num !current in - (* Clean the selection *) - Listbox.selection_clear lb ~first:(`Num 0) ~last:`End; - (* Set it to our unique element *) - Listbox.selection_set lb ~first:element ~last:element; - (* Activate it, to keep consistent with Up/Down. - You have to be in Extended or Browse mode *) - Listbox.activate lb ~index:element; - Listbox.selection_anchor lb ~index:element; - Listbox.see lb ~index:element in - - let complete time s = - if time - !lastevent < 500 then (* sorry, hard coded limit *) - prefx := !prefx ^ s - else begin (* reset *) - current := 0; - prefx := s - end; - lastevent := time; - move_forward(); - recenter() in - - - bind lb ~events:[`KeyPress] ~fields:[`Char; `Time] - (* consider only keys producing characters. The callback is called - if you press Shift. *) - ~action:(fun ev -> if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char); - (* Key specific bindings override KeyPress *) - bind lb ~events:[`KeyPressDetail "Return"] ~action; - (* Finally, we have to set focus, otherwise events dont get through *) - Focus.set lb; - recenter() (* so that first item is selected *); - (* returns init_completion function *) - (fun lb -> - prefx := ""; - maxi := Listbox.size lb - 1; - current := 0) - -(****************************************************************** Creation *) - -let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync = - (* Ah ! Now I regret about the names of the widgets... *) - - let current_pattern = ref "" - and current_dir = ref "" in - - (* init_completions *) - let filter_init_completion = ref (fun _ -> ()) - and directory_init_completion = ref (fun _ -> ()) in - - let tl = Toplevel.create default_toplevel in - Focus.set tl; - Wm.title_set tl title; - - let filter_var = Textvariable.create ~on:tl () (* new_temporary *) - and selection_var = Textvariable.create ~on:tl () - and sync_var = Textvariable.create ~on:tl () in - - let frm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in - let frm = Frame.create frm' ~borderwidth: 8 in - let fl = Label.create frm ~text: "Filter" in - let df = Frame.create frm in - let dfl = Frame.create df in - let dfll = Label.create dfl ~text: "Directories" in - let dflf = Frame.create dfl in - let directory_listbox = Listbox.create dflf ~relief: `Sunken - and directory_scrollbar = Scrollbar.create dflf in - scroll_link directory_scrollbar directory_listbox; - let dfr = Frame.create df in - let dfrl = Label.create dfr ~text: "Files" in - let dfrf = Frame.create dfr in - let filter_listbox = Listbox.create dfrf ~relief: `Sunken in - let filter_scrollbar = Scrollbar.create dfrf in - scroll_link filter_scrollbar filter_listbox; - let sl = Label.create frm ~text: "Selection" in - let filter_entry = myentry_create frm ~variable: filter_var in - let selection_entry = myentry_create frm ~variable: selection_var - in - let cfrm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in - let cfrm = Frame.create cfrm' ~borderwidth: 8 in - let dumf = Frame.create cfrm in - let dumf2 = Frame.create cfrm in - - let configure filter = - (* OLDER let curdir = getcwd () in *) -(* Printf.eprintf "CURDIR %s\n" curdir; *) - let filter = - if string_match (regexp "^/.*") filter 0 then filter - else - if filter = "" then !global_dir ^ "/*" - else !global_dir ^ "/" ^ filter in -(* Printf.eprintf "FILTER %s\n" filter; *) - let dirname, patternname = parse_filter filter in -(* Printf.eprintf "DIRNAME %s PATTERNNAME %s\n" dirname patternname; *) - current_dir := dirname; - global_dir := dirname; - let patternname = if patternname = "" then "*" else patternname in - current_pattern := patternname; - let filter = dirname ^ patternname in -(* Printf.eprintf "FILTER : %s\n\n" filter; *) -(* flush Pervasives.stderr; *) - try - let directories = get_directories_in_files dirname - (get_files_in_directory dirname) in - (* get matched file by subshell call. *) - let matched_files = remove_directories dirname (ls dirname patternname) - in - Textvariable.set filter_var filter; - Textvariable.set selection_var (dirname ^ deffile); - Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End; - Listbox.insert directory_listbox ~index:`End ~texts:directories; - Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End; - Listbox.insert filter_listbox ~index:`End ~texts:matched_files; - !directory_init_completion directory_listbox; - !filter_init_completion filter_listbox - with - Unix_error (ENOENT,_,_) -> - (* Directory is not found (maybe) *) - Bell.ring () - in - - let selected_files = ref [] in (* used for synchronous mode *) - let activate l () = - Grab.release tl; - destroy tl; - if sync then - begin - selected_files := l; - Textvariable.set sync_var "1" - end - else - begin - proc l; - break () - end - in - - (* and buttons *) - let okb = Button.create cfrm ~text: "OK" ~command: - begin fun () -> - let files = - List.map (Listbox.curselection filter_listbox) - ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x)) - in - let files = if files = [] then [Textvariable.get selection_var] - else files in - activate files () - end - in - let flb = Button.create cfrm ~text: "Filter" - ~command: (fun () -> configure (Textvariable.get filter_var)) in - let ccb = Button.create cfrm ~text: "Cancel" - ~command: (fun () -> activate [] ()) in - - (* binding *) - bind selection_entry ~events:[`KeyPressDetail "Return"] ~breakable:true - ~action:(fun _ -> activate [Textvariable.get selection_var] ()); - bind filter_entry ~events:[`KeyPressDetail "Return"] - ~action:(fun _ -> configure (Textvariable.get filter_var)); - - let action _ = - let files = - List.map (Listbox.curselection filter_listbox) - ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x)) - in - activate files () - in - bind filter_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~breakable:true ~action; - if multi then Listbox.configure filter_listbox ~selectmode: `Multiple; - filter_init_completion := add_completion filter_listbox action; - - let action _ = - try - configure (!current_dir ^ ((function - [x] -> Listbox.get directory_listbox ~index:x - | _ -> (* you must choose at least one directory. *) - Bell.ring (); raise Not_selected) - (Listbox.curselection directory_listbox)) ^ "/" ^ !current_pattern) - with _ -> () in - bind directory_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~breakable:true ~action; - Listbox.configure directory_listbox ~selectmode: `Browse; - directory_init_completion := add_completion directory_listbox action; - - pack [frm'; frm] ~fill: `X; - (* filter *) - pack [fl] ~side: `Top ~anchor: `W; - pack [filter_entry] ~side: `Top ~fill: `X; - (* directory + files *) - pack [df] ~side: `Top ~fill: `X ~ipadx: 8; - (* directory *) - pack [dfl] ~side: `Left; - pack [dfll] ~side: `Top ~anchor: `W; - pack [dflf] ~side: `Top; - pack [coe directory_listbox; coe directory_scrollbar] - ~side: `Left ~fill: `Y; - (* files *) - pack [dfr] ~side: `Right; - pack [dfrl] ~side: `Top ~anchor: `W; - pack [dfrf] ~side: `Top; - pack [coe filter_listbox; coe filter_scrollbar] ~side: `Left ~fill: `Y; - (* selection *) - pack [sl] ~side: `Top ~anchor: `W; - pack [selection_entry] ~side: `Top ~fill: `X; - - (* create OK, Filter and Cancel buttons *) - pack [cfrm'] ~fill: `X; - pack [cfrm] ~fill: `X; - pack [okb] ~side: `Left; - pack [dumf] ~side: `Left ~expand: true; - pack [flb] ~side: `Left; - pack [dumf2] ~side: `Left ~expand: true; - pack [ccb] ~side: `Left; - - configure deffilter; - - Tkwait.visibility tl; - Grab.set tl; - - if sync then - begin - Tkwait.variable sync_var; - proc !selected_files - end; - () diff --git a/otherlibs/labltk/jpf/fileselect.mli b/otherlibs/labltk/jpf/fileselect.mli deleted file mode 100644 index 79dc828f94..0000000000 --- a/otherlibs/labltk/jpf/fileselect.mli +++ /dev/null @@ -1,37 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* This file selecter works only under the OS with the full unix support. - For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *) - -open Support - -val f : - title:string -> - action:(string list -> unit) -> - filter:string -> file:string -> multi:bool -> sync:bool -> unit - -(* action - [] means canceled - if multi select is false, then the list is null or a singleton *) - -(* multi select - if true then more than one file are selectable *) - -(* sync it - if true then in synchronous mode *) diff --git a/otherlibs/labltk/jpf/jpf_font.ml b/otherlibs/labltk/jpf/jpf_font.ml deleted file mode 100644 index c9c3d05267..0000000000 --- a/otherlibs/labltk/jpf/jpf_font.ml +++ /dev/null @@ -1,218 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -(* find font information *) - -let debug = ref false -let log s = - if !debug then try prerr_endline s with _ -> () - -type ('s, 'i) xlfd = { - (* some of them are currently not interesting for me *) - mutable foundry: 's; - mutable family: 's; - mutable weight: 's; - mutable slant: 's; - mutable setWidth: 's; - mutable addStyle: 's; - mutable pixelSize: 'i; - mutable pointSize: 'i; - mutable resolutionX: 'i; - mutable resolutionY: 'i; - mutable spacing: 's; - mutable averageWidth: 'i; - mutable registry: 's; - mutable encoding: 's - } - -let copy xlfd = {xlfd with foundry= xlfd.foundry} - -let string_of_xlfd s i xlfd = - let foundry= s xlfd.foundry - and family= s xlfd.family - and weight= s xlfd.weight - and slant= s xlfd.slant - and setWidth = s xlfd.setWidth - and addStyle = s xlfd.addStyle - and pixelSize= i xlfd.pixelSize - and pointSize = i xlfd.pointSize - and resolutionX = i xlfd.resolutionX - and resolutionY = i xlfd.resolutionY - and spacing= s xlfd.spacing - and averageWidth = i xlfd.averageWidth - and registry= s xlfd.registry - and encoding = s xlfd.encoding in - - "-"^foundry^ - "-"^family^ - "-"^weight^ - "-"^slant^ - "-"^setWidth ^ - "-"^addStyle ^ - "-"^pixelSize^ - "-"^pointSize ^ - "-"^resolutionX ^ - "-"^resolutionY ^ - "-"^spacing^ - "-"^averageWidth ^ - "-"^registry^ - "-"^encoding - -exception Parse_Xlfd_Failure of string - -let parse_xlfd xlfd_string = - (* this must not be a pattern *) - let split_str char_sep str = - let len = String.length str in - let rec split beg cur = - if cur >= len then [String.sub str beg (len - beg)] - else if char_sep (String.get str cur) - then - let nextw = succ cur in - (String.sub str beg (cur - beg)) - ::(split nextw nextw) - else split beg (succ cur) in - split 0 0 - in - match split_str (function '-' -> true | _ -> false) xlfd_string with - | [ _; foundry; family; weight; slant; setWidth; addStyle; pixelSize; - pointSize; resolutionX; resolutionY; spacing; averageWidth; - registry; encoding ] -> - { foundry= foundry; - family= family; - weight= weight; - slant= slant; - setWidth= setWidth; - addStyle= addStyle; - pixelSize= int_of_string pixelSize; - pointSize= int_of_string pointSize; - resolutionX= int_of_string resolutionX; - resolutionY= int_of_string resolutionY; - spacing= spacing; - averageWidth= int_of_string averageWidth; - registry= registry; - encoding= encoding; - } - | _ -> raise (Parse_Xlfd_Failure xlfd_string) - -type valid_xlfd = (string, int) xlfd - -let string_of_valid_xlfd = string_of_xlfd (fun x -> x) string_of_int - -type pattern = (string option, int option) xlfd - -let empty_pattern = - { foundry= None; - family= None; - weight= None; - slant= None; - setWidth= None; - addStyle= None; - pixelSize= None; - pointSize= None; - resolutionX= None; - resolutionY= None; - spacing= None; - averageWidth= None; - registry= None; - encoding= None; - } - -let string_of_pattern = - let pat f = function - Some x -> f x - | None -> "*" - in - let pat_string = pat (fun x -> x) in - let pat_int = pat string_of_int in - string_of_xlfd pat_string pat_int - -let is_vector_font xlfd = - (xlfd.pixelSize = 0 && xlfd.resolutionX = 0 && xlfd.resolutionY = 0) || - xlfd.spacing <> "c" - -let list_fonts dispname pattern = - let dispopt = match dispname with - None -> "" - | Some x -> "-display " ^ x - in - let result = List.map parse_xlfd - (Shell.subshell ("xlsfonts "^dispopt^" -fn "^string_of_pattern pattern)) - in - if result = [] then raise Not_found - else result - -let available_pixel_size_aux dispname pattern = - (* return available pixel size without font resizing *) - (* to obtain good result, *) - (* the pattern should contain as many information as possible *) - let pattern = copy pattern in - pattern.pixelSize <- None; - let xlfds = list_fonts dispname pattern in - let pxszs = Hashtbl.create 107 in - List.iter (fun xlfd -> - Hashtbl.add pxszs xlfd.pixelSize xlfd) xlfds; - pxszs - -let extract_size_font_hash tbl = - let keys = ref [] in - Hashtbl.iter (fun k _ -> - if not (List.mem k !keys) then keys := k :: !keys) tbl; - Sort.list (fun (k1,_) (k2,_) -> k1 < k2) - (List.map (fun k -> k, Hashtbl.find_all tbl k) !keys) - -let available_pixel_size dispname pattern = - let pxszs = available_pixel_size_aux dispname pattern in - extract_size_font_hash pxszs - -let nearest_pixel_size dispname vector_ok pattern = - (* find the font with the nearest pixel size *) - log ("\n*** "^string_of_pattern pattern); - let pxlsz = - match pattern.pixelSize with - None -> raise (Failure "invalid pixelSize pattern") - | Some x -> x - in - let tbl = available_pixel_size_aux dispname pattern in - let newtbl = Hashtbl.create 107 in - Hashtbl.iter (fun s xlfd -> - if vector_ok then - if s = 0 then begin - if is_vector_font xlfd then begin - log (Printf.sprintf "%s is vector" (string_of_valid_xlfd xlfd)); - xlfd.pixelSize <- pxlsz; - Hashtbl.add newtbl pxlsz xlfd - end - end else Hashtbl.add newtbl s xlfd - else if not (is_vector_font xlfd) && s <> 0 then - Hashtbl.add newtbl s xlfd) tbl; - - let size_font_table = extract_size_font_hash newtbl in - - let diff = ref 10000 in - let min = ref None in - List.iter (fun (s,xlfds) -> - let d = abs(s - pxlsz) in - if d < !diff then begin - min := Some (s,xlfds); - diff := d - end) size_font_table; - (* if it contains more than one font, just return the first *) - match !min with - | None -> raise Not_found - | Some(s, xlfds) -> - log (Printf.sprintf "Size %d is selected" s); - List.iter (fun xlfd -> log (string_of_valid_xlfd xlfd)) xlfds; - List.hd xlfds diff --git a/otherlibs/labltk/jpf/jpf_font.mli b/otherlibs/labltk/jpf/jpf_font.mli deleted file mode 100644 index cd1e212297..0000000000 --- a/otherlibs/labltk/jpf/jpf_font.mli +++ /dev/null @@ -1,54 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -val debug : bool ref - -type ('a, 'b) xlfd = - { mutable foundry: 'a; - mutable family: 'a; - mutable weight: 'a; - mutable slant: 'a; - mutable setWidth: 'a; - mutable addStyle: 'a; - mutable pixelSize: 'b; - mutable pointSize: 'b; - mutable resolutionX: 'b; - mutable resolutionY: 'b; - mutable spacing: 'a; - mutable averageWidth: 'b; - mutable registry: 'a; - mutable encoding: 'a } - -exception Parse_Xlfd_Failure of string - -type valid_xlfd = (string, int) xlfd -type pattern = (string option, int option) xlfd - -val empty_pattern : pattern - -val copy : ('a, 'b) xlfd -> ('a, 'b) xlfd - -val string_of_valid_xlfd : valid_xlfd -> string -val string_of_pattern : pattern -> string - -val is_vector_font : valid_xlfd -> bool - -val list_fonts : string option -> pattern -> valid_xlfd list - -val available_pixel_size : - string option -> pattern -> (int * valid_xlfd list) list - -val nearest_pixel_size : - string option -> bool -> pattern -> valid_xlfd diff --git a/otherlibs/labltk/jpf/shell.ml b/otherlibs/labltk/jpf/shell.ml deleted file mode 100644 index 485a0d8741..0000000000 --- a/otherlibs/labltk/jpf/shell.ml +++ /dev/null @@ -1,36 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Unix - -(************************************************************* Subshell call *) - -let subshell cmd = - let r,w = pipe () in - match fork () with - 0 -> close r; dup2 w stdout; - close stderr; - execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; exit 127 - | id -> - close w; - let rc = in_channel_of_descr r in - let rec it () = try - let x = input_line rc in x:: it () - with _ -> [] - in - let answer = it() in - close_in rc; (* because of finalize_channel *) - let p, st = waitpid [] id in answer - diff --git a/otherlibs/labltk/jpf/shell.mli b/otherlibs/labltk/jpf/shell.mli deleted file mode 100644 index be93f5f1a9..0000000000 --- a/otherlibs/labltk/jpf/shell.mli +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -val subshell : string -> string list - diff --git a/otherlibs/labltk/labl.gif b/otherlibs/labltk/labl.gif Binary files differdeleted file mode 100644 index d0a29fab1d..0000000000 --- a/otherlibs/labltk/labl.gif +++ /dev/null diff --git a/otherlibs/labltk/labltk/.cvsignore b/otherlibs/labltk/labltk/.cvsignore deleted file mode 100644 index 585067641e..0000000000 --- a/otherlibs/labltk/labltk/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.ml *.mli labltktop labltk -modules -.depend diff --git a/otherlibs/labltk/labltk/Makefile b/otherlibs/labltk/labltk/Makefile deleted file mode 100644 index 53276dd164..0000000000 --- a/otherlibs/labltk/labltk/Makefile +++ /dev/null @@ -1,43 +0,0 @@ -include ../support/Makefile.common - -COMPFLAGS= -I ../support - -all: labltkobjs - -opt: labltkobjsx - -include ./modules - -LABLTKOBJS = $(WIDGETOBJS) tk.cmo labltk.cmo -LABLTKOBJSX = $(LABLTKOBJS:.cmo=.cmx) - -labltkobjs: $(LABLTKOBJS) - -labltkobjsx: $(LABLTKOBJSX) - -install: $(LABLTKOBJS) - if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(LABLTKOBJS:.cmo=.cmi) $(WIDGETOBJS:.cmo=.mli) $(INSTALLDIR) - chmod 644 $(INSTALLDIR)/*.cmi - -installopt: $(LABLTKOBJSX) - @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(LABLTKOBJSX) $(INSTALLDIR) - chmod 644 $(INSTALLDIR)/*.cmx - -clean: - $(MAKE) -f Makefile.gen clean - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -include .depend diff --git a/otherlibs/labltk/labltk/Makefile.gen b/otherlibs/labltk/labltk/Makefile.gen deleted file mode 100644 index a7f85082ed..0000000000 --- a/otherlibs/labltk/labltk/Makefile.gen +++ /dev/null @@ -1,45 +0,0 @@ -include ../support/Makefile.common - -all: tk.ml labltk.ml .depend - -_tkgen.ml: ../Widgets.src ../compiler/tkcompiler - cd ..; ../../boot/ocamlrun compiler/tkcompiler -outdir labltk - -# dependencies are broken: wouldn't work with gmake 3.77 - -tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../builtin/builtin_*.ml - (echo 'open StdLabels'; \ - echo 'open Widget'; \ - echo 'open Protocol'; \ - echo 'open Support'; \ - echo 'open Textvariable'; \ - cat ../builtin/report.ml; \ - cat ../builtin/builtin_*.ml; \ - cat _tkgen.ml; \ - echo ; \ - echo ; \ - echo 'module Tkintf = struct'; \ - cat ../builtin/builtini_*.ml; \ - cat _tkigen.ml; \ - echo 'end (* module Tkintf *)'; \ - echo ; \ - echo ; \ - echo 'open Tkintf' ;\ - echo ; \ - echo ; \ - cat ../builtin/builtinf_*.ml; \ - cat _tkfgen.ml; \ - echo ; \ - ) > _tk.ml - ../../../boot/ocamlrun ../compiler/pp < _tk.ml > tk.ml - rm -f _tk.ml - $(CAMLDEP) -I ../support [a-z]*.mli [a-z]*.ml > .depend - -../compiler/pp: - cd ../compiler; $(MAKE) pp - -# All .{ml,mli} files are generated in this directory -clean: - rm -f *.cm* *.ml *.mli *.o *.a .depend - -# rm -f modules diff --git a/otherlibs/labltk/labltk/Makefile.gen.nt b/otherlibs/labltk/labltk/Makefile.gen.nt deleted file mode 100644 index 8bac832b9e..0000000000 --- a/otherlibs/labltk/labltk/Makefile.gen.nt +++ /dev/null @@ -1,40 +0,0 @@ -include ../support/Makefile.common.nt - -all: tk.ml labltk.ml .depend - -_tkgen.ml: ../Widgets.src ../compiler/tkcompiler.exe - cd .. ; ../../boot/ocamlrun compiler/tkcompiler.exe -outdir labltk - -# dependencies are broken: wouldn't work with gmake 3.77 - -tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp.exe #../builtin/builtin_*.ml - (echo 'open StdLabels'; \ - echo 'open Widget'; \ - echo 'open Protocol'; \ - echo 'open Support'; \ - echo 'open Textvariable'; \ - cat ../builtin/report.ml; \ - cat ../builtin/builtin_*.ml; \ - cat _tkgen.ml; \ - echo ; \ - echo ; \ - echo 'module Tkintf = struct'; \ - cat ../builtin/builtini_*.ml; \ - cat _tkigen.ml; \ - echo 'end (* module Tkintf *)'; \ - echo ; \ - echo ; \ - echo 'open Tkintf' ;\ - echo ; \ - echo ; \ - cat ../builtin/builtinf_*.ml; \ - cat _tkfgen.ml; \ - echo ; \ - ) > _tk.ml - ../../../boot/ocamlrun ../compiler/pp < _tk.ml > tk.ml - rm -f _tk.ml - $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend - -clean: - rm -f *.cm* *.ml *.mli *.$(O) *.$(A) -# rm -f modules .depend diff --git a/otherlibs/labltk/labltk/Makefile.nt b/otherlibs/labltk/labltk/Makefile.nt deleted file mode 100644 index a8f4f694d9..0000000000 --- a/otherlibs/labltk/labltk/Makefile.nt +++ /dev/null @@ -1,43 +0,0 @@ -include ../support/Makefile.common.nt - -COMPFLAGS= -I ../support - -all: labltkobjs - -opt: labltkobjsx - -# All .{ml,mli} files are generated in this directory -clean : - rm -f *.cm* *.ml *.mli *.$(A) *.$(O) - $(MAKE) -f Makefile.gen.nt clean - -include ./modules - -LABLTKOBJS = $(WIDGETOBJS) tk.cmo labltk.cmo -LABLTKOBJSX = $(LABLTKOBJS:.cmo=.cmx) - -labltkobjs: $(LABLTKOBJS) - -labltkobjsx: $(LABLTKOBJSX) - -install: $(LABLTKOBJS) - mkdir -p $(INSTALLDIR) - cp *.cmi [a-z]*.mli $(INSTALLDIR) - -installopt: $(LABLTKOBJSX) - mkdir -p $(INSTALLDIR) - cp $(LABLTKOBJSX) $(INSTALLDIR) - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -include .depend diff --git a/otherlibs/labltk/labltk/modules b/otherlibs/labltk/labltk/modules deleted file mode 100644 index a17b6ab1eb..0000000000 --- a/otherlibs/labltk/labltk/modules +++ /dev/null @@ -1,77 +0,0 @@ -WIDGETOBJS=place.cmo wm.cmo imagephoto.cmo canvas.cmo button.cmo text.cmo label.cmo scrollbar.cmo image.cmo encoding.cmo pixmap.cmo palette.cmo font.cmo message.cmo menu.cmo entry.cmo listbox.cmo focus.cmo menubutton.cmo pack.cmo option.cmo toplevel.cmo frame.cmo dialog.cmo imagebitmap.cmo clipboard.cmo radiobutton.cmo tkwait.cmo grab.cmo selection.cmo scale.cmo optionmenu.cmo winfo.cmo grid.cmo checkbutton.cmo bell.cmo tkvars.cmo -place.ml wm.ml imagephoto.ml canvas.ml button.ml text.ml label.ml scrollbar.ml image.ml encoding.ml pixmap.ml palette.ml font.ml message.ml menu.ml entry.ml listbox.ml focus.ml menubutton.ml pack.ml option.ml toplevel.ml frame.ml dialog.ml imagebitmap.ml clipboard.ml radiobutton.ml tkwait.ml grab.ml selection.ml scale.ml optionmenu.ml winfo.ml grid.ml checkbutton.ml bell.ml tkvars.ml : _tkgen.ml - -place.cmo : place.ml -place.cmi : place.mli -wm.cmo : wm.ml -wm.cmi : wm.mli -imagephoto.cmo : imagephoto.ml -imagephoto.cmi : imagephoto.mli -canvas.cmo : canvas.ml -canvas.cmi : canvas.mli -button.cmo : button.ml -button.cmi : button.mli -text.cmo : text.ml -text.cmi : text.mli -label.cmo : label.ml -label.cmi : label.mli -scrollbar.cmo : scrollbar.ml -scrollbar.cmi : scrollbar.mli -image.cmo : image.ml -image.cmi : image.mli -encoding.cmo : encoding.ml -encoding.cmi : encoding.mli -pixmap.cmo : pixmap.ml -pixmap.cmi : pixmap.mli -palette.cmo : palette.ml -palette.cmi : palette.mli -font.cmo : font.ml -font.cmi : font.mli -message.cmo : message.ml -message.cmi : message.mli -menu.cmo : menu.ml -menu.cmi : menu.mli -entry.cmo : entry.ml -entry.cmi : entry.mli -listbox.cmo : listbox.ml -listbox.cmi : listbox.mli -focus.cmo : focus.ml -focus.cmi : focus.mli -menubutton.cmo : menubutton.ml -menubutton.cmi : menubutton.mli -pack.cmo : pack.ml -pack.cmi : pack.mli -option.cmo : option.ml -option.cmi : option.mli -toplevel.cmo : toplevel.ml -toplevel.cmi : toplevel.mli -frame.cmo : frame.ml -frame.cmi : frame.mli -dialog.cmo : dialog.ml -dialog.cmi : dialog.mli -imagebitmap.cmo : imagebitmap.ml -imagebitmap.cmi : imagebitmap.mli -clipboard.cmo : clipboard.ml -clipboard.cmi : clipboard.mli -radiobutton.cmo : radiobutton.ml -radiobutton.cmi : radiobutton.mli -tkwait.cmo : tkwait.ml -tkwait.cmi : tkwait.mli -grab.cmo : grab.ml -grab.cmi : grab.mli -selection.cmo : selection.ml -selection.cmi : selection.mli -scale.cmo : scale.ml -scale.cmi : scale.mli -optionmenu.cmo : optionmenu.ml -optionmenu.cmi : optionmenu.mli -winfo.cmo : winfo.ml -winfo.cmi : winfo.mli -grid.cmo : grid.ml -grid.cmi : grid.mli -checkbutton.cmo : checkbutton.ml -checkbutton.cmi : checkbutton.mli -bell.cmo : bell.ml -bell.cmi : bell.mli -tkvars.cmo : tkvars.ml -tkvars.cmi : tkvars.mli diff --git a/otherlibs/labltk/lib/.cvsignore b/otherlibs/labltk/lib/.cvsignore deleted file mode 100644 index 80df4415f0..0000000000 --- a/otherlibs/labltk/lib/.cvsignore +++ /dev/null @@ -1,8 +0,0 @@ -labltktop labltk mltktop mltk -.depend -*.ml -*.mli -modules -labltk.cma -labltk.cmxa - diff --git a/otherlibs/labltk/lib/Makefile b/otherlibs/labltk/lib/Makefile deleted file mode 100644 index 225c3d1c44..0000000000 --- a/otherlibs/labltk/lib/Makefile +++ /dev/null @@ -1,74 +0,0 @@ -include ../support/Makefile.common - -all: $(LIBNAME).cma $(LIBNAME)top$(EXE) $(LIBNAME) - -opt: $(LIBNAME).cmxa - -clean: - rm -f $(LIBNAME)top$(EXE) $(LIBNAME) *.cm* *.a - -superclean: - - if test -f tk.cmo; then \ - echo We have changes... Now lib directory has no .cmo files; \ - rm -f *.cm* *.o; \ - fi - -include ../labltk/modules -LABLTKOBJS=tk.cmo $(WIDGETOBJS) - -include ../camltk/modules -CAMLTKOBJS=cTk.cmo $(CWIDGETOBJS) labltk.cmo camltk.cmo - -SUPPORT=../support/support.cmo ../support/rawwidget.cmo \ - ../support/widget.cmo ../support/protocol.cmo \ - ../support/textvariable.cmo ../support/timer.cmo \ - ../support/fileevent.cmo ../support/camltkwrap.cmo - -TKOBJS=$(SUPPORT) $(LABLTKOBJS) $(CAMLTKOBJS) - -TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo - -$(LIBNAME).cma: $(SUPPORT) ../Widgets.src - $(MAKE) superclean - cd ../labltk; $(MAKE) - cd ../camltk; $(MAKE) - $(MKLIB) -ocamlc '$(CAMLC)' -o $(LIBNAME) -oc $(LIBNAME) \ - -I ../labltk -I ../camltk $(TKOBJS) \ - $(TK_LINK) - -$(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src - $(MAKE) superclean - cd ../labltk; $(MAKE) opt - cd ../camltk; $(MAKE) opt - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o $(LIBNAME) -oc $(LIBNAME) \ - -I ../labltk -I ../camltk $(TKOBJS:.cmo=.cmx) \ - $(TK_LINK) - -$(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).a - $(CAMLC) -verbose -linkall -o $(LIBNAME)top$(EXE) -I ../support \ - -I $(TOPDIR)/toplevel toplevellib.cma \ - -I ../labltk -I ../camltk $(LIBNAME).cma \ - -I $(OTHERS)/unix unix.cma \ - -I $(OTHERS)/str str.cma \ - topstart.cmo - -$(LIBNAME): Makefile $(TOPDIR)/config/Makefile - @echo Generate $@ - @echo "#!/bin/sh" > $@ - @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) $$*' >> $@ - -install: - if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(LIBNAME).cma $(LIBNAME)top$(EXE) $(INSTALLDIR) - chmod 644 $(INSTALLDIR)/$(LIBNAME).cma - chmod 755 $(INSTALLDIR)/$(LIBNAME)top$(EXE) - @if test -d $(BINDIR); then : ; else mkdir $(BINDIR); fi - cp $(LIBNAME) $(BINDIR) - chmod 755 $(BINDIR)/$(LIBNAME) - -installopt: - @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(LIBNAME).cmxa $(LIBNAME).a $(INSTALLDIR) - cd $(INSTALLDIR); $(RANLIB) $(LIBNAME).a - chmod 644 $(INSTALLDIR)/$(LIBNAME).cmxa - chmod 644 $(INSTALLDIR)/$(LIBNAME).a diff --git a/otherlibs/labltk/lib/Makefile.nt b/otherlibs/labltk/lib/Makefile.nt deleted file mode 100644 index 4ce22aca5e..0000000000 --- a/otherlibs/labltk/lib/Makefile.nt +++ /dev/null @@ -1,60 +0,0 @@ -include ../support/Makefile.common.nt - -all: $(LIBNAME).cma - -opt: $(LIBNAME).cmxa - -clean: - rm -f $(LIBNAME).cma $(LIBNAME).cmxa *.$(A) - -include ../labltk/modules -LABLTKOBJS=tk.cmo $(WIDGETOBJS) - -include ../camltk/modules -CAMLTKOBJS=cTk.cmo $(CWIDGETOBJS) labltk.cmo camltk.cmo - -SUPPORT=../support/support.cmo ../support/rawwidget.cmo \ - ../support/widget.cmo ../support/protocol.cmo \ - ../support/textvariable.cmo ../support/timer.cmo \ - ../support/fileevent.cmo ../support/camltkwrap.cmo - -TKOBJS=$(SUPPORT) $(LABLTKOBJS) $(CAMLTKOBJS) - -TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo - -UNIXLIB = $(call SYSLIB,wsock32) - -$(LIBNAME).cma: $(SUPPORT) - cd ../labltk ; $(MAKEREC) - cd ../camltk ; $(MAKEREC) - $(CAMLLIBR) -o $(LIBNAME).cma -I ../labltk -I ../camltk $(TKOBJS) \ - -dllib -l$(LIBNAME) -cclib -l$(LIBNAME) \ - -cclib "$(TK_LINK)" -cclib $(UNIXLIB) - -$(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) - cd ../labltk; $(MAKEREC) opt - cd ../camltk; $(MAKEREC) opt - $(CAMLOPTLIBR) -o $(LIBNAME).cmxa -I ../labltk -I ../camltk \ - $(TKOBJS:.cmo=.cmx) -cclib -l$(LIBNAME) \ - -cclib "$(TK_LINK)" -cclib $(UNIXLIB) - -# $(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).a -# $(CAMLC) -linkall -o $(LIBNAME)top$(EXE) -I ../support \ -# -I $(TOPDIR)/toplevel toplevellib.cma \ -# -I ../labltk -I ../camltk $(LIBNAME).cma \ -# -I $(OTHERS)/unix unix.cma \ -# -I $(OTHERS)/str str.cma \ -# topmain.cmo -# -# $(LIBNAME): Makefile $(TOPDIR)/config/Makefile -# @echo Generate $@ -# @echo "#!/bin/sh" > $@ -# @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) $$*' >> $@ - -install: all - mkdir -p $(INSTALLDIR) - cp $(LIBNAME).cma $(INSTALLDIR) - -installopt: opt - mkdir -p $(INSTALLDIR) - cp $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALLDIR) diff --git a/otherlibs/labltk/support/.depend b/otherlibs/labltk/support/.depend deleted file mode 100644 index 0abefc8922..0000000000 --- a/otherlibs/labltk/support/.depend +++ /dev/null @@ -1,24 +0,0 @@ -camltkwrap.cmi: protocol.cmi textvariable.cmi timer.cmi widget.cmi -protocol.cmi: widget.cmi -textvariable.cmi: protocol.cmi widget.cmi -widget.cmi: rawwidget.cmi -camltkwrap.cmo: fileevent.cmi protocol.cmi rawwidget.cmi textvariable.cmi \ - timer.cmi camltkwrap.cmi -camltkwrap.cmx: fileevent.cmx protocol.cmx rawwidget.cmx textvariable.cmx \ - timer.cmx camltkwrap.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 -rawwidget.cmo: support.cmi rawwidget.cmi -rawwidget.cmx: support.cmx rawwidget.cmi -slave.cmo: widget.cmi -slave.cmx: widget.cmx -support.cmo: support.cmi -support.cmx: support.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: rawwidget.cmi widget.cmi -widget.cmx: rawwidget.cmx widget.cmi diff --git a/otherlibs/labltk/support/Makefile b/otherlibs/labltk/support/Makefile deleted file mode 100644 index 36d5190308..0000000000 --- a/otherlibs/labltk/support/Makefile +++ /dev/null @@ -1,59 +0,0 @@ -include Makefile.common - -all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \ - textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \ - lib$(LIBNAME).a - -opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \ - textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \ - lib$(LIBNAME).a - -COBJS=cltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o cltkMain.o \ - cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o - -CCFLAGS=-I../../../byterun $(TK_DEFS) $(SHAREDCCCOMPOPTS) - -COMPFLAGS=-I $(OTHERS)/unix - -lib$(LIBNAME).a : $(COBJS) - $(MKLIB) -o $(LIBNAME) $(COBJS) $(TK_LINK) - -PUB=fileevent.cmi fileevent.mli \ - protocol.cmi protocol.mli \ - textvariable.cmi textvariable.mli \ - timer.cmi timer.mli \ - rawwidget.cmi rawwidget.mli \ - widget.cmi widget.mli - -install: lib$(LIBNAME).a $(PUB) - if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(PUB) lib$(LIBNAME).a $(INSTALLDIR) - cd $(INSTALLDIR); $(RANLIB) lib$(LIBNAME).a - cd $(INSTALLDIR); chmod 644 $(PUB) lib$(LIBNAME).a - if test -f dll$(LIBNAME).so; then \ - cp dll$(LIBNAME).so $(STUBLIBDIR)/dll$(LIBNAME).so; fi - -clean : - rm -f *.cm* *.o *.a *.so - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .cmx .mlp .c .o - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.o: - $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< - -depend: - $(CAMLDEP) *.mli *.ml > .depend - -$(COBJS): $(TOPDIR)/config/Makefile camltk.h - -include .depend diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common deleted file mode 100644 index 8745fee80b..0000000000 --- a/otherlibs/labltk/support/Makefile.common +++ /dev/null @@ -1,26 +0,0 @@ -## Paths are relative to subdirectories -## Where you compiled Objective Caml -TOPDIR=../../.. -## Path to the otherlibs subdirectory -OTHERS=../.. - -LIBNAME=labltk - -include $(TOPDIR)/config/Makefile - -INSTALLDIR=$(LIBDIR)/$(LIBNAME) - -## Tools from the Objective Caml distribution - -CAMLRUN=$(TOPDIR)/boot/ocamlrun -CAMLC=$(TOPDIR)/ocamlcomp.sh -CAMLOPT=$(TOPDIR)/ocamlcompopt.sh -CAMLCOMP=$(CAMLC) -c -warn-error A -CAMLYACC=$(TOPDIR)/boot/ocamlyacc -v -CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex -CAMLLIBR=$(CAMLC) -a -CAMLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep -COMPFLAGS= -LINKFLAGS= -CAMLOPTLIBR=$(CAMLOPT) -a -MKLIB=$(CAMLRUN) $(TOPDIR)/tools/ocamlmklib diff --git a/otherlibs/labltk/support/Makefile.common.nt b/otherlibs/labltk/support/Makefile.common.nt deleted file mode 100644 index d31de99dc5..0000000000 --- a/otherlibs/labltk/support/Makefile.common.nt +++ /dev/null @@ -1,29 +0,0 @@ -## Paths are relative to subdirectories -## Where you compiled Objective Caml -TOPDIR=../../.. -## Where to find OCaml binaries -EXEDIR=$(TOPDIR) -## Path to the otherlibs subdirectory -OTHERS=../.. - -LIBNAME=labltk - -include $(TOPDIR)/config/Makefile - -INSTALLDIR=$(LIBDIR)/$(LIBNAME) -TKLINKOPT=$(STATIC) - -## Tools from the Objective Caml distribution - -CAMLRUN=$(EXEDIR)/boot/ocamlrun -CAMLC=$(CAMLRUN) $(TOPDIR)/ocamlc -I $(TOPDIR)/stdlib -CAMLCOMP=$(CAMLC) -c -CAMLYACC=$(EXEDIR)/boot/ocamlyacc -v -CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex -CAMLLIBR=$(CAMLC) -a -CAMLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep -COMPFLAGS= -LINKFLAGS= - -CAMLOPT=$(CAMLRUN) $(TOPDIR)/ocamlopt -I $(TOPDIR)/stdlib -CAMLOPTLIBR=$(CAMLOPT) -a diff --git a/otherlibs/labltk/support/Makefile.nt b/otherlibs/labltk/support/Makefile.nt deleted file mode 100644 index e1720efb46..0000000000 --- a/otherlibs/labltk/support/Makefile.nt +++ /dev/null @@ -1,69 +0,0 @@ -include Makefile.common.nt - -all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \ - textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \ - dll$(LIBNAME).dll lib$(LIBNAME).$(A) - -opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \ - textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \ - lib$(LIBNAME).$(A) - -COBJS=cltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o \ - cltkMain.o cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o -DCOBJS=$(COBJS:.o=.$(DO)) -SCOBJS=$(COBJS:.o=.$(SO)) - -CCFLAGS=-I../../../byterun -I../../win32unix $(TK_DEFS) -DIN_CAMLTKSUPPORT - -COMPFLAGS=-I $(OTHERS)/win32unix - -dll$(LIBNAME).dll : $(DCOBJS) - $(call MKDLL,dll$(LIBNAME).dll,dll$(LIBNAME).$(A),\ - $(DCOBJS) ../../../byterun/ocamlrun.$(A) \ - $(TK_LINK) $(call SYSLIB,wsock32)) - -lib$(LIBNAME).$(A) : $(SCOBJS) - $(call MKLIB,lib$(LIBNAME).$(A), $(SCOBJS)) - -PUB=fileevent.cmi fileevent.mli \ - protocol.cmi protocol.mli \ - textvariable.cmi textvariable.mli \ - timer.cmi timer.mli \ - rawwidget.cmi rawwidget.mli \ - widget.cmi widget.mli - -install: - mkdir -p $(INSTALLDIR) - cp $(PUB) $(INSTALLDIR) - cp dll$(LIBNAME).dll $(STUBLIBDIR)/dll$(LIBNAME).dll - cp dll$(LIBNAME).$(A) lib$(LIBNAME).$(A) $(INSTALLDIR) - -clean : - rm -f *.cm* *.$(O) *.dll *.$(A) *.exp - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .cmx .mlp .c .$(DO) .$(SO) - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CCFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< - mv $*.$(O) $*.$(SO) - -depend: - $(CAMLDEP) *.mli *.ml > .depend - -$(DCOBJS) $(SCOBJS): camltk.h - -include .depend diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h deleted file mode 100644 index deba33086c..0000000000 --- a/otherlibs/labltk/support/camltk.h +++ /dev/null @@ -1,56 +0,0 @@ -/*************************************************************************/ -/* */ -/* Objective Caml LablTk library */ -/* */ -/* Francois Rouaix, Francois Pessaux and Jun Furuse */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 1999 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file ../../../LICENSE. */ -/* */ -/*************************************************************************/ - -/* $Id$ */ - -#if defined(_WIN32) && defined(CAML_DLL) && defined(IN_CAMLTKSUPPORT) -#define CAMLTKextern CAMLexport -#else -#define CAMLTKextern CAMLextern -#endif - -/* cltkMisc.c */ -/* copy a Caml string to the C heap. Must be deallocated with stat_free */ -extern char *string_to_c(value s); - -/* cltkUtf.c */ -extern value tcl_string_to_caml( char * ); -extern char * caml_string_to_tcl( value ); - -/* cltkEval.c */ -CAMLTKextern Tcl_Interp *cltclinterp; /* The Tcl interpretor */ -extern value copy_string_list(int argc, char ** argv); - -/* cltkCaml.c */ -/* pointers to Caml values */ -extern value *tkerror_exn; -extern value *handler_code; -extern int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, - int argc, char *argv[]); -CAMLTKextern void tk_error(char * errmsg) Noreturn; - -/* cltkMain.c */ -extern int signal_events; -extern void invoke_pending_caml_signals(ClientData clientdata); -extern Tk_Window cltk_mainWindow; -extern int cltk_slave_mode; - -/* check that initialisations took place */ -#define CheckInit() if (!cltclinterp) tk_error("Tcl/Tk not initialised") - -#define RCNAME ".camltkrc" -#define CAMLCB "camlcb" - diff --git a/otherlibs/labltk/support/camltkwrap.ml b/otherlibs/labltk/support/camltkwrap.ml deleted file mode 100644 index 5afe864dfc..0000000000 --- a/otherlibs/labltk/support/camltkwrap.ml +++ /dev/null @@ -1,77 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -module Widget = struct - include Rawwidget - type widget = raw_any raw_widget - - let default_toplevel = coe default_toplevel -end - -module Protocol = struct - open Widget - include Protocol - - let opentk () = coe (opentk ()) - let opentk_with_args args = coe (opentk_with_args args) - let openTk ?display ?clas () = coe (openTk ?display ?clas ()) - - let cCAMLtoTKwidget table w = - Widget.check_class w table; (* we need run time type check of widgets *) - TkToken (Widget.name w) - - (* backward compatibility *) - let openTkClass s = coe (openTkClass s) - let openTkDisplayClass disp c = coe (openTkDisplayClass disp c) -end - -module Textvariable = struct - open Textvariable - type textVariable = Textvariable.textVariable - let create = create - let set = set - let get = get - let name = name - let cCAMLtoTKtextVariable = cCAMLtoTKtextVariable - let handle tv cbk = handle tv ~callback:cbk - let coerce = coerce - - (*-*) - let free = free - - (* backward compatibility *) - let create_temporary w = create ~on: w () -end - -module Fileevent = struct - open Fileevent - let add_fileinput fd callback = add_fileinput ~fd ~callback - let remove_fileinput fd = remove_fileinput ~fd - let add_fileoutput fd callback = add_fileoutput ~fd ~callback - let remove_fileoutput fd = remove_fileoutput ~fd -end - -module Timer = struct - open Timer - type t = Timer.t - let add ms callback = add ~ms ~callback - let set ms callback = set ~ms ~callback - let remove = remove -end - -(* -Not compiled in support -module Tkwait = Tkwait -*) diff --git a/otherlibs/labltk/support/camltkwrap.mli b/otherlibs/labltk/support/camltkwrap.mli deleted file mode 100644 index 9c9321c21e..0000000000 --- a/otherlibs/labltk/support/camltkwrap.mli +++ /dev/null @@ -1,251 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -module Widget : sig - type widget = Widget.any Widget.widget - (* widget is an abstract type *) - - val default_toplevel : widget - (* [default_toplevel] is "." in Tk, the toplevel widget that is - always existing during a Tk session. Destroying [default_toplevel] - ends the main loop - *) - - val atom : parent: widget -> name: string -> widget - (* [atom parent name] returns the widget [parent.name]. The widget is - not created. Only its name is returned. In a given parent, there may - only exist one children for a given name. - This function should only be used to check the existence of a widget - with a known name. It doesn't add the widget to the internal tables - of CamlTk. - *) - - val name : widget -> string - (* [name w] returns the name (tk "path") of a widget *) - - (*--*) - (* The following functions are used internally. - There is normally no need for them in users programs - *) - - val known_class : widget -> string - (* [known_class w] returns the class of a widget (e.g. toplevel, frame), - as known by the CamlTk interface. - Not equivalent to "winfo w" in Tk. - *) - - val dummy : widget - (* [dummy] is a widget used as context when we don't have any. - It is *not* a real widget. - *) - - val new_atom : parent: widget -> ?name: string -> string -> widget - (* incompatible with the classic camltk *) - - val get_atom : string -> widget - (* [get_atom path] returns the widget with Tk path [path] *) - - val remove : widget -> unit - (* [remove w] removes widget from the internal tables *) - - (* Subtypes tables *) - val widget_any_table : string list - val widget_button_table : string list - val widget_canvas_table : string list - val widget_checkbutton_table : string list - val widget_entry_table : string list - val widget_frame_table : string list - val widget_label_table : string list - val widget_listbox_table : string list - val widget_menu_table : string list - val widget_menubutton_table : string list - val widget_message_table : string list - val widget_radiobutton_table : string list - val widget_scale_table : string list - val widget_scrollbar_table : string list - val widget_text_table : string list - val widget_toplevel_table : string list - - val chk_sub : string -> 'a list -> 'a -> unit - val check_class : widget -> string list -> unit - (* Widget subtyping *) - - exception IllegalWidgetType of string - (* Raised when widget command applied illegally*) - - (* this function is not used, but introduced for the compatibility - with labltk. useless for camltk users *) - val coe : 'a Widget.widget -> Widget.any Widget.widget -end - -module Protocol : sig - open Widget - - (* Lower level interface *) - exception TkError of string - (* Raised by the communication functions *) - - val debug : bool ref - (* When set to true, displays approximation of intermediate Tcl code *) - - type tkArgs = - TkToken of string - | TkTokenList of tkArgs list (* to be expanded *) - | TkQuote of tkArgs (* mapped to Tcl list *) - - - (* Misc *) - external splitlist : string -> string list - = "camltk_splitlist" - - val add_destroy_hook : (widget -> unit) -> unit - - - (* Opening, closing, and mainloop *) - val default_display : unit -> string - - val opentk : unit -> widget - (* The basic initialization function. [opentk ()] parses automatically - the command line options and use the tk related options in them - such as "-display localhost:0" to initialize Tk applications. - Consult wish manpage about the supported options. *) - - val keywords : (string * Arg.spec * string) list - (* Command line parsing specification for Arg.parse, which contains - the standard Tcl/Tk command line options such as "-display" and "-name". - These Tk command line options are used by opentk *) - - val opentk_with_args : string list -> widget - (* [opentk_with_args argv] invokes [opentk] with the tk related - command line options given by [argv] to the executable program. *) - - val openTk : ?display:string -> ?clas:string -> unit -> widget - (* [openTk ~display:display ~clas:clas ()] is equivalent to - [opentk ["-display"; display; "-name"; clas]] *) - - (* Legacy opentk functions *) - val openTkClass: string -> widget - (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *) - val openTkDisplayClass: string -> string -> widget - (* [openTkDisplayClass disp class] is equivalent to - [opentk ["-display"; disp; "-name"; class]] *) - - val closeTk : unit -> unit - val finalizeTk : unit -> unit - (* Finalize tcl/tk before exiting. This function will be automatically - called when you call [Pervasives.exit ()] *) - - val mainLoop : unit -> unit - - - (* Direct evaluation of tcl code *) - val tkEval : tkArgs array -> string - - val tkCommand : tkArgs array -> unit - - (* Returning a value from a Tcl callback *) - val tkreturn: string -> unit - - - (* Callbacks: this is private *) - - type cbid = Protocol.cbid - - type callback_buffer = string list - (* Buffer for reading callback arguments *) - - val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t - (* CAMLTK val callback_memo_table : (widget, cbid) Hashtbl.t *) - val callback_memo_table : (widget, cbid) Hashtbl.t - (* Exported for debug purposes only. Don't use them unless you - know what you are doing *) - val new_function_id : unit -> cbid - val string_of_cbid : cbid -> string - val register_callback : widget -> callback:(callback_buffer -> unit) -> string - (* Callback support *) - val clear_callback : cbid -> unit - (* Remove a given callback from the table *) - val remove_callbacks : widget -> unit - (* Clean up callbacks associated to widget. Must be used only when - the Destroy event is bind by the user and masks the default - Destroy event binding *) - - val cTKtoCAMLwidget : string -> widget - val cCAMLtoTKwidget : string list -> widget -> tkArgs - - val register : string -> callback:(callback_buffer -> unit) -> unit - - (*-*) - val prerr_cbid : cbid -> unit -end - -module Textvariable : sig - open Widget - open Protocol - - type textVariable = Textvariable.textVariable - (* TextVariable is an abstract type *) - - val create : ?on: widget -> unit -> textVariable - (* Allocation of a textVariable with lifetime associated to widget - if a widget is specified *) - val create_temporary : widget -> textVariable - (* for backward compatibility - [create_temporary w] is equivalent to [create ~on:w ()] *) - - val set : textVariable -> string -> unit - (* Setting the val of a textVariable *) - val get : textVariable -> string - (* Reading the val of a textVariable *) - val name : textVariable -> string - (* Its tcl name *) - - val cCAMLtoTKtextVariable : textVariable -> tkArgs - (* Internal conversion function *) - - val handle : textVariable -> (unit -> unit) -> unit - (* Callbacks on variable modifications *) - - val coerce : string -> textVariable - - (*-*) - val free : textVariable -> unit -end - -module Fileevent : sig - open Unix - - val add_fileinput : file_descr -> (unit -> unit) -> unit - val remove_fileinput: file_descr -> unit - val add_fileoutput : file_descr -> (unit -> unit) -> unit - val remove_fileoutput: file_descr -> unit - (* see [tk] module *) -end - -module Timer : sig - type t = Timer.t - - val add : int -> (unit -> unit) -> t - val set : int -> (unit -> unit) -> unit - val remove : t -> unit -end - -(* -Tkwait exists, but is not used in support -module Tkwait : sig - val internal_tracevis : string -> string -> unit - val internal_tracedestroy : string -> string -> unit -end -*) diff --git a/otherlibs/labltk/support/cltkCaml.c b/otherlibs/labltk/support/cltkCaml.c deleted file mode 100644 index 976c864efa..0000000000 --- a/otherlibs/labltk/support/cltkCaml.c +++ /dev/null @@ -1,83 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <tcl.h> -#include <tk.h> -#include <mlvalues.h> -#include <alloc.h> -#include <callback.h> -#include <fail.h> -#include "camltk.h" - -value * tkerror_exn = NULL; -value * handler_code = NULL; - -/* The Tcl command for evaluating callback in Caml */ -int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, int argc, char **argv) -{ - CheckInit(); - - /* Assumes no result */ - Tcl_SetResult(interp, NULL, NULL); - if (argc >= 2) { - int id; - if (Tcl_GetInt(interp, argv[1], &id) != TCL_OK) - return TCL_ERROR; - callback2(*handler_code,Val_int(id),copy_string_list(argc - 2,&argv[2])); - /* Never fails (Caml would have raised an exception) */ - /* but result may have been set by callback */ - return TCL_OK; - } - else - return TCL_ERROR; -} - -/* Callbacks are always of type _ -> unit, to simplify storage - * But a callback can nevertheless return something (to Tcl) by - * using the following. TCL_VOLATILE ensures that Tcl will make - * a copy of the string - */ -CAMLprim value camltk_return (value v) -{ - CheckInit(); - - Tcl_SetResult(cltclinterp, String_val(v), TCL_VOLATILE); - return Val_unit; -} - -/* Note: raise_with_string WILL copy the error message */ -CAMLprim void tk_error(char *errmsg) -{ - raise_with_string(*tkerror_exn, errmsg); -} - - -/* The initialisation of the C global variables pointing to Caml values - must be made accessible from Caml, so that we are sure that it *always* - takes place during loading of the protocol module - */ - -CAMLprim value camltk_init(value v) -{ - /* Initialize the Caml pointers */ - if (tkerror_exn == NULL) - tkerror_exn = caml_named_value("tkerror"); - if (handler_code == NULL) - handler_code = caml_named_value("camlcb"); - return Val_unit; -} diff --git a/otherlibs/labltk/support/cltkDMain.c b/otherlibs/labltk/support/cltkDMain.c deleted file mode 100644 index 7b2e59bc2d..0000000000 --- a/otherlibs/labltk/support/cltkDMain.c +++ /dev/null @@ -1,247 +0,0 @@ -/*************************************************************************/ -/* */ -/* Objective Caml LablTk library */ -/* */ -/* Francois Rouaix, Francois Pessaux and Jun Furuse */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 1999 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file ../../../LICENSE. */ -/* */ -/*************************************************************************/ - -/* $Id$ */ - -#include <unistd.h> -#include <fcntl.h> -#include <tcl.h> -#include <tk.h> -#include "gc.h" -#include "exec.h" -#include "sys.h" -#include "fail.h" -#include "io.h" -#include "mlvalues.h" -#include "memory.h" -#include "camltk.h" - -#ifndef O_BINARY -#define O_BINARY 0 -#endif - - -/* - * Dealing with signals: when a signal handler is defined in Caml, - * the actual execution of the signal handler upon reception of the - * signal is delayed until we are sure we are out of the GC. - * If a signal occurs during the MainLoop, we would have to wait - * the next event for the handler to be invoked. - * The following function will invoke a pending signal handler if any, - * and we put in on a regular timer. - */ - -#define SIGNAL_INTERVAL 300 - -int signal_events = 0; /* do we have a pending timer */ - -void invoke_pending_caml_signals (clientdata) - ClientData clientdata; -{ - signal_events = 0; - enter_blocking_section(); /* triggers signal handling */ - /* Rearm timer */ - Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL); - signal_events = 1; - leave_blocking_section(); -} -/* The following is taken from byterun/startup.c */ -header_t atom_table[256]; -code_t start_code; -asize_t code_size; - -static void init_atoms() -{ - int i; - for(i = 0; i < 256; i++) atom_table[i] = Make_header(0, i, White); -} - -static unsigned long read_size(p) - unsigned char * p; -{ - return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) + - ((unsigned long) p[2] << 8) + p[3]; -} - -#define FILE_NOT_FOUND (-1) -#define TRUNCATED_FILE (-2) -#define BAD_MAGIC_NUM (-3) - -static int read_trailer(fd, trail) - int fd; - struct exec_trailer * trail; -{ - char buffer[TRAILER_SIZE]; - - lseek(fd, (long) -TRAILER_SIZE, 2); - if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return TRUNCATED_FILE; - trail->code_size = read_size(buffer); - trail->data_size = read_size(buffer+4); - trail->symbol_size = read_size(buffer+8); - trail->debug_size = read_size(buffer+12); - if (strncmp(buffer + 16, EXEC_MAGIC, 12) == 0) - return 0; - else - return BAD_MAGIC_NUM; -} - -int attempt_open(name, trail, do_open_script) - char ** name; - struct exec_trailer * trail; - int do_open_script; -{ - char * truename; - int fd; - int err; - char buf [2]; - - truename = searchpath(*name); - if (truename == 0) truename = *name; else *name = truename; - fd = open(truename, O_RDONLY | O_BINARY); - if (fd == -1) return FILE_NOT_FOUND; - if (!do_open_script){ - err = read (fd, buf, 2); - if (err < 2) { close(fd); return TRUNCATED_FILE; } - if (buf [0] == '#' && buf [1] == '!') { close(fd); return BAD_MAGIC_NUM; } - } - err = read_trailer(fd, trail); - if (err != 0) { close(fd); return err; } - return fd; -} - - -/* Command for loading the bytecode file */ -int CamlRunCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - int fd; - struct exec_trailer trail; - struct longjmp_buffer raise_buf; - struct channel * chan; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " foo.cmo args\"", (char *) NULL); - return TCL_ERROR; - } - fd = attempt_open(&argv[1], &trail, 1); - - switch(fd) { - case FILE_NOT_FOUND: - fatal_error_arg("Fatal error: cannot find file %s\n", argv[1]); - break; - case TRUNCATED_FILE: - case BAD_MAGIC_NUM: - fatal_error_arg( - "Fatal error: the file %s is not a bytecode executable file\n", - argv[1]); - break; - } - - if (sigsetjmp(raise_buf.buf, 1) == 0) { - - external_raise = &raise_buf; - - lseek(fd, - (long) (TRAILER_SIZE + trail.code_size + trail.data_size - + trail.symbol_size + trail.debug_size), 2); - - code_size = trail.code_size; - start_code = (code_t) stat_alloc(code_size); - if (read(fd, (char *) start_code, code_size) != code_size) - fatal_error("Fatal error: truncated bytecode file.\n"); - -#ifdef ARCH_BIG_ENDIAN - fixup_endianness(start_code, code_size); -#endif - - chan = open_descr(fd); - global_data = input_value(chan); - close_channel(chan); - /* Ensure that the globals are in the major heap. */ - oldify(global_data, &global_data); - - sys_init(argv + 1); - interprete(start_code, code_size); - return TCL_OK; - } else { - Tcl_AppendResult(interp, "Caml program", argv[1], " raised exception \"", - String_val(Field(Field(exn_bucket, 0), 0))); - return TCL_ERROR; - } -} - -int CamlInvokeCmd(dummy - - - -/* Now the real Tk stuff */ -Tk_Window cltk_mainWindow; - -#define RCNAME ".camltkrc" -#define CAMLCB "camlcb" - -/* Initialisation of the dynamically loaded module */ -int Caml_Init(interp) - Tcl_Interp *interp; -{ - cltclinterp = interp; - /* Create the camlcallback command */ - Tcl_CreateCommand(cltclinterp, - CAMLCB, CamlCBCmd, - (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL); - - /* This is required by "unknown" and thus autoload */ - Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - /* Our hack for implementing break in callbacks */ - Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY); - - /* Load the traditional rc file */ - { - char *home = getenv("HOME"); - if (home != NULL) { - char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2); - f[0]='\0'; - strcat(f, home); - strcat(f, "/"); - strcat(f, RCNAME); - if (0 == access(f,R_OK)) - if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { - stat_free(f); - tk_error(cltclinterp->result); - }; - stat_free(f); - } - } - - /* Initialisations from caml_main */ - { - int verbose_init = 0, - percent_free_init = Percent_free_def; - long minor_heap_init = Minor_heap_def, - heap_chunk_init = Heap_chunk_def; - - /* Machine-dependent initialization of the floating-point hardware - so that it behaves as much as possible as specified in IEEE */ - init_ieee_floats(); - init_gc (minor_heap_init, heap_chunk_init, percent_free_init, - verbose_init); - init_stack(); - init_atoms(); - } -} diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c deleted file mode 100644 index b31bc1adfd..0000000000 --- a/otherlibs/labltk/support/cltkEval.c +++ /dev/null @@ -1,245 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <stdlib.h> -#include <string.h> - -#include <tcl.h> -#include <tk.h> -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#ifdef HAS_UNISTD -#include <unistd.h> -#endif -#include "camltk.h" - -/* The Tcl interpretor */ -Tcl_Interp *cltclinterp = NULL; - -/* Copy a list of strings from the C heap to Caml */ -value copy_string_list(int argc, char **argv) -{ - CAMLparam0(); - CAMLlocal3( res, oldres, str ); - int i; - oldres = Val_unit; - str = Val_unit; - - res = Val_int(0); /* [] */ - for (i = argc-1; i >= 0; i--) { - oldres = res; - str = tcl_string_to_caml(argv[i]); - res = alloc(2, 0); - Field(res, 0) = str; - Field(res, 1) = oldres; - } - CAMLreturn(res); -} - -/* - * Calling Tcl from Caml - * this version works on an arbitrary Tcl command, - * and does parsing and substitution - */ -CAMLprim value camltk_tcl_eval(value str) -{ - int code; - char *cmd = NULL; - - CheckInit(); - - /* Tcl_Eval may write to its argument, so we take a copy - * If the evaluation raises a Caml exception, we have a space - * leak - */ - Tcl_ResetResult(cltclinterp); - cmd = caml_string_to_tcl(str); - code = Tcl_Eval(cltclinterp, cmd); - stat_free(cmd); - - switch (code) { - case TCL_OK: - return tcl_string_to_caml(cltclinterp->result); - case TCL_ERROR: - tk_error(cltclinterp->result); - default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ - tk_error("bad tcl result"); - } -} - - -/* - * Calling Tcl from Caml - * direct call, argument is TkArgs vect - type TkArgs = - TkToken of string - | TkTokenList of TkArgs list (* to be expanded *) - | TkQuote of TkArgs (* mapped to Tcl list *) - * NO PARSING, NO SUBSTITUTION - */ - -/* - * Compute the size of the argument (of type TkArgs). - * TkTokenList must be expanded, - * TkQuote count for one. - */ -int argv_size(value v) -{ - switch (Tag_val(v)) { - case 0: /* TkToken */ - return 1; - case 1: /* TkTokenList */ - { int n = 0; - value l; - for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1)) - n+=argv_size(Field(l,0)); - return n; - } - case 2: /* TkQuote */ - return 1; - default: - tk_error("argv_size: illegal tag"); - } -} - -/* Fill a preallocated vector arguments, doing expansion and all. - * Assumes Tcl will - * not tamper with our strings - * make copies if strings are "persistent" - */ -int fill_args (char **argv, int where, value v) -{ - value l; - - switch (Tag_val(v)) { - case 0: - argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by stat_free */ - return (where + 1); - case 1: - for (l=Field(v,0); Is_block(l); l=Field(l,1)) - where = fill_args(argv,where,Field(l,0)); - return where; - case 2: - { char **tmpargv; - char *merged; - int i; - int size = argv_size(Field(v,0)); - tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *)); - fill_args(tmpargv,0,Field(v,0)); - tmpargv[size] = NULL; - merged = Tcl_Merge(size,tmpargv); - for(i = 0 ; i<size; i++){ stat_free(tmpargv[i]); } - stat_free((char *)tmpargv); - /* must be freed by stat_free */ - argv[where] = (char*)stat_alloc(strlen(merged)+1); - strcpy(argv[where], merged); - Tcl_Free(merged); - return (where + 1); - } - default: - tk_error("fill_args: illegal tag"); - } -} - -/* v is an array of TkArg */ -CAMLprim value camltk_tcl_direct_eval(value v) -{ - int i; - int size; /* size of argv */ - char **argv, **allocated; - int result; - Tcl_CmdInfo info; - - CheckInit(); - - /* walk the array to compute final size for Tcl */ - for(i=0,size=0;i<Wosize_val(v);i++) - size += argv_size(Field(v,i)); - - /* +2: one slot for NULL - one slot for "unknown" if command not found */ - argv = (char **)stat_alloc((size + 2) * sizeof(char *)); - allocated = (char **)stat_alloc(size * sizeof(char *)); - - /* Copy -- argv[i] must be freed by stat_free */ - { - int where; - for(i=0, where=0;i<Wosize_val(v);i++){ - where = fill_args(argv,where,Field(v,i)); - } - if( size != where ){ tk_error("fill_args error!!! Call the CamlTk maintainer!"); } - for(i=0; i<where; i++){ allocated[i] = argv[i]; } - argv[size] = NULL; - argv[size + 1] = NULL; - } - - /* Eval */ - Tcl_ResetResult(cltclinterp); - if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */ -#if (TCL_MAJOR_VERSION >= 8) - /* info.proc might be a NULL pointer - * We should probably attempt an Obj invocation, but the following quick - * hack is easier. - */ - if (info.proc == NULL) { - Tcl_DString buf; - char *string; - Tcl_DStringInit(&buf); - Tcl_DStringAppend(&buf, argv[0], -1); - for (i=1; i<size; i++) { - Tcl_DStringAppend(&buf, " ", -1); - Tcl_DStringAppend(&buf, argv[i], -1); - } - result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf)); - Tcl_DStringFree(&buf); - } else { - result = (*info.proc)(info.clientData,cltclinterp,size,argv); - } -#else - result = (*info.proc)(info.clientData,cltclinterp,size,argv); -#endif - } else { /* implement the autoload stuff */ - if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */ - for (i = size; i >= 0; i--) - argv[i+1] = argv[i]; - argv[0] = "unknown"; - result = (*info.proc)(info.clientData,cltclinterp,size+1,argv); - } else { /* ah, it isn't there at all */ - result = TCL_ERROR; - Tcl_AppendResult(cltclinterp, "Unknown command \"", - argv[0], "\"", NULL); - } - } - - /* Free the various things we allocated */ - for(i=0; i< size; i ++){ - stat_free((char *) allocated[i]); - } - stat_free((char *)argv); - stat_free((char *)allocated); - - switch (result) { - case TCL_OK: - return tcl_string_to_caml (cltclinterp->result); - case TCL_ERROR: - tk_error(cltclinterp->result); - default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ - tk_error("bad tcl result"); - } -} diff --git a/otherlibs/labltk/support/cltkEvent.c b/otherlibs/labltk/support/cltkEvent.c deleted file mode 100644 index 81c9413f6c..0000000000 --- a/otherlibs/labltk/support/cltkEvent.c +++ /dev/null @@ -1,55 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <tcl.h> -#include <tk.h> -#include <mlvalues.h> -#include <alloc.h> -#include "camltk.h" - -CAMLprim value camltk_tk_mainloop(void) -{ - CheckInit(); - - if (cltk_slave_mode) return Val_unit; - - if (!signal_events) { - /* Initialise signal handling */ - signal_events = 1; - Tk_CreateTimerHandler(100, invoke_pending_caml_signals, NULL); - } - Tk_MainLoop(); - return Val_unit; -} - -/* Note: this HAS to be reported "as-is" in ML source */ -static int event_flag_table[] = { - TK_DONT_WAIT, TK_X_EVENTS, TK_FILE_EVENTS, TK_TIMER_EVENTS, TK_IDLE_EVENTS, - TK_ALL_EVENTS -}; - -CAMLprim value camltk_dooneevent(value flags) -{ - int ret; - - CheckInit(); - - ret = Tk_DoOneEvent(convert_flag_list(flags, event_flag_table)); - return Val_int(ret); -} - diff --git a/otherlibs/labltk/support/cltkFile.c b/otherlibs/labltk/support/cltkFile.c deleted file mode 100644 index 9ea6004edf..0000000000 --- a/otherlibs/labltk/support/cltkFile.c +++ /dev/null @@ -1,158 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#ifdef __CYGWIN__ -#define _WIN32 -#endif - -#ifdef _WIN32 -#include <wtypes.h> -#include <winbase.h> -#include <winsock.h> -#endif -#include <tcl.h> -#include <tk.h> -#include <mlvalues.h> -#include <callback.h> -#include "camltk.h" - -/* - * File descriptor callbacks - */ - -void FileProc(ClientData clientdata, int mask) -{ - callback2(*handler_code,Val_int(clientdata),Val_int(0)); -} - -/* Map Unix.file_descr values to Tcl file handles */ - -#ifndef _WIN32 - -/* Under Unix, we use file handlers */ - -/* Map Unix.file_descr values to Tcl file handles (for tcl 7) - or Unix file descriptors (for tcl 8). */ - -#if (TCL_MAJOR_VERSION < 8) -static Tcl_File tcl_filehandle(value fd) -{ - return Tcl_GetFile((ClientData)Long_val(fd), TCL_UNIX_FD); -} -#else -#define tcl_filehandle(fd) Int_val(fd) -#define Tcl_File int -#endif - -CAMLprim value camltk_add_file_input(value fd, value cbid) -{ - CheckInit(); - Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_READABLE, - FileProc, (ClientData)(Long_val(cbid))); - return Val_unit; -} - -/* We have to free the Tcl handle when we are finished using it (Tcl - * asks us to, and moreover it is probably dangerous to keep the same - * handle over two allocations of the same fd by the kernel). - * But we don't know when we are finished with the fd, so we free it - * in rem_file (it doesn't close the fd anyway). For fds for which we - * repeatedly add/rem, this will cause some overhead. - */ -CAMLprim value camltk_rem_file_input(value fd, value cbid) -{ - Tcl_File fh = tcl_filehandle(fd); - Tcl_DeleteFileHandler(fh); -#if (TCL_MAJOR_VERSION < 8) - Tcl_FreeFile(fh); -#endif - return Val_unit; -} - -CAMLprim value camltk_add_file_output(value fd, value cbid) -{ - CheckInit(); - Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_WRITABLE, - FileProc, (ClientData) (Long_val(cbid))); - return Val_unit; -} - -CAMLprim value camltk_rem_file_output(value fd, value cbid) -{ - Tcl_File fh = tcl_filehandle(fd); - Tcl_DeleteFileHandler(fh); -#if (TCL_MAJOR_VERSION < 8) - Tcl_FreeFile(fh); -#endif - return Val_unit; -} - -#else - -/* Under Win32, we go through the generic channel abstraction */ - -#define Handle_val(v) (*((HANDLE *) Data_custom_val(v))) - -/* Map Unix.file_descr values to Tcl channels */ - -static Tcl_Channel tcl_channel(value fd, int flags) -{ - HANDLE h = Handle_val(fd); - int optval, optsize; - - optsize = sizeof(optval); - if (getsockopt((SOCKET) h, SOL_SOCKET, SO_TYPE, - (char *)&optval, &optsize) == 0) - return Tcl_MakeTcpClientChannel((ClientData) h); - else - return Tcl_MakeFileChannel((ClientData) h, flags); -} - -CAMLprim value camltk_add_file_input(value fd, value cbid) -{ - CheckInit(); - Tcl_CreateChannelHandler(tcl_channel(fd, TCL_READABLE), - TCL_READABLE, - FileProc, (ClientData) (Int_val(cbid))); - return Val_unit; -} - -CAMLprim value camltk_rem_file_input(value fd, value cbid) -{ - Tcl_DeleteChannelHandler(tcl_channel(fd, TCL_READABLE), - FileProc, (ClientData) (Int_val(cbid))); - return Val_unit; -} - -CAMLprim value camltk_add_file_output(value fd, value cbid) -{ - CheckInit(); - Tcl_CreateChannelHandler(tcl_channel(fd, TCL_WRITABLE), - TCL_WRITABLE, - FileProc, (ClientData) (Int_val(cbid))); - return Val_unit; -} - -CAMLprim value camltk_rem_file_output(value fd, value cbid) -{ - Tcl_DeleteChannelHandler(tcl_channel(fd, TCL_WRITABLE), - FileProc, (ClientData) (Int_val(cbid))); - return Val_unit; -} - -#endif diff --git a/otherlibs/labltk/support/cltkImg.c b/otherlibs/labltk/support/cltkImg.c deleted file mode 100644 index 1debe822e5..0000000000 --- a/otherlibs/labltk/support/cltkImg.c +++ /dev/null @@ -1,115 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ -#include <string.h> -#include <tcl.h> -#include <tk.h> -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> -#include "camltk.h" - -/* - * Pixmap manipulation from OCaml : get the pixmap from an arbitrary photo - * image, and put it back in some (possibly other) image. - * TODO: other blits - * We use the same format of "internal" pixmap data as in Tk, that is - * 24 bits per pixel - */ - -CAMLprim value camltk_getimgdata (value imgname) /* ML */ -{ - CAMLparam1(imgname); - CAMLlocal1(res); - Tk_PhotoHandle ph; - Tk_PhotoImageBlock pib; - int code,size; - -#if (TK_MAJOR_VERSION < 8) - if (NULL == (ph = Tk_FindPhoto(String_val(imgname)))) - tk_error("no such image"); -#else - if (NULL == (ph = Tk_FindPhoto(cltclinterp, String_val(imgname)))) - tk_error("no such image"); -#endif - - code = Tk_PhotoGetImage(ph,&pib); /* never fails ? */ - size = pib.width * pib.height * pib.pixelSize; - res = alloc_string(size); - - /* no holes, default format ? */ - if ((pib.pixelSize == 3) && - (pib.pitch == (pib.width * pib.pixelSize)) && - (pib.offset[0] == 0) && - (pib.offset[1] == 1) && - (pib.offset[2] == 2)) { - memcpy(pib.pixelPtr, String_val(res),size); - CAMLreturn(res); - } else { - int y; /* varies from 0 to height - 1 */ - int yoffs = 0; /* byte offset of line in src */ - int yidx = 0; /* byte offset of line in dst */ - for (y=0; y<pib.height; y++,yoffs+=pib.pitch,yidx+=pib.width * 3) { - int x; /* varies from 0 to width - 1 */ - int xoffs = yoffs; /* byte offset of pxl in src */ - int xidx = yidx; /* byte offset of pxl in dst */ - for (x=0; x<pib.width; x++,xoffs+=pib.pixelSize,xidx+=3) { - Byte(res, xidx) = pib.pixelPtr[xoffs+pib.offset[0]]; - Byte(res, xidx + 1) = pib.pixelPtr[xoffs+pib.offset[1]]; - Byte(res, xidx + 2) = pib.pixelPtr[xoffs+pib.offset[2]]; - }; - } - CAMLreturn(res); - } -} - -CAMLprim void -camltk_setimgdata_native (value imgname, value pixmap, value x, value y, - value w, value h) /* ML */ -{ - Tk_PhotoHandle ph; - Tk_PhotoImageBlock pib; - int code; - -#if (TK_MAJOR_VERSION < 8) - if (NULL == (ph = Tk_FindPhoto(String_val(imgname)))) - tk_error("no such image"); -#else - if (NULL == (ph = Tk_FindPhoto(cltclinterp, String_val(imgname)))) - tk_error("no such image"); -#endif - - pib.pixelPtr = String_val(pixmap); - pib.width = Int_val(w); - pib.height = Int_val(h); - pib.pitch = pib.width * 3; - pib.pixelSize = 3; - pib.offset[0] = 0; - pib.offset[1] = 1; - pib.offset[2] = 2; - Tk_PhotoPutBlock(ph,&pib,Int_val(x),Int_val(y),Int_val(w),Int_val(h) -#if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 4 || TK_MAJOR_VERSION > 8) - , TK_PHOTO_COMPOSITE_SET -#endif - ); -} - -CAMLprim void camltk_setimgdata_bytecode(argv,argn) - value *argv; - int argn; -{ - camltk_setimgdata_native(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5]); -} diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c deleted file mode 100644 index 6a3a35641b..0000000000 --- a/otherlibs/labltk/support/cltkMain.c +++ /dev/null @@ -1,181 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <string.h> -#include <tcl.h> -#include <tk.h> -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> -#include <callback.h> -#include <signals.h> -#include <fail.h> -#ifdef HAS_UNISTD -#include <unistd.h> /* for R_OK */ -#endif -#include "camltk.h" - -#ifndef R_OK -#define R_OK 4 -#endif - -/* - * Dealing with signals: when a signal handler is defined in Caml, - * the actual execution of the signal handler upon reception of the - * signal is delayed until we are sure we are out of the GC. - * If a signal occurs during the MainLoop, we would have to wait - * the next event for the handler to be invoked. - * The following function will invoke a pending signal handler if any, - * and we put in on a regular timer. - */ - -#define SIGNAL_INTERVAL 300 - -int signal_events = 0; /* do we have a pending timer */ - -void invoke_pending_caml_signals (ClientData clientdata) -{ - signal_events = 0; - enter_blocking_section(); /* triggers signal handling */ - /* Rearm timer */ - Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL); - signal_events = 1; - leave_blocking_section(); -} - -/* Now the real Tk stuff */ - -Tk_Window cltk_mainWindow; - - -/* In slave mode, the interpreter *already* exists */ -int cltk_slave_mode = 0; - -/* Initialisation, based on tkMain.c */ -CAMLprim value camltk_opentk(value argv) -{ - CAMLparam1(argv); - CAMLlocal1(tmp); - char *argv0; - - /* argv must contain argv[0], the application command name */ - tmp = Val_unit; - - if ( argv == Val_int(0) ){ - failwith("camltk_opentk: argv is empty"); - } - argv0 = String_val( Field( argv, 0 ) ); - - if (!cltk_slave_mode) { - /* Create an interpreter, dies if error */ -#if TCL_MAJOR_VERSION >= 8 - Tcl_FindExecutable(String_val(argv0)); -#endif - cltclinterp = Tcl_CreateInterp(); - { - /* Register cltclinterp for use in other related extensions */ - value *interp = caml_named_value("cltclinterp"); - if (interp != NULL) - Store_field(*interp,0,copy_nativeint((long)cltclinterp)); - } - - if (Tcl_Init(cltclinterp) != TCL_OK) - tk_error(cltclinterp->result); - Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY); - - { /* Sets argv */ - int argc = 0; - - tmp = Field(argv, 1); /* starts from argv[1] */ - while ( tmp != Val_int(0) ) { - argc++; - tmp = Field(tmp, 1); - } - - if( argc != 0 ){ - int i; - char *args; - char **tkargv; - char argcstr[256]; /* string of argc */ - - tkargv = (char**)stat_alloc(sizeof( char* ) * argc ); - tmp = Field(argv, 1); /* starts from argv[1] */ - i = 0; - - while ( tmp != Val_int(0) ) { - tkargv[i] = String_val(Field(tmp, 0)); - tmp = Field(tmp, 1); - i++; - } - - sprintf( argcstr, "%d", argc ); - Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY); - args = Tcl_Merge(argc, tkargv); /* args must be freed by Tcl_Free */ - Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY); - Tcl_Free(args); - stat_free( tkargv ); - } - } - if (Tk_Init(cltclinterp) != TCL_OK) - tk_error(cltclinterp->result); - - /* Retrieve the main window */ - cltk_mainWindow = Tk_MainWindow(cltclinterp); - - if (NULL == cltk_mainWindow) - tk_error(cltclinterp->result); - - Tk_GeometryRequest(cltk_mainWindow,200,200); - } - - /* Create the camlcallback command */ - Tcl_CreateCommand(cltclinterp, - CAMLCB, CamlCBCmd, - (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL); - - /* This is required by "unknown" and thus autoload */ - Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - /* Our hack for implementing break in callbacks */ - Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY); - - /* Load the traditional rc file */ - { - char *home = getenv("HOME"); - if (home != NULL) { - char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2); - f[0]='\0'; - strcat(f, home); - strcat(f, "/"); - strcat(f, RCNAME); - if (0 == access(f,R_OK)) - if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { - stat_free(f); - tk_error(cltclinterp->result); - }; - stat_free(f); - } - } - - CAMLreturn(Val_unit); -} - -CAMLprim value camltk_finalize(value unit) /* ML */ -{ - Tcl_Finalize(); - return Val_unit; -} diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c deleted file mode 100644 index e9824b6e9e..0000000000 --- a/otherlibs/labltk/support/cltkMisc.c +++ /dev/null @@ -1,64 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <string.h> -#include <tcl.h> -#include <tk.h> -#include <mlvalues.h> -#include <memory.h> -#include "camltk.h" - -/* Parsing results */ -CAMLprim value camltk_splitlist (value v) -{ - int argc; - char **argv; - int result; - char *utf; - - CheckInit(); - - utf = caml_string_to_tcl(v); - /* argv is allocated by Tcl, to be freed by us */ - result = Tcl_SplitList(cltclinterp,utf,&argc,&argv); - switch(result) { - case TCL_OK: - { value res = copy_string_list(argc,argv); - Tcl_Free((char *)argv); /* only one large block was allocated */ - /* argv points into utf: utf must be freed after argv are freed */ - stat_free( utf ); - return res; - } - case TCL_ERROR: - default: - stat_free( utf ); - tk_error(cltclinterp->result); - } -} - -/* Copy a Caml string to the C heap. Should deallocate with stat_free */ -char *string_to_c(value s) -{ - int l = string_length(s); - char *res = stat_alloc(l + 1); - memmove (res, String_val (s), l); - res[l] = '\0'; - return res; -} - - diff --git a/otherlibs/labltk/support/cltkTimer.c b/otherlibs/labltk/support/cltkTimer.c deleted file mode 100644 index 21f1b15885..0000000000 --- a/otherlibs/labltk/support/cltkTimer.c +++ /dev/null @@ -1,45 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <tcl.h> -#include <tk.h> -#include <mlvalues.h> -#include <callback.h> -#include "camltk.h" - - -/* Basically the same thing as FileProc */ -void TimerProc (ClientData clientdata) -{ - callback2(*handler_code,Val_long(clientdata),Val_int(0)); -} - -CAMLprim value camltk_add_timer(value milli, value cbid) -{ - CheckInit(); - /* look at tkEvent.c , Tk_Token is an int */ - return (Val_int(Tcl_CreateTimerHandler(Int_val(milli), TimerProc, - (ClientData) (Int_val(cbid))))); -} - -CAMLprim value camltk_rem_timer(value token) -{ - Tcl_DeleteTimerHandler((Tcl_TimerToken) Int_val(token)); - return Val_unit; -} - diff --git a/otherlibs/labltk/support/cltkUtf.c b/otherlibs/labltk/support/cltkUtf.c deleted file mode 100644 index fd01bd15a4..0000000000 --- a/otherlibs/labltk/support/cltkUtf.c +++ /dev/null @@ -1,89 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <stdlib.h> -#include <string.h> - -#include <tcl.h> -#include <tk.h> -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#ifdef HAS_UNISTD -#include <unistd.h> -#endif -#include "camltk.h" - -#if (TCL_MAJOR_VERSION > 8 || \ - (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)) /* 8.1 */ -# define UTFCONVERSION -#endif - -#ifdef UTFCONVERSION - -char *external_to_utf( char *str ){ - char *res; - Tcl_DString dstr; - int length; - - Tcl_ExternalToUtfDString(NULL, str, strlen(str), &dstr); - length = Tcl_DStringLength(&dstr); - res = stat_alloc(length + 1); - memmove( res, Tcl_DStringValue(&dstr), length+1); - Tcl_DStringFree(&dstr); - - return res; -} - -char *utf_to_external( char *str ){ - char *res; - Tcl_DString dstr; - int length; - - Tcl_UtfToExternalDString(NULL, str, strlen(str), &dstr); - length = Tcl_DStringLength(&dstr); - res = stat_alloc(length + 1); - memmove( res, Tcl_DStringValue(&dstr), length+1); - Tcl_DStringFree(&dstr); - - return res; -} - -char *caml_string_to_tcl( value s ) -{ - return external_to_utf( String_val(s) ); -} - -value tcl_string_to_caml( char *s ) -{ - CAMLparam0(); - CAMLlocal1(res); - char *str; - - str = utf_to_external( s ); - res = copy_string(str); - stat_free(str); - CAMLreturn(res); -} - -#else - -char *caml_string_to_tcl(value s){ return string_to_c(s); } -value tcl_string_to_caml(char *s){ return copy_string(s); } - -#endif diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c deleted file mode 100644 index 83fedbafd4..0000000000 --- a/otherlibs/labltk/support/cltkVar.c +++ /dev/null @@ -1,128 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Alternative to tkwait variable */ -#include <string.h> -#include <tcl.h> -#include <tk.h> -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> -#include <callback.h> -#include "camltk.h" - -CAMLprim value camltk_getvar(value var) -{ - char *s; - char *stable_var = NULL; - CheckInit(); - - stable_var = string_to_c(var); - s = Tcl_GetVar(cltclinterp,stable_var, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); - stat_free(stable_var); - - if (s == NULL) - tk_error(cltclinterp->result); - else - return(tcl_string_to_caml(s)); -} - -CAMLprim value camltk_setvar(value var, value contents) -{ - char *s; - char *stable_var = NULL; - char *utf_contents; - CheckInit(); - - /* SetVar makes a copy of the contents. */ - /* In case we have write traces in Caml, it's better to make sure that - var doesn't move... */ - stable_var = string_to_c(var); - utf_contents = caml_string_to_tcl(contents); - s = Tcl_SetVar(cltclinterp,stable_var, utf_contents, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); - stat_free(stable_var); - if( s == utf_contents ){ - tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!"); - } - stat_free(utf_contents); - - if (s == NULL) - tk_error(cltclinterp->result); - else - return(Val_unit); -} - - -/* The appropriate type is -typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *part1, char *part2, int flags)); - */ -static char * tracevar(clientdata, interp, name1, name2, flags) - ClientData clientdata; - Tcl_Interp *interp; /* Interpreter containing variable. */ - char *name1; /* Name of variable. */ - char *name2; /* Second part of variable name. */ - int flags; /* Information about what happened. */ -{ - Tcl_UntraceVar2(interp, name1, name2, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - tracevar, clientdata); - callback2(*handler_code,Val_int(clientdata),Val_unit); - return (char *)NULL; -} - -/* Sets up a callback upon modification of a variable */ -CAMLprim value camltk_trace_var(value var, value cbid) -{ - char *cvar = NULL; - - CheckInit(); - /* Make a copy of var, since Tcl will modify it in place, and we - * don't trust that much what it will do here - */ - cvar = string_to_c(var); - if (Tcl_TraceVar(cltclinterp, cvar, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - tracevar, - (ClientData) (Long_val(cbid))) - != TCL_OK) { - stat_free(cvar); - tk_error(cltclinterp->result); - }; - stat_free(cvar); - return Val_unit; -} - -CAMLprim value camltk_untrace_var(value var, value cbid) -{ - char *cvar = NULL; - - CheckInit(); - /* Make a copy of var, since Tcl will modify it in place, and we - * don't trust that much what it will do here - */ - cvar = string_to_c(var); - Tcl_UntraceVar(cltclinterp, cvar, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - tracevar, - (ClientData) (Long_val(cbid))); - stat_free(cvar); - return Val_unit; -} diff --git a/otherlibs/labltk/support/cltkWait.c b/otherlibs/labltk/support/cltkWait.c deleted file mode 100644 index 7c3cef53fd..0000000000 --- a/otherlibs/labltk/support/cltkWait.c +++ /dev/null @@ -1,102 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <tcl.h> -#include <tk.h> -#include <mlvalues.h> -#include <memory.h> -#include <callback.h> -#include "camltk.h" - -/* The following are replacements for - tkwait visibility - tkwait window - in the case where we use threads (tkwait internally calls an event loop, - and thus prevents thread scheduling from taking place). - - Instead, one should set up a callback, wait for a signal, and signal - from inside the callback -*/ - -static void WaitVisibilityProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -static void WaitWindowProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); - -/* For the other handlers, we need a bit more data */ -struct WinCBData { - int cbid; - Tk_Window win; -}; - -static void WaitVisibilityProc(clientData, eventPtr) - ClientData clientData; - XEvent *eventPtr; /* Information about event (not used). */ -{ - struct WinCBData *vis = clientData; - value cbid = Val_int(vis->cbid); - - Tk_DeleteEventHandler(vis->win, VisibilityChangeMask, - WaitVisibilityProc, clientData); - - stat_free((char *)vis); - callback2(*handler_code,cbid,Val_int(0)); -} - -/* Sets up a callback upon Visibility of a window */ -CAMLprim value camltk_wait_vis(value win, value cbid) -{ - struct WinCBData *vis = - (struct WinCBData *)stat_alloc(sizeof(struct WinCBData)); - vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); - if (vis -> win == NULL) { - stat_free((char *)vis); - tk_error(cltclinterp->result); - }; - vis->cbid = Int_val(cbid); - Tk_CreateEventHandler(vis->win, VisibilityChangeMask, - WaitVisibilityProc, (ClientData) vis); - return Val_unit; -} - -static void WaitWindowProc(ClientData clientData, XEvent *eventPtr) -{ - if (eventPtr->type == DestroyNotify) { - struct WinCBData *vis = clientData; - value cbid = Val_int(vis->cbid); - stat_free((char *)clientData); - /* The handler is destroyed by Tk itself */ - callback2(*handler_code,cbid,Val_int(0)); - } -} - -/* Sets up a callback upon window destruction */ -CAMLprim value camltk_wait_des(value win, value cbid) -{ - struct WinCBData *vis = - (struct WinCBData *)stat_alloc(sizeof(struct WinCBData)); - vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); - if (vis -> win == NULL) { - stat_free((char *)vis); - tk_error(cltclinterp->result); - }; - vis->cbid = Int_val(cbid); - Tk_CreateEventHandler(vis->win, StructureNotifyMask, - WaitWindowProc, (ClientData) vis); - return Val_unit; -} diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml deleted file mode 100644 index 9d985147c9..0000000000 --- a/otherlibs/labltk/support/fileevent.ml +++ /dev/null @@ -1,81 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Unix -open Support -open Protocol - -external add_file_input : file_descr -> cbid -> unit - = "camltk_add_file_input" -external rem_file_input : file_descr -> cbid -> unit - = "camltk_rem_file_input" -external add_file_output : file_descr -> cbid -> unit - = "camltk_add_file_output" -external rem_file_output : file_descr -> cbid -> unit - = "camltk_rem_file_output" - -(* File input handlers *) - -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 id (fun _ -> f()); - Hashtbl.add fd_table (fd, 'r') id; - if !Protocol.debug then begin - Protocol.prerr_cbid id; prerr_endline " for fileinput" - end; - add_file_input fd id - -let remove_fileinput ~fd = - try - let id = Hashtbl.find fd_table (fd, 'r') in - clear_callback id; - Hashtbl.remove fd_table (fd, 'r'); - if !Protocol.debug then begin - prerr_string "clear "; - Protocol.prerr_cbid id; - prerr_endline " for fileinput" - end; - rem_file_input fd id - with - Not_found -> () - -let add_fileoutput ~fd ~callback:f = - let id = new_function_id () in - Hashtbl.add callback_naming_table id (fun _ -> f()); - Hashtbl.add fd_table (fd, 'w') id; - if !Protocol.debug then begin - Protocol.prerr_cbid id; prerr_endline " for fileoutput" - end; - add_file_output fd id - -let remove_fileoutput ~fd = - try - let id = Hashtbl.find fd_table (fd, 'w') in - clear_callback id; - Hashtbl.remove fd_table (fd, 'w'); - if !Protocol.debug then begin - prerr_string "clear "; - Protocol.prerr_cbid id; - prerr_endline " for fileoutput" - end; - rem_file_output fd id - with - Not_found -> () - diff --git a/otherlibs/labltk/support/fileevent.mli b/otherlibs/labltk/support/fileevent.mli deleted file mode 100644 index 34760f0c7e..0000000000 --- a/otherlibs/labltk/support/fileevent.mli +++ /dev/null @@ -1,25 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Unix - -val add_fileinput : fd:file_descr -> callback:(unit -> unit) -> unit -val remove_fileinput: fd:file_descr -> unit -val add_fileoutput : fd:file_descr -> callback:(unit -> unit) -> unit -val remove_fileoutput: fd:file_descr -> unit - (* see [tk] module *) diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml deleted file mode 100644 index 6e3208cfe7..0000000000 --- a/otherlibs/labltk/support/protocol.ml +++ /dev/null @@ -1,276 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Support -open Widget - -type callback_buffer = string list - (* Buffer for reading callback arguments *) - -type tkArgs = - TkToken of string - | TkTokenList of tkArgs list (* to be expanded *) - | TkQuote of tkArgs (* mapped to Tcl list *) - -type cbid = int - -external opentk_low : string list -> unit - = "camltk_opentk" -external tcl_eval : string -> string - = "camltk_tcl_eval" -external tk_mainloop : unit -> unit - = "camltk_tk_mainloop" -external tcl_direct_eval : tkArgs array -> string - = "camltk_tcl_direct_eval" -external splitlist : string -> string list - = "camltk_splitlist" -external tkreturn : string -> unit - = "camltk_return" -external callback_init : unit -> unit - = "camltk_init" -external finalizeTk : unit -> unit - = "camltk_finalize" - (* Finalize tcl/tk before exiting. This function will be automatically - called when you call [Pervasives.exit ()] (This is installed at - [install_cleanup ()] *) - -let tcl_command s = ignore (tcl_eval s);; - -exception TkError of string - (* Raised by the communication functions *) -let () = Callback.register_exception "tkerror" (TkError "") - -let cltclinterp = ref Nativeint.zero - (* For use in other extensions *) -let () = Callback.register "cltclinterp" cltclinterp - -(* Debugging support *) -let debug = - ref (try ignore (Sys.getenv "CAMLTKDEBUG"); true - with Not_found -> false) - -(* This is approximative, since we don't quote what needs to be quoted *) -let dump_args args = - let rec print_arg = function - TkToken s -> prerr_string s; prerr_string " " - | TkTokenList l -> List.iter print_arg l - | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} " - in - Array.iter print_arg args; - prerr_newline() - -(* - * Evaluating Tcl code - * debugging support should not affect performances... - *) - -let tkEval args = - if !debug then dump_args args; - let res = tcl_direct_eval args in - if !debug then begin - prerr_string "->>"; - prerr_endline res - end; - res - -let tkCommand args = ignore (tkEval args) - -(* - * Callbacks - *) - -(* LablTk only *) -let cCAMLtoTKwidget w = - (* Widget.check_class w table; (* with subtyping, it is redundant *) *) - TkToken (Widget.name w) - -let cTKtoCAMLwidget = function - "" -> raise (Invalid_argument "cTKtoCAMLwidget") - | s -> Widget.get_atom s - -let callback_naming_table = - (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t) - -let callback_memo_table = - (Hashtbl.create 401 : (any widget, int) Hashtbl.t) - -let new_function_id = - let counter = ref 0 in - function () -> incr counter; !counter - -let string_of_cbid = string_of_int - -(* Add a new callback, associated to widget w *) -(* 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 id f; - if (forget_type w) <> (forget_type Widget.dummy) then - Hashtbl.add callback_memo_table (forget_type w) id; - (string_of_cbid id) - -let clear_callback id = - Hashtbl.remove callback_naming_table id - -(* Clear callbacks associated to a given widget *) -let remove_callbacks w = - let w = forget_type w in - let cb_ids = Hashtbl.find_all callback_memo_table w in - List.iter clear_callback cb_ids; - for i = 1 to List.length cb_ids do - Hashtbl.remove callback_memo_table w - done - -(* Hand-coded callback for destroyed widgets - * This may be extended by the application, or by other layers of Camltk. - * Could use bind + of Tk, but I'd rather give an alternate mechanism so - * that hooks can be set up at load time (i.e. before openTk) - *) -let destroy_hooks = ref [] -let add_destroy_hook f = - destroy_hooks := f :: !destroy_hooks - -let _ = - add_destroy_hook (fun w -> remove_callbacks w; Widget.remove w) - -let install_cleanup () = - let call_destroy_hooks = function - [wname] -> - let w = cTKtoCAMLwidget wname in - List.iter (fun f -> f w) !destroy_hooks - | _ -> raise (TkError "bad cleanup callback") in - let fid = new_function_id () in - Hashtbl.add callback_naming_table fid call_destroy_hooks; - (* setup general destroy callback *) - tcl_command ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}"); - at_exit finalizeTk - -let prerr_cbid id = - prerr_string "camlcb "; prerr_int id - -(* The callback dispatch function *) -let dispatch_callback id args = - if !debug then begin - prerr_cbid id; - List.iter (fun x -> prerr_string " "; prerr_string x) args; - prerr_newline() - end; - (Hashtbl.find callback_naming_table id) args; - if !debug then prerr_endline "<<-" - -let protected_dispatch id args = - try - dispatch_callback id args - with - | e -> - try - Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e); - flush stderr; - (* raise x *) - with - Out_of_memory -> raise Out_of_memory - | Sys.Break -> raise Sys.Break - -let _ = Callback.register "camlcb" protected_dispatch - -(* Make sure the C variables are initialised *) -let _ = callback_init () - -(* Different version of initialisation functions *) -let default_display_name = ref "" -let default_display () = !default_display_name - -let camltk_argv = ref [] - -(* options for Arg.parse *) -let keywords = [ - "-display", Arg.String (fun s -> - camltk_argv := "-display" :: s :: !camltk_argv), - "<disp> : X server to contact (CamlTk)"; - "-colormap", Arg.String (fun s -> - camltk_argv := "-colormap" :: s :: !camltk_argv), - "<colormap> : colormap to use (CamlTk)"; - "-geometry", Arg.String (fun s -> - camltk_argv := "-geometry" :: s :: !camltk_argv), - "<geom> : size and position (CamlTk)"; - "-name", Arg.String (fun s -> - camltk_argv := "-name" :: s :: !camltk_argv), - "<name> : application class (CamlTk)"; - "-sync", Arg.Unit (fun () -> - camltk_argv := "-sync" :: !camltk_argv), - ": sync mode (CamlTk)"; - "-use", Arg.String (fun s -> - camltk_argv := "-use" :: s :: !camltk_argv), - "<id> : parent window id (CamlTk)"; - "-window", Arg.String (fun s -> - camltk_argv := "-use" :: s :: !camltk_argv), - "<id> : parent window id (CamlTk)"; - "-visual", Arg.String (fun s -> - camltk_argv := "-visual" :: s :: !camltk_argv), - "<visual> : visual to use (CamlTk)" ] - -let opentk_with_args argv (* = [argv1;..;argvn] *) = - (* argv must be command line for wish *) - let argv0 = Sys.argv.(0) in - let rec find_display = function - | "-display" :: s :: xs -> s - | "-colormap" :: s :: xs -> find_display xs - | "-geometry" :: s :: xs -> find_display xs - | "-name" :: s :: xs -> find_display xs - | "-sync" :: xs -> find_display xs - | "-use" :: s :: xs -> find_display xs - | "-window" :: s :: xs -> find_display xs - | "-visual" :: s :: xs -> find_display xs - | "--" :: _ -> "" - | _ :: xs -> find_display xs - | [] -> "" - in - default_display_name := find_display argv; - opentk_low (argv0 :: argv); - install_cleanup(); - Widget.default_toplevel - -let opentk () = opentk_with_args !camltk_argv;; - -let openTkClass s = opentk_with_args ["-name"; s] -let openTkDisplayClass disp cl = opentk_with_args ["-display"; disp; "-name"; cl] - -(*JPF CAMLTK/LABLTK? *) -let openTk ?(display = "") ?(clas = "LablTk") () = - let dispopt = - match display with - | "" -> [] - | _ -> ["-display"; display] - in - opentk_with_args (dispopt @ ["-name"; clas]) - -(* Destroy all widgets, thus cleaning up table and exiting the loop *) -let closeTk () = - tcl_command "destroy ." - -let mainLoop = - tk_mainloop - - -(* [register tclname f] makes [f] available from Tcl with - name [tclname] *) -let register tclname ~callback = - let s = register_callback Widget.default_toplevel ~callback in - tcl_command (Printf.sprintf "proc %s {args} {eval {camlcb %s} $args}" - tclname s) - diff --git a/otherlibs/labltk/support/protocol.mli b/otherlibs/labltk/support/protocol.mli deleted file mode 100644 index fe3ff794f8..0000000000 --- a/otherlibs/labltk/support/protocol.mli +++ /dev/null @@ -1,115 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Widget - -(* Lower level interface *) -exception TkError of string - (* Raised by the communication functions *) - -val debug : bool ref - (* When set to true, displays approximation of intermediate Tcl code *) - -type tkArgs = - TkToken of string - | TkTokenList of tkArgs list (* to be expanded *) - | TkQuote of tkArgs (* mapped to Tcl list *) - - -(* Misc *) -external splitlist : string -> string list - = "camltk_splitlist" - -val add_destroy_hook : (any widget -> unit) -> unit - - -(* Opening, closing, and mainloop *) -val default_display : unit -> string - -val opentk : unit -> toplevel widget - (* The basic initialization function. *) - -val keywords : (string * Arg.spec * string) list - (* Command line parsing specification for Arg.parse, which contains - the standard Tcl/Tk command line options such as "-display" and "-name". - Add [keywords] to a [Arg.parse] call, then call [opentk]. - Then [opentk] can make use of these command line options - to initiate applications. *) - -val opentk_with_args : string list -> toplevel widget - (* [opentk_with_args] is a lower level interface to initiate Tcl/Tk - applications. [opentk_with_args argv] initializes Tcl/Tk with - the command line options given by [argv] *) - -val openTk : ?display:string -> ?clas:string -> unit -> toplevel widget - (* [openTk ~display:display ~clas:clas ()] is equivalent to - [opentk_with_args ["-display"; display; "-name"; clas]] *) - -(* Legacy opentk functions *) -val openTkClass: string -> toplevel widget - (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *) -val openTkDisplayClass: string -> string -> toplevel widget - (* [openTkDisplayClass disp class] is equivalent to - [opentk ["-display"; disp; "-name"; class]] *) - -val closeTk : unit -> unit -val finalizeTk : unit -> unit - (* Finalize tcl/tk before exiting. This function will be automatically - called when you call [Pervasives.exit ()] *) - -val mainLoop : unit -> unit - - -(* Direct evaluation of tcl code *) -val tkEval : tkArgs array -> string - -val tkCommand : tkArgs array -> unit - -(* Returning a value from a Tcl callback *) -val tkreturn: string -> unit - - -(* Callbacks: this is private *) - -type cbid - -type callback_buffer = string list - (* Buffer for reading callback arguments *) - -val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t -val callback_memo_table : (any widget, cbid) Hashtbl.t - (* Exported for debug purposes only. Don't use them unless you - know what you are doing *) -val new_function_id : unit -> cbid -val string_of_cbid : cbid -> string -val register_callback : 'a widget -> callback:(callback_buffer -> unit) -> string - (* Callback support *) -val clear_callback : cbid -> unit - (* Remove a given callback from the table *) -val remove_callbacks : 'a widget -> unit - (* Clean up callbacks associated to widget. Must be used only when - the Destroy event is bind by the user and masks the default - Destroy event binding *) - -val cTKtoCAMLwidget : string -> any widget -val cCAMLtoTKwidget : 'a widget -> tkArgs - -val register : string -> callback:(callback_buffer -> unit) -> unit - -(*-*) -val prerr_cbid : cbid -> unit diff --git a/otherlibs/labltk/support/rawwidget.ml b/otherlibs/labltk/support/rawwidget.ml deleted file mode 100644 index 8eba3b8b14..0000000000 --- a/otherlibs/labltk/support/rawwidget.ml +++ /dev/null @@ -1,176 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Support - -(* - * Widgets - *) - -exception IllegalWidgetType of string - (* Raised when widget command applied illegally*) - -(***************************************************) -(* Widgets *) -(* This 'a raw_widget will be 'a Widget.widget *) -(***************************************************) -type 'a raw_widget = - Untyped of string -| Typed of string * string - -type raw_any (* will be Widget.any *) -and button -and canvas -and checkbutton -and entry -and frame -and label -and listbox -and menu -and menubutton -and message -and radiobutton -and scale -and scrollbar -and text -and toplevel - -let forget_type w = (Obj.magic (w : 'a raw_widget) : raw_any raw_widget) -let coe = forget_type - -(* table of widgets *) -let table = (Hashtbl.create 401 : (string, raw_any raw_widget) Hashtbl.t) - -let name = function - Untyped s -> s - | Typed (s,_) -> s - -(* Normally all widgets are known *) -(* this is a provision for send commands to external tk processes *) -let known_class = function - Untyped _ -> "unknown" - | Typed (_,c) -> c - -(* This one is always created by opentk *) -let default_toplevel = - let wname = "." in - let w = Typed (wname, "toplevel") in - Hashtbl.add table wname w; - w - -(* Dummy widget to which global callbacks are associated *) -(* also passed around by camltotkoption when no widget in context *) -let dummy = - Untyped "dummy" - -let remove w = - Hashtbl.remove table (name w) - -(* Retype widgets returned from Tk *) -(* JPF report: sometime s is "", see Protocol.cTKtoCAMLwidget *) -let get_atom s = - try - Hashtbl.find table s - with - Not_found -> Untyped s - -let naming_scheme = [ - "button", "b"; - "canvas", "ca"; - "checkbutton", "cb"; - "entry", "en"; - "frame", "f"; - "label", "l"; - "listbox", "li"; - "menu", "me"; - "menubutton", "mb"; - "message", "ms"; - "radiobutton", "rb"; - "scale", "sc"; - "scrollbar", "sb"; - "text", "t"; - "toplevel", "top" ] - - -let widget_any_table = List.map fst naming_scheme -(* subtypes *) -let widget_button_table = [ "button" ] -and widget_canvas_table = [ "canvas" ] -and widget_checkbutton_table = [ "checkbutton" ] -and widget_entry_table = [ "entry" ] -and widget_frame_table = [ "frame" ] -and widget_label_table = [ "label" ] -and widget_listbox_table = [ "listbox" ] -and widget_menu_table = [ "menu" ] -and widget_menubutton_table = [ "menubutton" ] -and widget_message_table = [ "message" ] -and widget_radiobutton_table = [ "radiobutton" ] -and widget_scale_table = [ "scale" ] -and widget_scrollbar_table = [ "scrollbar" ] -and widget_text_table = [ "text" ] -and widget_toplevel_table = [ "toplevel" ] - -let new_suffix clas n = - try - (List.assoc clas naming_scheme) ^ (string_of_int n) - with - Not_found -> "w" ^ (string_of_int n) - -(* The function called by generic creation *) -let counter = ref 0 -let new_atom ~parent ?name:nom clas = - let parentpath = name parent in - let path = - match nom with - None -> - incr counter; - if parentpath = "." - then "." ^ (new_suffix clas !counter) - else parentpath ^ "." ^ (new_suffix clas !counter) - | Some name -> - if parentpath = "." - then "." ^ name - else parentpath ^ "." ^ name - in - let w = Typed(path,clas) in - Hashtbl.add table path w; - w - -(* Just create a path. Only to check existence of widgets *) -(* Use with care *) -let atom ~parent ~name:pathcomp = - let parentpath = name parent in - let path = - if parentpath = "." - then "." ^ pathcomp - else parentpath ^ "." ^ pathcomp in - Untyped path - -(* LablTk: Redundant with subtyping of Widget, backward compatibility *) -let check_class w clas = - match w with - Untyped _ -> () (* assume run-time check by tk*) - | Typed(_,c) -> - if List.mem c clas then () - else raise (IllegalWidgetType c) - - -(* Checking membership of constructor in subtype table *) -let chk_sub errname table c = - if List.mem c table then () - else raise (Invalid_argument errname) diff --git a/otherlibs/labltk/support/rawwidget.mli b/otherlibs/labltk/support/rawwidget.mli deleted file mode 100644 index 7a7857dc7e..0000000000 --- a/otherlibs/labltk/support/rawwidget.mli +++ /dev/null @@ -1,109 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Support for widget manipulations *) - -type 'a raw_widget - (* widget is an abstract type *) - -type raw_any -and button -and canvas -and checkbutton -and entry -and frame -and label -and listbox -and menu -and menubutton -and message -and radiobutton -and scale -and scrollbar -and text -and toplevel - -val forget_type : 'a raw_widget -> raw_any raw_widget -val coe : 'a raw_widget -> raw_any raw_widget - -val default_toplevel : toplevel raw_widget - (* [default_toplevel] is "." in Tk, the toplevel widget that is - always existing during a Tk session. Destroying [default_toplevel] - ends the main loop - *) - -val atom : parent: 'a raw_widget -> name: string -> raw_any raw_widget - (* [atom parent name] returns the widget [parent.name]. The widget is - not created. Only its name is returned. In a given parent, there may - only exist one children for a given name. - This function should only be used to check the existence of a widget - with a known name. It doesn't add the widget to the internal tables - of CamlTk. - *) - -val name : 'a raw_widget -> string - (* [name w] returns the name (tk "path") of a widget *) - -(*--*) -(* The following functions are used internally. - There is normally no need for them in users programs - *) - -val known_class : 'a raw_widget -> string - (* [known_class w] returns the class of a widget (e.g. toplevel, frame), - as known by the CamlTk interface. - Not equivalent to "winfo w" in Tk. - *) - -val dummy : raw_any raw_widget - (* [dummy] is a widget used as context when we don't have any. - It is *not* a real widget. - *) - -val new_atom : parent:'a raw_widget -> ?name: string -> string -> 'b raw_widget - -val get_atom : string -> raw_any raw_widget - (* [get_atom path] returns the widget with Tk path [path] *) - -val remove : 'a raw_widget -> unit - (* [remove w] removes widget from the internal tables *) - -(* Subtypes tables *) -val widget_any_table : string list -val widget_button_table : string list -val widget_canvas_table : string list -val widget_checkbutton_table : string list -val widget_entry_table : string list -val widget_frame_table : string list -val widget_label_table : string list -val widget_listbox_table : string list -val widget_menu_table : string list -val widget_menubutton_table : string list -val widget_message_table : string list -val widget_radiobutton_table : string list -val widget_scale_table : string list -val widget_scrollbar_table : string list -val widget_text_table : string list -val widget_toplevel_table : string list - -val chk_sub : string -> 'a list -> 'a -> unit -val check_class : 'a raw_widget -> string list -> unit - (* Widget subtyping *) - -exception IllegalWidgetType of string - (* Raised when widget command applied illegally*) diff --git a/otherlibs/labltk/support/slave.ml b/otherlibs/labltk/support/slave.ml deleted file mode 100644 index b994fe17e7..0000000000 --- a/otherlibs/labltk/support/slave.ml +++ /dev/null @@ -1,51 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* The code run on initialisation, in addition to normal Tk code - * NOTE: camltk has not fully been initialised yet - *) -external tcl_eval : string -> string - = "camltk_tcl_eval" -let tcl_command s = ignore (tcl_eval s);; -open Printf - -let dynload args = - List.iter Dynlink.loadfile args - -(* Default modules include everything from -let default_modules = [] -*) - -(* [caml::run foo.cmo .. bar.cmo] is now available from Tcl *) -let init () = - Dynlink.init(); - (* Make it unsafe by default, with everything available *) - Dynlink.allow_unsafe_modules true; - Dynlink.add_interfaces [] []; - let s = register_callback Widget.dummy dynload in - tcl_command (sprintf "proc caml::run {l} {camlcb %s l}" s) - -let _ = - Printexc.print init () - -(* A typical master program would then - * caml::run foo.cmo - * # during initialisation, "foo" was registered as a tcl procedure - * foo x y z - * # proceed with some Tcl code calling foo - *) diff --git a/otherlibs/labltk/support/support.ml b/otherlibs/labltk/support/support.ml deleted file mode 100644 index c8bebc2fc7..0000000000 --- a/otherlibs/labltk/support/support.ml +++ /dev/null @@ -1,48 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Parsing results of Tcl *) -(* List.split a string according to char_sep predicate *) -let split_str ~pred:char_sep str = - let len = String.length str in - let rec skip_sep cur = - if cur >= len then cur - else if char_sep str.[cur] then skip_sep (succ cur) - else cur in - let rec split beg cur = - if cur >= len then - if beg = cur then [] - else [String.sub str beg (len - beg)] - else if char_sep str.[cur] - then - let nextw = skip_sep cur in - (String.sub str beg (cur - beg)) - ::(split nextw nextw) - else split beg (succ cur) in - let wstart = skip_sep 0 in - split wstart wstart - -(* Very easy hack for option type *) -let may f = function - Some x -> Some (f x) -| None -> None - -let maycons f x l = - match x with - Some x -> f x :: l - | None -> l diff --git a/otherlibs/labltk/support/support.mli b/otherlibs/labltk/support/support.mli deleted file mode 100644 index 95a2255cb5..0000000000 --- a/otherlibs/labltk/support/support.mli +++ /dev/null @@ -1,21 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -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 diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml deleted file mode 100644 index 4581976b5d..0000000000 --- a/otherlibs/labltk/support/textvariable.ml +++ /dev/null @@ -1,152 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Support -open Protocol - -external internal_tracevar : string -> cbid -> unit - = "camltk_trace_var" -external internal_untracevar : string -> cbid -> unit - = "camltk_untrace_var" -external set : string -> string -> unit = "camltk_setvar" -external get : string -> string = "camltk_getvar" - - -type textVariable = string - -(* List of handles *) -let handles = Hashtbl.create 401 - -let add_handle var cbid = - try - let r = Hashtbl.find handles var in - r := cbid :: !r - with - Not_found -> - Hashtbl.add handles var (ref [cbid]) - -let exceptq x = - let rec ex acc = function - [] -> acc - | y::l when y == x -> ex acc l - | y::l -> ex (y::acc) l - in - ex [] - -let rem_handle var cbid = - try - let r = Hashtbl.find handles var in - match exceptq cbid !r with - [] -> Hashtbl.remove handles var - | remaining -> r := remaining - with - Not_found -> () - -(* Used when we "free" the variable (otherwise, old handlers would apply to - * new usage of the variable) - *) -let rem_all_handles var = - try - let r = Hashtbl.find handles var in - List.iter (internal_untracevar var) !r; - Hashtbl.remove handles var - with - Not_found -> () - - -(* Variable trace *) -let handle vname ~callback:f = - let id = new_function_id() in - let wrapped _ = - clear_callback id; - rem_handle vname id; - f() in - Hashtbl.add callback_naming_table id wrapped; - add_handle vname id; - if !Protocol.debug then begin - prerr_cbid id; prerr_string " for variable "; prerr_endline vname - end; - internal_tracevar vname id - -(* Avoid space leak (all variables are global in Tcl) *) -module StringSet = - Set.Make(struct type t = string let compare = compare end) -let freelist = ref (StringSet.empty) -let memo = Hashtbl.create 101 - -(* Added a variable v referenced by widget w *) -let add w v = - let w = Widget.forget_type w in - let r = - try Hashtbl.find memo w - with - Not_found -> - let r = ref StringSet.empty in - Hashtbl.add memo w r; - r in - r := StringSet.add v !r - -(* to be used with care ! *) -let free v = - rem_all_handles v; - freelist := StringSet.add v !freelist - -(* Free variables associated with a widget *) -let freew w = - try - let r = Hashtbl.find memo w in - StringSet.iter free !r; - Hashtbl.remove memo w - with - Not_found -> () - -let _ = add_destroy_hook freew - -(* Allocate a new variable *) -let counter = ref 0 -let getv () = - let v = - if StringSet.is_empty !freelist then begin - incr counter; - "camlv("^ string_of_int !counter ^")" - end - else - let v = StringSet.choose !freelist in - freelist := StringSet.remove v !freelist; - v in - set v ""; - v - -let create ?on: w () = - let v = getv() in - begin - match w with - Some w -> add w v - | None -> () - end; - v - -(* to be used with care ! *) -let free v = - freelist := StringSet.add v !freelist - -let cCAMLtoTKtextVariable s = TkToken s - -let name s = s -let coerce s = s - diff --git a/otherlibs/labltk/support/textvariable.mli b/otherlibs/labltk/support/textvariable.mli deleted file mode 100644 index 09a19148a1..0000000000 --- a/otherlibs/labltk/support/textvariable.mli +++ /dev/null @@ -1,45 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Support for Tk -textvariable option *) -open Widget -open Protocol - -type textVariable - (* TextVariable is an abstract type *) - -val create : ?on: 'a widget -> unit -> textVariable - (* Allocation of a textVariable with lifetime associated to widget - if a widget is specified *) -val set : textVariable -> string -> unit - (* Setting the val of a textVariable *) -val get : textVariable -> string - (* Reading the val of a textVariable *) -val name : textVariable -> string - (* Its tcl name *) - -val cCAMLtoTKtextVariable : textVariable -> tkArgs - (* Internal conversion function *) - -val handle : textVariable -> callback:(unit -> unit) -> unit - (* Callbacks on variable modifications *) - -val coerce : string -> textVariable - -(*-*) -val free : textVariable -> unit diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml deleted file mode 100644 index ada8100fd2..0000000000 --- a/otherlibs/labltk/support/timer.ml +++ /dev/null @@ -1,58 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Timers *) -open Support -open Protocol - -type tkTimer = int - -external internal_add_timer : int -> cbid -> tkTimer - = "camltk_add_timer" -external internal_rem_timer : tkTimer -> unit - = "camltk_rem_timer" - -type t = tkTimer * cbid (* the token and the cb id *) - -(* A timer is used only once, so we must clean the callback table *) -let add ~ms ~callback = - if !Protocol.debug then begin - prerr_string "Timer.add "; flush stderr; - end; - let id = new_function_id () in - if !Protocol.debug then begin - prerr_string "id="; prerr_cbid id; flush stderr; - end; - let wrapped _ = - clear_callback id; (* do it first in case f raises exception *) - callback() in - Hashtbl.add callback_naming_table id wrapped; - let t = internal_add_timer ms id in - if !Protocol.debug then begin - prerr_endline " done" - end; - t,id - -let set ~ms ~callback = ignore (add ~ms ~callback);; - -(* If the timer has never been used, there is a small space leak in - the C heap, where a copy of id has been stored *) -let remove (tkTimer, id) = - internal_rem_timer tkTimer; - clear_callback id - diff --git a/otherlibs/labltk/support/timer.mli b/otherlibs/labltk/support/timer.mli deleted file mode 100644 index a45e1c9d22..0000000000 --- a/otherlibs/labltk/support/timer.mli +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type t - -val add : ms:int -> callback:(unit -> unit) -> t -val set : ms:int -> callback:(unit -> unit) -> unit -val remove : t -> unit diff --git a/otherlibs/labltk/support/tkwait.ml b/otherlibs/labltk/support/tkwait.ml deleted file mode 100644 index 2574928c0f..0000000000 --- a/otherlibs/labltk/support/tkwait.ml +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -external internal_tracevis : string -> string -> unit - = "camltk_wait_vis" -external internal_tracedestroy : string -> string -> unit - = "camltk_wait_des" diff --git a/otherlibs/labltk/support/widget.ml b/otherlibs/labltk/support/widget.ml deleted file mode 100644 index 65e0d26a9e..0000000000 --- a/otherlibs/labltk/support/widget.ml +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Hack to permit having the different data type with the same name - [widget] for CamlTk and LablTk. *) -include Rawwidget -type 'a widget = 'a raw_widget -type any = raw_any diff --git a/otherlibs/labltk/support/widget.mli b/otherlibs/labltk/support/widget.mli deleted file mode 100644 index fd3b461c2b..0000000000 --- a/otherlibs/labltk/support/widget.mli +++ /dev/null @@ -1,109 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Support for widget manipulations *) - -type 'a widget = 'a Rawwidget.raw_widget - (* widget is an abstract type *) - -type any = Rawwidget.raw_any -and button -and canvas -and checkbutton -and entry -and frame -and label -and listbox -and menu -and menubutton -and message -and radiobutton -and scale -and scrollbar -and text -and toplevel - -val forget_type : 'a widget -> any widget -val coe : 'a widget -> any widget - -val default_toplevel : toplevel widget - (* [default_toplevel] is "." in Tk, the toplevel widget that is - always existing during a Tk session. Destroying [default_toplevel] - ends the main loop - *) - -val atom : parent: 'a widget -> name: string -> any widget - (* [atom parent name] returns the widget [parent.name]. The widget is - not created. Only its name is returned. In a given parent, there may - only exist one children for a given name. - This function should only be used to check the existence of a widget - with a known name. It doesn't add the widget to the internal tables - of CamlTk. - *) - -val name : 'a widget -> string - (* [name w] returns the name (tk "path") of a widget *) - -(*--*) -(* The following functions are used internally. - There is normally no need for them in users programs - *) - -val known_class : 'a widget -> string - (* [known_class w] returns the class of a widget (e.g. toplevel, frame), - as known by the CamlTk interface. - Not equivalent to "winfo w" in Tk. - *) - -val dummy : any widget - (* [dummy] is a widget used as context when we don't have any. - It is *not* a real widget. - *) - -val new_atom : parent:'a widget -> ?name: string -> string -> 'b widget - -val get_atom : string -> any widget - (* [get_atom path] returns the widget with Tk path [path] *) - -val remove : 'a widget -> unit - (* [remove w] removes widget from the internal tables *) - -(* Subtypes tables *) -val widget_any_table : string list -val widget_button_table : string list -val widget_canvas_table : string list -val widget_checkbutton_table : string list -val widget_entry_table : string list -val widget_frame_table : string list -val widget_label_table : string list -val widget_listbox_table : string list -val widget_menu_table : string list -val widget_menubutton_table : string list -val widget_message_table : string list -val widget_radiobutton_table : string list -val widget_scale_table : string list -val widget_scrollbar_table : string list -val widget_text_table : string list -val widget_toplevel_table : string list - -val chk_sub : string -> 'a list -> 'a -> unit -val check_class : 'a widget -> string list -> unit - (* Widget subtyping *) - -exception IllegalWidgetType of string - (* Raised when widget command applied illegally*) diff --git a/otherlibs/labltk/tkanim/.cvsignore b/otherlibs/labltk/tkanim/.cvsignore deleted file mode 100644 index e1c70145f5..0000000000 --- a/otherlibs/labltk/tkanim/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -gifanimtest -gifanimtest-static diff --git a/otherlibs/labltk/tkanim/.depend b/otherlibs/labltk/tkanim/.depend deleted file mode 100644 index 6009347798..0000000000 --- a/otherlibs/labltk/tkanim/.depend +++ /dev/null @@ -1,2 +0,0 @@ -tkanim.cmo: tkanim.cmi -tkanim.cmx: tkanim.cmi diff --git a/otherlibs/labltk/tkanim/Makefile b/otherlibs/labltk/tkanim/Makefile deleted file mode 100644 index 0e841da77e..0000000000 --- a/otherlibs/labltk/tkanim/Makefile +++ /dev/null @@ -1,70 +0,0 @@ -include ../support/Makefile.common - -COMPFLAGS=-I ../../../byterun -I ../support -I ../camltk -I ../../unix -CCFLAGS=-I../../../byterun -I../support $(TK_DEFS) $(SHAREDCCCOMPOPTS) - -all: tkanim.cma libtkanim.a -opt: tkanim.cmxa libtkanim.a -example: gifanimtest - -OBJS=tkanim.cmo -COBJS= cltkaniminit.o tkAnimGIF.o - -tkanim.cma: $(OBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -o tkanim -oc tkanim \ - $(OBJS) $(TK_LINK) - -tkanim.cmxa: $(OBJS:.cmo=.cmx) - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o tkanim -oc tkanim \ - $(OBJS:.cmo=.cmx) $(TK_LINK) - -libtkanim.a: $(COBJS) - $(MKLIB) -o tkanim $(COBJS) $(TK_LINK) - -gifanimtest-static: all gifanimtest.cmo - $(CAMLC) -custom -o $@ -I ../lib -I ../support -I ../../unix -dllpath ../support -dllpath . unix.cma -ccopt -L. $(LIBNAME).cma tkanim.cma gifanimtest.cmo - -# dynamic loading -gifanimtest: all gifanimtest.cmo - $(CAMLC) -o $@ -I ../lib -I ../support -I ../../unix -dllpath ../support -dllpath . unix.cma $(LIBNAME).cma tkanim.cma gifanimtest.cmo - -animwish: $(TKANIM_LIB) tkAppInit.o - $(CC) -o $@ tkAppInit.o $(TK_LINK) $(X11_LINK) \ - -L. -ltkanim $(LIBS) - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJS:.cmo=.cmx): ../lib/$(LIBNAME).cmxa - -clean: - rm -f *.cm* *.o *.a dlltkanim.so animwish gifanimtest gifanimtest-static - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .mlp .cmx .c .o - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.o: - $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< - - -install: tkanim.cma - cp tkanim.cma *.cmi *.mli libtkanim.a $(INSTALLDIR) - if [ -f dlltkanim.so ]; then \ - cp dlltkanim.so $(STUBLIBDIR)/dlltkanim.so; \ - fi - -installopt: tkanim.cmxa - cp tkanim.cmxa tkanim.a $(INSTALLDIR) - -depend: tkanim.ml - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/labltk/tkanim/Makefile.nt b/otherlibs/labltk/tkanim/Makefile.nt deleted file mode 100644 index 9c6da7ee2a..0000000000 --- a/otherlibs/labltk/tkanim/Makefile.nt +++ /dev/null @@ -1,78 +0,0 @@ -include ../support/Makefile.common.nt - -CCFLAGS=-I../support -I../../../byterun $(TK_DEFS) - -COMPFLAGS=-I $(OTHERS)/win32unix -I ../support -I ../camltk - -all: tkanim.cma dlltkanim.dll libtkanim.$(A) -opt: tkanim.cmxa libtkanim.$(A) -example: gifanimtest.exe - -OBJS=tkanim.cmo -COBJS= cltkaniminit.obj tkAnimGIF.obj -DCOBJS=$(COBJS:.obj=.$(DO)) -SCOBJS=$(COBJS:.obj=.$(SO)) - -tkanim.cma: $(OBJS) - $(CAMLLIBR) -o tkanim.cma $(OBJS) \ - -dllib -ltkanim -cclib -ltkanim -cclib "$(TK_LINK)" - -tkanim.cmxa: $(OBJS:.cmo=.cmx) - $(CAMLOPTLIBR) -o tkanim.cmxa $(OBJS:.cmo=.cmx) \ - -cclib -ltkanim -cclib "$(TK_LINK)" - -libtkanim.$(A): $(SCOBJS) - $(call MKLIB,libtkanim.$(A), $(SCOBJS)) - -dlltkanim.dll: $(DCOBJS) - $(call MKDLL,dlltkanim.dll,tmp.$(A), \ - $(DCOBJS) ../support/dll$(LIBNAME).$(A) \ - ../../../byterun/ocamlrun.$(A) \ - $(TK_LINK) $(call SYSLIB,wsock32)) - rm tmp.* - -gifanimtest.exe: all gifanimtest.cmo - $(CAMLC) -custom -o $@ -I ../lib -I ../camltk -I ../support unix.cma $(LIBNAME).cma tkanim.cma gifanimtest.cmo - -# animwish: $(TKANIM_LIB) tkAppInit.o -# $(CC) -o $@ tkAppInit.o $(TK_LINK) $(X11_LINK) \ -# -L. -ltkanim $(LIBS) - -clean: - rm -f *.cm* *.$(O) *.$(A) *.dll gifanimtest.exe - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJS:.cmo=.cmx): ../lib/$(LIBNAME).cmxa - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .mlp .cmx .c .$(DO) .$(SO) - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CCFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< - mv $*.$(O) $*.$(SO) - -install: tkanim.cma - cp dlltkanim.dll $(STUBLIBDIR)/dlltkanim.dll - cp tkanim.cma *.cmi *.mli libtkanim.$(A) $(INSTALLDIR) - -installopt: tkanim.cmxa - cp tkanim.cmxa tkanim.$(A) $(INSTALLDIR) - -depend: tkanim.ml - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/labltk/tkanim/README b/otherlibs/labltk/tkanim/README deleted file mode 100644 index 175401f30c..0000000000 --- a/otherlibs/labltk/tkanim/README +++ /dev/null @@ -1,5 +0,0 @@ -This ML code is an interface for Tkanim Tcl/Tk extension. Unfortunately -it is still test implementation. Look example directory for an example. - -The codes under this directory are mainly written by Jun Furuse -(Jun.Furuse@inria.fr). diff --git a/otherlibs/labltk/tkanim/cltkaniminit.c b/otherlibs/labltk/tkanim/cltkaniminit.c deleted file mode 100644 index a45bedcb50..0000000000 --- a/otherlibs/labltk/tkanim/cltkaniminit.c +++ /dev/null @@ -1,28 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ -#include <tk.h> -#include <mlvalues.h> -#include "camltk.h" - -extern int Tkanim_Init(Tcl_Interp *); - -CAMLprim value tkanim_init (rien) /* ML */ - value rien; -{ - if (Tkanim_Init(cltclinterp) != TCL_OK) - tk_error ("Can't initialize TkAnim"); - return Val_unit; -} diff --git a/otherlibs/labltk/tkanim/gifanimtest.ml b/otherlibs/labltk/tkanim/gifanimtest.ml deleted file mode 100644 index 5b79985449..0000000000 --- a/otherlibs/labltk/tkanim/gifanimtest.ml +++ /dev/null @@ -1,71 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget -open Tkanim -open Tk - -let main () = - let file = ref "" in - Arg.parse [] (fun s -> file := s) - "usage: gifanimtest file (animated gif)\n\ - \tbutton 1 toggles the animation,\n\ - \tbutton 2 displays the next frame,\n\ - \tbutton 3 quits."; - let t = openTk () in - - (* First of all, you must initialize the extension. *) - Tkanim.init (); - - prerr_endline !file; - - (* Then load the animated gif. *) - let anim = Tkanim.create !file in - prerr_endline "load done"; - - (* Check it is really animated or not. *) - match anim with - | Still x -> - (* Use whatever you want in CamlTk with this ImagePhoto. *) - prerr_endline "Sorry, it is not an animated GIF." - - | Animated x -> - (* OK, let's animate it. *) - let l = Label.create t [] in - pack [l] []; - - (* animate returns an interface function. *) - let f = animate l x in - - (* Button1 toggles the animation *) - bind l [[], ButtonPressDetail 1] (BindSet ([], (fun _ -> - f false))); - - (* Button2 displays the next frame. *) - bind l [[], ButtonPressDetail 2] (BindSet ([], (fun _ -> - f true))); - - (* Button3 quits. *) - bind l [[], ButtonPressDetail 3] (BindSet ([], (fun _ -> - closeTk ()))); - - (* start the animation *) - f false; - - (* Go to the main loop. *) - mainLoop () - -let _ = Printexc.print main () diff --git a/otherlibs/labltk/tkanim/mmm.anim.gif b/otherlibs/labltk/tkanim/mmm.anim.gif Binary files differdeleted file mode 100644 index daeee00eea..0000000000 --- a/otherlibs/labltk/tkanim/mmm.anim.gif +++ /dev/null diff --git a/otherlibs/labltk/tkanim/tkAnimGIF.c b/otherlibs/labltk/tkanim/tkAnimGIF.c deleted file mode 100644 index 1beb814397..0000000000 --- a/otherlibs/labltk/tkanim/tkAnimGIF.c +++ /dev/null @@ -1,911 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ -#define TKANIM_VERSION "1.0" -/* #define TKANIM_DEBUG */ - -#include <tk.h> -#include <string.h> - -/* - * The format record for the Animated GIF file format: - */ - -static int FileMatchGIF _ANSI_ARGS_((FILE *f, char *fileName, - char *formatString, int *widthPtr, int *heightPtr)); -static int FileReadGIF _ANSI_ARGS_((Tcl_Interp *interp, - FILE *f, char *fileName, char *formatString)); - -#define INTERLACE 0x40 -#define LOCALCOLORMAP 0x80 -#define BitSet(byte, bit) (((byte) & (bit)) == (bit)) -#define MAXCOLORMAPSIZE 256 -#define CM_RED 0 -#define CM_GREEN 1 -#define CM_BLUE 2 -#define MAX_LWZ_BITS 12 -#define LM_to_uint(a,b) (((b)<<8)|(a)) -#define ReadOK(file,buffer,len) (fread(buffer, len, 1, file) != 0) - -/* - * Prototypes for local procedures defined in this file: - */ - -static int DoExtension _ANSI_ARGS_((FILE *fd, int label, - int *transparent, int *delay, int *loop)); -static int GetCode _ANSI_ARGS_((FILE *fd, int code_size, - int flag)); -static int GetDataBlock _ANSI_ARGS_((FILE *fd, - unsigned char *buf)); -static int LWZReadByte _ANSI_ARGS_((FILE *fd, int flag, - int input_code_size)); -static int ReadColorMap _ANSI_ARGS_((FILE *fd, int number, - unsigned char buffer[3][MAXCOLORMAPSIZE])); -static int ReadGIFHeader _ANSI_ARGS_((FILE *f, int *widthPtr, - int *heightPtr)); -static int ReadImage _ANSI_ARGS_((Tcl_Interp *interp, - char *imagePtr, FILE *fd, int len, int height, - unsigned char cmap[3][MAXCOLORMAPSIZE], - int interlace, int transparent)); - -static int -FileMatchGIF(f, fileName, formatString, widthPtr, heightPtr) - FILE *f; /* The image file, open for reading. */ - char *fileName; /* The name of the image file. */ - char *formatString; /* User-specified format string, or NULL. */ - int *widthPtr, *heightPtr; /* The dimensions of the image are - * returned here if the file is a valid - * raw GIF file. */ -{ - return ReadGIFHeader(f, widthPtr, heightPtr); -} - -static int -FileReadGIF(interp, f, fileName, formatString) - Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ - FILE *f; /* The image file, open for reading. */ - char *fileName; /* The name of the image file. */ - char *formatString; /* User-specified format string, or NULL. */ -{ - int logicalWidth, logicalHeight; - int nBytes; - Tk_PhotoImageBlock block; - unsigned char buf[100]; - int bitPixel; - unsigned int colorResolution; - unsigned int background; - unsigned int aspectRatio; - unsigned char localColorMap[3][MAXCOLORMAPSIZE]; - unsigned char colorMap[3][MAXCOLORMAPSIZE]; - int useGlobalColormap; - int transparent = -1; - int delay = 0; - Tk_Window winPtr; - int imageLeftPos, imageTopPos, imageWidth, imageHeight; - Tk_PhotoHandle photoHandle; - - char widthbuf[32], heightbuf[32]; - Tcl_DString resultbuf; - - char newresbuf[640]; - char *imageName; - char *resultptr; - int prevpos; - int loop = -1; - - if((winPtr = Tk_MainWindow(interp)) == NULL){ - return TCL_ERROR; - } - -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\t\tHeader check..."); -#endif - if (!ReadGIFHeader(f, &logicalWidth, &logicalHeight)) { - Tcl_AppendResult(interp, "couldn't read GIF header from file \"", - fileName, "\"", NULL); - return TCL_ERROR; - } -#ifdef TKANIM_DEBUG - fprintf(stderr, "done "); -#endif - if ((logicalWidth <= 0) || (logicalHeight <= 0)) { - Tcl_AppendResult(interp, "GIF image file \"", fileName, - "\" has dimension(s) <= 0", (char *) NULL); - return TCL_ERROR; - } - - if (fread(buf, 1, 3, f) != 3) { - return TCL_OK; - } - bitPixel = 2<<(buf[0]&0x07); - colorResolution = (((buf[0]&0x70)>>3)+1); - background = buf[1]; - aspectRatio = buf[2]; - - if (BitSet(buf[0], LOCALCOLORMAP)) { /* Global Colormap */ - if (!ReadColorMap(f, bitPixel, colorMap)) { - Tcl_AppendResult(interp, "error reading color map", - (char *) NULL); - return TCL_ERROR; - } - } - -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\t\tReading frames "); - prevpos = ftell(f); -#endif - sprintf( widthbuf, "%d ", logicalWidth); - sprintf( heightbuf, "%d ", logicalHeight); - - Tcl_DStringInit(&resultbuf); - Tcl_DStringAppend(&resultbuf, widthbuf, -1); - Tcl_DStringAppend(&resultbuf, " ", -1); - Tcl_DStringAppend(&resultbuf, heightbuf, -1); - Tcl_DStringAppend(&resultbuf, " ", -1); - Tcl_DStringAppend(&resultbuf, "{", -1); - - while (1) { - if (fread(buf, 1, 1, f) != 1) { - /* - * Premature end of image. We should really notify - * the user, but for now just show garbage. - */ -#ifdef TKANIM_DEBUG - fprintf(stderr, "Premature end of image"); -#endif - - break; - } - - if (buf[0] == ';') { - /* - * GIF terminator. - */ -#ifdef TKANIM_DEBUG - fprintf(stderr, ";"); - prevpos = ftell(f); -#endif - - break; - } - - if (buf[0] == '!') { - /* - * This is a GIF extension. - */ -#ifdef TKANIM_DEBUG - fprintf(stderr, "!"); - prevpos = ftell(f); -#endif - - if (fread(buf, 1, 1, f) != 1) { - Tcl_AppendResult( interp, - "error reading extension function code in GIF image", NULL ); -/* - interp->result = - "error reading extension function code in GIF image"; -*/ - goto error; - } - if (DoExtension(f, buf[0], &transparent, &delay, &loop) < 0) { - Tcl_AppendResult( interp, - "error reading extension in GIF image", NULL ); -/* - interp->result = "error reading extension in GIF image"; -*/ goto error; - } - continue; - } - - if (buf[0] == '\0') { - /* - * Not a valid start character; ignore it. - */ -#ifdef TKANIM_DEBUG - fprintf(stderr, "0", buf[0]); - prevpos = ftell(f); -#endif - continue; - } - - if (buf[0] != ',') { - /* - * Not a valid start character; ignore it. - */ -#ifdef TKANIM_DEBUG - fprintf(stderr, "?(%c)", buf[0]); - prevpos = ftell(f); -#endif - continue; - } - - if (fread(buf, 1, 9, f) != 9) { - Tcl_AppendResult( interp, - "couldn't read left/top/width/height in GIF image", NULL ); -/* - interp->result = "couldn't read left/top/width/height in GIF image"; -*/ - goto error; - } - - useGlobalColormap = ! BitSet(buf[8], LOCALCOLORMAP); - - bitPixel = 1<<((buf[8]&0x07)+1); - - imageLeftPos= LM_to_uint(buf[0], buf[1]); - imageTopPos= LM_to_uint(buf[2], buf[3]); - imageWidth= LM_to_uint(buf[4], buf[5]); - imageHeight= LM_to_uint(buf[6], buf[7]); - - block.width = imageWidth; - block.height = imageHeight; - block.pixelSize = 3; - block.pitch = 3 * imageWidth; - block.offset[0] = 0; - block.offset[1] = 1; - block.offset[2] = 2; - block.offset[3] = 3; - nBytes = imageHeight * block.pitch; - block.pixelPtr = (unsigned char *) ckalloc((unsigned) nBytes); - - sprintf(widthbuf, "%d", imageWidth); - sprintf(heightbuf, "%d", imageHeight); - - /* save result */ - - { -#if (TK_MAJOR_VERSION >= 8 && TK_MINOR_VERSION >= 1) - Tcl_Obj *argv[7]; - int i; - - argv[0] = Tcl_NewStringObj("image", -1); - argv[1] = Tcl_NewStringObj("create", -1); - argv[2] = Tcl_NewStringObj("photo", -1); - argv[3] = Tcl_NewStringObj("-width", -1); - argv[4] = Tcl_NewStringObj(widthbuf, -1); - argv[5] = Tcl_NewStringObj("-height", -1); - argv[6] = Tcl_NewStringObj(heightbuf, -1); - - for(i=0; i<7; i++){ Tcl_IncrRefCount(argv[i]); } - - if( Tk_ImageObjCmd((ClientData) winPtr, interp, - /* "image create photo -width <imageWidth> - -height <imageHeight>" */ - 7, argv) == TCL_ERROR ){ - return TCL_ERROR; - } - - for(i=0; i<7; i++){ Tcl_DecrRefCount(argv[i]); } - -#else - char *argv[7] = {"image", "create", "photo", "-width", NULL, - "-height", NULL}; - argv[4] = widthbuf; - argv[6] = heightbuf; -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\t\timage creation (%s %s %s %s %s %s %s)", - argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); -#endif - if( Tk_ImageCmd((ClientData) winPtr, interp, - /* "image create photo -width <imageWidth> - -height <imageHeight>" */ - 7, argv) == TCL_ERROR ){ - return TCL_ERROR; - } -#endif - -#ifdef TKANIM_DEBUG - fprintf(stderr, " done "); -#endif - } - - imageName = interp->result; -#if (TK_MAJOR_VERSION < 8) - photoHandle = Tk_FindPhoto(interp->result); -#else - photoHandle = Tk_FindPhoto(interp, interp->result); -#endif - if (!useGlobalColormap) { - if (!ReadColorMap(f, bitPixel, localColorMap)) { - Tcl_AppendResult(interp, "error reading color map", - (char *) NULL); - goto error; - } - if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth, - imageHeight, localColorMap, BitSet(buf[8], INTERLACE), - transparent) != TCL_OK) { - goto error; - } - } else { - if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth, - imageHeight, colorMap, BitSet(buf[8], INTERLACE), - transparent) != TCL_OK) { - goto error; - } - } - Tk_PhotoPutBlock(photoHandle, &block, 0, 0, imageWidth, imageHeight -#if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 4 || TK_MAJOR_VERSION > 8) - , TK_PHOTO_COMPOSITE_SET -#endif - ); -#ifdef TKANIM_DEBUG - fprintf(stderr, " Retrieving result\n"); -#endif - /* retrieve result */ - sprintf(newresbuf, "{%s %d %d %d %d %d} ", - imageName, imageWidth, imageHeight, imageLeftPos, imageTopPos, - delay); -#ifdef TKANIM_DEBUG - fprintf(stderr, " newresbuf = %s\n", newresbuf); -#endif - ckfree((char *) block.pixelPtr); -#ifdef TKANIM_DEBUG - fprintf(stderr, " free done (now append result)"); -#endif - Tcl_DStringAppend( &resultbuf, newresbuf, -1 ); -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\t\tFrame done (%d)", ftell(f) - prevpos); - prevpos = ftell(f); -#endif - } - sprintf( widthbuf, "%d", loop ); - Tcl_DStringAppend( &resultbuf, "} ", -1 ); - resultptr = Tcl_DStringAppend( &resultbuf, widthbuf, -1 ); -#ifdef TKANIM_DEBUG - fprintf(stderr, "\nResult = %s\n", resultptr); -#endif - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, resultptr, NULL); - Tcl_DStringFree(&resultbuf); - return TCL_OK; - - error: - Tcl_DStringFree(&resultbuf); - ckfree((char *) block.pixelPtr); - return TCL_ERROR; - -} - -static int -DoExtension(fd, label, transparent, delay, loop) -FILE *fd; -int label; -int *transparent; -int *delay; -int *loop; -{ - static unsigned char buf[256]; - int count = 0; - - switch (label) { - case 0x01: /* Plain Text Extension */ - break; - - case 0xff: /* Application Extension */ - count = GetDataBlock(fd, (unsigned char*) buf); - if( count < 0){ - return 1; - } - if( !strncmp (buf, "NETSCAPE", 8) ) { - /* we ignore check of "2.0" */ - count = GetDataBlock (fd, (unsigned char*) buf); - if( count < 0){ - return 1; - } - if( buf[0] != 1 ){ - fprintf(stderr, "??? %d", buf[0]); - } - *loop = LM_to_uint(buf[1], buf[2]); - } - do { - count = GetDataBlock(fd, (unsigned char*) buf); - } while (count > 0); - return count; - break; - - case 0xfe: /* Comment Extension */ - do { - count = GetDataBlock(fd, (unsigned char*) buf); - } while (count > 0); - return count; - - case 0xf9: /* Graphic Control Extension */ - count = GetDataBlock(fd, (unsigned char*) buf); - if (count < 0) { - return 1; - } - if ((buf[0] & 0x1) != 0) { - *transparent = buf[3]; - } - - /* Delay time */ - *delay = LM_to_uint(buf[1],buf[2]); - - do { - count = GetDataBlock(fd, (unsigned char*) buf); - } while (count > 0); - return count; - } - - do { - count = GetDataBlock(fd, (unsigned char*) buf); - } while (count > 0); - return count; -} - -/* - *---------------------------------------------------------------------- - * - * ReadGIFHeader -- - * - * This procedure reads the GIF header from the beginning of a - * GIF file and returns the dimensions of the image. - * - * Results: - * The return value is 1 if file "f" appears to start with - * a valid GIF header, 0 otherwise. If the header is valid, - * then *widthPtr and *heightPtr are modified to hold the - * dimensions of the image. - * - * Side effects: - * The access position in f advances. - * - *---------------------------------------------------------------------- - */ - -static int -ReadGIFHeader(f, widthPtr, heightPtr) - FILE *f; /* Image file to read the header from */ - int *widthPtr, *heightPtr; /* The dimensions of the image are - * returned here. */ -{ - unsigned char buf[7]; - - if ((fread(buf, 1, 6, f) != 6) - || ((strncmp("GIF87a", (char *) buf, 6) != 0) - && (strncmp("GIF89a", (char *) buf, 6) != 0))) { - return 0; - } - - if (fread(buf, 1, 4, f) != 4) { - return 0; - } - - *widthPtr = LM_to_uint(buf[0],buf[1]); - *heightPtr = LM_to_uint(buf[2],buf[3]); - return 1; -} - -/* - *----------------------------------------------------------------- - * The code below is copied from the giftoppm program and modified - * just slightly. - *----------------------------------------------------------------- - */ - -static int -ReadColorMap(fd,number,buffer) -FILE *fd; -int number; -unsigned char buffer[3][MAXCOLORMAPSIZE]; -{ - int i; - unsigned char rgb[3]; - - for (i = 0; i < number; ++i) { - if (! ReadOK(fd, rgb, sizeof(rgb))) - return 0; - - buffer[CM_RED][i] = rgb[0] ; - buffer[CM_GREEN][i] = rgb[1] ; - buffer[CM_BLUE][i] = rgb[2] ; - } - return 1; -} - - - -static int ZeroDataBlock = 0; - -static int -GetDataBlock(fd, buf) -FILE *fd; -unsigned char *buf; -{ - unsigned char count; - - if (! ReadOK(fd,&count,1)) { - return -1; - } - - ZeroDataBlock = count == 0; - - if ((count != 0) && (! ReadOK(fd, buf, count))) { - return -1; - } - - return count; -} - - -static int -ReadImage(interp, imagePtr, fd, len, height, cmap, interlace, transparent) -Tcl_Interp *interp; -char *imagePtr; -FILE *fd; -int len, height; -unsigned char cmap[3][MAXCOLORMAPSIZE]; -int interlace; -int transparent; -{ - unsigned char c; - int v; - int xpos = 0, ypos = 0, pass = 0; - char *colStr; - - - /* - * Initialize the Compression routines - */ - if (! ReadOK(fd,&c,1)) { - Tcl_AppendResult(interp, "error reading GIF image: ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - - if (LWZReadByte(fd, 1, c) < 0) { - interp->result = "format error in GIF image"; - return TCL_ERROR; - } - - if (transparent!=-1 && - (colStr = Tcl_GetVar(interp, "TRANSPARENT_GIF_COLOR", 0L))) { - XColor *colorPtr; - colorPtr = Tk_GetColor(interp, Tk_MainWindow(interp), - Tk_GetUid(colStr)); - if (colorPtr) { -/* - printf("color is %d %d %d\n", - colorPtr->red >> 8, - colorPtr->green >> 8, - colorPtr->blue >> 8); -*/ - cmap[CM_RED][transparent] = colorPtr->red >> 8; - cmap[CM_GREEN][transparent] = colorPtr->green >> 8; - cmap[CM_BLUE][transparent] = colorPtr->blue >> 8; - Tk_FreeColor(colorPtr); - } - } - - while ((v = LWZReadByte(fd,0,c)) >= 0 ) { - - imagePtr[ (xpos*3) + (ypos *len*3)] = cmap[CM_RED][v]; - imagePtr[ (xpos*3) + (ypos *len*3) +1] = cmap[CM_GREEN][v]; - imagePtr[ (xpos*3) + (ypos *len*3) +2] = cmap[CM_BLUE][v]; - - ++xpos; - if (xpos == len) { - xpos = 0; - if (interlace) { - switch (pass) { - case 0: - case 1: - ypos += 8; break; - case 2: - ypos += 4; break; - case 3: - ypos += 2; break; - } - - if (ypos >= height) { - ++pass; - switch (pass) { - case 1: - ypos = 4; break; - case 2: - ypos = 2; break; - case 3: - ypos = 1; break; - default: - return TCL_OK; - } - } - } else { - ++ypos; - } - } - if (ypos >= height) - break; - } - return TCL_OK; -} - -static int -LWZReadByte(fd, flag, input_code_size) -FILE *fd; -int flag; -int input_code_size; -{ - static int fresh = 0; - int code, incode; - static int code_size, set_code_size; - static int max_code, max_code_size; - static int firstcode, oldcode; - static int clear_code, end_code; - static int table[2][(1<< MAX_LWZ_BITS)]; - static int stack[(1<<(MAX_LWZ_BITS))*2], *sp; - register int i; - - - if (flag) { - - set_code_size = input_code_size; - code_size = set_code_size+1; - clear_code = 1 << set_code_size ; - end_code = clear_code + 1; - max_code_size = 2*clear_code; - max_code = clear_code+2; - - GetCode(fd, 0, 1); - - fresh = 1; - - for (i = 0; i < clear_code; ++i) { - table[0][i] = 0; - table[1][i] = i; - } - for (; i < (1<<MAX_LWZ_BITS); ++i) { - table[0][i] = table[1][0] = 0; - } - - sp = stack; - - return 0; - - } else if (fresh) { - - fresh = 0; - do { - firstcode = oldcode = GetCode(fd, code_size, 0); - } while (firstcode == clear_code); - return firstcode; - } - - if (sp > stack) - return *--sp; - - while ((code = GetCode(fd, code_size, 0)) >= 0) { - if (code == clear_code) { - for (i = 0; i < clear_code; ++i) { - table[0][i] = 0; - table[1][i] = i; - } - - for (; i < (1<<MAX_LWZ_BITS); ++i) { - table[0][i] = table[1][i] = 0; - } - - code_size = set_code_size+1; - max_code_size = 2*clear_code; - max_code = clear_code+2; - sp = stack; - firstcode = oldcode = GetCode(fd, code_size, 0); - return firstcode; - - } else if (code == end_code) { - int count; - unsigned char buf[260]; - - if (ZeroDataBlock) - return -2; - - while ((count = GetDataBlock(fd, buf)) > 0) - ; - - if (count != 0) - return -2; - } - - incode = code; - - if (code >= max_code) { - *sp++ = firstcode; - code = oldcode; - } - - while (code >= clear_code) { - *sp++ = table[1][code]; - if (code == table[0][code]) { - return -2; - - fprintf(stderr, "circular table entry BIG ERROR\n"); - /* - * Used to be this instead, Steve Ball suggested - * the change to just return. - - printf("circular table entry BIG ERROR\n"); - */ - } - code = table[0][code]; - } - - *sp++ = firstcode = table[1][code]; - - if ((code = max_code) <(1<<MAX_LWZ_BITS)) { - - table[0][code] = oldcode; - table[1][code] = firstcode; - ++max_code; - if ((max_code>=max_code_size) && (max_code_size < (1<<MAX_LWZ_BITS))) { - max_code_size *= 2; - ++code_size; - } - } - - oldcode = incode; - - if (sp > stack) - return *--sp; - } - return code; -} - - -static int -GetCode(fd, code_size, flag) -FILE *fd; -int code_size; -int flag; -{ - static unsigned char buf[280]; - static int curbit, lastbit, done, last_byte; - int i, j, ret; - unsigned char count; - - if (flag) { - curbit = 0; - lastbit = 0; - done = 0; - return 0; - } - - - if ( (curbit+code_size) >= lastbit) { - if (done) { - /* ran off the end of my bits */ - return -1; - } - buf[0] = buf[last_byte-2]; - buf[1] = buf[last_byte-1]; - - if ((count = GetDataBlock(fd, &buf[2])) == 0) - done = 1; - - last_byte = 2 + count; - curbit = (curbit - lastbit) + 16; - lastbit = (2+count)*8 ; - } - - ret = 0; - for (i = curbit, j = 0; j < code_size; ++i, ++j) - ret |= ((buf[ i / 8 ] & (1 << (i % 8))) != 0) << j; - - - curbit += code_size; - - return ret; -} - -int Tk_AnimationCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - char c; - int length; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option ?arg arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - c = argv[1][0]; - length = strlen(argv[1]); - if((c == 'c') && (length >= 2) - && (strncmp(argv[1], "create", length) == 0)) { - - char * realFileName; - Tcl_DString buffer; - FILE *f; - -#ifdef TKANIM_DEBUG - fprintf(stderr, "AnimationCmd => create "); -#endif - - if ( argc != 3 ){ - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " create GifFile\"", (char *) NULL); - return TCL_ERROR; - } -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\tRealFileName = "); -#endif - realFileName = Tcl_TranslateFileName(interp, argv[2], - &buffer); - if(realFileName == NULL) { - Tcl_DStringFree(&buffer); - return TCL_ERROR; - } -#ifdef TKANIM_DEBUG - fprintf(stderr, "%s ", realFileName); -#endif -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\tOpen ", realFileName); -#endif - f = fopen(realFileName, "rb"); - Tcl_DStringFree(&buffer); - if (f == NULL ){ - Tcl_AppendResult(interp, "couldn't read image file \"", - argv[2], "\": ", Tcl_PosixError(interp), - (char *) NULL); - return TCL_ERROR; - } -#ifdef TKANIM_DEBUG - fprintf(stderr, "success ", realFileName); -#endif -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\tRead ", realFileName); -#endif - if( FileReadGIF(interp, f, argv[2], "gif") != TCL_OK ){ -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\tRead failed", realFileName); -#endif - return TCL_ERROR; - } - fclose(f); -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\tRead done", realFileName); -#endif -#ifdef TKANIM_DEBUG - fprintf(stderr, "done\n"); -#endif - } - return TCL_OK; -} - -void -TkDeleteTkAnim(clientData) - ClientData clientData; -{ -#ifdef TKANIM_DEBUG - fprintf(stderr, "TkDeleteTkAnim\n"); -#endif -} - -int Tkanim_Init(interp) - Tcl_Interp *interp; -{ -#ifdef TKANIM_DEBUG - fprintf(stderr, "Tkanim initialize..."); -#endif - Tcl_CreateCommand(interp, "animation", Tk_AnimationCmd, - (ClientData) NULL, - (Tcl_CmdDeleteProc *) TkDeleteTkAnim); -#ifdef TKANIM_DEBUG - fprintf(stderr, "done\n"); -#endif - return Tcl_PkgProvide(interp, "Tkanim", TKANIM_VERSION ); -} diff --git a/otherlibs/labltk/tkanim/tkAppInit.c b/otherlibs/labltk/tkanim/tkAppInit.c deleted file mode 100644 index 60807d9152..0000000000 --- a/otherlibs/labltk/tkanim/tkAppInit.c +++ /dev/null @@ -1,141 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ -/* - * tkAppInit.c -- - * - * Provides a default version of the Tcl_AppInit procedure for - * use in wish and similar Tk-based applications. - * - * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#ifndef lint -static char sccsid[] = "@(#) tkAppInit.c 1.19 95/12/23 17:09:24"; -#endif /* not lint */ - -#include "tk.h" - -int Tkanimation_Init _ANSI_ARGS_ ((Tcl_Interp *interp)); - -/* - * The following variable is a special hack that is needed in order for - * Sun shared libraries to be used for Tcl. - */ - -extern int matherr(); -int *tclDummyMathPtr = (int *) matherr; - -#ifdef TK_TEST -EXTERN int Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -#endif /* TK_TEST */ - -/* - *---------------------------------------------------------------------- - * - * main -- - * - * This is the main program for the application. - * - * Results: - * None: Tk_Main never returns here, so this procedure never - * returns either. - * - * Side effects: - * Whatever the application does. - * - *---------------------------------------------------------------------- - */ - -int -main(argc, argv) - int argc; /* Number of command-line arguments. */ - char **argv; /* Values of command-line arguments. */ -{ - Tk_Main(argc, argv, Tcl_AppInit); - return 0; /* Needed only to prevent compiler warning. */ -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppInit -- - * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. - * - * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. - * - * Side effects: - * Depends on the startup script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_AppInit(interp) - Tcl_Interp *interp; /* Interpreter for application. */ -{ - if (Tcl_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - if (Tk_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "Tk", Tk_Init, (Tcl_PackageInitProc *) NULL); -#ifdef TK_TEST - if (Tktest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } -#endif /* TK_TEST */ - - - /* - * Call the init procedures for included packages. Each call should - * look like this: - * - * if (Mod_Init(interp) == TCL_ERROR) { - * return TCL_ERROR; - * } - * - * where "Mod" is the name of the module. - */ - - if (Tkanim_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - - /* - * Call Tcl_CreateCommand for application-specific commands, if - * they weren't already created by the init procedures called above. - */ - - /* - * Specify a user-specific startup file to invoke if the application - * is run interactively. Typically the startup file is "~/.apprc" - * where "app" is the name of the application. If this line is deleted - * then no user-specific startup file will be run under any conditions. - */ - - Tcl_SetVar(interp, "tcl_rcFileName", "~/.tkanimationrc", TCL_GLOBAL_ONLY); - return TCL_OK; -} diff --git a/otherlibs/labltk/tkanim/tkanim.ml b/otherlibs/labltk/tkanim/tkanim.ml deleted file mode 100644 index cc859e1cfd..0000000000 --- a/otherlibs/labltk/tkanim/tkanim.ml +++ /dev/null @@ -1,230 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget -open Support -open Protocol -open Tkintf - -external init : unit -> unit = "tkanim_init" - -type gifFrame = { - imagephoto : imagePhoto; - frameWidth : int; - frameHeight : int; - left : int; - top : int; - delay : int - } - -type animatedGif = { - frames : gifFrame list; - animWidth : int; - animHeight : int; - loop : int -} - -type imageType = - | Still of Tk.options - | Animated of animatedGif - -let debug = ref false - -let cTKtoCAMLgifFrame s = - match splitlist s with - | [photo; width; height; left; top; delay] -> - {imagephoto = cTKtoCAMLimagePhoto photo; - frameWidth = int_of_string width; - frameHeight = int_of_string height; - left = int_of_string left; - top = int_of_string top; - delay = int_of_string delay} - | _ -> raise (Invalid_argument ("cTKtoCAMLgifFrame: " ^ s)) - -let cTKtoCAMLanimatedGif s = - match splitlist s with - | [width; height; frames; loop] -> - {frames = List.map cTKtoCAMLgifFrame (splitlist frames); - animWidth = int_of_string width; - animHeight = int_of_string height; - loop = int_of_string loop} - | _ -> raise (Invalid_argument ("cTKtoCAMLgifFrame: " ^ s)) - -(* check Tkanim package is in the interpreter *) -let available () = - let packages = - splitlist (Protocol.tkEval [| TkToken "package"; - TkToken "names" |]) - in - List.mem "Tkanim" packages - -let create file = - let s = - Protocol.tkEval [| TkToken "animation"; - TkToken "create"; - TkToken file |] - in - let anmgif = cTKtoCAMLanimatedGif s in - match anmgif.frames with - | [] -> raise (TkError "Null frame in a gif ?") - | [x] -> Still (ImagePhoto x.imagephoto) - | _ -> Animated anmgif - -let delete anim = - List.iter (fun {imagephoto = i} -> Imagephoto.delete i) anim.frames - -let width anm = anm.animWidth -let height anm = anm.animHeight -let images anm = List.map (fun x -> x.imagephoto) anm.frames - -let image_existence_check img = - (* I found there is a bug in Tk (even v8.0a2). *) - (* We can copy from deleted images, Tk never says "it doesn't exist", *) - (* But just do some operation. And sometimes it causes Seg-fault. *) - (* So, before using Imagephoto.copy, I should check the source image *) - (* really exists. *) - try ignore (Imagephoto.height img) with - TkError s -> prerr_endline ("tkanim: " ^ s); raise (TkError s) - -let imagephoto_copy dst src opts = - image_existence_check src; - Imagephoto.copy dst src opts - -let animate_gen w i anim = - let length = List.length anim.frames in - let frames = Array.of_list anim.frames in - let current = ref 0 in - let loop = ref anim.loop in - let f = frames.(!current) in - imagephoto_copy i f.imagephoto - [ImgTo (f.left, f.top, f.left + f.frameWidth, - f.top + f.frameHeight)]; - let visible = ref true in - let animated = ref false in - let timer = ref None in - (* Loop *) - let display_current () = - let f = frames.(!current) in - imagephoto_copy i f.imagephoto - [ImgTo (f.left, f.top, - f.left + f.frameWidth, f.top + f.frameHeight)] - in - let rec tick () = - if not (Winfo.exists w && Winfo.viewable w) then begin - (* the widget is invisible. stop animation for efficiency *) - if !debug then prerr_endline "Stopped (Visibility)"; - visible := false; - end else - begin - display_current (); - let t = - Timer.add (if f.delay = 0 then 100 else f.delay * 10) - (fun () -> - incr current; - if !current = length then begin - current := 0; - (* loop check *) - if !loop > 1 then begin - decr loop; - if !loop = 0 then begin - if !debug then prerr_endline "Loop end"; - (* stop *) - loop := anim.loop; - timer := None - end - end - end; - tick ()) - in - timer := Some t - end - in - let start () = - animated := true; - tick () - in - let stop () = - match !timer with - | Some t -> - Timer.remove t; - timer := None; - animated := false - | None -> () - in - let next () = - if !timer = None then begin - incr current; - if !current = length then current := 0; - display_current () - end - in - (* We shouldn't delete the animation here. *) -(* - bind w [[], Destroy] - (BindSet ([], (fun _ -> Imagephoto.delete i))); -*) - bind w [[], Visibility] - (BindSet ([], (fun _ -> - if not !visible then begin - visible := true; - if !animated then start () - end))); - (function - | false -> - if !animated then stop () else start () - | true -> next ()) - -let animate label anim = - (* prerr_endline "animate"; *) - let i = Imagephoto.create [Width (Pixels anim.animWidth); - Height (Pixels anim.animHeight)] - in - bind label [[], Destroy] (BindExtend ([], (fun _ -> - Imagephoto.delete i))); - Label.configure label [ImagePhoto i]; - animate_gen label i anim - -let animate_canvas_item canvas tag anim = -(* prerr_endline "animate"; *) - let i = Imagephoto.create [Width (Pixels anim.animWidth); - Height (Pixels anim.animHeight)] - in - bind canvas [[], Destroy] (BindExtend ([], (fun _ -> - Imagephoto.delete i))); - Canvas.configure_image canvas tag [ImagePhoto i]; - animate_gen canvas i anim - -let gifdata s = - let tmp_dir = ref "/tmp" in - let mktemp = - let cnter = ref 0 - and pid = Unix.getpid() in - (function prefx -> - incr cnter; - (Filename.concat !tmp_dir - (prefx ^ string_of_int pid ^ "." ^ string_of_int !cnter))) - in - let fname = mktemp "gifdata" in - let oc = open_out_bin fname in - try - output_string oc s; - close_out oc; - let anim = create fname in - Unix.unlink fname; - anim - with - e -> begin Unix.unlink fname; raise e end - diff --git a/otherlibs/labltk/tkanim/tkanim.mli b/otherlibs/labltk/tkanim/tkanim.mli deleted file mode 100644 index e83ceb9bd1..0000000000 --- a/otherlibs/labltk/tkanim/tkanim.mli +++ /dev/null @@ -1,95 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget -open Support - -(*** Data types ***) - -type animatedGif - - (* This data type contains all the information of an animation of - gif89a format. It is still test implementation, so I should - keep it abstract. --- JPF *) - -type imageType = - | Still of Tk.options - | Animated of animatedGif - - (* This data type is required to distinguish normal still images - and animated gifs. Usually objects typed imagePhoto or - imageBitmap are used for Still. *) - -(*** Flags ***) - -val debug : bool ref - -(*** Library availability check ***) - -val init : unit -> unit - - (* This function calls the initialization function for Tkanim - Tcl/Tk extension. *) - -val available : unit -> bool - - (* [available ()] returns true if there is Tkanim Tcl/Tk - extension linked statically/dynamically in Tcl/Tk - interpreter. Otherwise, return false. *) - -(*** User interface ***) - -(* create is unsafe *) -val create : string -> imageType - - (* [create file] loads a gif87 or gif89 image file and parse it, - and returns [Animated animated_gif] if the image file has - more than one images. Otherwise, it returns - [Still (ImagePhoto image_photo)] *) - -val delete : animatedGif -> unit - - (* [delete anim] deletes all the images in anim. Usually - animatedGifs contain many images, so you must not forget to - use this function to free the memory. *) - -val width : animatedGif -> int -val height : animatedGif -> int - (* [width anim] and [height anim] return the width and height of - given animated gif. *) - -val images : animatedGif -> imagePhoto list - (* [images anim] returns the list of still images used in the - animation *) - -val animate : widget -> animatedGif -> bool -> unit -val animate_canvas_item : widget -> tagOrId -> animatedGif -> bool -> unit - (* The display functions for animated gifs. Since [animatedGif] is - an abstract type, you must use those functions to display - [animatedGif] images. - [animate label anim] and [animate_canvas_item canvas tag anim] - display animation [anim] on a label widget [label] or an - image tag [tag] on a canvas widget [canvas] respectively. - - Note that animation is stopped by default. - These functions return interface functions, say, [inter : - bool -> unit]. Currently, [inter false] toggles start/stop of - the animation, and [inter true] displays the next frame of - the animation if the animation is stopped. *) - -val gifdata : string -> imageType - (* [gifdata data] reads [data] as a row data of a gif file and - decodes it. *) diff --git a/otherlibs/macosunix/.cvsignore b/otherlibs/macosunix/.cvsignore deleted file mode 100644 index 2bbb2a16c5..0000000000 --- a/otherlibs/macosunix/.cvsignore +++ /dev/null @@ -1,71 +0,0 @@ -*.x -byterun -config -accept.c -access.c -addrofstr.c -alarm.c -bind.c -chdir.c -chmod.c -close.c -closedir.c -connect.c -cst2constr.c -cstringv.c -dup.c -dup2.c -errmsg.c -exit.c -fchmod.c -fchown.c -fcntl.c -ftruncate.c -getcwd.c -getgroups.c -gethost.c -gethostname.c -getpeername.c -getproto.c -getserv.c -getsockname.c -gettimeofday.c -gmtime.c -itimer.c -listen.c -lockf.c -lseek.c -mkdir.c -open.c -opendir.c -pipe.c -putenv.c -read.c -readdir.c -readlink.c -rename.c -rewinddir.c -rmdir.c -select.c -sendrecv.c -setsid.c -shutdown.c -signals.c -sleep.c -socket.c -socketaddr.c -socketpair.c -sockopt.c -stat.c -strofaddr.c -symlink.c -termios.c -truncate.c -unixsupport.c -unlink.c -utimes.c -write.c -cst2constr.h -socketaddr.h -unix.ml -unix.mli diff --git a/otherlibs/macosunix/Makefile.Mac b/otherlibs/macosunix/Makefile.Mac deleted file mode 100644 index 4eecaf1cbf..0000000000 --- a/otherlibs/macosunix/Makefile.Mac +++ /dev/null @@ -1,152 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Moscova, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -includepath = ":config:,:byterun:,{GUSI}include:" - -C = sc -COptions = -i {includepath} -includes unix -w 30,35 {cdbgflag} -model far - -PPCC = mrc -PPCCOptions = -i {includepath} -includes unix -w 30,35 {cdbgflag} - -CAMLC = :::boot:ocamlrun :::boot:ocamlc -I :::stdlib: -warn-error A - - -# Files in this directory -MAC_OBJS = macosunix.c.o - -MAC_OBJSPPC = macosunix.c.x - -# Files from the ::unix: directory -UNIX_FILES = accept.c access.c addrofstr.c alarm.c bind.c ¶ - chdir.c chmod.c close.c closedir.c ¶ - connect.c cst2constr.c cstringv.c dup.c dup2.c ¶ - errmsg.c exit.c ¶ - fchmod.c fchown.c fcntl.c ftruncate.c ¶ - getcwd.c ¶ - getgroups.c gethost.c gethostname.c ¶ - getpeername.c getproto.c ¶ - getserv.c getsockname.c gettimeofday.c ¶ - gmtime.c itimer.c listen.c lockf.c ¶ - lseek.c mkdir.c open.c opendir.c ¶ - pipe.c putenv.c read.c readdir.c readlink.c ¶ - rename.c rewinddir.c rmdir.c select.c sendrecv.c ¶ - setsid.c shutdown.c signals.c ¶ - sleep.c socket.c socketaddr.c socketpair.c ¶ - sockopt.c stat.c strofaddr.c symlink.c termios.c ¶ - truncate.c unixsupport.c ¶ - unlink.c utimes.c write.c ¶ - ¶ - cst2constr.h socketaddr.h ¶ - unix.ml unix.mli - -UNIX_OBJS = accept.c.o access.c.o addrofstr.c.o alarm.c.o bind.c.o ¶ - chdir.c.o chmod.c.o close.c.o closedir.c.o ¶ - connect.c.o cst2constr.c.o cstringv.c.o dup.c.o dup2.c.o ¶ - errmsg.c.o exit.c.o ¶ - fchmod.c.o fchown.c.o fcntl.c.o ftruncate.c.o ¶ - getcwd.c.o ¶ - getgroups.c.o gethost.c.o gethostname.c.o ¶ - getpeername.c.o getproto.c.o ¶ - getserv.c.o getsockname.c.o gettimeofday.c.o ¶ - gmtime.c.o itimer.c.o listen.c.o lockf.c.o ¶ - lseek.c.o mkdir.c.o open.c.o opendir.c.o ¶ - pipe.c.o putenv.c.o read.c.o readdir.c.o readlink.c.o ¶ - rename.c.o rewinddir.c.o rmdir.c.o select.c.o sendrecv.c.o ¶ - setsid.c.o shutdown.c.o signals.c.o ¶ - sleep.c.o socket.c.o socketaddr.c.o socketpair.c.o ¶ - sockopt.c.o stat.c.o strofaddr.c.o symlink.c.o termios.c.o ¶ - truncate.c.o unixsupport.c.o ¶ - unlink.c.o utimes.c.o write.c.o - -PPCUNIX_OBJS = accept.c.x access.c.x addrofstr.c.x alarm.c.x bind.c.x ¶ - chdir.c.x chmod.c.x close.c.x closedir.c.x ¶ - connect.c.x cst2constr.c.x cstringv.c.x dup.c.x dup2.c.x ¶ - errmsg.c.x exit.c.x ¶ - fchmod.c.x fchown.c.x fcntl.c.x ftruncate.c.x ¶ - getcwd.c.x ¶ - getgroups.c.x gethost.c.x gethostname.c.x ¶ - getpeername.c.x getproto.c.x ¶ - getserv.c.x getsockname.c.x gettimeofday.c.x ¶ - gmtime.c.x itimer.c.x listen.c.x lockf.c.x ¶ - lseek.c.x mkdir.c.x open.c.x opendir.c.x ¶ - pipe.c.x putenv.c.x read.c.x readdir.c.x readlink.c.x ¶ - rename.c.x rewinddir.c.x rmdir.c.x select.c.x sendrecv.c.x ¶ - setsid.c.x shutdown.c.x signals.c.x ¶ - sleep.c.x socket.c.x socketaddr.c.x socketpair.c.x ¶ - sockopt.c.x stat.c.x strofaddr.c.x symlink.c.x termios.c.x ¶ - truncate.c.x unixsupport.c.x ¶ - unlink.c.x utimes.c.x write.c.x - -C_OBJS = {MAC_OBJS} {UNIX_OBJS} -C_OBJSPPC = {MAC_OBJSPPC} {PPCUNIX_OBJS} - -CAML_OBJS = macosunix_startup.cmo unix.cmo - -all Ä - domake copy-files - directory :byterun: - domake libcamlrun.x libcamlrun.o - directory :: - domake libcamlrun-unix.x libcamlrun-unix.o unix.cma - -### WATCH OUT: libcamlrun.[ox] must be linked last to override getcwd - -libcamlrun-unix.x Ä {C_OBJSPPC} :byterun:libcamlrun.x - ppclink {ldbgflag} -xm library -o libcamlrun-unix.x ¶ - {C_OBJSPPC} :byterun:libcamlrun.x - -libcamlrun-unix.o Ä {C_OBJS} :byterun:libcamlrun.o - lib {ldbgflag} -o libcamlrun-unix.o {C_OBJS} :byterun:libcamlrun.o - -copy-files Ä $OutOfDate - directory ::unix: - duplicate -y {UNIX_FILES} ::macosunix: - directory ::macosunix: - newfolder :byterun || set status 0 - duplicate -y :::byterun:Å.[ach] :::byterun:Makefile.Mac.depend :byterun: - begin - echo 'ocamlgusiflag = -d macintosh_GUSI -includes unix -i "{GUSI}include:"' - catenate :::byterun:Makefile.Mac - end > :byterun:Makefile.Mac - duplicate -y :::config: : - -unix.cma Ä {CAML_OBJS} - {CAMLC} -a -linkall -o unix.cma {CAML_OBJS} - -partialclean Ä - delete -i Å.cmÅ || set status 0 - -clean Ä partialclean - delete -i Å.[xo] || set status 0 - delete -i -y :byterun :config - delete -i {UNIX_FILES} - -install Ä - duplicate -y libcamlrun-unix.o libcamlrun-unix.x unix.cmi unix.cma ¶ - "{LIBDIR}" - -.cmi Ä .mli - {CAMLC} -c {COMPFLAGS} "{depdir}{default}.mli" - -.cmo Ä .ml - {CAMLC} -c {COMPFLAGS} "{depdir}{default}.ml" - -depend Ä copy-files - begin - MakeDepend -w -objext .x Å.c - MakeDepend -w Å.c - :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml - end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend diff --git a/otherlibs/macosunix/Makefile.Mac.depend b/otherlibs/macosunix/Makefile.Mac.depend deleted file mode 100644 index bf3f0f8fbe..0000000000 --- a/otherlibs/macosunix/Makefile.Mac.depend +++ /dev/null @@ -1,872 +0,0 @@ -#*** Dependencies: Cut here *** -# These dependencies were produced at 23:43:09 on 27 fŽv 2001 by MakeDepend - -:accept.c.x Ä ¶ - :accept.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - :socketaddr.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:access.c.x Ä ¶ - :access.c ¶ - :unixsupport.h - -:addrofstr.c.x Ä ¶ - :addrofstr.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:alarm.c.x Ä ¶ - :alarm.c ¶ - :unixsupport.h - -:bind.c.x Ä ¶ - :bind.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:chdir.c.x Ä ¶ - :chdir.c ¶ - :unixsupport.h - -:chmod.c.x Ä ¶ - :chmod.c ¶ - :unixsupport.h - -:close.c.x Ä ¶ - :close.c ¶ - :unixsupport.h - -:closedir.c.x Ä ¶ - :closedir.c ¶ - :unixsupport.h - -:connect.c.x Ä ¶ - :connect.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:cst2constr.c.x Ä ¶ - :cst2constr.c ¶ - :cst2constr.h - -:cstringv.c.x Ä ¶ - :cstringv.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:dup.c.x Ä ¶ - :dup.c ¶ - :unixsupport.h - -:dup2.c.x Ä ¶ - :dup2.c ¶ - :unixsupport.h - -:errmsg.c.x Ä ¶ - :errmsg.c ¶ - "{CIncludes}"errno.h - -:exit.c.x Ä ¶ - :exit.c ¶ - :unixsupport.h - -:fchmod.c.x Ä ¶ - :fchmod.c ¶ - :unixsupport.h - -:fchown.c.x Ä ¶ - :fchown.c ¶ - :unixsupport.h - -:fcntl.c.x Ä ¶ - :fcntl.c ¶ - :unixsupport.h ¶ - "{CIncludes}"fcntl.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"SizeTDef.h - -:ftruncate.c.x Ä ¶ - :ftruncate.c ¶ - :unixsupport.h - -:getcwd.c.x Ä ¶ - :getcwd.c ¶ - :unixsupport.h - -:getgroups.c.x Ä ¶ - :getgroups.c ¶ - "{CIncludes}"limits.h ¶ - :unixsupport.h - -:gethost.c.x Ä ¶ - :gethost.c ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - :socketaddr.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:gethostname.c.x Ä ¶ - :gethostname.c ¶ - :unixsupport.h - -:getpeername.c.x Ä ¶ - :getpeername.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:getproto.c.x Ä ¶ - :getproto.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:getserv.c.x Ä ¶ - :getserv.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:getsockname.c.x Ä ¶ - :getsockname.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:gettimeofday.c.x Ä ¶ - :gettimeofday.c ¶ - :unixsupport.h - -:gmtime.c.x Ä ¶ - :gmtime.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"time.h ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:itimer.c.x Ä ¶ - :itimer.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:listen.c.x Ä ¶ - :listen.c ¶ - :unixsupport.h - -:lockf.c.x Ä ¶ - :lockf.c ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"fcntl.h ¶ - :unixsupport.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"SizeTDef.h - -:lseek.c.x Ä ¶ - :lseek.c ¶ - :unixsupport.h - -:macosunix.c.x Ä ¶ - :macosunix.c ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"time.h ¶ - :unixsupport.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Quickdraw.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"MacErrors.h - -:mkdir.c.x Ä ¶ - :mkdir.c ¶ - :unixsupport.h - -:open.c.x Ä ¶ - :open.c ¶ - :unixsupport.h ¶ - "{CIncludes}"fcntl.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"SizeTDef.h - -:opendir.c.x Ä ¶ - :opendir.c ¶ - :unixsupport.h - -:pipe.c.x Ä ¶ - :pipe.c ¶ - :unixsupport.h - -:putenv.c.x Ä ¶ - :putenv.c ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:read.c.x Ä ¶ - :read.c ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:readdir.c.x Ä ¶ - :readdir.c ¶ - :unixsupport.h - -:readlink.c.x Ä ¶ - :readlink.c ¶ - :unixsupport.h - -:rename.c.x Ä ¶ - :rename.c ¶ - "{CIncludes}"stdio.h ¶ - :unixsupport.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h - -:rewinddir.c.x Ä ¶ - :rewinddir.c ¶ - :unixsupport.h - -:rmdir.c.x Ä ¶ - :rmdir.c ¶ - :unixsupport.h - -:select.c.x Ä ¶ - :select.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:sendrecv.c.x Ä ¶ - :sendrecv.c ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - :socketaddr.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:setsid.c.x Ä ¶ - :setsid.c ¶ - :unixsupport.h - -:shutdown.c.x Ä ¶ - :shutdown.c ¶ - :unixsupport.h - -:signals.c.x Ä ¶ - :signals.c ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:sleep.c.x Ä ¶ - :sleep.c ¶ - :unixsupport.h - -:socket.c.x Ä ¶ - :socket.c ¶ - :unixsupport.h - -:socketaddr.c.x Ä ¶ - :socketaddr.c ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"memory.h ¶ - "{CIncludes}"errno.h ¶ - :unixsupport.h ¶ - :socketaddr.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:socketpair.c.x Ä ¶ - :socketpair.c ¶ - :unixsupport.h - -:sockopt.c.x Ä ¶ - :sockopt.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:stat.c.x Ä ¶ - :stat.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - :cst2constr.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:strofaddr.c.x Ä ¶ - :strofaddr.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:symlink.c.x Ä ¶ - :symlink.c ¶ - :unixsupport.h - -:termios.c.x Ä ¶ - :termios.c ¶ - :unixsupport.h ¶ - "{CIncludes}"errno.h - -:truncate.c.x Ä ¶ - :truncate.c ¶ - :unixsupport.h - -:unixsupport.c.x Ä ¶ - :unixsupport.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - :cst2constr.h ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:unlink.c.x Ä ¶ - :unlink.c ¶ - :unixsupport.h - -:utimes.c.x Ä ¶ - :utimes.c ¶ - :unixsupport.h - -:write.c.x Ä ¶ - :write.c ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -#*** Dependencies: Cut here *** -# These dependencies were produced at 23:43:16 on 27 fŽv 2001 by MakeDepend - -:accept.c.o Ä ¶ - :accept.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - :socketaddr.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:access.c.o Ä ¶ - :access.c ¶ - :unixsupport.h - -:addrofstr.c.o Ä ¶ - :addrofstr.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:alarm.c.o Ä ¶ - :alarm.c ¶ - :unixsupport.h - -:bind.c.o Ä ¶ - :bind.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:chdir.c.o Ä ¶ - :chdir.c ¶ - :unixsupport.h - -:chmod.c.o Ä ¶ - :chmod.c ¶ - :unixsupport.h - -:close.c.o Ä ¶ - :close.c ¶ - :unixsupport.h - -:closedir.c.o Ä ¶ - :closedir.c ¶ - :unixsupport.h - -:connect.c.o Ä ¶ - :connect.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:cst2constr.c.o Ä ¶ - :cst2constr.c ¶ - :cst2constr.h - -:cstringv.c.o Ä ¶ - :cstringv.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:dup.c.o Ä ¶ - :dup.c ¶ - :unixsupport.h - -:dup2.c.o Ä ¶ - :dup2.c ¶ - :unixsupport.h - -:errmsg.c.o Ä ¶ - :errmsg.c ¶ - "{CIncludes}"errno.h - -:exit.c.o Ä ¶ - :exit.c ¶ - :unixsupport.h - -:fchmod.c.o Ä ¶ - :fchmod.c ¶ - :unixsupport.h - -:fchown.c.o Ä ¶ - :fchown.c ¶ - :unixsupport.h - -:fcntl.c.o Ä ¶ - :fcntl.c ¶ - :unixsupport.h ¶ - "{CIncludes}"fcntl.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"SizeTDef.h - -:ftruncate.c.o Ä ¶ - :ftruncate.c ¶ - :unixsupport.h - -:getcwd.c.o Ä ¶ - :getcwd.c ¶ - :unixsupport.h - -:getgroups.c.o Ä ¶ - :getgroups.c ¶ - "{CIncludes}"limits.h ¶ - :unixsupport.h - -:gethost.c.o Ä ¶ - :gethost.c ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - :socketaddr.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:gethostname.c.o Ä ¶ - :gethostname.c ¶ - :unixsupport.h - -:getpeername.c.o Ä ¶ - :getpeername.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:getproto.c.o Ä ¶ - :getproto.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:getserv.c.o Ä ¶ - :getserv.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:getsockname.c.o Ä ¶ - :getsockname.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:gettimeofday.c.o Ä ¶ - :gettimeofday.c ¶ - :unixsupport.h - -:gmtime.c.o Ä ¶ - :gmtime.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"time.h ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:itimer.c.o Ä ¶ - :itimer.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:listen.c.o Ä ¶ - :listen.c ¶ - :unixsupport.h - -:lockf.c.o Ä ¶ - :lockf.c ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"fcntl.h ¶ - :unixsupport.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"SizeTDef.h - -:lseek.c.o Ä ¶ - :lseek.c ¶ - :unixsupport.h - -:macosunix.c.o Ä ¶ - :macosunix.c ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"Resources.h ¶ - "{CIncludes}"TextUtils.h ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"time.h ¶ - :unixsupport.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Quickdraw.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"NumberFormatting.h ¶ - "{CIncludes}"StringCompare.h ¶ - "{CIncludes}"DateTimeUtils.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"IntlResources.h ¶ - "{CIncludes}"Script.h ¶ - "{CIncludes}"MacErrors.h - -:mkdir.c.o Ä ¶ - :mkdir.c ¶ - :unixsupport.h - -:open.c.o Ä ¶ - :open.c ¶ - :unixsupport.h ¶ - "{CIncludes}"fcntl.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"SizeTDef.h - -:opendir.c.o Ä ¶ - :opendir.c ¶ - :unixsupport.h - -:pipe.c.o Ä ¶ - :pipe.c ¶ - :unixsupport.h - -:putenv.c.o Ä ¶ - :putenv.c ¶ - "{CIncludes}"stdlib.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"WCharTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:read.c.o Ä ¶ - :read.c ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:readdir.c.o Ä ¶ - :readdir.c ¶ - :unixsupport.h - -:readlink.c.o Ä ¶ - :readlink.c ¶ - :unixsupport.h - -:rename.c.o Ä ¶ - :rename.c ¶ - "{CIncludes}"stdio.h ¶ - :unixsupport.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"SeekDefs.h ¶ - "{CIncludes}"VaListTDef.h - -:rewinddir.c.o Ä ¶ - :rewinddir.c ¶ - :unixsupport.h - -:rmdir.c.o Ä ¶ - :rmdir.c ¶ - :unixsupport.h - -:select.c.o Ä ¶ - :select.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:sendrecv.c.o Ä ¶ - :sendrecv.c ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - :socketaddr.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:setsid.c.o Ä ¶ - :setsid.c ¶ - :unixsupport.h - -:shutdown.c.o Ä ¶ - :shutdown.c ¶ - :unixsupport.h - -:signals.c.o Ä ¶ - :signals.c ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:sleep.c.o Ä ¶ - :sleep.c ¶ - :unixsupport.h - -:socket.c.o Ä ¶ - :socket.c ¶ - :unixsupport.h - -:socketaddr.c.o Ä ¶ - :socketaddr.c ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"memory.h ¶ - "{CIncludes}"errno.h ¶ - :unixsupport.h ¶ - :socketaddr.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:socketpair.c.o Ä ¶ - :socketpair.c ¶ - :unixsupport.h - -:sockopt.c.o Ä ¶ - :sockopt.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:stat.c.o Ä ¶ - :stat.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - :cst2constr.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:strofaddr.c.o Ä ¶ - :strofaddr.c ¶ - :unixsupport.h ¶ - :socketaddr.h - -:symlink.c.o Ä ¶ - :symlink.c ¶ - :unixsupport.h - -:termios.c.o Ä ¶ - :termios.c ¶ - :unixsupport.h ¶ - "{CIncludes}"errno.h - -:truncate.c.o Ä ¶ - :truncate.c ¶ - :unixsupport.h - -:unixsupport.c.o Ä ¶ - :unixsupport.c ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - :cst2constr.h ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:unlink.c.o Ä ¶ - :unlink.c ¶ - :unixsupport.h - -:utimes.c.o Ä ¶ - :utimes.c ¶ - :unixsupport.h - -:write.c.o Ä ¶ - :write.c ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"memory.h ¶ - :unixsupport.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -macosunix_startup.cmoÄ macosunix_startup.cmi -macosunix_startup.cmxÄ macosunix_startup.cmi -unix.cmoÄ unix.cmi -unix.cmxÄ unix.cmi diff --git a/otherlibs/macosunix/macosunix.c b/otherlibs/macosunix/macosunix.c deleted file mode 100644 index 403aaf7045..0000000000 --- a/otherlibs/macosunix/macosunix.c +++ /dev/null @@ -1,119 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 1999 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <Events.h> -#include <Processes.h> -#include <Resources.h> -#include <TextUtils.h> - -#include <errno.h> -#include <string.h> -#include <time.h> - -#include <alloc.h> -#include <mlvalues.h> -#include <ui.h> - -#include "unixsupport.h" - - -static unsigned long start_ticks; - -value macosunix_startup (value unit) /* ML */ -{ - start_ticks = TickCount (); - - return Val_unit; -} - -value unix_getlogin (void) /* ML */ -{ - char **hs = (char **) GetString (-16096); - if (hs == NULL || *hs == NULL || strlen (*hs) == 0){ - unix_error (ENOENT, "getlogin", Nothing); - } - return copy_string (*hs); -} - -value unix_getegid (void) /* ML */ -{ - return Val_int (1); -} - -value unix_geteuid (void) /* ML */ -{ - return Val_int (1); -} - -value unix_getgid (void) /* ML */ -{ - return Val_int (1); -} - -value unix_getuid (void) /* ML */ -{ - return Val_int (1); -} - -value unix_getpid (void) /* ML */ -{ - ProcessSerialNumber psn; - - GetCurrentProcess (&psn); - return Val_long (psn.lowLongOfPSN); -} - -value unix_time (void) /* ML */ -{ - return copy_double (time (NULL) /* - 2082844800. */); -} - -value unix_times (void) /* ML */ -{ - value res; - - res = alloc_small(4 * Double_wosize, Double_array_tag); - Store_double_field(res, 0, (double) (TickCount () - start_ticks) / 60); - Store_double_field(res, 1, (double) 0.0); - Store_double_field(res, 2, (double) 0.0); - Store_double_field(res, 3, (double) 0.0); - return res; -} - -#define Unimplemented(f, args) \ - value unix_##f args { invalid_argument (#f " not implemented"); } - -Unimplemented (chown, (value path, value uid, value gid)) -Unimplemented (chroot, (value path)) -Unimplemented (environment, (void)) -Unimplemented (execv, (value path, value args)) -Unimplemented (execve, (value path, value args, value env)) -Unimplemented (execvp, (value path, value args)) -Unimplemented (execvpe, (value path, value args, value env)) -Unimplemented (fork, (value unit)) -Unimplemented (getgrnam, (value name)) -Unimplemented (getgrgid, (value gid)) -Unimplemented (getppid, (void)) -Unimplemented (getpwnam, (value name)) -Unimplemented (getpwuid, (value uid)) -Unimplemented (kill, (value pid, value signal)) -Unimplemented (link, (value path1, value path2)) -Unimplemented (mkfifo, (value path, value mode)) -Unimplemented (nice, (value incr)) -Unimplemented (setgid, (value gid)) -Unimplemented (setuid, (value uid)) -Unimplemented (umask, (value perm)) -Unimplemented (wait, (void)) -Unimplemented (waitpid, (value flags, value pid_req)) diff --git a/otherlibs/macosunix/macosunix_startup.ml b/otherlibs/macosunix/macosunix_startup.ml deleted file mode 100644 index 93c4f213b1..0000000000 --- a/otherlibs/macosunix/macosunix_startup.ml +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -external startup : unit -> unit = "macosunix_startup";; -startup ();; diff --git a/otherlibs/macosunix/macosunix_startup.mli b/otherlibs/macosunix/macosunix_startup.mli deleted file mode 100644 index 96a84e30b2..0000000000 --- a/otherlibs/macosunix/macosunix_startup.mli +++ /dev/null @@ -1,16 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* This file left blank intentionally. *) diff --git a/otherlibs/macosunix/unix-primitives b/otherlibs/macosunix/unix-primitives deleted file mode 100644 index 9f920883a7..0000000000 --- a/otherlibs/macosunix/unix-primitives +++ /dev/null @@ -1,113 +0,0 @@ -macosunix_startup -unix_accept -unix_access -unix_alarm -unix_bind -unix_chdir -unix_chmod -unix_chown -unix_chroot -unix_clear_close_on_exec -unix_clear_nonblock -unix_close -unix_closedir -unix_connect -unix_dup -unix_dup2 -unix_environment -unix_error_message -unix_execv -unix_execve -unix_execvp -unix_execvpe -unix_exit -unix_fchmod -unix_fchown -unix_fork -unix_fstat -unix_ftruncate -unix_getcwd -unix_getegid -unix_geteuid -unix_getgid -unix_getgrgid -unix_getgrnam -unix_getgroups -unix_gethostbyaddr -unix_gethostbyname -unix_gethostname -unix_getitimer -unix_getlogin -unix_getpeername -unix_getpid -unix_getppid -unix_getprotobyname -unix_getprotobynumber -unix_getpwnam -unix_getpwuid -unix_getservbyname -unix_getservbyport -unix_getsockname -unix_getsockopt -unix_gettimeofday -unix_getuid -unix_gmtime -unix_inet_addr_of_string -unix_kill -unix_link -unix_listen -unix_localtime -unix_lockf -unix_lseek -unix_lstat -unix_mkdir -unix_mkfifo -unix_mktime -unix_nice -unix_open -unix_opendir -unix_pipe -unix_putenv -unix_read -unix_readdir -unix_readlink -unix_recv -unix_recvfrom -unix_rename -unix_rewinddir -unix_rmdir -unix_select -unix_send -unix_sendto -unix_set_close_on_exec -unix_set_nonblock -unix_setgid -unix_setitimer -unix_setsid -unix_setsockopt -unix_setuid -unix_shutdown -unix_sigpending -unix_sigprocmask -unix_sigsuspend -unix_sleep -unix_socket -unix_socketpair -unix_stat -unix_string_of_inet_addr -unix_symlink -unix_tcdrain -unix_tcflow -unix_tcflush -unix_tcgetattr -unix_tcsendbreak -unix_tcsetattr -unix_time -unix_times -unix_truncate -unix_umask -unix_unlink -unix_utimes -unix_wait -unix_waitpid -unix_write diff --git a/otherlibs/macosunix/unixsupport.h b/otherlibs/macosunix/unixsupport.h deleted file mode 100644 index 8b9e4526f1..0000000000 --- a/otherlibs/macosunix/unixsupport.h +++ /dev/null @@ -1,43 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 1999 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#define POSIX_SIGNALS -#define HAS_MEMMOVE -#define HAS_STRERROR -#define HAS_SOCKETS -#define HAS_SOCKLEN_T -#define HAS_UNISTD -#define HAS_DIRENT -#define HAS_REWINDDIR -#define HAS_GETCWD -#define HAS_UTIME -#define HAS_DUP2 -#define HAS_TRUNCATE -#define HAS_SELECT -#define HAS_SYMLINK -#define HAS_GETHOSTNAME -#define HAS_GETTIMEOFDAY -#define HAS_MKTIME - -#ifdef HAS_UNISTD -#include <unistd.h> -#endif - -#define Nothing ((value) 0) - -extern void unix_error (int errcode, char * cmdname, value arg) Noreturn; -extern void uerror (char * cmdname, value arg) Noreturn; - -#define UNIX_BUFFER_SIZE 2048 diff --git a/otherlibs/num/.cvsignore b/otherlibs/num/.cvsignore deleted file mode 100644 index 7786c62f9f..0000000000 --- a/otherlibs/num/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -libnums.x -*.c.x -so_locations diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend deleted file mode 100644 index a44606d1d8..0000000000 --- a/otherlibs/num/.depend +++ /dev/null @@ -1,35 +0,0 @@ -bng_alpha.o: bng_alpha.c -bng_amd64.o: bng_amd64.c -bng.o: bng.c bng.h bng_ia32.c bng_digit.c -bng_digit.o: bng_digit.c -bng_ia32.o: bng_ia32.c -bng_mips.o: bng_mips.c -bng_ppc.o: bng_ppc.c -bng_sparc.o: bng_sparc.c -nat_stubs.o: nat_stubs.c ../../byterun/alloc.h ../../byterun/misc.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/mlvalues.h ../../byterun/custom.h ../../byterun/intext.h \ - ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h bng.h nat.h -big_int.cmi: nat.cmi -num.cmi: big_int.cmi nat.cmi ratio.cmi -ratio.cmi: big_int.cmi nat.cmi -arith_flags.cmo: arith_flags.cmi -arith_flags.cmx: arith_flags.cmi -arith_status.cmo: arith_flags.cmi arith_status.cmi -arith_status.cmx: arith_flags.cmx arith_status.cmi -big_int.cmo: int_misc.cmi nat.cmi big_int.cmi -big_int.cmx: int_misc.cmx nat.cmx big_int.cmi -int_misc.cmo: int_misc.cmi -int_misc.cmx: int_misc.cmi -nat.cmo: int_misc.cmi nat.cmi -nat.cmx: int_misc.cmx nat.cmi -num.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi ratio.cmi num.cmi -num.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx ratio.cmx num.cmi -ratio.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi string_misc.cmi \ - ratio.cmi -ratio.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx string_misc.cmx \ - ratio.cmi -string_misc.cmo: string_misc.cmi -string_misc.cmx: string_misc.cmi diff --git a/otherlibs/num/.depend.nt b/otherlibs/num/.depend.nt deleted file mode 100644 index 0d604eab10..0000000000 --- a/otherlibs/num/.depend.nt +++ /dev/null @@ -1,56 +0,0 @@ -nat_stubs.dobj: nat_stubs.c ../../byterun/alloc.h ../../byterun/misc.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/custom.h ../../byterun/intext.h ../../byterun/io.h \ - ../../byterun/fix_code.h ../../byterun/fail.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h nat.h bignum/h/BigNum.h bignum/h/BntoBnn.h -big_int.cmi: nat.cmi -num.cmi: big_int.cmi nat.cmi ratio.cmi -ratio.cmi: big_int.cmi nat.cmi -arith_flags.cmo: arith_flags.cmi -arith_flags.cmx: arith_flags.cmi -arith_status.cmo: arith_flags.cmi arith_status.cmi -arith_status.cmx: arith_flags.cmx arith_status.cmi -big_int.cmo: int_misc.cmi nat.cmi big_int.cmi -big_int.cmx: int_misc.cmx nat.cmx big_int.cmi -int_misc.cmo: int_misc.cmi -int_misc.cmx: int_misc.cmi -nat.cmo: int_misc.cmi nat.cmi -nat.cmx: int_misc.cmx nat.cmi -num.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi ratio.cmi num.cmi -num.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx ratio.cmx num.cmi -ratio.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi string_misc.cmi \ - ratio.cmi -ratio.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx string_misc.cmx \ - ratio.cmi -string_misc.cmo: string_misc.cmi -string_misc.cmx: string_misc.cmi -nat_stubs.sobj: nat_stubs.c ../../byterun/alloc.h ../../byterun/misc.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/custom.h ../../byterun/intext.h ../../byterun/io.h \ - ../../byterun/fix_code.h ../../byterun/fail.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h nat.h bignum/h/BigNum.h bignum/h/BntoBnn.h -big_int.cmi: nat.cmi -num.cmi: big_int.cmi nat.cmi ratio.cmi -ratio.cmi: big_int.cmi nat.cmi -arith_flags.cmo: arith_flags.cmi -arith_flags.cmx: arith_flags.cmi -arith_status.cmo: arith_flags.cmi arith_status.cmi -arith_status.cmx: arith_flags.cmx arith_status.cmi -big_int.cmo: int_misc.cmi nat.cmi big_int.cmi -big_int.cmx: int_misc.cmx nat.cmx big_int.cmi -int_misc.cmo: int_misc.cmi -int_misc.cmx: int_misc.cmi -nat.cmo: int_misc.cmi nat.cmi -nat.cmx: int_misc.cmx nat.cmi -num.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi ratio.cmi num.cmi -num.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx ratio.cmx num.cmi -ratio.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi string_misc.cmi \ - ratio.cmi -ratio.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx string_misc.cmx \ - ratio.cmi -string_misc.cmo: string_misc.cmi -string_misc.cmx: string_misc.cmi diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile deleted file mode 100644 index e79df16c70..0000000000 --- a/otherlibs/num/Makefile +++ /dev/null @@ -1,86 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the "num" (exact rational arithmetic) library - -include ../../config/Makefile - -# Compilation options -CC=$(BYTECC) -CFLAGS=-O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \ - -DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL) -CAMLC=../../ocamlcomp.sh -w s -CAMLOPT=../../ocamlcompopt.sh -w s -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A - -CAMLOBJS=int_misc.cmo string_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \ - ratio.cmo num.cmo arith_status.cmo - -CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi - -COBJS=bng.o nat_stubs.o - -all: libnums.a nums.cma $(CMIFILES) - -allopt: libnums.a nums.cmxa $(CMIFILES) - -nums.cma: $(CAMLOBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -o nums $(CAMLOBJS) - -nums.cmxa: $(CAMLOBJS:.cmo=.cmx) - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o nums $(CAMLOBJS:.cmo=.cmx) - -libnums.a: $(COBJS) - $(MKLIB) -o nums $(COBJS) - -$(CAMLOBJS:.cmo=.cmx): ../../ocamlopt - -install: - if test -f dllnums.so; then cp dllnums.so $(STUBLIBDIR)/dllnums.so; fi - cp libnums.a $(LIBDIR)/libnums.a - cd $(LIBDIR); $(RANLIB) libnums.a - cp nums.cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(LIBDIR) - -installopt: - cp $(CAMLOBJS:.cmo=.cmx) nums.cmxa nums.a $(LIBDIR) - cd $(LIBDIR); $(RANLIB) nums.a - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.a *.o *.so - cd test; $(MAKE) clean - -.SUFFIXES: .ml .mli .cmi .cmo .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -bng.o: bng.h bng_digit.c \ - bng_alpha.c bng_amd64.c bng_ia32.c bng_mips.c bng_ppc.c bng_sparc.c - -depend: - gcc -MM $(CFLAGS) *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend - -include .depend diff --git a/otherlibs/num/Makefile.Mac b/otherlibs/num/Makefile.Mac deleted file mode 100644 index 6e3c1e5fd2..0000000000 --- a/otherlibs/num/Makefile.Mac +++ /dev/null @@ -1,64 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the "num" (exact rational arithmetic) library - -# Compilation options -PPCC = mrc -PPCCOptions = -i :bignum:h:,:::byterun:,:::config: -w 35 {cdbgflag} - -CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib: -w s -CAMLOPT = :::boot:ocamlrun :::ocamlopt: -I :::stdlib: -w s - -CAMLOBJS = int_misc.cmo string_misc.cmo nat.cmo big_int.cmo arith_flags.cmo ¶ - ratio.cmo num.cmo arith_status.cmo - -CMIFILES = big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi - -PPCCOBJS = nat_stubs.c.x - -all Ä libnums.x nums.cma {CMIFILES} - -nums.cma Ä {CAMLOBJS} - {CAMLC} -a -o nums.cma {CAMLOBJS} - -libnums.x Ä :bignum:libbignum.x {PPCCOBJS} - ppclink {ldbgflag} -xm library -o libnums.x :bignum:libbignum.x {PPCCOBJS} - -:bignum:libbignum.x Ä :bignum:libbignum.o - directory :bignum; domake C; directory :: - -install Ä - duplicate -y libnums.x nums.cma {CMIFILES} "{LIBDIR}" - -partialclean Ä - delete -i Å.cm[aio] || set status 0 - -clean Ä partialclean - delete -i Å.x || set status 0 - directory :bignum; domake scratch; directory :: - directory :test; domake clean; directory :: - -.cmi Ä .mli - {CAMLC} -c {COMPFLAGS} {default}.mli - -.cmo Ä .ml - {CAMLC} -c {COMPFLAGS} {default}.ml - -depend Ä - begin - MakeDepend -w -objext .x Å.c - :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml - end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend diff --git a/otherlibs/num/Makefile.Mac.depend b/otherlibs/num/Makefile.Mac.depend deleted file mode 100644 index c36b26712d..0000000000 --- a/otherlibs/num/Makefile.Mac.depend +++ /dev/null @@ -1,33 +0,0 @@ -#*** Dependencies: Cut here *** -# These dependencies were produced at 20:33:19 on Tue, Aug 21, 2001 by MakeDepend - -:nat_stubs.c.x Ä ¶ - :nat_stubs.c ¶ - "{CIncludes}"memory.h ¶ - :nat.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -big_int.cmiÄ nat.cmi -num.cmiÄ big_int.cmi nat.cmi ratio.cmi -ratio.cmiÄ big_int.cmi nat.cmi -arith_flags.cmoÄ arith_flags.cmi -arith_flags.cmxÄ arith_flags.cmi -arith_status.cmoÄ arith_flags.cmi arith_status.cmi -arith_status.cmxÄ arith_flags.cmx arith_status.cmi -big_int.cmoÄ int_misc.cmi nat.cmi big_int.cmi -big_int.cmxÄ int_misc.cmx nat.cmx big_int.cmi -int_misc.cmoÄ int_misc.cmi -int_misc.cmxÄ int_misc.cmi -nat.cmoÄ int_misc.cmi nat.cmi -nat.cmxÄ int_misc.cmx nat.cmi -num.cmoÄ arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi ratio.cmi num.cmi -num.cmxÄ arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx ratio.cmx num.cmi -ratio.cmoÄ arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi string_misc.cmi ¶ - ratio.cmi -ratio.cmxÄ arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx string_misc.cmx ¶ - ratio.cmi -string_misc.cmoÄ string_misc.cmi -string_misc.cmxÄ string_misc.cmi diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt deleted file mode 100644 index a36a3d3b99..0000000000 --- a/otherlibs/num/Makefile.nt +++ /dev/null @@ -1,97 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the "num" (exact rational arithmetic) library - -include ../../config/Makefile - -# Compilation options -CC=$(BYTECC) -CFLAGS=-O -I../../byterun \ - -DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL) -CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../boot -w s -CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -w s - -CAMLOBJS=int_misc.cmo string_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \ - ratio.cmo num.cmo arith_status.cmo - -CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi - -DCOBJS=bng.$(DO) nat_stubs.$(DO) -SCOBJS=bng.$(SO) nat_stubs.$(SO) - -all: dllnums.dll libnums.$(A) nums.cma $(CMIFILES) - -allopt: libnums.$(A) nums.cmxa $(CMIFILES) - -nums.cma: $(CAMLOBJS) - $(CAMLC) -a -o nums.cma $(CAMLOBJS) -dllib -lnums -cclib -lnums - -nums.cmxa: $(CAMLOBJS:.cmo=.cmx) - $(CAMLOPT) -a -o nums.cmxa $(CAMLOBJS:.cmo=.cmx) -cclib -lnums - -dllnums.dll: $(DCOBJS) - $(call MKDLL,dllnums.dll,tmp.$(A),\ - $(DCOBJS) ../../byterun/ocamlrun.$(A)) - rm tmp.* - -libnums.$(A): $(SCOBJS) - $(call MKLIB,libnums.$(A),$(SCOBJS)) - -$(CAMLOBJS:.cmo=.cmx): ../../ocamlopt - -install: - cp dllnums.dll $(STUBLIBDIR)/dllnums.dll - cp libnums.$(A) $(LIBDIR)/libnums.$(A) - cp nums.cma $(CMIFILES) $(LIBDIR) - -installopt: - cp $(CAMLOBJS:.cmo=.cmx) nums.cmxa nums.$(A) $(LIBDIR) - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.dll *.$(A) *.$(O) - cd bignum ; $(MAKEREC) scratch - cd test ; $(MAKEREC) clean - -.SUFFIXES: .ml .mli .cmi .cmo .cmx .$(DO) .$(SO) - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(SO) - -bng.$(DO) bng.$(SO): bng.h bng_digit.c \ - bng_alpha.c bng_amd64.c bng_ia32.c bng_mips.c bng_ppc.c bng_sparc.c - -depend: - sed -e 's/\.o/.$(DO)/g' .depend > .depend.nt - sed -e 's/\.o/.$(SO)/g' .depend >> .depend.nt - -include .depend.nt diff --git a/otherlibs/num/README b/otherlibs/num/README deleted file mode 100644 index d4969bfdd0..0000000000 --- a/otherlibs/num/README +++ /dev/null @@ -1,55 +0,0 @@ -The "libnum" library implements exact-precision arithmetic on -big integers and on rationals. - -This library is derived from Valerie Menissie-Morain's implementation -of rational arithmetic for Caml V3.1 (INRIA). Xavier Leroy (INRIA) -did the Caml Light port. Victor Manuel Gulias Fernandez did the -initial Caml Special Light port. Pierre Weis did most of the -maintenance and bug fixing. - -Initially, the low-level big integer operations were provided by the -BigNum package developed by Bernard Serpette, Jean Vuillemin and -Jean-Claude Herve (INRIA and Digital PRL). License issues forced us to -replace the BigNum package. The current implementation of low-level -big integer operations is due to Xavier Leroy. - -This library is documented in "The CAML Numbers Reference Manual" by -Valerie Menissier-Morain, technical report 141, INRIA, july 1992, -available at ftp://ftp.inria.fr/INRIA/publication/RT/RT-0141.ps.gz - - -USAGE: - -To use the bignum library from your programs, just do - - ocamlc <options> nums.cma <.cmo and .ml files> -or - ocamlopt <options> nums.cmxa <.cmx and .ml files> - -for the linking phase. - -If you'd like to have the bignum functions available at toplevel, do - - ocamlmktop -o ocamltopnum <options> nums.cma <.cmo and .ml files> - ./ocamltopnum - -As an example, try: - - open Num;; - let rec fact n = - if n = 0 then Int 1 else mult_num (num_of_int n) (fact(n-1));; - string_of_num(fact 1000);; - - -PROCESSOR-SPECIFIC OPTIMIZATIONS: - -When compiled with GCC, the low-level primitives use "inline extended asm" -to exploit useful features of the target processor (additions and -subtractions with carry; double-width multiplication, division). -Here are the processors for which such optimizations are available: - IA32 (x86) (carry, dwmult, dwdiv, 64-bit ops with SSE2 if available) - AMD64 (Opteron) (carry, dwmult, dwdiv) - PowerPC (carry, dwmult) - Alpha (dwmult) - SPARC (carry, dwmult, dwdiv) - MIPS (dwmult) diff --git a/otherlibs/num/arith_flags.ml b/otherlibs/num/arith_flags.ml deleted file mode 100644 index 6192ba2027..0000000000 --- a/otherlibs/num/arith_flags.ml +++ /dev/null @@ -1,25 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -let error_when_null_denominator_flag = ref true;; - -let normalize_ratio_flag = ref false;; - -let normalize_ratio_when_printing_flag = ref true;; - -let floating_precision = ref 12;; - -let approx_printing_flag = ref false;; - diff --git a/otherlibs/num/arith_flags.mli b/otherlibs/num/arith_flags.mli deleted file mode 100644 index 36160edb24..0000000000 --- a/otherlibs/num/arith_flags.mli +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -val error_when_null_denominator_flag : bool ref -val normalize_ratio_flag : bool ref -val normalize_ratio_when_printing_flag : bool ref -val floating_precision : int ref -val approx_printing_flag : bool ref diff --git a/otherlibs/num/arith_status.ml b/otherlibs/num/arith_status.ml deleted file mode 100644 index 02affd92b2..0000000000 --- a/otherlibs/num/arith_status.ml +++ /dev/null @@ -1,100 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Arith_flags;; - -let get_error_when_null_denominator () = - !error_when_null_denominator_flag -and set_error_when_null_denominator choice = - error_when_null_denominator_flag := choice;; - -let get_normalize_ratio () = !normalize_ratio_flag -and set_normalize_ratio choice = normalize_ratio_flag := choice;; - -let get_normalize_ratio_when_printing () = - !normalize_ratio_when_printing_flag -and set_normalize_ratio_when_printing choice = - normalize_ratio_when_printing_flag := choice;; - -let get_floating_precision () = !floating_precision -and set_floating_precision i = floating_precision := i;; - -let get_approx_printing () = !approx_printing_flag -and set_approx_printing b = approx_printing_flag := b;; - -let arith_print_string s = print_string s; print_string " --> ";; - -let arith_print_bool = function - true -> print_string "ON" -| _ -> print_string "OFF" -;; - -let arith_status () = - print_newline (); - - arith_print_string - "Normalization during computation"; - arith_print_bool (get_normalize_ratio ()); - print_newline (); - print_string " (returned by get_normalize_ratio ())"; - print_newline (); - print_string " (modifiable with set_normalize_ratio <your choice>)"; - print_newline (); - print_newline (); - - arith_print_string - "Normalization when printing"; - arith_print_bool (get_normalize_ratio_when_printing ()); - print_newline (); - print_string - " (returned by get_normalize_ratio_when_printing ())"; - print_newline (); - print_string - " (modifiable with set_normalize_ratio_when_printing <your choice>)"; - print_newline (); - print_newline (); - - arith_print_string - "Floating point approximation when printing rational numbers"; - arith_print_bool (get_approx_printing ()); - print_newline (); - print_string - " (returned by get_approx_printing ())"; - print_newline (); - print_string - " (modifiable with set_approx_printing <your choice>)"; - print_newline (); - (if (get_approx_printing ()) - then (print_string " Default precision = "; - print_int (get_floating_precision ()); - print_newline (); - print_string " (returned by get_floating_precision ())"; - print_newline (); - print_string - " (modifiable with set_floating_precision <your choice>)"; - print_newline (); - print_newline ()) - else print_newline()); - - arith_print_string - "Error when a rational denominator is null"; - arith_print_bool (get_error_when_null_denominator ()); - print_newline (); - print_string " (returned by get_error_when_null_denominator ())"; - print_newline (); - print_string - " (modifiable with set_error_when_null_denominator <your choice>)"; - print_newline () -;; diff --git a/otherlibs/num/arith_status.mli b/otherlibs/num/arith_status.mli deleted file mode 100644 index ec339cc422..0000000000 --- a/otherlibs/num/arith_status.mli +++ /dev/null @@ -1,60 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Flags that control rational arithmetic. *) - -val arith_status: unit -> unit - (** Print the current status of the arithmetic flags. *) - -val get_error_when_null_denominator : unit -> bool - (** See {!Arith_status.set_error_when_null_denominator}.*) -val set_error_when_null_denominator : bool -> unit - (** Get or set the flag [null_denominator]. When on, attempting to - create a rational with a null denominator raises an exception. - When off, rationals with null denominators are accepted. - Initially: on. *) - -val get_normalize_ratio : unit -> bool - (** See {!Arith_status.set_normalize_ratio}.*) -val set_normalize_ratio : bool -> unit - (** Get or set the flag [normalize_ratio]. When on, rational - numbers are normalized after each operation. When off, - rational numbers are not normalized until printed. - Initially: off. *) - -val get_normalize_ratio_when_printing : unit -> bool - (** See {!Arith_status.set_normalize_ratio_when_printing}.*) -val set_normalize_ratio_when_printing : bool -> unit - (** Get or set the flag [normalize_ratio_when_printing]. - When on, rational numbers are normalized before being printed. - When off, rational numbers are printed as is, without normalization. - Initially: on. *) - -val get_approx_printing : unit -> bool - (** See {!Arith_status.set_approx_printing}.*) -val set_approx_printing : bool -> unit - (** Get or set the flag [approx_printing]. - When on, rational numbers are printed as a decimal approximation. - When off, rational numbers are printed as a fraction. - Initially: off. *) - -val get_floating_precision : unit -> int - (** See {!Arith_status.set_floating_precision}.*) -val set_floating_precision : int -> unit - (** Get or set the parameter [floating_precision]. - This parameter is the number of digits displayed when - [approx_printing] is on. - Initially: 12. *) - diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml deleted file mode 100644 index 7542f1f89b..0000000000 --- a/otherlibs/num/big_int.ml +++ /dev/null @@ -1,603 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Int_misc -open Nat - -type big_int = - { sign : int; - abs_value : nat } - -let create_big_int sign nat = - if sign = 1 || sign = -1 || - (sign = 0 && - is_zero_nat nat 0 (num_digits_nat nat 0 (length_nat nat))) - then { sign = sign; - abs_value = nat } - else invalid_arg "create_big_int" - -(* Sign of a big_int *) -let sign_big_int bi = bi.sign - -let zero_big_int = - { sign = 0; - abs_value = make_nat 1 } - -let unit_big_int = - { sign = 1; - abs_value = nat_of_int 1 } - -(* Number of digits in a big_int *) -let num_digits_big_int bi = - num_digits_nat (bi.abs_value) 0 (length_nat bi.abs_value) - -(* Opposite of a big_int *) -let minus_big_int bi = - { sign = - bi.sign; - abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)} - -(* Absolute value of a big_int *) -let abs_big_int bi = - { sign = if bi.sign = 0 then 0 else 1; - abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)} - -(* Comparison operators on big_int *) - -(* - compare_big_int (bi, bi2) = sign of (bi-bi2) - i.e. 1 if bi > bi2 - 0 if bi = bi2 - -1 if bi < bi2 -*) -let compare_big_int bi1 bi2 = - if bi1.sign = 0 && bi2.sign = 0 then 0 - else if bi1.sign < bi2.sign then -1 - else if bi1.sign > bi2.sign then 1 - else if bi1.sign = 1 then - compare_nat (bi1.abs_value) 0 (num_digits_big_int bi1) - (bi2.abs_value) 0 (num_digits_big_int bi2) - else - compare_nat (bi2.abs_value) 0 (num_digits_big_int bi2) - (bi1.abs_value) 0 (num_digits_big_int bi1) - -let eq_big_int bi1 bi2 = compare_big_int bi1 bi2 = 0 -and le_big_int bi1 bi2 = compare_big_int bi1 bi2 <= 0 -and ge_big_int bi1 bi2 = compare_big_int bi1 bi2 >= 0 -and lt_big_int bi1 bi2 = compare_big_int bi1 bi2 < 0 -and gt_big_int bi1 bi2 = compare_big_int bi1 bi2 > 0 - -let max_big_int bi1 bi2 = if lt_big_int bi1 bi2 then bi2 else bi1 -and min_big_int bi1 bi2 = if gt_big_int bi1 bi2 then bi2 else bi1 - -(* Operations on big_int *) - -let pred_big_int bi = - match bi.sign with - 0 -> { sign = -1; abs_value = nat_of_int 1} - | 1 -> let size_bi = num_digits_big_int bi in - let copy_bi = copy_nat (bi.abs_value) 0 size_bi in - decr_nat copy_bi 0 size_bi 0; - { sign = if is_zero_nat copy_bi 0 size_bi then 0 else 1; - abs_value = copy_bi } - | _ -> let size_bi = num_digits_big_int bi in - let size_res = succ (size_bi) in - let copy_bi = create_nat (size_res) in - blit_nat copy_bi 0 (bi.abs_value) 0 size_bi; - set_digit_nat copy_bi size_bi 0; - incr_nat copy_bi 0 size_res 1; - { sign = -1; - abs_value = copy_bi } - -let succ_big_int bi = - match bi.sign with - 0 -> {sign = 1; abs_value = nat_of_int 1} - | -1 -> let size_bi = num_digits_big_int bi in - let copy_bi = copy_nat (bi.abs_value) 0 size_bi in - decr_nat copy_bi 0 size_bi 0; - { sign = if is_zero_nat copy_bi 0 size_bi then 0 else -1; - abs_value = copy_bi } - | _ -> let size_bi = num_digits_big_int bi in - let size_res = succ (size_bi) in - let copy_bi = create_nat (size_res) in - blit_nat copy_bi 0 (bi.abs_value) 0 size_bi; - set_digit_nat copy_bi size_bi 0; - incr_nat copy_bi 0 size_res 1; - { sign = 1; - abs_value = copy_bi } - -let add_big_int bi1 bi2 = - let size_bi1 = num_digits_big_int bi1 - and size_bi2 = num_digits_big_int bi2 in - if bi1.sign = bi2.sign - then (* Add absolute values if signs are the same *) - { sign = bi1.sign; - abs_value = - match compare_nat (bi1.abs_value) 0 size_bi1 - (bi2.abs_value) 0 size_bi2 with - -1 -> let res = create_nat (succ size_bi2) in - (blit_nat res 0 (bi2.abs_value) 0 size_bi2; - set_digit_nat res size_bi2 0; - add_nat res 0 (succ size_bi2) - (bi1.abs_value) 0 size_bi1 0; - res) - |_ -> let res = create_nat (succ size_bi1) in - (blit_nat res 0 (bi1.abs_value) 0 size_bi1; - set_digit_nat res size_bi1 0; - add_nat res 0 (succ size_bi1) - (bi2.abs_value) 0 size_bi2 0; - res)} - - else (* Subtract absolute values if signs are different *) - match compare_nat (bi1.abs_value) 0 size_bi1 - (bi2.abs_value) 0 size_bi2 with - 0 -> zero_big_int - | 1 -> { sign = bi1.sign; - abs_value = - let res = copy_nat (bi1.abs_value) 0 size_bi1 in - (sub_nat res 0 size_bi1 - (bi2.abs_value) 0 size_bi2 1; - res) } - | _ -> { sign = bi2.sign; - abs_value = - let res = copy_nat (bi2.abs_value) 0 size_bi2 in - (sub_nat res 0 size_bi2 - (bi1.abs_value) 0 size_bi1 1; - res) } - -(* Coercion with int type *) -let big_int_of_int i = - { sign = sign_int i; - abs_value = - let res = (create_nat 1) - in (if i = monster_int - then (set_digit_nat res 0 biggest_int; - incr_nat res 0 1 1; ()) - else set_digit_nat res 0 (abs i)); - res } - -let add_int_big_int i bi = add_big_int (big_int_of_int i) bi - -let sub_big_int bi1 bi2 = add_big_int bi1 (minus_big_int bi2) - -(* Returns i * bi *) -let mult_int_big_int i bi = - let size_bi = num_digits_big_int bi in - let size_res = succ size_bi in - if i = monster_int - then let res = create_nat size_res in - blit_nat res 0 (bi.abs_value) 0 size_bi; - mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi - (nat_of_int biggest_int) 0; - { sign = - (sign_big_int bi); - abs_value = res } - else let res = make_nat (size_res) in - mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi - (nat_of_int (abs i)) 0; - { sign = (sign_int i) * (sign_big_int bi); - abs_value = res } - -let mult_big_int bi1 bi2 = - let size_bi1 = num_digits_big_int bi1 - and size_bi2 = num_digits_big_int bi2 in - let size_res = size_bi1 + size_bi2 in - let res = make_nat (size_res) in - { sign = bi1.sign * bi2.sign; - abs_value = - if size_bi2 > size_bi1 - then (mult_nat res 0 size_res (bi2.abs_value) 0 size_bi2 - (bi1.abs_value) 0 size_bi1;res) - else (mult_nat res 0 size_res (bi1.abs_value) 0 size_bi1 - (bi2.abs_value) 0 size_bi2;res) } - -(* (quotient, rest) of the euclidian division of 2 big_int *) -let quomod_big_int bi1 bi2 = - if bi2.sign = 0 then raise Division_by_zero - else - let size_bi1 = num_digits_big_int bi1 - and size_bi2 = num_digits_big_int bi2 in - match compare_nat (bi1.abs_value) 0 size_bi1 - (bi2.abs_value) 0 size_bi2 with - -1 -> (* 1/2 -> 0, reste 1, -1/2 -> -1, reste 1 *) - if bi1.sign = -1 - then (big_int_of_int(-1), add_big_int bi2 bi1) - else (big_int_of_int 0, bi1) - | 0 -> (big_int_of_int (bi1.sign * bi2.sign), zero_big_int) - | _ -> let bi1_negatif = bi1.sign = -1 in - let size_q = - if bi1_negatif - then succ (max (succ (size_bi1 - size_bi2)) 1) - else max (succ (size_bi1 - size_bi2)) 1 - and size_r = succ (max size_bi1 size_bi2) - (* r is long enough to contain both quotient and remainder *) - (* of the euclidian division *) - in - (* set up quotient, remainder *) - let q = create_nat size_q - and r = create_nat size_r in - blit_nat r 0 (bi1.abs_value) 0 size_bi1; - set_to_zero_nat r size_bi1 (size_r - size_bi1); - - (* do the division of |bi1| by |bi2| - - at the beginning, r contains |bi1| - - at the end, r contains - * in the size_bi2 least significant digits, the remainder - * in the size_r-size_bi2 most significant digits, the quotient - note the conditions for application of div_nat are verified here - *) - div_nat r 0 size_r (bi2.abs_value) 0 size_bi2; - - (* separate quotient and remainder *) - blit_nat q 0 r size_bi2 (size_r - size_bi2); - let not_null_mod = not (is_zero_nat r 0 size_bi2) in - - (* correct the signs, adjusting the quotient and remainder *) - if bi1_negatif && not_null_mod - then - (* bi1<0, r>0, noting r for (r, size_bi2) the remainder, *) - (* we have |bi1|=q * |bi2| + r with 0 < r < |bi2|, *) - (* thus -bi1 = q * |bi2| + r *) - (* and bi1 = (-q) * |bi2| + (-r) with -|bi2| < (-r) < 0 *) - (* thus bi1 = -(q+1) * |bi2| + (|bi2|-r) *) - (* with 0 < (|bi2|-r) < |bi2| *) - (* so the quotient has for sign the opposite of the bi2'one *) - (* and for value q+1 *) - (* and the remainder is strictly positive *) - (* has for value |bi2|-r *) - (let new_r = copy_nat (bi2.abs_value) 0 size_bi2 in - (* new_r contains (r, size_bi2) the remainder *) - { sign = - bi2.sign; - abs_value = (set_digit_nat q (pred size_q) 0; - incr_nat q 0 size_q 1; q) }, - { sign = 1; - abs_value = - (sub_nat new_r 0 size_bi2 r 0 size_bi2 1; - new_r) }) - else - (if bi1_negatif then set_digit_nat q (pred size_q) 0; - { sign = if is_zero_nat q 0 size_q - then 0 - else bi1.sign * bi2.sign; - abs_value = q }, - { sign = if not_null_mod then 1 else 0; - abs_value = copy_nat r 0 size_bi2 }) - -let div_big_int bi1 bi2 = fst (quomod_big_int bi1 bi2) -and mod_big_int bi1 bi2 = snd (quomod_big_int bi1 bi2) - -let gcd_big_int bi1 bi2 = - let size_bi1 = num_digits_big_int bi1 - and size_bi2 = num_digits_big_int bi2 in - if is_zero_nat (bi1.abs_value) 0 size_bi1 then abs_big_int bi2 - else if is_zero_nat (bi2.abs_value) 0 size_bi2 then - { sign = 1; - abs_value = bi1.abs_value } - else - { sign = 1; - abs_value = - match compare_nat (bi1.abs_value) 0 size_bi1 - (bi2.abs_value) 0 size_bi2 with - 0 -> bi1.abs_value - | 1 -> - let res = copy_nat (bi1.abs_value) 0 size_bi1 in - let len = - gcd_nat res 0 size_bi1 (bi2.abs_value) 0 size_bi2 in - copy_nat res 0 len - | _ -> - let res = copy_nat (bi2.abs_value) 0 size_bi2 in - let len = - gcd_nat res 0 size_bi2 (bi1.abs_value) 0 size_bi1 in - copy_nat res 0 len - } - -(* Coercion operators *) - -let monster_big_int = big_int_of_int monster_int;; - -let monster_nat = monster_big_int.abs_value;; - -let is_int_big_int bi = - num_digits_big_int bi == 1 && - match compare_nat bi.abs_value 0 1 monster_nat 0 1 with - | 0 -> bi.sign == -1 - | -1 -> true - | _ -> false;; - -let int_of_big_int bi = - try let n = int_of_nat bi.abs_value in - if bi.sign = -1 then - n else n - with Failure _ -> - if eq_big_int bi monster_big_int then monster_int - else failwith "int_of_big_int";; - -(* Coercion with nat type *) -let nat_of_big_int bi = - if bi.sign = -1 - then failwith "nat_of_big_int" - else copy_nat (bi.abs_value) 0 (num_digits_big_int bi) - -let sys_big_int_of_nat nat off len = - let length = num_digits_nat nat off len in - { sign = if is_zero_nat nat off length then 0 else 1; - abs_value = copy_nat nat off length } - -let big_int_of_nat nat = - sys_big_int_of_nat nat 0 (length_nat nat) - -(* Coercion with string type *) - -let string_of_big_int bi = - if bi.sign = -1 - then "-" ^ string_of_nat bi.abs_value - else string_of_nat bi.abs_value - - -let sys_big_int_of_string_aux s ofs len sgn = - if len < 1 then failwith "sys_big_int_of_string"; - let n = sys_nat_of_string 10 s ofs len in - if is_zero_nat n 0 (length_nat n) then zero_big_int - else {sign = sgn; abs_value = n} -;; - -let sys_big_int_of_string s ofs len = - match s.[ofs] with - | '-' -> sys_big_int_of_string_aux s (ofs+1) (len-1) (-1) - | '+' -> sys_big_int_of_string_aux s (ofs+1) (len-1) 1 - | _ -> sys_big_int_of_string_aux s ofs len 1 -;; - -let big_int_of_string s = - sys_big_int_of_string s 0 (String.length s) - -let power_base_nat base nat off len = - if is_zero_nat nat off len then nat_of_int 1 else - let power_base = make_nat (succ length_of_digit) in - let (pmax, pint) = make_power_base base power_base in - let (n, rem) = - let (x, y) = quomod_big_int (sys_big_int_of_nat nat off len) - (big_int_of_int (succ pmax)) in - (int_of_big_int x, int_of_big_int y) in - if n = 0 then copy_nat power_base (pred rem) 1 else - begin - let res = make_nat n - and res2 = make_nat (succ n) - and l = num_bits_int n - 2 in - let p = ref (1 lsl l) in - blit_nat res 0 power_base pmax 1; - for i = l downto 0 do - let len = num_digits_nat res 0 n in - let len2 = min n (2 * len) in - let succ_len2 = succ len2 in - square_nat res2 0 len2 res 0 len; - begin - if n land !p > 0 - then (set_to_zero_nat res 0 len; - mult_digit_nat res 0 succ_len2 - res2 0 len2 - power_base pmax; ()) - else blit_nat res 0 res2 0 len2 - end; - set_to_zero_nat res2 0 len2; - p := !p lsr 1 - done; - if rem > 0 - then (mult_digit_nat res2 0 (succ n) - res 0 n power_base (pred rem); - res2) - else res - end - -let power_int_positive_int i n = - match sign_int n with - 0 -> unit_big_int - | -1 -> invalid_arg "power_int_positive_int" - | _ -> let nat = power_base_int (abs i) n in - { sign = if i >= 0 - then sign_int i - else if n land 1 = 0 - then 1 - else -1; - abs_value = nat} - -let power_big_int_positive_int bi n = - match sign_int n with - 0 -> unit_big_int - | -1 -> invalid_arg "power_big_int_positive_int" - | _ -> let bi_len = num_digits_big_int bi in - let res_len = bi_len * n in - let res = make_nat res_len - and res2 = make_nat res_len - and l = num_bits_int n - 2 in - let p = ref (1 lsl l) in - blit_nat res 0 (bi.abs_value) 0 bi_len; - for i = l downto 0 do - let len = num_digits_nat res 0 res_len in - let len2 = min res_len (2 * len) in - let succ_len2 = succ len2 in - square_nat res2 0 len2 res 0 len; - (if n land !p > 0 - then (set_to_zero_nat res 0 len; - mult_nat res 0 succ_len2 - res2 0 len2 (bi.abs_value) 0 bi_len; - set_to_zero_nat res2 0 len2) - else blit_nat res 0 res2 0 len2; - set_to_zero_nat res2 0 len2); - p := !p lsr 1 - done; - {sign = if bi.sign >= 0 - then bi.sign - else if n land 1 = 0 - then 1 - else -1; - abs_value = res} - -let power_int_positive_big_int i bi = - match sign_big_int bi with - 0 -> unit_big_int - | -1 -> invalid_arg "power_int_positive_big_int" - | _ -> let nat = power_base_nat - (abs i) (bi.abs_value) 0 (num_digits_big_int bi) in - { sign = if i >= 0 - then sign_int i - else if is_digit_odd (bi.abs_value) 0 - then -1 - else 1; - abs_value = nat } - -let power_big_int_positive_big_int bi1 bi2 = - match sign_big_int bi2 with - 0 -> unit_big_int - | -1 -> invalid_arg "power_big_int_positive_big_int" - | _ -> let nat = bi2.abs_value - and off = 0 - and len_bi2 = num_digits_big_int bi2 in - let bi1_len = num_digits_big_int bi1 in - let res_len = int_of_big_int (mult_int_big_int bi1_len bi2) in - let res = make_nat res_len - and res2 = make_nat res_len - and l = (len_bi2 * length_of_digit - - num_leading_zero_bits_in_digit nat (pred len_bi2)) - 2 in - let p = ref (1 lsl l) in - blit_nat res 0 (bi1.abs_value) 0 bi1_len; - for i = l downto 0 do - let nat = copy_nat bi2.abs_value 0 len_bi2 in - let len = num_digits_nat res 0 res_len in - let len2 = min res_len (2 * len) in - let succ_len2 = succ len2 in - square_nat res2 0 len2 res 0 len; - land_digit_nat nat 0 (nat_of_int !p) 0; - if is_zero_nat nat 0 len_bi2 - then (blit_nat res 0 res2 0 len2; - set_to_zero_nat res2 0 len2) - else (set_to_zero_nat res 0 len; - mult_nat res 0 succ_len2 - res2 0 len2 (bi1.abs_value) 0 bi1_len; - set_to_zero_nat res2 0 len2); - p := !p lsr 1 - done; - {sign = if bi1.sign >= 0 - then bi1.sign - else if is_digit_odd (bi2.abs_value) 0 - then -1 - else 1; - abs_value = res} - -(* base_power_big_int compute bi*base^n *) -let base_power_big_int base n bi = - match sign_int n with - 0 -> bi - | -1 -> let nat = power_base_int base (-n) in - let len_nat = num_digits_nat nat 0 (length_nat nat) - and len_bi = num_digits_big_int bi in - if len_bi < len_nat then - invalid_arg "base_power_big_int" - else if len_bi = len_nat && - compare_digits_nat (bi.abs_value) len_bi nat len_nat = -1 - then invalid_arg "base_power_big_int" - else - let copy = create_nat (succ len_bi) in - blit_nat copy 0 (bi.abs_value) 0 len_bi; - set_digit_nat copy len_bi 0; - div_nat copy 0 (succ len_bi) - nat 0 len_nat; - if not (is_zero_nat copy 0 len_nat) - then invalid_arg "base_power_big_int" - else { sign = bi.sign; - abs_value = copy_nat copy len_nat 1 } - | _ -> let nat = power_base_int base n in - let len_nat = num_digits_nat nat 0 (length_nat nat) - and len_bi = num_digits_big_int bi in - let new_len = len_bi + len_nat in - let res = make_nat new_len in - (if len_bi > len_nat - then mult_nat res 0 new_len - (bi.abs_value) 0 len_bi - nat 0 len_nat - else mult_nat res 0 new_len - nat 0 len_nat - (bi.abs_value) 0 len_bi) - ; if is_zero_nat res 0 new_len - then zero_big_int - else create_big_int (bi.sign) res - -(* Coercion with float type *) - -let float_of_big_int bi = - float_of_string (string_of_big_int bi) - -(* XL: suppression de big_int_of_float et nat_of_float. *) - -(* Other functions needed *) - -(* Integer part of the square root of a big_int *) -let sqrt_big_int bi = - match bi.sign with - | 0 -> zero_big_int - | -1 -> invalid_arg "sqrt_big_int" - | _ -> {sign = 1; - abs_value = sqrt_nat (bi.abs_value) 0 (num_digits_big_int bi)} - -let square_big_int bi = - if bi.sign == 0 then zero_big_int else - let len_bi = num_digits_big_int bi in - let len_res = 2 * len_bi in - let res = make_nat len_res in - square_nat res 0 len_res (bi.abs_value) 0 len_bi; - {sign = 1; abs_value = res} - -(* round off of the futur last digit (of the integer represented by the string - argument of the function) that is now the previous one. - if s contains an integer of the form (10^n)-1 - then s <- only 0 digits and the result_int is true - else s <- the round number and the result_int is false *) -let round_futur_last_digit s off_set length = - let l = pred (length + off_set) in - if Char.code(String.get s l) >= Char.code '5' - then - let rec round_rec l = - let current_char = String.get s l in - if current_char = '9' - then - (String.set s l '0'; - if l = off_set then true else round_rec (pred l)) - else - (String.set s l (Char.chr (succ (Char.code current_char))); - false) - in round_rec (pred l) - else false - - -(* Approximation with floating decimal point a` la approx_ratio_exp *) -let approx_big_int prec bi = - let len_bi = num_digits_big_int bi in - let n = - max 0 - (int_of_big_int ( - add_int_big_int - (-prec) - (div_big_int (mult_big_int (big_int_of_int (pred len_bi)) - (big_int_of_string "963295986")) - (big_int_of_string "100000000")))) in - let s = - string_of_big_int (div_big_int bi (power_int_positive_int 10 n)) in - let (sign, off, len) = - if String.get s 0 = '-' - then ("-", 1, succ prec) - else ("", 0, prec) in - if (round_futur_last_digit s off (succ prec)) - then (sign^"1."^(String.make prec '0')^"e"^ - (string_of_int (n + 1 - off + String.length s))) - else (sign^(String.sub s off 1)^"."^ - (String.sub s (succ off) (pred prec)) - ^"e"^(string_of_int (n - succ off + String.length s))) diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli deleted file mode 100644 index 9b140abf2f..0000000000 --- a/otherlibs/num/big_int.mli +++ /dev/null @@ -1,143 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Operations on arbitrary-precision integers. - - Big integers (type [big_int]) are signed integers of arbitrary size. -*) - -open Nat - -type big_int - (** The type of big integers. *) - -val zero_big_int : big_int - (** The big integer [0]. *) -val unit_big_int : big_int - (** The big integer [1]. *) - -(** {6 Arithmetic operations} *) - -val minus_big_int : big_int -> big_int - (** Unary negation. *) -val abs_big_int : big_int -> big_int - (** Absolute value. *) -val add_big_int : big_int -> big_int -> big_int - (** Addition. *) -val succ_big_int : big_int -> big_int - (** Successor (add 1). *) -val add_int_big_int : int -> big_int -> big_int - (** Addition of a small integer to a big integer. *) -val sub_big_int : big_int -> big_int -> big_int - (** Subtraction. *) -val pred_big_int : big_int -> big_int - (** Predecessor (subtract 1). *) -val mult_big_int : big_int -> big_int -> big_int - (** Multiplication of two big integers. *) -val mult_int_big_int : int -> big_int -> big_int - (** Multiplication of a big integer by a small integer *) -val square_big_int: big_int -> big_int - (** Return the square of the given big integer *) -val sqrt_big_int: big_int -> big_int - (** [sqrt_big_int a] returns the integer square root of [a], - that is, the largest big integer [r] such that [r * r <= a]. - Raise [Invalid_argument] if [a] is negative. *) -val quomod_big_int : big_int -> big_int -> big_int * big_int - (** Euclidean division of two big integers. - The first part of the result is the quotient, - the second part is the remainder. - Writing [(q,r) = quomod_big_int a b], we have - [a = q * b + r] and [0 <= r < |b|]. - Raise [Division_by_zero] if the divisor is zero. *) -val div_big_int : big_int -> big_int -> big_int - (** Euclidean quotient of two big integers. - This is the first result [q] of [quomod_big_int] (see above). *) -val mod_big_int : big_int -> big_int -> big_int - (** Euclidean modulus of two big integers. - This is the second result [r] of [quomod_big_int] (see above). *) -val gcd_big_int : big_int -> big_int -> big_int - (** Greatest common divisor of two big integers. *) -val power_int_positive_int: int -> int -> big_int -val power_big_int_positive_int: big_int -> int -> big_int -val power_int_positive_big_int: int -> big_int -> big_int -val power_big_int_positive_big_int: big_int -> big_int -> big_int - (** Exponentiation functions. Return the big integer - representing the first argument [a] raised to the power [b] - (the second argument). Depending - on the function, [a] and [b] can be either small integers - or big integers. Raise [Invalid_argument] if [b] is negative. *) - -(** {6 Comparisons and tests} *) - -val sign_big_int : big_int -> int - (** Return [0] if the given big integer is zero, - [1] if it is positive, and [-1] if it is negative. *) -val compare_big_int : big_int -> big_int -> int - (** [compare_big_int a b] returns [0] if [a] and [b] are equal, - [1] if [a] is greater than [b], and [-1] if [a] is smaller - than [b]. *) -val eq_big_int : big_int -> big_int -> bool -val le_big_int : big_int -> big_int -> bool -val ge_big_int : big_int -> big_int -> bool -val lt_big_int : big_int -> big_int -> bool -val gt_big_int : big_int -> big_int -> bool - (** Usual boolean comparisons between two big integers. *) -val max_big_int : big_int -> big_int -> big_int - (** Return the greater of its two arguments. *) -val min_big_int : big_int -> big_int -> big_int - (** Return the smaller of its two arguments. *) -val num_digits_big_int : big_int -> int - (** Return the number of machine words used to store the - given big integer. *) - -(** {6 Conversions to and from strings} *) - -val string_of_big_int : big_int -> string - (** Return the string representation of the given big integer, - in decimal (base 10). *) -val big_int_of_string : string -> big_int - (** Convert a string to a big integer, in decimal. - The string consists of an optional [-] or [+] sign, - followed by one or several decimal digits. *) - -(** {6 Conversions to and from other numerical types} *) - -val big_int_of_int : int -> big_int - (** Convert a small integer to a big integer. *) -val is_int_big_int : big_int -> bool - (** Test whether the given big integer is small enough to - be representable as a small integer (type [int]) - without loss of precision. On a 32-bit platform, - [is_int_big_int a] returns [true] if and only if - [a] is between 2{^30} and 2{^30}-1. On a 64-bit platform, - [is_int_big_int a] returns [true] if and only if - [a] is between -2{^62} and 2{^62}-1. *) -val int_of_big_int : big_int -> int - (** Convert a big integer to a small integer (type [int]). - Raises [Failure "int_of_big_int"] if the big integer - is not representable as a small integer. *) -val float_of_big_int : big_int -> float - (** Returns a floating-point number approximating the - given big integer. *) - -(**/**) - -(** {6 For internal use} *) -val nat_of_big_int : big_int -> nat -val big_int_of_nat : nat -> big_int -val base_power_big_int: int -> int -> big_int -> big_int -val sys_big_int_of_string: string -> int -> int -> big_int -val round_futur_last_digit : string -> int -> int -> bool -val approx_big_int: int -> big_int -> string diff --git a/otherlibs/num/bignum/.cvsignore b/otherlibs/num/bignum/.cvsignore deleted file mode 100644 index c76baffd17..0000000000 --- a/otherlibs/num/bignum/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -libbignum.x diff --git a/otherlibs/num/bng.c b/otherlibs/num/bng.c deleted file mode 100644 index c96af2cf28..0000000000 --- a/otherlibs/num/bng.c +++ /dev/null @@ -1,434 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "bng.h" - -#if defined(__GNUC__) && BNG_ASM_LEVEL > 0 -#if defined(BNG_ARCH_ia32) -#include "bng_ia32.c" -#elif defined(BNG_ARCH_amd64) -#include "bng_amd64.c" -#elif defined(BNG_ARCH_ppc) -#include "bng_ppc.c" -#elif defined (BNG_ARCH_alpha) -#include "bng_alpha.c" -#elif defined (BNG_ARCH_sparc) -#include "bng_sparc.c" -#elif defined (BNG_ARCH_mips) -#include "bng_mips.c" -#endif -#endif - -#include "bng_digit.c" - -/**** Operations that cannot be overriden ****/ - -/* Return number of leading zero bits in d */ -int bng_leading_zero_bits(bngdigit d) -{ - int n = BNG_BITS_PER_DIGIT; -#ifdef ARCH_SIXTYFOUR - if ((d & 0xFFFFFFFF00000000L) != 0) { n -= 32; d = d >> 32; } -#endif - if ((d & 0xFFFF0000) != 0) { n -= 16; d = d >> 16; } - if ((d & 0xFF00) != 0) { n -= 8; d = d >> 8; } - if ((d & 0xF0) != 0) { n -= 4; d = d >> 4; } - if ((d & 0xC) != 0) { n -= 2; d = d >> 2; } - if ((d & 2) != 0) { n -= 1; d = d >> 1; } - return n - d; -} - -/* Complement the digits of {a,len} */ -void bng_complement(bng a/*[alen]*/, bngsize alen) -{ - for (/**/; alen > 0; alen--, a++) *a = ~*a; -} - -/* Return number of significant digits in {a,alen}. */ -bngsize bng_num_digits(bng a/*[alen]*/, bngsize alen) -{ - while (1) { - if (alen == 0) return 1; - if (a[alen - 1] != 0) return alen; - alen--; - } -} - -/* Return 0 if {a,alen} = {b,blen} - -1 if {a,alen} < {b,blen} - 1 if {a,alen} > {b,blen}. */ -int bng_compare(bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen) -{ - bngdigit da, db; - - while (alen > 0 && a[alen-1] == 0) alen--; - while (blen > 0 && b[blen-1] == 0) blen--; - if (alen > blen) return 1; - if (alen < blen) return -1; - while (alen > 0) { - alen--; - da = a[alen]; - db = b[alen]; - if (da > db) return 1; - if (da < db) return -1; - } - return 0; -} - -/**** Generic definitions of the overridable operations ****/ - -/* {a,alen} := {a, alen} + carry. Return carry out. */ -static bngcarry bng_generic_add_carry - (bng a/*[alen]*/, bngsize alen, bngcarry carry) -{ - if (carry == 0 || alen == 0) return carry; - do { - if (++(*a) != 0) return 0; - a++; - } while (--alen); - return 1; -} - -/* {a,alen} := {a,alen} + {b,blen} + carry. Return carry out. - Require alen >= blen. */ -static bngcarry bng_generic_add - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngcarry carry) -{ - alen -= blen; - for (/**/; blen > 0; blen--, a++, b++) { - BngAdd2Carry(*a, carry, *a, *b, carry); - } - if (carry == 0 || alen == 0) return carry; - do { - if (++(*a) != 0) return 0; - a++; - } while (--alen); - return 1; -} - -/* {a,alen} := {a, alen} - carry. Return carry out. */ -static bngcarry bng_generic_sub_carry - (bng a/*[alen]*/, bngsize alen, bngcarry carry) -{ - if (carry == 0 || alen == 0) return carry; - do { - if ((*a)-- != 0) return 0; - a++; - } while (--alen); - return 1; -} - -/* {a,alen} := {a,alen} - {b,blen} - carry. Return carry out. - Require alen >= blen. */ -static bngcarry bng_generic_sub - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngcarry carry) -{ - alen -= blen; - for (/**/; blen > 0; blen--, a++, b++) { - BngSub2Carry(*a, carry, *a, *b, carry); - } - if (carry == 0 || alen == 0) return carry; - do { - if ((*a)-- != 0) return 0; - a++; - } while (--alen); - return 1; -} - -/* {a,alen} := {a,alen} << shift. - Return the bits shifted out of the most significant digit of a. - Require 0 <= shift < BITS_PER_BNGDIGIT. */ -static bngdigit bng_generic_shift_left - (bng a/*[alen]*/, bngsize alen, - int shift) -{ - int shift2 = BNG_BITS_PER_DIGIT - shift; - bngdigit carry = 0; - if (shift > 0) { - for (/**/; alen > 0; alen--, a++) { - bngdigit d = *a; - *a = (d << shift) | carry; - carry = d >> shift2; - } - } - return carry; -} - -/* {a,alen} := {a,alen} >> shift. - Return the bits shifted out of the least significant digit of a. - Require 0 <= shift < BITS_PER_BNGDIGIT. */ -static bngdigit bng_generic_shift_right - (bng a/*[alen]*/, bngsize alen, - int shift) -{ - int shift2 = BNG_BITS_PER_DIGIT - shift; - bngdigit carry = 0; - if (shift > 0) { - for (a = a + alen - 1; alen > 0; alen--, a--) { - bngdigit d = *a; - *a = (d >> shift) | carry; - carry = d << shift2; - } - } - return carry; -} - -/* {a,alen} := {a,alen} + d * {b,blen}. Return carry out. - Require alen >= blen. */ -static bngdigit bng_generic_mult_add_digit - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngdigit d) -{ - bngdigit out, ph, pl; - bngcarry carry; - - alen -= blen; - for (out = 0; blen > 0; blen--, a++, b++) { - bngdigit bd = *b; - /* ph:pl = double-digit product of b's current digit and d */ - BngMult(ph, pl, bd, d); - /* current digit of a += pl + out. Accumulate carries in ph. */ - BngAdd3(*a, ph, *a, pl, out); - /* prepare out for next iteration */ - out = ph; - } - if (alen == 0) return out; - /* current digit of a += out */ - BngAdd2(*a, carry, *a, out); - a++; - alen--; - /* Propagate carry */ - if (carry == 0 || alen == 0) return carry; - do { - if (++(*a) != 0) return 0; - a++; - } while (--alen); - return 1; -} - -/* {a,alen} := {a,alen} - d * {b,blen}. Return carry out. - Require alen >= blen. */ -static bngdigit bng_generic_mult_sub_digit - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngdigit d) -{ - bngdigit out, ph, pl; - bngcarry carry; - - alen -= blen; - for (out = 0; blen > 0; blen--, a++, b++) { - bngdigit bd = *b; - /* ph:pl = double-digit product of b's current digit and d */ - BngMult(ph, pl, bd, d); - /* current digit of a -= pl + out. Accumulate carrys in ph. */ - BngSub3(*a, ph, *a, pl, out); - /* prepare out for next iteration */ - out = ph; - } - if (alen == 0) return out; - /* current digit of a -= out */ - BngSub2(*a, carry, *a, out); - a++; - alen--; - /* Propagate carry */ - if (carry == 0 || alen == 0) return carry; - do { - if ((*a)-- != 0) return 0; - a++; - } while (--alen); - return 1; -} - -/* {a,alen} := {a,alen} + {b,blen} * {c,clen}. Return carry out. - Require alen >= blen + clen. */ -static bngcarry bng_generic_mult_add - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bng c/*[clen]*/, bngsize clen) -{ - bngcarry carry; - for (carry = 0; clen > 0; clen--, c++, alen--, a++) - carry += bng_mult_add_digit(a, alen, b, blen, *c); - return carry; -} - -/* {a,alen} := 2 * {a,alen} + {b,blen}^2. Return carry out. - Require alen >= 2 * blen. */ -static bngcarry bng_generic_square_add - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen) -{ - bngcarry carry1, carry2; - bngsize i, aofs; - bngdigit ph, pl, d; - - /* Double products */ - for (carry1 = 0, i = 1; i < blen; i++) { - aofs = 2 * i - 1; - carry1 += bng_mult_add_digit(a + aofs, alen - aofs, - b + i, blen - i, b[i - 1]); - } - /* Multiply by two */ - carry1 = (carry1 << 1) | bng_shift_left(a, alen, 1); - /* Add square of digits */ - carry2 = 0; - for (i = 0; i < blen; i++) { - d = b[i]; - BngMult(ph, pl, d, d); - BngAdd2Carry(*a, carry2, *a, pl, carry2); - a++; - BngAdd2Carry(*a, carry2, *a, ph, carry2); - a++; - } - alen -= 2 * blen; - if (alen > 0 && carry2 != 0) { - do { - if (++(*a) != 0) { carry2 = 0; break; } - a++; - } while (--alen); - } - return carry1 + carry2; -} - -/* {a,len-1} := {b,len} / d. Return {b,len} modulo d. - Require MSD of b < d. - If BngDivNeedsNormalization is defined, require d normalized. */ -static bngdigit bng_generic_div_rem_norm_digit - (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d) -{ - bngdigit topdigit, quo, rem; - long i; - - topdigit = b[len - 1]; - for (i = len - 2; i >= 0; i--) { - /* Divide topdigit:current digit of numerator by d */ - BngDiv(quo, rem, topdigit, b[i], d); - /* Quotient is current digit of result */ - a[i] = quo; - /* Iterate with topdigit = remainder */ - topdigit = rem; - } - return topdigit; -} - -#ifdef BngDivNeedsNormalization -/* {a,len-1} := {b,len} / d. Return {b,len} modulo d. - Require MSD of b < d. */ -static bngdigit bng_generic_div_rem_digit - (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d) -{ - bngdigit rem; - int shift; - - /* Normalize d and b */ - shift = bng_leading_zero_bits(d); - d <<= shift; - bng_shift_left(b, len, shift); - /* Do the division */ - rem = bng_div_rem_norm_digit(a, b, len, d); - /* Undo normalization on b and remainder */ - bng_shift_right(b, len, shift); - return rem >> shift; -} -#endif - -/* {n+dlen, nlen-dlen} := {n,nlen} / {d, dlen}. - {n, dlen} := {n,nlen} modulo {d, dlen}. - Require nlen > dlen and MSD of n < MSD of d. - (This implies MSD of d > 0). */ -static void bng_generic_div_rem - (bng n/*[nlen]*/, bngsize nlen, - bng d/*[dlen]*/, bngsize dlen) -{ - bngdigit topden, quo, rem; - int shift; - bngsize i, j; - - /* Normalize d */ - shift = bng_leading_zero_bits(d[dlen - 1]); - /* Note that no bits of n are lost by the following shift, - since n[nlen-1] < d[dlen-1] */ - bng_shift_left(n, nlen, shift); - bng_shift_left(d, dlen, shift); - /* Special case if d is just one digit */ - if (dlen == 1) { - *n = bng_div_rem_norm_digit(n + 1, n, nlen, *d); - } else { - topden = d[dlen - 1]; - /* Long division */ - for (j = nlen - 1; j >= dlen; j--) { - i = j - dlen; - /* At this point: - - the current numerator is n[j] : ...................... : n[0] - - to be subtracted quo times: d[dlen-1] : ... : d[0] : 0... : 0 - (there are i zeroes at the end) */ - /* Under-estimate the next digit of the quotient (quo) */ - if (topden + 1 == 0) - quo = n[j]; - else - BngDiv(quo, rem, n[j], n[j - 1], topden + 1); - /* Subtract d * quo (shifted i places) from numerator */ - n[j] -= bng_mult_sub_digit(n + i, dlen, d, dlen, quo); - /* Adjust if necessary */ - while (n[j] != 0 || bng_compare(n + i, dlen, d, dlen) >= 0) { - /* Numerator is still bigger than shifted divisor. - Increment quotient and subtract shifted divisor. */ - quo++; - n[j] -= bng_sub(n + i, dlen, d, dlen, 0); - } - /* Store quotient digit */ - n[j] = quo; - } - } - /* Undo normalization on remainder and divisor */ - bng_shift_right(n, dlen, shift); - bng_shift_right(d, dlen, shift); -} - -/**** Construction of the table of operations ****/ - -struct bng_operations bng_ops = { - bng_generic_add_carry, - bng_generic_add, - bng_generic_sub_carry, - bng_generic_sub, - bng_generic_shift_left, - bng_generic_shift_right, - bng_generic_mult_add_digit, - bng_generic_mult_sub_digit, - bng_generic_mult_add, - bng_generic_square_add, - bng_generic_div_rem_norm_digit, -#ifdef BngDivNeedsNormalization - bng_generic_div_rem_digit, -#else - bng_generic_div_rem_norm_digit, -#endif - bng_generic_div_rem -}; - -void bng_init(void) -{ -#ifdef BNG_SETUP_OPS - BNG_SETUP_OPS; -#endif -} diff --git a/otherlibs/num/bng.h b/otherlibs/num/bng.h deleted file mode 100644 index 28c6b2d105..0000000000 --- a/otherlibs/num/bng.h +++ /dev/null @@ -1,156 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <string.h> - -typedef unsigned long bngdigit; -typedef bngdigit * bng; -typedef unsigned int bngcarry; -typedef unsigned long bngsize; - -#define BNG_BITS_PER_DIGIT (sizeof(bngdigit) * 8) -#define BNG_BITS_PER_HALF_DIGIT (sizeof(bngdigit) * 4) - -struct bng_operations { - - /* {a,alen} := {a, alen} + carry. Return carry out. */ - bngcarry (*add_carry) - (bng a/*[alen]*/, bngsize alen, bngcarry carry); -#define bng_add_carry bng_ops.add_carry - - /* {a,alen} := {a,alen} + {b,blen} + carry. Return carry out. - Require alen >= blen. */ - bngcarry (*add) - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngcarry carry); -#define bng_add bng_ops.add - - /* {a,alen} := {a, alen} - carry. Return carry out. */ - bngcarry (*sub_carry) - (bng a/*[alen]*/, bngsize alen, bngcarry carry); -#define bng_sub_carry bng_ops.sub_carry - - /* {a,alen} := {a,alen} - {b,blen} - carry. Return carry out. - Require alen >= blen. */ - bngcarry (*sub) - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngcarry carry); -#define bng_sub bng_ops.sub - - /* {a,alen} := {a,alen} << shift. - Return the bits shifted out of the most significant digit of a. - Require 0 <= shift < BITS_PER_BNGDIGIT. */ - bngdigit (*shift_left) - (bng a/*[alen]*/, bngsize alen, - int shift); -#define bng_shift_left bng_ops.shift_left - - /* {a,alen} := {a,alen} >> shift. - Return the bits shifted out of the least significant digit of a. - Require 0 <= shift < BITS_PER_BNGDIGIT. */ - bngdigit (*shift_right) - (bng a/*[alen]*/, bngsize alen, - int shift); -#define bng_shift_right bng_ops.shift_right - - /* {a,alen} := {a,alen} + d * {b,blen}. Return carry out. - Require alen >= blen. - If alen > blen, the carry out returned is 0 or 1. - If alen == blen, the carry out returned is a full digit. */ - bngdigit (*mult_add_digit) - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngdigit d); -#define bng_mult_add_digit bng_ops.mult_add_digit - - /* {a,alen} := {a,alen} - d * {b,blen}. Return carry out. - Require alen >= blen. - If alen > blen, the carry out returned is 0 or 1. - If alen == blen, the carry out returned is a full digit. */ - bngdigit (*mult_sub_digit) - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngdigit d); -#define bng_mult_sub_digit bng_ops.mult_sub_digit - - /* {a,alen} := {a,alen} + {b,blen} * {c,clen}. Return carry out. - Require alen >= blen + clen. */ - bngcarry (*mult_add) - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bng c/*[clen]*/, bngsize clen); -#define bng_mult_add bng_ops.mult_add - - /* {a,alen} := 2 * {a,alen} + {b,blen}^2. Return carry out. - Require alen >= 2 * blen. */ - bngcarry (*square_add) - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen); -#define bng_square_add bng_ops.square_add - - /* {a,len-1} := {b,len} / d. Return {b,len} modulo d. - Require d is normalized and MSD of b < d. - See div_rem_digit for a function that does not require d - to be normalized */ - bngdigit (*div_rem_norm_digit) - (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d); -#define bng_div_rem_norm_digit bng_ops.div_rem_norm_digit - - /* {a,len-1} := {b,len} / d. Return {b,len} modulo d. - Require MSD of b < d. */ - bngdigit (*div_rem_digit) - (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d); -#define bng_div_rem_digit bng_ops.div_rem_digit - - /* {n+dlen, nlen-dlen} := {n,nlen} / {d, dlen}. - {n, dlen} := {n,nlen} modulo {d, dlen}. - Require nlen > dlen and MSD of n < MSD of d (which implies d != 0). */ - void (*div_rem) - (bng n/*[nlen]*/, bngsize nlen, - bng d/*[nlen]*/, bngsize dlen); -#define bng_div_rem bng_ops.div_rem -}; - -extern struct bng_operations bng_ops; - -/* Initialize the BNG library */ -extern void bng_init(void); - -/* {a,alen} := 0 */ -#define bng_zero(a,alen) memset((a), 0, (alen) * sizeof(bngdigit)) - -/* {a,len} := {b,len} */ -#define bng_assign(a,b,len) memmove((a), (b), (len) * sizeof(bngdigit)) - -/* Complement the digits of {a,len} */ -extern void bng_complement(bng a/*[alen]*/, bngsize alen); - -/* Return number of significant digits in {a,alen}. */ -extern bngsize bng_num_digits(bng a/*[alen]*/, bngsize alen); - -/* Return 1 if {a,alen} is 0, 0 otherwise. */ -#define bng_is_zero(a,alen) (bng_num_digits(a,alen) == 0) - -/* Return 0 if {a,alen} = {b,blen} - <0 if {a,alen} < {b,blen} - >0 if {a,alen} > {b,blen}. */ -extern int bng_compare(bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen); - -/* Return the number of leading zero bits in digit d. */ -extern int bng_leading_zero_bits(bngdigit d); - diff --git a/otherlibs/num/bng_alpha.c b/otherlibs/num/bng_alpha.c deleted file mode 100644 index 0360cff7bc..0000000000 --- a/otherlibs/num/bng_alpha.c +++ /dev/null @@ -1,23 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Code specific to the Alpha architecture. */ - -#define BngMult(resh,resl,arg1,arg2) \ - asm("mulq %2, %3, %0 \n\t" \ - "umulh %2, %3, %1" \ - : "=&r" (resl), "=r" (resh) \ - : "r" (arg1), "r" (arg2)) - diff --git a/otherlibs/num/bng_amd64.c b/otherlibs/num/bng_amd64.c deleted file mode 100644 index 0a0bd107f7..0000000000 --- a/otherlibs/num/bng_amd64.c +++ /dev/null @@ -1,196 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Code specific to the AMD x86_64 architecture. */ - -#define BngAdd2(res,carryout,arg1,arg2) \ - asm("xorl %1, %1 \n\t" \ - "addq %3, %0 \n\t" \ - "setc %b1" \ - : "=r" (res), "=&q" (carryout) \ - : "0" (arg1), "rm" (arg2)) - -#define BngSub2(res,carryout,arg1,arg2) \ - asm("xorl %1, %1 \n\t" \ - "subq %3, %0 \n\t" \ - "setc %b1" \ - : "=r" (res), "=&q" (carryout) \ - : "0" (arg1), "rm" (arg2)) - -#define BngMult(resh,resl,arg1,arg2) \ - asm("mulq %3" \ - : "=a" (resl), "=d" (resh) \ - : "a" (arg1), "r" (arg2)) - -#define BngDiv(quo,rem,nh,nl,d) \ - asm("divq %4" \ - : "=a" (quo), "=d" (rem) \ - : "a" (nl), "d" (nh), "r" (d)) - -/* Reimplementation in asm of some of the bng operations. */ - -static bngcarry bng_amd64_add - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngcarry carry) -{ - bngdigit tmp; - alen -= blen; - if (blen > 0) { - asm("negb %b3 \n\t" - "1: \n\t" - "movq (%0), %4 \n\t" - "adcq (%1), %4 \n\t" - "movq %4, (%0) \n\t" - "leaq 8(%0), %0 \n\t" - "leaq 8(%1), %1 \n\t" - "decq %2 \n\t" - "jnz 1b \n\t" - "setc %b3" - : "=r" (a), "=r" (b), "=r" (blen), "=q" (carry), "=r" (tmp) - : "0" (a), "1" (b), "2" (blen), "3" (carry)); - } - if (carry == 0 || alen == 0) return carry; - do { - if (++(*a) != 0) return 0; - a++; - } while (--alen); - return 1; -} - -static bngcarry bng_amd64_sub - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngcarry carry) -{ - bngdigit tmp; - alen -= blen; - if (blen > 0) { - asm("negb %b3 \n\t" - "1: \n\t" - "movq (%0), %4 \n\t" - "sbbq (%1), %4 \n\t" - "movq %4, (%0) \n\t" - "leaq 8(%0), %0 \n\t" - "leaq 8(%1), %1 \n\t" - "decq %2 \n\t" - "jnz 1b \n\t" - "setc %b3" - : "=r" (a), "=r" (b), "=r" (blen), "=q" (carry), "=r" (tmp) - : "0" (a), "1" (b), "2" (blen), "3" (carry)); - } - if (carry == 0 || alen == 0) return carry; - do { - if ((*a)-- != 0) return 0; - a++; - } while (--alen); - return 1; -} - -static bngdigit bng_amd64_mult_add_digit - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngdigit d) -{ - bngdigit out; - bngcarry carry; - - alen -= blen; - out = 0; - if (blen > 0) { - asm("1: \n\t" - "movq (%1), %%rax \n\t" - "mulq %7\n\t" /* rdx:rax = d * next digit of b */ - "addq (%0), %%rax \n\t" /* add next digit of a to rax */ - "adcq $0, %%rdx \n\t" /* accumulate carry in rdx */ - "addq %3, %%rax \n\t" /* add out to rax */ - "adcq $0, %%rdx \n\t" /* accumulate carry in rdx */ - "movq %%rax, (%0) \n\t" /* rax is next digit of result */ - "movq %%rdx, %3 \n\t" /* rdx is next out */ - "leaq 8(%0), %0 \n\t" - "leaq 8(%1), %1 \n\t" - "decq %2 \n\t" - "jnz 1b" - : "=&r" (a), "=&r" (b), "=&r" (blen), "=&r" (out) - : "0" (a), "1" (b), "2" (blen), "rm" (d), "3" (out) - : "rax", "rdx"); - } - if (alen == 0) return out; - /* current digit of a += out */ - BngAdd2(*a, carry, *a, out); - a++; - alen--; - /* Propagate carry */ - if (carry == 0 || alen == 0) return carry; - do { - if (++(*a) != 0) return 0; - a++; - } while (--alen); - return 1; -} - -static bngdigit bng_amd64_mult_sub_digit - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngdigit d) -{ - bngdigit out, tmp; - bngcarry carry; - - alen -= blen; - out = 0; - if (blen > 0) { - asm("1: \n\t" - "movq (%1), %%rax \n\t" - "movq (%0), %4 \n\t" - "mulq %8\n\t" /* rdx:rax = d * next digit of b */ - "subq %%rax, %4 \n\t" /* subtract rax from next digit of a */ - "adcq $0, %%rdx \n\t" /* accumulate carry in rdx */ - "subq %3, %4 \n\t" /* subtract out */ - "adcq $0, %%rdx \n\t" /* accumulate carry in rdx */ - "movq %4, (%0) \n\t" /* store next digit of result */ - "movq %%rdx, %3 \n\t" /* rdx is next out */ - "leaq 8(%0), %0 \n\t" - "leaq 8(%1), %1 \n\t" - "decq %2 \n\t" - "jnz 1b" - : "=&r" (a), "=&r" (b), "=&rm" (blen), "=&r" (out), "=&r" (tmp) - : "0" (a), "1" (b), "2" (blen), "rm" (d), "3" (out) - : "rax", "rdx"); - } - if (alen == 0) return out; - /* current digit of a -= out */ - BngSub2(*a, carry, *a, out); - a++; - alen--; - /* Propagate carry */ - if (carry == 0 || alen == 0) return carry; - do { - if ((*a)-- != 0) return 0; - a++; - } while (--alen); - return 1; -} - -static void bng_amd64_setup_ops(void) -{ - bng_ops.add = bng_amd64_add; - bng_ops.sub = bng_amd64_sub; - bng_ops.mult_add_digit = bng_amd64_mult_add_digit; - bng_ops.mult_sub_digit = bng_amd64_mult_sub_digit; -} - -#define BNG_SETUP_OPS bng_amd64_setup_ops() - diff --git a/otherlibs/num/bng_digit.c b/otherlibs/num/bng_digit.c deleted file mode 100644 index e46eacb6b8..0000000000 --- a/otherlibs/num/bng_digit.c +++ /dev/null @@ -1,171 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/**** Generic operations on digits ****/ - -/* These macros can be defined in the machine-specific include file. - Below are the default definitions (in plain C). - Except for BngMult, all macros are guaranteed to evaluate their - arguments exactly once. */ - -#ifndef BngAdd2 -/* res = arg1 + arg2. carryout = carry out. */ -#define BngAdd2(res,carryout,arg1,arg2) { \ - bngdigit tmp1, tmp2; \ - tmp1 = arg1; \ - tmp2 = tmp1 + (arg2); \ - carryout = (tmp2 < tmp1); \ - res = tmp2; \ -} -#endif - -#ifndef BngAdd2Carry -/* res = arg1 + arg2 + carryin. carryout = carry out. */ -#define BngAdd2Carry(res,carryout,arg1,arg2,carryin) { \ - bngdigit tmp1, tmp2, tmp3; \ - tmp1 = arg1; \ - tmp2 = tmp1 + (arg2); \ - tmp3 = tmp2 + (carryin); \ - carryout = (tmp2 < tmp1) + (tmp3 < tmp2); \ - res = tmp3; \ -} -#endif - -#ifndef BngAdd3 -/* res = arg1 + arg2 + arg3. Each carry increments carryaccu. */ -#define BngAdd3(res,carryaccu,arg1,arg2,arg3) { \ - bngdigit tmp1, tmp2, tmp3; \ - tmp1 = arg1; \ - tmp2 = tmp1 + (arg2); \ - carryaccu += (tmp2 < tmp1); \ - tmp3 = tmp2 + (arg3); \ - carryaccu += (tmp3 < tmp2); \ - res = tmp3; \ -} -#endif - -#ifndef BngSub2 -/* res = arg1 - arg2. carryout = carry out. */ -#define BngSub2(res,carryout,arg1,arg2) { \ - bngdigit tmp1, tmp2; \ - tmp1 = arg1; \ - tmp2 = arg2; \ - res = tmp1 - tmp2; \ - carryout = (tmp1 < tmp2); \ -} -#endif - -#ifndef BngSub2Carry -/* res = arg1 - arg2 - carryin. carryout = carry out. */ -#define BngSub2Carry(res,carryout,arg1,arg2,carryin) { \ - bngdigit tmp1, tmp2, tmp3; \ - tmp1 = arg1; \ - tmp2 = arg2; \ - tmp3 = tmp1 - tmp2; \ - res = tmp3 - (carryin); \ - carryout = (tmp1 < tmp2) + (tmp3 < carryin); \ -} -#endif - -#ifndef BngSub3 -/* res = arg1 - arg2 - arg3. Each carry increments carryaccu. */ -#define BngSub3(res,carryaccu,arg1,arg2,arg3) { \ - bngdigit tmp1, tmp2, tmp3, tmp4; \ - tmp1 = arg1; \ - tmp2 = arg2; \ - tmp3 = arg3; \ - tmp4 = tmp1 - tmp2; \ - res = tmp4 - tmp3; \ - carryaccu += (tmp1 < tmp2) + (tmp4 < tmp3); \ -} -#endif - -#define BngLowHalf(d) ((d) & ((1L << BNG_BITS_PER_HALF_DIGIT) - 1)) -#define BngHighHalf(d) ((d) >> BNG_BITS_PER_HALF_DIGIT) - -#ifndef BngMult -/* resl = low digit of product arg1 * arg2 - resh = high digit of product arg1 * arg2. */ -#define BngMult(resh,resl,arg1,arg2) { \ - bngdigit p11 = BngLowHalf(arg1) * BngLowHalf(arg2); \ - bngdigit p12 = BngLowHalf(arg1) * BngHighHalf(arg2); \ - bngdigit p21 = BngHighHalf(arg1) * BngLowHalf(arg2); \ - bngdigit p22 = BngHighHalf(arg1) * BngHighHalf(arg2); \ - resh = p22 + (p12 >> BNG_BITS_PER_HALF_DIGIT) \ - + (p21 >> BNG_BITS_PER_HALF_DIGIT); \ - BngAdd3(resl, resh, \ - p11, p12 << BNG_BITS_PER_HALF_DIGIT, p21 << BNG_BITS_PER_HALF_DIGIT); \ -} -#endif - -#ifndef BngDiv -/* Divide the double-width number nh:nl by d. - Require d != 0 and nh < d. - Store quotient in quo, remainder in rem. - Can be slow if d is not normalized. */ -#define BngDiv(quo,rem,nh,nl,d) bng_div_aux(&(quo),&(rem),nh,nl,d) -#define BngDivNeedsNormalization - -static void bng_div_aux(bngdigit * quo, bngdigit * rem, - bngdigit nh, bngdigit nl, bngdigit d) -{ - bngdigit dl, dh, ql, qh, pl, ph, nsaved; - - dl = BngLowHalf(d); - dh = BngHighHalf(d); - /* Under-estimate the top half of the quotient (qh) */ - qh = nh / (dh + 1); - /* Shift nh:nl right by BNG_BITS_PER_HALF_DIGIT bits, - so that we focus on the top 1.5 digits of the numerator. - Then, subtract (qh * d) from nh:nl. */ - nsaved = BngLowHalf(nl); - ph = qh * dh; - pl = qh * dl; - nh -= ph; /* Subtract before shifting so that carry propagates for free */ - nl = (nl >> BNG_BITS_PER_HALF_DIGIT) | (nh << BNG_BITS_PER_HALF_DIGIT); - nh = (nh >> BNG_BITS_PER_HALF_DIGIT); - nh -= (nl < pl); /* Borrow */ - nl -= pl; - /* Adjust estimate qh until nh:nl < 0:d */ - while (nh != 0 || nl >= d) { - nh -= (nl < d); /* Borrow */ - nl -= d; - qh++; - } - /* Under-estimate the bottom half of the quotient (ql) */ - ql = nl / (dh + 1); - /* Shift nh:nl left by BNG_BITS_PER_HALF_DIGIT bits, restoring the - low bits we saved earlier, so that we focus on the bottom 1.5 digit - of the numerator. Then, subtract (ql * d) from nh:nl. */ - ph = ql * dh; - pl = ql * dl; - nl -= ph; /* Subtract before shifting so that carry propagates for free */ - nh = (nl >> BNG_BITS_PER_HALF_DIGIT); - nl = (nl << BNG_BITS_PER_HALF_DIGIT) | nsaved; - nh -= (nl < pl); /* Borrow */ - nl -= pl; - /* Adjust estimate ql until nh:nl < 0:d */ - while (nh != 0 || nl >= d) { - nh -= (nl < d); /* Borrow */ - nl -= d; - ql++; - } - /* We're done */ - *quo = (qh << BNG_BITS_PER_HALF_DIGIT) | ql; - *rem = nl; -} - -#endif - diff --git a/otherlibs/num/bng_ia32.c b/otherlibs/num/bng_ia32.c deleted file mode 100644 index c3ca9a9805..0000000000 --- a/otherlibs/num/bng_ia32.c +++ /dev/null @@ -1,412 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Code specific to the Intel IA32 (x86) architecture. */ - -#define BngAdd2(res,carryout,arg1,arg2) \ - asm("xorl %1, %1 \n\t" \ - "addl %3, %0 \n\t" \ - "setc %b1" \ - : "=r" (res), "=&q" (carryout) \ - : "0" (arg1), "rm" (arg2)) - -#define BngSub2(res,carryout,arg1,arg2) \ - asm("xorl %1, %1 \n\t" \ - "subl %3, %0 \n\t" \ - "setc %b1" \ - : "=r" (res), "=&q" (carryout) \ - : "0" (arg1), "rm" (arg2)) - -#define BngMult(resh,resl,arg1,arg2) \ - asm("mull %3" \ - : "=a" (resl), "=d" (resh) \ - : "a" (arg1), "r" (arg2)) - -#define BngDiv(quo,rem,nh,nl,d) \ - asm("divl %4" \ - : "=a" (quo), "=d" (rem) \ - : "a" (nl), "d" (nh), "r" (d)) - -/* Reimplementation in asm of some of the bng operations. */ - -static bngcarry bng_ia32_add - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngcarry carry) -{ - bngdigit tmp; - alen -= blen; - if (blen > 0) { - asm("negb %b3 \n\t" - "1: \n\t" - "movl (%0), %4 \n\t" - "adcl (%1), %4 \n\t" - "movl %4, (%0) \n\t" - "leal 4(%0), %0 \n\t" - "leal 4(%1), %1 \n\t" - "decl %2 \n\t" - "jnz 1b \n\t" - "setc %b3" - : "+&r" (a), "+&r" (b), "+&r" (blen), "+&q" (carry), "=&r" (tmp)); - } - if (carry == 0 || alen == 0) return carry; - do { - if (++(*a) != 0) return 0; - a++; - } while (--alen); - return 1; -} - -static bngcarry bng_ia32_sub - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngcarry carry) -{ - bngdigit tmp; - alen -= blen; - if (blen > 0) { - asm("negb %b3 \n\t" - "1: \n\t" - "movl (%0), %4 \n\t" - "sbbl (%1), %4 \n\t" - "movl %4, (%0) \n\t" - "leal 4(%0), %0 \n\t" - "leal 4(%1), %1 \n\t" - "decl %2 \n\t" - "jnz 1b \n\t" - "setc %b3" - : "+&r" (a), "+&r" (b), "+&r" (blen), "+&q" (carry), "=&r" (tmp)); - } - if (carry == 0 || alen == 0) return carry; - do { - if ((*a)-- != 0) return 0; - a++; - } while (--alen); - return 1; -} - -static bngdigit bng_ia32_mult_add_digit - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngdigit d) -{ - bngdigit out; - bngcarry carry; - - alen -= blen; - out = 0; - if (blen > 0) { - asm("1: \n\t" - "movl (%1), %%eax \n\t" - "mull %4\n\t" /* edx:eax = d * next digit of b */ - "addl (%0), %%eax \n\t" /* add next digit of a to eax */ - "adcl $0, %%edx \n\t" /* accumulate carry in edx */ - "addl %3, %%eax \n\t" /* add out to eax */ - "adcl $0, %%edx \n\t" /* accumulate carry in edx */ - "movl %%eax, (%0) \n\t" /* eax is next digit of result */ - "movl %%edx, %3 \n\t" /* edx is next out */ - "leal 4(%0), %0 \n\t" - "leal 4(%1), %1 \n\t" - "decl %2 \n\t" - "jnz 1b" - : "+&r" (a), "+&r" (b), "+&rm" (blen), "+&r" (out) - : "rm" (d) - : "eax", "edx"); - } - if (alen == 0) return out; - /* current digit of a += out */ - BngAdd2(*a, carry, *a, out); - a++; - alen--; - /* Propagate carry */ - if (carry == 0 || alen == 0) return carry; - do { - if (++(*a) != 0) return 0; - a++; - } while (--alen); - return 1; -} - -static bngdigit bng_ia32_mult_sub_digit - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngdigit d) -{ - bngdigit out, tmp; - bngcarry carry; - - alen -= blen; - out = 0; - if (blen > 0) { - asm("1: \n\t" - "movl (%1), %%eax \n\t" - "movl (%0), %4 \n\t" - "mull %5\n\t" /* edx:eax = d * next digit of b */ - "subl %%eax, %4 \n\t" /* subtract eax from next digit of a */ - "adcl $0, %%edx \n\t" /* accumulate carry in edx */ - "subl %3, %4 \n\t" /* subtract out */ - "adcl $0, %%edx \n\t" /* accumulate carry in edx */ - "movl %4, (%0) \n\t" /* store next digit of result */ - "movl %%edx, %3 \n\t" /* edx is next out */ - "leal 4(%0), %0 \n\t" - "leal 4(%1), %1 \n\t" - "decl %2 \n\t" - "jnz 1b" - : "+&r" (a), "+&r" (b), "+&rm" (blen), "+&rm" (out), "=&r" (tmp) - : "rm" (d) - : "eax", "edx"); - } - if (alen == 0) return out; - /* current digit of a -= out */ - BngSub2(*a, carry, *a, out); - a++; - alen--; - /* Propagate carry */ - if (carry == 0 || alen == 0) return carry; - do { - if ((*a)-- != 0) return 0; - a++; - } while (--alen); - return 1; -} - -/* This is another asm implementation of some of the bng operations, - using SSE2 operations to provide 64-bit arithmetic. - This is faster than the plain IA32 code above on the Pentium 4. - (Arithmetic operations with carry are slow on the Pentium 4). */ - -#if BNG_ASM_LEVEL >= 2 - -static bngcarry bng_ia32sse2_add - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngcarry carry) -{ - alen -= blen; - if (blen > 0) { - asm("movd %3, %%mm0 \n\t" /* MM0 is carry */ - "1: \n\t" - "movd (%0), %%mm1 \n\t" /* MM1 is next digit of a */ - "movd (%1), %%mm2 \n\t" /* MM2 is next digit of b */ - "paddq %%mm1, %%mm0 \n\t" /* Add carry (64 bits) */ - "paddq %%mm2, %%mm0 \n\t" /* Add digits (64 bits) */ - "movd %%mm0, (%0) \n\t" /* Store low 32 bits of result */ - "psrlq $32, %%mm0 \n\t" /* Next carry is top 32 bits of results */ - "addl $4, %0\n\t" - "addl $4, %1\n\t" - "subl $1, %2\n\t" - "jne 1b \n\t" - "movd %%mm0, %3 \n\t" - "emms" - : "+&r" (a), "+&r" (b), "+&r" (blen), "+&rm" (carry)); - } - if (carry == 0 || alen == 0) return carry; - do { - if (++(*a) != 0) return 0; - a++; - } while (--alen); - return 1; -} - -static bngcarry bng_ia32sse2_sub - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngcarry carry) -{ - alen -= blen; - if (blen > 0) { - asm("movd %3, %%mm0 \n\t" /* MM0 is carry */ - "1: \n\t" - "movd (%0), %%mm1 \n\t" /* MM1 is next digit of a */ - "movd (%1), %%mm2 \n\t" /* MM2 is next digit of b */ - "psubq %%mm0, %%mm1 \n\t" /* Subtract carry (64 bits) */ - "psubq %%mm2, %%mm1 \n\t" /* Subtract digits (64 bits) */ - "movd %%mm1, (%0) \n\t" /* Store low 32 bits of result */ - "psrlq $63, %%mm1 \n\t" /* Next carry is sign bit of result */ - "movq %%mm1, %%mm0 \n\t" - "addl $4, %0\n\t" - "addl $4, %1\n\t" - "subl $1, %2\n\t" - "jne 1b \n\t" - "movd %%mm0, %3 \n\t" - "emms" - : "+&r" (a), "+&r" (b), "+&r" (blen), "+&rm" (carry)); - } - if (carry == 0 || alen == 0) return carry; - do { - if ((*a)-- != 0) return 0; - a++; - } while (--alen); - return 1; -} - -static bngdigit bng_ia32sse2_mult_add_digit - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngdigit d) -{ - bngdigit out; - bngcarry carry; - - alen -= blen; - out = 0; - if (blen > 0) { - asm("pxor %%mm0, %%mm0 \n\t" /* MM0 is carry */ - "movd %4, %%mm7 \n\t" /* MM7 is digit d */ - "1: \n\t" - "movd (%0), %%mm1 \n\t" /* MM1 is next digit of a */ - "movd (%1), %%mm2 \n\t" /* MM2 is next digit of b */ - "pmuludq %%mm7, %%mm2 \n\t" /* MM2 = d * digit of b */ - "paddq %%mm1, %%mm0 \n\t" /* Add product and carry ... */ - "paddq %%mm2, %%mm0 \n\t" /* ... and digit of a */ - "movd %%mm0, (%0) \n\t" /* Store low 32 bits of result */ - "psrlq $32, %%mm0 \n\t" /* Next carry is high 32 bits result */ - "addl $4, %0\n\t" - "addl $4, %1\n\t" - "subl $1, %2\n\t" - "jne 1b \n\t" - "movd %%mm0, %3 \n\t" - "emms" - : "+&r" (a), "+&r" (b), "+&r" (blen), "=&rm" (out) - : "m" (d)); - } - if (alen == 0) return out; - /* current digit of a += out */ - BngAdd2(*a, carry, *a, out); - a++; - alen--; - /* Propagate carry */ - if (carry == 0 || alen == 0) return carry; - do { - if (++(*a) != 0) return 0; - a++; - } while (--alen); - return 1; -} - -static bngdigit bng_ia32sse2_mult_sub_digit - (bng a/*[alen]*/, bngsize alen, - bng b/*[blen]*/, bngsize blen, - bngdigit d) -{ - static unsigned long long bias1 = 0xFFFFFFFF00000000ULL - 0xFFFFFFFFULL; - static unsigned long bias2 = 0xFFFFFFFFUL; - bngdigit out; - bngcarry carry; - - alen -= blen; - out = 0; - if (blen > 0) { - /* Carry C is represented by ENC(C) = 0xFFFFFFFF - C (one's complement) */ - asm("movd %6, %%mm0 \n\t" /* MM0 is carry (initially 0xFFFFFFFF) */ - "movq %5, %%mm6 \n\t" /* MM6 is magic constant bias1 */ - "movd %4, %%mm7 \n\t" /* MM7 is digit d */ - "1: \n\t" - "movd (%0), %%mm1 \n\t" /* MM1 is next digit of a */ - "movd (%1), %%mm2 \n\t" /* MM2 is next digit of b */ - "paddq %%mm6, %%mm1 \n\t" /* bias digit of a */ - "pmuludq %%mm7, %%mm2 \n\t" /* MM2 = d * digit of b */ - /* Compute - digit of a + ENC(carry) + 0xFFFFFFFF00000000 - 0xFFFFFFFF - product - = digit of a - carry + 0xFFFFFFFF00000000 - product - = digit of a - carry - productlow + (ENC(nextcarry) << 32) */ - "psubq %%mm2, %%mm1 \n\t" - "paddq %%mm1, %%mm0 \n\t" - "movd %%mm0, (%0) \n\t" /* Store low 32 bits of result */ - "psrlq $32, %%mm0 \n\t" /* Next carry is 32 high bits of result */ - "addl $4, %0\n\t" - "addl $4, %1\n\t" - "subl $1, %2\n\t" - "jne 1b \n\t" - "movd %%mm0, %3 \n\t" - "emms" - : "+&r" (a), "+&r" (b), "+&r" (blen), "=&rm" (out) - : "m" (d), "m" (bias1), "m" (bias2)); - out = ~out; /* Undo encoding on out digit */ - } - if (alen == 0) return out; - /* current digit of a -= out */ - BngSub2(*a, carry, *a, out); - a++; - alen--; - /* Propagate carry */ - if (carry == 0 || alen == 0) return carry; - do { - if ((*a)-- != 0) return 0; - a++; - } while (--alen); - return 1; -} - -/* Detect whether SSE2 instructions are supported */ - -static int bng_ia32_sse2_supported(void) -{ - unsigned int flags, newflags, max_id, capabilities; - -#define EFLAG_CPUID 0x00200000 -#define CPUID_IDENTIFY 0 -#define CPUID_CAPABILITIES 1 -#define SSE2_CAPABILITY 26 - - /* Check if processor has CPUID instruction */ - asm("pushfl \n\t" - "popl %0" - : "=r" (flags) : ); - newflags = flags ^ EFLAG_CPUID; /* CPUID detection flag */ - asm("pushfl \n\t" - "pushl %1 \n\t" - "popfl \n\t" - "pushfl \n\t" - "popl %0 \n\t" - "popfl" - : "=r" (flags) : "r" (newflags)); - /* If CPUID detection flag cannot be changed, CPUID instruction is not - available */ - if ((flags & EFLAG_CPUID) != (newflags & EFLAG_CPUID)) return 0; - /* See if SSE2 extensions are supported */ - asm("pushl %%ebx \n\t" /* need to preserve %ebx for PIC */ - "cpuid \n\t" - "popl %%ebx" - : "=a" (max_id) : "a" (CPUID_IDENTIFY): "ecx", "edx"); - if (max_id < 1) return 0; - asm("pushl %%ebx \n\t" - "cpuid \n\t" - "popl %%ebx" - : "=d" (capabilities) : "a" (CPUID_CAPABILITIES) : "ecx"); - return capabilities & (1 << SSE2_CAPABILITY); -} - -#endif - -static void bng_ia32_setup_ops(void) -{ -#if BNG_ASM_LEVEL >= 2 - if (bng_ia32_sse2_supported()) { - bng_ops.add = bng_ia32sse2_add; - bng_ops.sub = bng_ia32sse2_sub; - bng_ops.mult_add_digit = bng_ia32sse2_mult_add_digit; - bng_ops.mult_sub_digit = bng_ia32sse2_mult_sub_digit; - return; - } -#endif - bng_ops.add = bng_ia32_add; - bng_ops.sub = bng_ia32_sub; - bng_ops.mult_add_digit = bng_ia32_mult_add_digit; - bng_ops.mult_sub_digit = bng_ia32_mult_sub_digit; -} - -#define BNG_SETUP_OPS bng_ia32_setup_ops() - diff --git a/otherlibs/num/bng_mips.c b/otherlibs/num/bng_mips.c deleted file mode 100644 index 2b760e4b5e..0000000000 --- a/otherlibs/num/bng_mips.c +++ /dev/null @@ -1,24 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Code specific to the MIPS architecture. */ - -#define BngMult(resh,resl,arg1,arg2) \ - asm("multu %2, %3 \n\t" \ - "mflo %0 \n\t" \ - "mfhi %1" \ - : "=r" (resl), "=r" (resh) \ - : "r" (arg1), "r" (arg2)) - diff --git a/otherlibs/num/bng_ppc.c b/otherlibs/num/bng_ppc.c deleted file mode 100644 index d0e33a2f25..0000000000 --- a/otherlibs/num/bng_ppc.c +++ /dev/null @@ -1,86 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Code specific to the PowerPC architecture. */ - -#define BngAdd2(res,carryout,arg1,arg2) \ - asm("addc %0, %2, %3 \n\t" \ - "li %1, 0 \n\t" \ - "addze %1, %1" \ - : "=r" (res), "=r" (carryout) \ - : "r" (arg1), "r" (arg2)) - -#define BngAdd2Carry(res,carryout,arg1,arg2,carryin) \ - asm("addic %1, %4, -1 \n\t" \ - "adde %0, %2, %3 \n\t" \ - "li %1, 0 \n\t" \ - "addze %1, %1" \ - : "=r" (res), "=&r" (carryout) \ - : "r" (arg1), "r" (arg2), "1" (carryin)) - -#define BngAdd3(res,carryaccu,arg1,arg2,arg3) \ - asm("addc %0, %2, %3 \n\t" \ - "addze %1, %1 \n\t" \ - "addc %0, %0, %4 \n\t" \ - "addze %1, %1" \ - : "=&r" (res), "=&r" (carryaccu) \ - : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu)) - -/* The "subtract" instructions interpret carry differently than what we - need: the processor carry bit CA is 1 if no carry occured, - 0 if a carry occured. In other terms, CA = !carry. - Thus, subfe rd,ra,rb computes rd = ra - rb - !CA - subfe rd,rd,rd sets rd = - !CA - subfe rd,rd,rd; neg rd, rd sets rd = !CA and recovers "our" carry. */ - -#define BngSub2(res,carryout,arg1,arg2) \ - asm("subfc %0, %3, %2 \n\t" \ - "subfe %1, %1, %1\n\t" \ - "neg %1, %1" \ - : "=r" (res), "=r" (carryout) \ - : "r" (arg1), "r" (arg2)) - -#define BngSub2Carry(res,carryout,arg1,arg2,carryin) \ - asm("subfic %1, %4, 0 \n\t" \ - "subfe %0, %3, %2 \n\t" \ - "subfe %1, %1, %1 \n\t" \ - "neg %1, %1" \ - : "=r" (res), "=&r" (carryout) \ - : "r" (arg1), "r" (arg2), "1" (carryin)) - -/* Here is what happens with carryaccu: - neg %1, %1 carryaccu = -carryaccu - addze %1, %1 carryaccu += !carry1 - addze %1, %1 carryaccu += !carry2 - subifc %1, %1, 2 carryaccu = 2 - carryaccu - Thus, carryaccu_final = carryaccu_initial + 2 - (1 - carry1) - (1 - carry2) - = carryaccu_initial + carry1 + carry2 -*/ - -#define BngSub3(res,carryaccu,arg1,arg2,arg3) \ - asm("neg %1, %1 \n\t" \ - "subfc %0, %3, %2 \n\t" \ - "addze %1, %1 \n\t" \ - "subfc %0, %4, %0 \n\t" \ - "addze %1, %1 \n\t" \ - "subfic %1, %1, 2 \n\t" \ - : "=&r" (res), "=&r" (carryaccu) \ - : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu)) - -#define BngMult(resh,resl,arg1,arg2) \ - asm("mullw %0, %2, %3 \n\t" \ - "mulhwu %1, %2, %3" \ - : "=&r" (resl), "=r" (resh) \ - : "r" (arg1), "r" (arg2)) diff --git a/otherlibs/num/bng_sparc.c b/otherlibs/num/bng_sparc.c deleted file mode 100644 index 934c0b2f7e..0000000000 --- a/otherlibs/num/bng_sparc.c +++ /dev/null @@ -1,77 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Code specific to the SPARC (V8 and above) architecture. */ - -#define BngAdd2(res,carryout,arg1,arg2) \ - asm("addcc %2, %3, %0 \n\t" \ - "addx %%g0, 0, %1" \ - : "=r" (res), "=r" (carryout) \ - : "r" (arg1), "r" (arg2) \ - : "cc") - -#define BngAdd2Carry(res,carryout,arg1,arg2,carryin) \ - asm("subcc %%g0, %4, %%g0 \n\t" \ - "addxcc %2, %3, %0 \n\t" \ - "addx %%g0, 0, %1" \ - : "=r" (res), "=r" (carryout) \ - : "r" (arg1), "r" (arg2), "r" (carryin) \ - : "cc") - -#define BngAdd3(res,carryaccu,arg1,arg2,arg3) \ - asm("addcc %2, %3, %0 \n\t" \ - "addx %1, 0, %1 \n\t" \ - "addcc %0, %4, %0 \n\t" \ - "addx %1, 0, %1" \ - : "=r" (res), "=r" (carryaccu) \ - : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu) \ - : "cc") - -#define BngSub2(res,carryout,arg1,arg2) \ - asm("subcc %2, %3, %0 \n\t" \ - "addx %%g0, 0, %1" \ - : "=r" (res), "=r" (carryout) \ - : "r" (arg1), "r" (arg2) \ - : "cc") - -#define BngSub2Carry(res,carryout,arg1,arg2,carryin) \ - asm("subcc %%g0, %4, %%g0 \n\t" \ - "subxcc %2, %3, %0 \n\t" \ - "addx %%g0, 0, %1" \ - : "=r" (res), "=r" (carryout) \ - : "r" (arg1), "r" (arg2), "r" (carryin) \ - : "cc") - -#define BngSub3(res,carryaccu,arg1,arg2,arg3) \ - asm("subcc %2, %3, %0 \n\t" \ - "addx %1, 0, %1 \n\t" \ - "subcc %0, %4, %0 \n\t" \ - "addx %1, 0, %1" \ - : "=r" (res), "=r" (carryaccu) \ - : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu) \ - : "cc") - -#define BngMult(resh,resl,arg1,arg2) \ - asm("umul %2, %3, %0 \n\t" \ - "rd %%y, %1" \ - : "=r" (resl), "=r" (resh) \ - : "r" (arg1), "r" (arg2)) - -#define BngDiv(quo,rem,nh,nl,d) \ - asm("wr %1, %%y \n\t" \ - "udiv %2, %3, %0" \ - : "=r" (quo) \ - : "r" (nh), "r" (nl), "r" (d)); \ - rem = nl - d * quo diff --git a/otherlibs/num/int_misc.ml b/otherlibs/num/int_misc.ml deleted file mode 100644 index b7eb4c67d4..0000000000 --- a/otherlibs/num/int_misc.ml +++ /dev/null @@ -1,36 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Some extra operations on integers *) - -let rec gcd_int i1 i2 = - if i2 = 0 then abs i1 else gcd_int i2 (i1 mod i2) -;; - -let rec num_bits_int_aux n = - if n = 0 then 0 else succ(num_bits_int_aux (n lsr 1));; - -let num_bits_int n = num_bits_int_aux (abs n);; - -let sign_int i = if i = 0 then 0 else if i > 0 then 1 else -1;; - -let length_of_int = Sys.word_size - 2;; - -let monster_int = 1 lsl length_of_int;; -let biggest_int = monster_int - 1;; -let least_int = - biggest_int;; - -let compare_int n1 n2 = - if n1 == n2 then 0 else if n1 > n2 then 1 else -1;; diff --git a/otherlibs/num/int_misc.mli b/otherlibs/num/int_misc.mli deleted file mode 100644 index 28bb335b8e..0000000000 --- a/otherlibs/num/int_misc.mli +++ /dev/null @@ -1,25 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Some extra operations on integers *) - -val gcd_int: int -> int -> int -val num_bits_int: int -> int -val compare_int: int -> int -> int -val sign_int: int -> int -val length_of_int: int -val biggest_int: int -val least_int: int -val monster_int: int diff --git a/otherlibs/num/nat.h b/otherlibs/num/nat.h deleted file mode 100644 index 66a664fab0..0000000000 --- a/otherlibs/num/nat.h +++ /dev/null @@ -1,19 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1999 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Nats are represented as unstructured blocks with tag Custom_tag. */ - -#define Digit_val(nat,pos) (((bng) Data_custom_val(nat))[pos]) - diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml deleted file mode 100644 index dcfb4c5057..0000000000 --- a/otherlibs/num/nat.ml +++ /dev/null @@ -1,570 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Int_misc - -type nat;; - -external create_nat: int -> nat = "create_nat" -external set_to_zero_nat: nat -> int -> int -> unit = "set_to_zero_nat" -external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat" -external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat" -external nth_digit_nat: nat -> int -> int = "nth_digit_nat" -external num_digits_nat: nat -> int -> int -> int = "num_digits_nat" -external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit" -external is_digit_int: nat -> int -> bool = "is_digit_int" -external is_digit_zero: nat -> int -> bool = "is_digit_zero" -external is_digit_normalized: nat -> int -> bool = "is_digit_normalized" -external is_digit_odd: nat -> int -> bool = "is_digit_odd" -external incr_nat: nat -> int -> int -> int -> int = "incr_nat" -external add_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "add_nat" "add_nat_native" -external complement_nat: nat -> int -> int -> unit = "complement_nat" -external decr_nat: nat -> int -> int -> int -> int = "decr_nat" -external sub_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "sub_nat" "sub_nat_native" -external mult_digit_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int = "mult_digit_nat" "mult_digit_nat_native" -external mult_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int -> int = "mult_nat" "mult_nat_native" -external square_nat: nat -> int -> int -> nat -> int -> int -> int = "square_nat" "square_nat_native" -external shift_left_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_left_nat" "shift_left_nat_native" -external div_digit_nat: nat -> int -> nat -> int -> nat -> int -> int -> nat -> int -> unit = "div_digit_nat" "div_digit_nat_native" -external div_nat: nat -> int -> int -> nat -> int -> int -> unit = "div_nat" "div_nat_native" -external shift_right_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_right_nat" "shift_right_nat_native" -external compare_digits_nat: nat -> int -> nat -> int -> int = "compare_digits_nat" -external compare_nat: nat -> int -> int -> nat -> int -> int -> int = "compare_nat" "compare_nat_native" -external land_digit_nat: nat -> int -> nat -> int -> unit = "land_digit_nat" -external lor_digit_nat: nat -> int -> nat -> int -> unit = "lor_digit_nat" -external lxor_digit_nat: nat -> int -> nat -> int -> unit = "lxor_digit_nat" - -external initialize_nat: unit -> unit = "initialize_nat" -let _ = initialize_nat() - -let length_nat (n : nat) = Obj.size (Obj.repr n) - 1 - -let length_of_digit = Sys.word_size;; - -let make_nat len = - if len < 0 then invalid_arg "make_nat" else - let res = create_nat len in set_to_zero_nat res 0 len; res - -(* Nat temporaries *) -let a_2 = make_nat 2 -and a_1 = make_nat 1 -and b_2 = make_nat 2 - -let copy_nat nat off_set length = - let res = create_nat (length) in - blit_nat res 0 nat off_set length; - res - -let is_zero_nat n off len = - compare_nat (make_nat 1) 0 1 n off (num_digits_nat n off len) = 0 - -let is_nat_int nat off len = - num_digits_nat nat off len = 1 && is_digit_int nat off - -let sys_int_of_nat nat off len = - if is_nat_int nat off len - then nth_digit_nat nat off - else failwith "int_of_nat" - -let int_of_nat nat = - sys_int_of_nat nat 0 (length_nat nat) - -let nat_of_int i = - if i < 0 then invalid_arg "nat_of_int" else - let res = make_nat 1 in - if i = 0 then res else begin set_digit_nat res 0 i; res end - -let eq_nat nat1 off1 len1 nat2 off2 len2 = - compare_nat nat1 off1 (num_digits_nat nat1 off1 len1) - nat2 off2 (num_digits_nat nat2 off2 len2) = 0 -and le_nat nat1 off1 len1 nat2 off2 len2 = - compare_nat nat1 off1 (num_digits_nat nat1 off1 len1) - nat2 off2 (num_digits_nat nat2 off2 len2) <= 0 -and lt_nat nat1 off1 len1 nat2 off2 len2 = - compare_nat nat1 off1 (num_digits_nat nat1 off1 len1) - nat2 off2 (num_digits_nat nat2 off2 len2) < 0 -and ge_nat nat1 off1 len1 nat2 off2 len2 = - compare_nat nat1 off1 (num_digits_nat nat1 off1 len1) - nat2 off2 (num_digits_nat nat2 off2 len2) >= 0 -and gt_nat nat1 off1 len1 nat2 off2 len2 = - compare_nat nat1 off1 (num_digits_nat nat1 off1 len1) - nat2 off2 (num_digits_nat nat2 off2 len2) > 0 - -(* XL: now implemented in C for better performance. - The code below doesn't handle carries correctly. - Fortunately, the carry is never used. *) -(*** -let square_nat nat1 off1 len1 nat2 off2 len2 = - let c = ref 0 - and trash = make_nat 1 in - (* Double product *) - for i = 0 to len2 - 2 do - c := !c + mult_digit_nat - nat1 - (succ (off1 + 2 * i)) - (2 * (pred (len2 - i))) - nat2 - (succ (off2 + i)) - (pred (len2 - i)) - nat2 - (off2 + i) - done; - shift_left_nat nat1 0 len1 trash 0 1; - (* Square of digit *) - for i = 0 to len2 - 1 do - c := !c + mult_digit_nat - nat1 - (off1 + 2 * i) - (len1 - 2 * i) - nat2 - (off2 + i) - 1 - nat2 - (off2 + i) - done; - !c -***) - -let gcd_int_nat i nat off len = - if i = 0 then 1 else - if is_nat_int nat off len then begin - set_digit_nat nat off (gcd_int (nth_digit_nat nat off) i); 0 - end else begin - let len_copy = succ len in - let copy = create_nat len_copy - and quotient = create_nat 1 - and remainder = create_nat 1 in - blit_nat copy 0 nat off len; - set_digit_nat copy len 0; - div_digit_nat quotient 0 remainder 0 copy 0 len_copy (nat_of_int i) 0; - set_digit_nat nat off (gcd_int (nth_digit_nat remainder 0) i); - 0 - end - -let exchange r1 r2 = - let old1 = !r1 in r1 := !r2; r2 := old1 - -let gcd_nat nat1 off1 len1 nat2 off2 len2 = - if is_zero_nat nat1 off1 len1 then begin - blit_nat nat1 off1 nat2 off2 len2; len2 - end else begin - let copy1 = ref (create_nat (succ len1)) - and copy2 = ref (create_nat (succ len2)) in - blit_nat !copy1 0 nat1 off1 len1; - blit_nat !copy2 0 nat2 off2 len2; - set_digit_nat !copy1 len1 0; - set_digit_nat !copy2 len2 0; - if lt_nat !copy1 0 len1 !copy2 0 len2 - then exchange copy1 copy2; - let real_len1 = - ref (num_digits_nat !copy1 0 (length_nat !copy1)) - and real_len2 = - ref (num_digits_nat !copy2 0 (length_nat !copy2)) in - while not (is_zero_nat !copy2 0 !real_len2) do - set_digit_nat !copy1 !real_len1 0; - div_nat !copy1 0 (succ !real_len1) !copy2 0 !real_len2; - exchange copy1 copy2; - real_len1 := !real_len2; - real_len2 := num_digits_nat !copy2 0 !real_len2 - done; - blit_nat nat1 off1 !copy1 0 !real_len1; - !real_len1 - end - -(* Racine carrée entière par la méthode de Newton (entière par défaut). *) - -(* Théorème: la suite xn+1 = (xn + a/xn) / 2 converge vers la racine *) -(* carrée entière de a par défaut, si on part d'une valeur x0 *) -(* strictement plus grande que la racine de a, sauf quand a est un *) -(* carré - 1, cas auquel la suite alterne entre la racine par défaut *) -(* et par excès. Dans tous les cas, le dernier terme de la partie *) -(* strictement décroissante de la suite est le résultat cherché. *) - -let sqrt_nat rad off len = - let len = num_digits_nat rad off len in - (* Copie de travail du radicande *) - let len_parity = len mod 2 in - let rad_len = len + 1 + len_parity in - let rad = - let res = create_nat rad_len in - blit_nat res 0 rad off len; - set_digit_nat res len 0; - set_digit_nat res (rad_len - 1) 0; - res in - let cand_len = (len + 1) / 2 in (* ceiling len / 2 *) - let cand_rest = rad_len - cand_len in - (* Racine carrée supposée cand = "|FFFF .... |" *) - let cand = make_nat cand_len in - (* Amélioration de la racine de départ: - on calcule nbb le nombre de bits significatifs du premier digit du candidat - (la moitié du nombre de bits significatifs dans les deux premiers - digits du radicande étendu à une longueur paire). - shift_cand est word_size - nbb *) - let shift_cand = - ((num_leading_zero_bits_in_digit rad (len-1)) + - Sys.word_size * len_parity) / 2 in - (* Tous les bits du radicande sont à 0, on rend 0. *) - if shift_cand = Sys.word_size then cand else - begin - complement_nat cand 0 cand_len; - shift_right_nat cand 0 1 a_1 0 shift_cand; - let next_cand = create_nat rad_len in - (* Repeat until *) - let rec loop () = - (* next_cand := rad *) - blit_nat next_cand 0 rad 0 rad_len; - (* next_cand <- next_cand / cand *) - div_nat next_cand 0 rad_len cand 0 cand_len; - (* next_cand (poids fort) <- next_cand (poids fort) + cand, - i.e. next_cand <- cand + rad / cand *) - add_nat next_cand cand_len cand_rest cand 0 cand_len 0; - (* next_cand <- next_cand / 2 *) - shift_right_nat next_cand cand_len cand_rest a_1 0 1; - if lt_nat next_cand cand_len cand_rest cand 0 cand_len then - begin (* cand <- next_cand *) - blit_nat cand 0 next_cand cand_len cand_len; loop () - end - else cand in - loop () - end;; - -let power_base_max = make_nat 2;; - -match length_of_digit with - | 64 -> - set_digit_nat power_base_max 0 (Int64.to_int 1000000000000000000L); - mult_digit_nat power_base_max 0 2 - power_base_max 0 1 (nat_of_int 9) 0; - () - | 32 -> set_digit_nat power_base_max 0 1000000000 - | _ -> assert false -;; - -let pmax = - match length_of_digit with - | 64 -> 19 - | 32 -> 9 - | _ -> assert false -;; - -let max_superscript_10_power_in_int = - match length_of_digit with - | 64 -> 18 - | 32 -> 9 - | _ -> assert false -;; -let max_power_10_power_in_int = - match length_of_digit with - | 64 -> nat_of_int (Int64.to_int 1000000000000000000L) - | 32 -> nat_of_int 1000000000 - | _ -> assert false -;; - -let raw_string_of_digit nat off = - if is_nat_int nat off 1 - then begin string_of_int (nth_digit_nat nat off) end - else begin - blit_nat b_2 0 nat off 1; - div_digit_nat a_2 0 a_1 0 b_2 0 2 max_power_10_power_in_int 0; - let leading_digits = nth_digit_nat a_2 0 - and s1 = string_of_int (nth_digit_nat a_1 0) in - let len = String.length s1 in - if leading_digits < 10 then begin - let result = String.make (max_superscript_10_power_in_int+1) '0' in - String.set result 0 - (Char.chr (48 + leading_digits)); - String.blit s1 0 - result (String.length result - len) len; - result - end else begin - let result = String.make (max_superscript_10_power_in_int+2) '0' in - String.blit (string_of_int leading_digits) 0 result 0 2; - String.blit s1 0 - result (String.length result - len) len; - result - end - end - -(* XL: suppression de string_of_digit et de sys_string_of_digit. - La copie est de toute facon faite dans string_of_nat, qui est le - seul point d entree public dans ce code. *) - -(****** -let sys_string_of_digit nat off = - let s = raw_string_of_digit nat off in - let result = String.create (String.length s) in - String.blit s 0 result 0 (String.length s); - s - -let string_of_digit nat = - sys_string_of_digit nat 0 - -*******) - -let digits = "0123456789ABCDEF" - -(* - make_power_base affecte power_base des puissances successives de base a - partir de la puissance 1-ieme. - A la fin de la boucle i-1 est la plus grande puissance de la base qui tient - sur un seul digit et j est la plus grande puissance de la base qui tient - sur un int. -*) -let make_power_base base power_base = - let i = ref 0 - and j = ref 0 in - set_digit_nat power_base 0 base; - while incr i; is_digit_zero power_base !i do - mult_digit_nat power_base !i 2 - power_base (pred !i) 1 - power_base 0 - done; - while !j <= !i && is_digit_int power_base !j do incr j done; - (!i - 2, !j) - -(* - int_to_string place la representation de l entier int en base base - dans la chaine s en le rangeant de la fin indiquee par pos vers le - debut, sur times places et affecte a pos sa nouvelle valeur. -*) -let int_to_string int s pos_ref base times = - let i = ref int - and j = ref times in - while ((!i != 0) || (!j != 0)) && (!pos_ref != -1) do - String.set s !pos_ref (String.get digits (!i mod base)); - decr pos_ref; - decr j; - i := !i / base - done - -(* XL: suppression de adjust_string *) - -let power_base_int base i = - if i = 0 then - nat_of_int 1 - else if i < 0 then - invalid_arg "power_base_int" - else begin - let power_base = make_nat (succ length_of_digit) in - let (pmax, pint) = make_power_base base power_base in - let n = i / (succ pmax) - and rem = i mod (succ pmax) in - if n > 0 then begin - let newn = - if i = biggest_int then n else (succ n) in - let res = make_nat newn - and res2 = make_nat newn - and l = num_bits_int n - 2 in - let p = ref (1 lsl l) in - blit_nat res 0 power_base pmax 1; - for i = l downto 0 do - let len = num_digits_nat res 0 newn in - let len2 = min n (2 * len) in - let succ_len2 = succ len2 in - square_nat res2 0 len2 res 0 len; - if n land !p > 0 then begin - set_to_zero_nat res 0 len; - mult_digit_nat res 0 succ_len2 - res2 0 len2 - power_base pmax; - () - end else - blit_nat res 0 res2 0 len2; - set_to_zero_nat res2 0 len2; - p := !p lsr 1 - done; - if rem > 0 then begin - mult_digit_nat res2 0 newn - res 0 n power_base (pred rem); - res2 - end else res - end else - copy_nat power_base (pred rem) 1 - end - -(* the ith element (i >= 2) of num_digits_max_vector is : - | | - | biggest_string_length * log (i) | - | ------------------------------- | + 1 - | length_of_digit * log (2) | - -- -- -*) - -(* XL: ai specialise le code d origine a length_of_digit = 32. *) -(* Puis suppression (inutile?) *) - -(****** -let num_digits_max_vector = - [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402; - 3543; 3671; 3789; 3899; 4001; 4096|] - -let num_digits_max_vector = - match length_of_digit with - 16 -> [|0; 0; 2048; 3246; 4096; 4755; 5294; 5749; 6144; 6492; 6803; - 7085; 7342; 7578; 7797; 8001; 8192|] -(* If really exotic machines !!!! - | 17 -> [|0; 0; 1928; 3055; 3855; 4476; 4983; 5411; 5783; 6110; 6403; - 6668; 6910; 7133; 7339; 7530; 7710|] - | 18 -> [|0; 0; 1821; 2886; 3641; 4227; 4706; 5111; 5461; 5771; 6047; - 6298; 6526; 6736; 6931; 7112; 7282|] - | 19 -> [|0; 0; 1725; 2734; 3449; 4005; 4458; 4842; 5174; 5467; 5729; - 5966; 6183; 6382; 6566; 6738; 6898|] - | 20 -> [|0; 0; 1639; 2597; 3277; 3804; 4235; 4600; 4915; 5194; 5443; - 5668; 5874; 6063; 6238; 6401; 6553|] - | 21 -> [|0; 0; 1561; 2473; 3121; 3623; 4034; 4381; 4681; 4946; 5183; - 5398; 5594; 5774; 5941; 6096; 6241|] - | 22 -> [|0; 0; 1490; 2361; 2979; 3459; 3850; 4182; 4468; 4722; 4948; - 5153; 5340; 5512; 5671; 5819; 5958|] - | 23 -> [|0; 0; 1425; 2258; 2850; 3308; 3683; 4000; 4274; 4516; 4733; - 4929; 5108; 5272; 5424; 5566; 5699|] - | 24 -> [|0; 0; 1366; 2164; 2731; 3170; 3530; 3833; 4096; 4328; 4536; - 4723; 4895; 5052; 5198; 5334; 5461|] - | 25 -> [|0; 0; 1311; 2078; 2622; 3044; 3388; 3680; 3932; 4155; 4354; - 4534; 4699; 4850; 4990; 5121; 5243|] - | 26 -> [|0; 0; 1261; 1998; 2521; 2927; 3258; 3538; 3781; 3995; 4187; - 4360; 4518; 4664; 4798; 4924; 5041|] - | 27 -> [|0; 0; 1214; 1924; 2428; 2818; 3137; 3407; 3641; 3847; 4032; - 4199; 4351; 4491; 4621; 4742; 4855|] - | 28 -> [|0; 0; 1171; 1855; 2341; 2718; 3025; 3286; 3511; 3710; 3888; - 4049; 4196; 4331; 4456; 4572; 4681|] - | 29 -> [|0; 0; 1130; 1791; 2260; 2624; 2921; 3172; 3390; 3582; 3754; - 3909; 4051; 4181; 4302; 4415; 4520|] - | 30 -> [|0; 0; 1093; 1732; 2185; 2536; 2824; 3067; 3277; 3463; 3629; - 3779; 3916; 4042; 4159; 4267; 4369|] - | 31 -> [|0; 0; 1057; 1676; 2114; 2455; 2733; 2968; 3171; 3351; 3512; - 3657; 3790; 3912; 4025; 4130; 4228|] -*) - | 32 -> [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402; - 3543; 3671; 3789; 3899; 4001; 4096|] - | n -> failwith "num_digits_max_vector" -******) - -(* XL: suppression de string_list_of_nat *) - -let unadjusted_string_of_nat nat off len_nat = - let len = num_digits_nat nat off len_nat in - if len = 1 then - raw_string_of_digit nat off - else - let len_copy = ref (succ len) in - let copy1 = create_nat !len_copy - and copy2 = make_nat !len_copy - and rest_digit = make_nat 2 in - if len > biggest_int / (succ pmax) - then failwith "number too long" - else let len_s = (succ pmax) * len in - let s = String.make len_s '0' - and pos_ref = ref len_s in - len_copy := pred !len_copy; - blit_nat copy1 0 nat off len; - set_digit_nat copy1 len 0; - while not (is_zero_nat copy1 0 !len_copy) do - div_digit_nat copy2 0 - rest_digit 0 - copy1 0 (succ !len_copy) - power_base_max 0; - let str = raw_string_of_digit rest_digit 0 in - String.blit str 0 - s (!pos_ref - String.length str) - (String.length str); - (* XL: il y avait pmax a la place de String.length str - mais ca ne marche pas avec le blit de Caml Light, - qui ne verifie pas les debordements *) - pos_ref := !pos_ref - pmax; - len_copy := num_digits_nat copy2 0 !len_copy; - blit_nat copy1 0 copy2 0 !len_copy; - set_digit_nat copy1 !len_copy 0 - done; - s - -let string_of_nat nat = - let s = unadjusted_string_of_nat nat 0 (length_nat nat) - and index = ref 0 in - begin try - for i = 0 to String.length s - 2 do - if String.get s i <> '0' then (index:= i; raise Exit) - done - with Exit -> () - end; - String.sub s !index (String.length s - !index) - -(* XL: suppression de sys_string_of_nat *) - -(* XL: suppression de debug_string_nat *) - -let base_digit_of_char c base = - let n = Char.code c in - if n >= 48 && n <= 47 + min base 10 then n - 48 - else if n >= 65 && n <= 65 + base - 11 then n - 55 - else failwith "invalid digit" - -(* - La sous-chaine (s, off, len) represente un nat en base base que - on determine ici -*) -let sys_nat_of_string base s off len = - let power_base = make_nat (succ length_of_digit) in - let (pmax, pint) = make_power_base base power_base in - let new_len = ref (1 + len / (pmax + 1)) - and current_len = ref 1 in - let possible_len = ref (min 2 !new_len) in - - let nat1 = make_nat !new_len - and nat2 = make_nat !new_len - - and digits_read = ref 0 - and bound = off + len - 1 - and int = ref 0 in - - for i = off to bound do - (* - on lit pint (au maximum) chiffres, on en fait un int - et on l integre au nombre - *) - let c = String.get s i in - begin match c with - ' ' | '\t' | '\n' | '\r' | '\\' -> () - | _ -> int := !int * base + base_digit_of_char c base; - incr digits_read - end; - if (!digits_read = pint || i = bound) && not (!digits_read = 0) then - begin - set_digit_nat nat1 0 !int; - let erase_len = if !new_len = !current_len then !current_len - 1 - else !current_len in - for j = 1 to erase_len do - set_digit_nat nat1 j 0 - done; - mult_digit_nat nat1 0 !possible_len - nat2 0 !current_len - power_base (pred !digits_read); - blit_nat nat2 0 nat1 0 !possible_len; - current_len := num_digits_nat nat1 0 !possible_len; - possible_len := min !new_len (succ !current_len); - int := 0; - digits_read := 0 - end - done; - (* - On recadre le nat - *) - let nat = create_nat !current_len in - blit_nat nat 0 nat1 0 !current_len; - nat - -let nat_of_string s = sys_nat_of_string 10 s 0 (String.length s) - -let float_of_nat nat = float_of_string(string_of_nat nat) - diff --git a/otherlibs/num/nat.mli b/otherlibs/num/nat.mli deleted file mode 100644 index 18cd812011..0000000000 --- a/otherlibs/num/nat.mli +++ /dev/null @@ -1,71 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Module [Nat]: operations on natural numbers *) - -type nat - -(* Natural numbers (type [nat]) are positive integers of arbitrary size. - All operations on [nat] are performed in-place. *) - -external create_nat: int -> nat = "create_nat" -val make_nat: int -> nat -external set_to_zero_nat: nat -> int -> int -> unit = "set_to_zero_nat" -external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat" -val copy_nat: nat -> int -> int -> nat -external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat" -external nth_digit_nat: nat -> int -> int = "nth_digit_nat" -val length_nat : nat -> int -external num_digits_nat: nat -> int -> int -> int = "num_digits_nat" -external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit" -external is_digit_int: nat -> int -> bool = "is_digit_int" -external is_digit_zero: nat -> int -> bool = "is_digit_zero" -external is_digit_normalized: nat -> int -> bool = "is_digit_normalized" -external is_digit_odd: nat -> int -> bool = "is_digit_odd" -val is_zero_nat: nat -> int -> int -> bool -val is_nat_int: nat -> int -> int -> bool -val int_of_nat: nat -> int -val nat_of_int: int -> nat -external incr_nat: nat -> int -> int -> int -> int = "incr_nat" -external add_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "add_nat" "add_nat_native" -external complement_nat: nat -> int -> int -> unit = "complement_nat" -external decr_nat: nat -> int -> int -> int -> int = "decr_nat" -external sub_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "sub_nat" "sub_nat_native" -external mult_digit_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int = "mult_digit_nat" "mult_digit_nat_native" -external mult_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int -> int = "mult_nat" "mult_nat_native" -external square_nat: nat -> int -> int -> nat -> int -> int -> int = "square_nat" "square_nat_native" -external shift_left_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_left_nat" "shift_left_nat_native" -external div_digit_nat: nat -> int -> nat -> int -> nat -> int -> int -> nat -> int -> unit = "div_digit_nat" "div_digit_nat_native" -external div_nat: nat -> int -> int -> nat -> int -> int -> unit = "div_nat" "div_nat_native" -external shift_right_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_right_nat" "shift_right_nat_native" -external compare_digits_nat: nat -> int -> nat -> int -> int = "compare_digits_nat" -external compare_nat: nat -> int -> int -> nat -> int -> int -> int = "compare_nat" "compare_nat_native" -val eq_nat : nat -> int -> int -> nat -> int -> int -> bool -val le_nat : nat -> int -> int -> nat -> int -> int -> bool -val lt_nat : nat -> int -> int -> nat -> int -> int -> bool -val ge_nat : nat -> int -> int -> nat -> int -> int -> bool -val gt_nat : nat -> int -> int -> nat -> int -> int -> bool -external land_digit_nat: nat -> int -> nat -> int -> unit = "land_digit_nat" -external lor_digit_nat: nat -> int -> nat -> int -> unit = "lor_digit_nat" -external lxor_digit_nat: nat -> int -> nat -> int -> unit = "lxor_digit_nat" -val gcd_nat : nat -> int -> int -> nat -> int -> int -> int -val sqrt_nat : nat -> int -> int -> nat -val string_of_nat : nat -> string -val nat_of_string : string -> nat -val sys_nat_of_string : int -> string -> int -> int -> nat -val float_of_nat : nat -> float -val make_power_base : int -> nat -> int * int -val power_base_int : int -> int -> nat -val length_of_digit: int diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c deleted file mode 100644 index a7fb7dcfe0..0000000000 --- a/otherlibs/num/nat_stubs.c +++ /dev/null @@ -1,369 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "alloc.h" -#include "custom.h" -#include "intext.h" -#include "fail.h" -#include "memory.h" -#include "mlvalues.h" - -#include "bng.h" -#include "nat.h" - -/* Stub code for the Nat module. */ - -static void serialize_nat(value, unsigned long *, unsigned long *); -static unsigned long deserialize_nat(void * dst); - -static struct custom_operations nat_operations = { - "_nat", - custom_finalize_default, - custom_compare_default, - custom_hash_default, - serialize_nat, - deserialize_nat -}; - -CAMLprim value initialize_nat(value unit) -{ - bng_init(); - register_custom_operations(&nat_operations); - return Val_unit; -} - -CAMLprim value create_nat(value size) -{ - mlsize_t sz = Long_val(size); - - return alloc_custom(&nat_operations, sz * sizeof(value), 0, 1); -} - -CAMLprim value length_nat(value nat) -{ - return Val_long(Wosize_val(nat) - 1); -} - -CAMLprim value set_to_zero_nat(value nat, value ofs, value len) -{ - bng_zero(&Digit_val(nat, Long_val(ofs)), Long_val(len)); - return Val_unit; -} - -CAMLprim value blit_nat(value nat1, value ofs1, - value nat2, value ofs2, - value len) -{ - bng_assign(&Digit_val(nat1, Long_val(ofs1)), - &Digit_val(nat2, Long_val(ofs2)), - Long_val(len)); - return Val_unit; -} - -CAMLprim value set_digit_nat(value nat, value ofs, value digit) -{ - Digit_val(nat, Long_val(ofs)) = Long_val(digit); - return Val_unit; -} - -CAMLprim value nth_digit_nat(value nat, value ofs) -{ - return Val_long(Digit_val(nat, Long_val(ofs))); -} - -CAMLprim value num_digits_nat(value nat, value ofs, value len) -{ - return Val_long(bng_num_digits(&Digit_val(nat, Long_val(ofs)), - Long_val(len))); -} - -CAMLprim value num_leading_zero_bits_in_digit(value nat, value ofs) -{ - return - Val_long(bng_leading_zero_bits(Digit_val(nat, Long_val(ofs)))); -} - -CAMLprim value is_digit_int(value nat, value ofs) -{ - return Val_bool(Digit_val(nat, Long_val(ofs)) <= Max_long); -} - -CAMLprim value is_digit_zero(value nat, value ofs) -{ - return Val_bool(Digit_val(nat, Long_val(ofs)) == 0); -} - -CAMLprim value is_digit_normalized(value nat, value ofs) -{ - return - Val_bool(Digit_val(nat, Long_val(ofs)) & (1L << (BNG_BITS_PER_DIGIT-1))); -} - -CAMLprim value is_digit_odd(value nat, value ofs) -{ - return Val_bool(Digit_val(nat, Long_val(ofs)) & 1); -} - -CAMLprim value incr_nat(value nat, value ofs, value len, value carry_in) -{ - return Val_long(bng_add_carry(&Digit_val(nat, Long_val(ofs)), - Long_val(len), Long_val(carry_in))); -} - -value add_nat_native(value nat1, value ofs1, value len1, - value nat2, value ofs2, value len2, value carry_in) -{ - return Val_long(bng_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), - &Digit_val(nat2, Long_val(ofs2)), Long_val(len2), - Long_val(carry_in))); -} - -CAMLprim value add_nat(value *argv, int argn) -{ - return add_nat_native(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5], argv[6]); -} - -CAMLprim value complement_nat(value nat, value ofs, value len) -{ - bng_complement(&Digit_val(nat, Long_val(ofs)), Long_val(len)); - return Val_unit; -} - -CAMLprim value decr_nat(value nat, value ofs, value len, value carry_in) -{ - return Val_long(1 ^ bng_sub_carry(&Digit_val(nat, Long_val(ofs)), - Long_val(len), 1 ^ Long_val(carry_in))); -} - -value sub_nat_native(value nat1, value ofs1, value len1, - value nat2, value ofs2, value len2, value carry_in) -{ - return Val_long(1 ^ bng_sub(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), - &Digit_val(nat2, Long_val(ofs2)), Long_val(len2), - 1 ^ Long_val(carry_in))); -} - -CAMLprim value sub_nat(value *argv, int argn) -{ - return sub_nat_native(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5], argv[6]); -} - -value mult_digit_nat_native(value nat1, value ofs1, value len1, - value nat2, value ofs2, value len2, - value nat3, value ofs3) -{ - return - Val_long(bng_mult_add_digit( - &Digit_val(nat1, Long_val(ofs1)), Long_val(len1), - &Digit_val(nat2, Long_val(ofs2)), Long_val(len2), - Digit_val(nat3, Long_val(ofs3)))); -} - -CAMLprim value mult_digit_nat(value *argv, int argn) -{ - return mult_digit_nat_native(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5], argv[6], argv[7]); -} - -value mult_nat_native(value nat1, value ofs1, value len1, - value nat2, value ofs2, value len2, - value nat3, value ofs3, value len3) -{ - return - Val_long(bng_mult_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), - &Digit_val(nat2, Long_val(ofs2)), Long_val(len2), - &Digit_val(nat3, Long_val(ofs3)), Long_val(len3))); -} - -CAMLprim value mult_nat(value *argv, int argn) -{ - return mult_nat_native(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5], argv[6], argv[7], argv[8]); -} - -value square_nat_native(value nat1, value ofs1, value len1, - value nat2, value ofs2, value len2) -{ - return - Val_long(bng_square_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), - &Digit_val(nat2, Long_val(ofs2)), Long_val(len2))); -} - -CAMLprim value square_nat(value *argv, int argn) -{ - return square_nat_native(argv[0], argv[1], argv[2], - argv[3], argv[4], argv[5]); -} - -value shift_left_nat_native(value nat1, value ofs1, value len1, - value nat2, value ofs2, value nbits) -{ - Digit_val(nat2, Long_val(ofs2)) = - bng_shift_left(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), - Long_val(nbits)); - return Val_unit; -} - -CAMLprim value shift_left_nat(value *argv, int argn) -{ - return shift_left_nat_native(argv[0], argv[1], argv[2], - argv[3], argv[4], argv[5]); -} - -value div_digit_nat_native(value natq, value ofsq, - value natr, value ofsr, - value nat1, value ofs1, value len1, - value nat2, value ofs2) -{ - Digit_val(natr, Long_val(ofsr)) = - bng_div_rem_digit(&Digit_val(natq, Long_val(ofsq)), - &Digit_val(nat1, Long_val(ofs1)), Long_val(len1), - Digit_val(nat2, Long_val(ofs2))); - return Val_unit; -} - -CAMLprim value div_digit_nat(value *argv, int argn) -{ - return div_digit_nat_native(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5], argv[6], argv[7], argv[8]); -} - -value div_nat_native(value nat1, value ofs1, value len1, - value nat2, value ofs2, value len2) -{ - bng_div_rem(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), - &Digit_val(nat2, Long_val(ofs2)), Long_val(len2)); - return Val_unit; -} - -CAMLprim value div_nat(value *argv, int argn) -{ - return div_nat_native(argv[0], argv[1], argv[2], - argv[3], argv[4], argv[5]); -} - -value shift_right_nat_native(value nat1, value ofs1, value len1, - value nat2, value ofs2, value nbits) -{ - Digit_val(nat2, Long_val(ofs2)) = - bng_shift_right(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), - Long_val(nbits)); - return Val_unit; -} - -CAMLprim value shift_right_nat(value *argv, int argn) -{ - return shift_right_nat_native(argv[0], argv[1], argv[2], - argv[3], argv[4], argv[5]); -} - -CAMLprim value compare_digits_nat(value nat1, value ofs1, - value nat2, value ofs2) -{ - bngdigit d1 = Digit_val(nat1, Long_val(ofs1)); - bngdigit d2 = Digit_val(nat2, Long_val(ofs2)); - if (d1 > d2) return Val_int(1); - if (d1 < d2) return Val_int(-1); - return Val_int(0); -} - -value compare_nat_native(value nat1, value ofs1, value len1, - value nat2, value ofs2, value len2) -{ - return - Val_int(bng_compare(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), - &Digit_val(nat2, Long_val(ofs2)), Long_val(len2))); -} - -CAMLprim value compare_nat(value *argv, int argn) -{ - return compare_nat_native(argv[0], argv[1], argv[2], - argv[3], argv[4], argv[5]); -} - -CAMLprim value land_digit_nat(value nat1, value ofs1, value nat2, value ofs2) -{ - Digit_val(nat1, Long_val(ofs1)) &= Digit_val(nat2, Long_val(ofs2)); - return Val_unit; -} - -CAMLprim value lor_digit_nat(value nat1, value ofs1, value nat2, value ofs2) -{ - Digit_val(nat1, Long_val(ofs1)) |= Digit_val(nat2, Long_val(ofs2)); - return Val_unit; -} - -CAMLprim value lxor_digit_nat(value nat1, value ofs1, value nat2, value ofs2) -{ - Digit_val(nat1, Long_val(ofs1)) ^= Digit_val(nat2, Long_val(ofs2)); - return Val_unit; -} - -/* The wire format for a nat is: - - 32-bit word: number of 32-bit words in nat - - N 32-bit words (big-endian format) - For little-endian platforms, the memory layout between 32-bit and 64-bit - machines is identical, so we can write the nat using serialize_block_4. - For big-endian 64-bit platforms, we need to swap the two 32-bit halves - of 64-bit words to obtain the correct behavior. */ - -static void serialize_nat(value nat, - unsigned long * wsize_32, - unsigned long * wsize_64) -{ - mlsize_t len = Wosize_val(nat) - 1; - -#ifdef ARCH_SIXTYFOUR - len = len * 2; /* two 32-bit words per 64-bit digit */ - if (len >= (1L << 32)) - failwith("output_value: nat too big"); -#endif - serialize_int_4((int32) len); -#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN) - { int32 * p; - mlsize_t i; - for (i = len, p = Data_custom_val(nat); i > 0; i -= 2, p += 2) { - serialize_int_4(p[1]); /* low 32 bits of 64-bit digit */ - serialize_int_4(p[0]); /* high 32 bits of 64-bit digit */ - } - } -#else - serialize_block_4(Data_custom_val(nat), len); -#endif - *wsize_32 = len * 4; - *wsize_64 = len * 4; -} - -static unsigned long deserialize_nat(void * dst) -{ - mlsize_t len; - - len = deserialize_uint_4(); -#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN) - { uint32 * p; - mlsize_t i; - for (i = len, p = dst; i > 0; i -= 2, p += 2) { - p[1] = deserialize_uint_4(); /* low 32 bits of 64-bit digit */ - p[0] = deserialize_uint_4(); /* high 32 bits of 64-bit digit */ - } - } -#else - deserialize_block_4(dst, len); -#endif - return len * 4; -} - diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml deleted file mode 100644 index 3d53aefdf8..0000000000 --- a/otherlibs/num/num.ml +++ /dev/null @@ -1,396 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Int_misc -open Nat -open Big_int -open Arith_flags -open Ratio - -type num = Int of int | Big_int of big_int | Ratio of ratio - (* The type of numbers. *) - -let biggest_INT = big_int_of_int biggest_int -and least_INT = big_int_of_int least_int - -(* Coercion big_int -> num *) -let num_of_big_int bi = - if le_big_int bi biggest_INT && ge_big_int bi least_INT - then Int (int_of_big_int bi) - else Big_int bi - -let numerator_num = function - Ratio r -> normalize_ratio r; num_of_big_int (numerator_ratio r) -| n -> n - -let denominator_num = function - Ratio r -> normalize_ratio r; num_of_big_int (denominator_ratio r) -| n -> Int 1 - -let normalize_num = function - Int i -> Int i -| Big_int bi -> num_of_big_int bi -| Ratio r -> if is_integer_ratio r - then num_of_big_int (numerator_ratio r) - else Ratio r - -let cautious_normalize_num_when_printing n = - if (!normalize_ratio_when_printing_flag) then (normalize_num n) else n - -let num_of_ratio r = - normalize_ratio r; - if not (is_integer_ratio r) then Ratio r - else if is_int_big_int (numerator_ratio r) then - Int (int_of_big_int (numerator_ratio r)) - else Big_int (numerator_ratio r) - -(* Operations on num *) - -let add_num a b = match (a,b) with - ((Int int1), (Int int2)) -> - let r = int1 + int2 in - if (int1 lxor int2) lor (int1 lxor (r lxor (-1))) < 0 - then Int r (* No overflow *) - else Big_int(add_big_int (big_int_of_int int1) (big_int_of_int int2)) - | ((Int i), (Big_int bi)) -> - num_of_big_int (add_int_big_int i bi) - | ((Big_int bi), (Int i)) -> - num_of_big_int (add_int_big_int i bi) - - | ((Int i), (Ratio r)) -> - Ratio (add_int_ratio i r) - | ((Ratio r), (Int i)) -> - Ratio (add_int_ratio i r) - - | ((Big_int bi1), (Big_int bi2)) -> num_of_big_int (add_big_int bi1 bi2) - - | ((Big_int bi), (Ratio r)) -> - Ratio (add_big_int_ratio bi r) - | ((Ratio r), (Big_int bi)) -> - Ratio (add_big_int_ratio bi r) - - | ((Ratio r1), (Ratio r2)) -> num_of_ratio (add_ratio r1 r2) - -let ( +/ ) = add_num - -let minus_num = function - Int i -> if i = monster_int - then Big_int (minus_big_int (big_int_of_int i)) - else Int (-i) -| Big_int bi -> Big_int (minus_big_int bi) -| Ratio r -> Ratio (minus_ratio r) - -let sub_num n1 n2 = add_num n1 (minus_num n2) - -let ( -/ ) = sub_num - -let mult_num a b = match (a,b) with - ((Int int1), (Int int2)) -> - if num_bits_int int1 + num_bits_int int2 < length_of_int - then Int (int1 * int2) - else num_of_big_int (mult_big_int (big_int_of_int int1) - (big_int_of_int int2)) - - | ((Int i), (Big_int bi)) -> - num_of_big_int (mult_int_big_int i bi) - | ((Big_int bi), (Int i)) -> - num_of_big_int (mult_int_big_int i bi) - - | ((Int i), (Ratio r)) -> - num_of_ratio (mult_int_ratio i r) - | ((Ratio r), (Int i)) -> - num_of_ratio (mult_int_ratio i r) - - | ((Big_int bi1), (Big_int bi2)) -> - num_of_big_int (mult_big_int bi1 bi2) - - | ((Big_int bi), (Ratio r)) -> - num_of_ratio (mult_big_int_ratio bi r) - | ((Ratio r), (Big_int bi)) -> - num_of_ratio (mult_big_int_ratio bi r) - - | ((Ratio r1), (Ratio r2)) -> - num_of_ratio (mult_ratio r1 r2) - -let ( */ ) = mult_num - -let square_num = function - Int i -> if 2 * num_bits_int i < length_of_int - then Int (i * i) - else num_of_big_int (square_big_int (big_int_of_int i)) - | Big_int bi -> Big_int (square_big_int bi) - | Ratio r -> Ratio (square_ratio r) - -let div_num n1 n2 = - match n1 with - | Int i1 -> - begin match n2 with - | Int i2 -> - num_of_ratio (create_ratio (big_int_of_int i1) (big_int_of_int i2)) - | Big_int bi2 -> num_of_ratio (create_ratio (big_int_of_int i1) bi2) - | Ratio r2 -> num_of_ratio (div_int_ratio i1 r2) end - - | Big_int bi1 -> - begin match n2 with - | Int i2 -> num_of_ratio (create_ratio bi1 (big_int_of_int i2)) - | Big_int bi2 -> num_of_ratio (create_ratio bi1 bi2) - | Ratio r2 -> num_of_ratio (div_big_int_ratio bi1 r2) end - - | Ratio r1 -> - begin match n2 with - | Int i2 -> num_of_ratio (div_ratio_int r1 i2) - | Big_int bi2 -> num_of_ratio (div_ratio_big_int r1 bi2) - | Ratio r2 -> num_of_ratio (div_ratio r1 r2) end -;; - -let ( // ) = div_num - -let floor_num = function - Int i as n -> n -| Big_int bi as n -> n -| Ratio r -> num_of_big_int (floor_ratio r) - -let quo_num x y = floor_num (div_num x y) - -let mod_num x y = sub_num x (mult_num y (quo_num x y)) - -let power_num_int a b = match (a,b) with - ((Int i), n) -> - (match sign_int n with - 0 -> Int 1 - | 1 -> num_of_big_int (power_int_positive_int i n) - | _ -> Ratio (create_normalized_ratio - unit_big_int (power_int_positive_int i (-n)))) -| ((Big_int bi), n) -> - (match sign_int n with - 0 -> Int 1 - | 1 -> num_of_big_int (power_big_int_positive_int bi n) - | _ -> Ratio (create_normalized_ratio - unit_big_int (power_big_int_positive_int bi (-n)))) -| ((Ratio r), n) -> - (match sign_int n with - 0 -> Int 1 - | 1 -> Ratio (power_ratio_positive_int r n) - | _ -> Ratio (power_ratio_positive_int - (inverse_ratio r) (-n))) - -let power_num_big_int a b = match (a,b) with - ((Int i), n) -> - (match sign_big_int n with - 0 -> Int 1 - | 1 -> num_of_big_int (power_int_positive_big_int i n) - | _ -> Ratio (create_normalized_ratio - unit_big_int - (power_int_positive_big_int i (minus_big_int n)))) -| ((Big_int bi), n) -> - (match sign_big_int n with - 0 -> Int 1 - | 1 -> num_of_big_int (power_big_int_positive_big_int bi n) - | _ -> Ratio (create_normalized_ratio - unit_big_int - (power_big_int_positive_big_int bi (minus_big_int n)))) -| ((Ratio r), n) -> - (match sign_big_int n with - 0 -> Int 1 - | 1 -> Ratio (power_ratio_positive_big_int r n) - | _ -> Ratio (power_ratio_positive_big_int - (inverse_ratio r) (minus_big_int n))) - -let power_num a b = match (a,b) with - (n, (Int i)) -> power_num_int n i -| (n, (Big_int bi)) -> power_num_big_int n bi -| _ -> invalid_arg "power_num" - -let ( **/ ) = power_num - -let is_integer_num = function - Int _ -> true -| Big_int _ -> true -| Ratio r -> is_integer_ratio r - -(* integer_num, floor_num, round_num, ceiling_num rendent des nums *) -let integer_num = function - Int i as n -> n -| Big_int bi as n -> n -| Ratio r -> num_of_big_int (integer_ratio r) - -and round_num = function - Int i as n -> n -| Big_int bi as n -> n -| Ratio r -> num_of_big_int (round_ratio r) - -and ceiling_num = function - Int i as n -> n -| Big_int bi as n -> n -| Ratio r -> num_of_big_int (ceiling_ratio r) - -(* Comparisons on nums *) - -let sign_num = function - Int i -> sign_int i -| Big_int bi -> sign_big_int bi -| Ratio r -> sign_ratio r - -let eq_num a b = match (a,b) with - ((Int int1), (Int int2)) -> int1 = int2 - -| ((Int i), (Big_int bi)) -> eq_big_int (big_int_of_int i) bi -| ((Big_int bi), (Int i)) -> eq_big_int (big_int_of_int i) bi - -| ((Int i), (Ratio r)) -> eq_big_int_ratio (big_int_of_int i) r -| ((Ratio r), (Int i)) -> eq_big_int_ratio (big_int_of_int i) r - -| ((Big_int bi1), (Big_int bi2)) -> eq_big_int bi1 bi2 - -| ((Big_int bi), (Ratio r)) -> eq_big_int_ratio bi r -| ((Ratio r), (Big_int bi)) -> eq_big_int_ratio bi r - -| ((Ratio r1), (Ratio r2)) -> eq_ratio r1 r2 - -let ( =/ ) = eq_num - -let ( <>/ ) a b = not(eq_num a b) - -let compare_num a b = match (a,b) with - ((Int int1), (Int int2)) -> compare_int int1 int2 - -| ((Int i), (Big_int bi)) -> compare_big_int (big_int_of_int i) bi -| ((Big_int bi), (Int i)) -> compare_big_int bi (big_int_of_int i) - -| ((Int i), (Ratio r)) -> compare_big_int_ratio (big_int_of_int i) r -| ((Ratio r), (Int i)) -> -(compare_big_int_ratio (big_int_of_int i) r) - -| ((Big_int bi1), (Big_int bi2)) -> compare_big_int bi1 bi2 - -| ((Big_int bi), (Ratio r)) -> compare_big_int_ratio bi r -| ((Ratio r), (Big_int bi)) -> -(compare_big_int_ratio bi r) - -| ((Ratio r1), (Ratio r2)) -> compare_ratio r1 r2 - -let lt_num num1 num2 = compare_num num1 num2 < 0 -and le_num num1 num2 = compare_num num1 num2 <= 0 -and gt_num num1 num2 = compare_num num1 num2 > 0 -and ge_num num1 num2 = compare_num num1 num2 >= 0 - -let ( </ ) = lt_num -and ( <=/ ) = le_num -and ( >/ ) = gt_num -and ( >=/ ) = ge_num - -let max_num num1 num2 = if lt_num num1 num2 then num2 else num1 -and min_num num1 num2 = if gt_num num1 num2 then num2 else num1 - -(* Coercions with basic types *) - -(* Coercion with int type *) -let int_of_num = function - Int i -> i -| Big_int bi -> int_of_big_int bi -| Ratio r -> int_of_ratio r - -and num_of_int i = - if i = monster_int - then Big_int (big_int_of_int i) - else Int i - -(* Coercion with nat type *) -let nat_of_num = function - Int i -> nat_of_int i -| Big_int bi -> nat_of_big_int bi -| Ratio r -> nat_of_ratio r - -and num_of_nat nat = - if (is_nat_int nat 0 (length_nat nat)) - then Int (nth_digit_nat nat 0) - else Big_int (big_int_of_nat nat) - -(* Coercion with big_int type *) -let big_int_of_num = function - Int i -> big_int_of_int i -| Big_int bi -> bi -| Ratio r -> big_int_of_ratio r - -(* Coercion with ratio type *) -let ratio_of_num = function - Int i -> ratio_of_int i -| Big_int bi -> ratio_of_big_int bi -| Ratio r -> r;; - -let string_of_big_int_for_num bi = - if !approx_printing_flag - then approx_big_int !floating_precision bi - else string_of_big_int bi - -(* Coercion with string type *) - -(* XL: suppression de sys_string_of_num *) - -let string_of_normalized_num = function - Int i -> string_of_int i -| Big_int bi -> string_of_big_int_for_num bi -| Ratio r -> string_of_ratio r -let string_of_num n = - string_of_normalized_num (cautious_normalize_num_when_printing n) -let num_of_string s = - try - let flag = !normalize_ratio_flag in - normalize_ratio_flag := true; - let r = ratio_of_string s in - normalize_ratio_flag := flag; - if eq_big_int (denominator_ratio r) unit_big_int - then num_of_big_int (numerator_ratio r) - else Ratio r - with Failure _ -> - failwith "num_of_string" - -(* Coercion with float type *) -let float_of_num = function - Int i -> float i -| Big_int bi -> float_of_big_int bi -| Ratio r -> float_of_ratio r - -(* XL: suppression de num_of_float, float_num *) - -let succ_num = function - Int i -> if i = biggest_int - then Big_int (succ_big_int (big_int_of_int i)) - else Int (succ i) -| Big_int bi -> num_of_big_int (succ_big_int bi) -| Ratio r -> Ratio (add_int_ratio 1 r) - -and pred_num = function - Int i -> if i = monster_int - then Big_int (pred_big_int (big_int_of_int i)) - else Int (pred i) -| Big_int bi -> num_of_big_int (pred_big_int bi) -| Ratio r -> Ratio (add_int_ratio (-1) r) - -let abs_num = function - Int i -> if i = monster_int - then Big_int (minus_big_int (big_int_of_int i)) - else Int (abs i) - | Big_int bi -> Big_int (abs_big_int bi) - | Ratio r -> Ratio (abs_ratio r) - -let approx_num_fix n num = approx_ratio_fix n (ratio_of_num num) -and approx_num_exp n num = approx_ratio_exp n (ratio_of_num num) - -let incr_num r = r := succ_num !r -and decr_num r = r := pred_num !r - - - - - diff --git a/otherlibs/num/num.mli b/otherlibs/num/num.mli deleted file mode 100644 index c69f3b0d4a..0000000000 --- a/otherlibs/num/num.mli +++ /dev/null @@ -1,171 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Operation on arbitrary-precision numbers. - - Numbers (type [num]) are arbitrary-precision rational numbers, - plus the special elements [1/0] (infinity) and [0/0] (undefined). -*) - -open Nat -open Big_int -open Ratio - -(** The type of numbers. *) -type num = - Int of int - | Big_int of big_int - | Ratio of ratio - - -(** {6 Arithmetic operations} *) - - -val ( +/ ) : num -> num -> num -(** Same as {!Num.add_num}.*) - -val add_num : num -> num -> num -(** Addition *) - -val minus_num : num -> num -(** Unary negation. *) - -val ( -/ ) : num -> num -> num -(** Same as {!Num.sub_num}.*) - -val sub_num : num -> num -> num -(** Subtraction *) - -val ( */ ) : num -> num -> num -(** Same as {!Num.mult_num}.*) - -val mult_num : num -> num -> num -(** Multiplication *) - -val square_num : num -> num -(** Squaring *) - -val ( // ) : num -> num -> num -(** Same as {!Num.div_num}.*) - -val div_num : num -> num -> num -(** Division *) - -val quo_num : num -> num -> num -(** Euclidean division: quotient. *) - -val mod_num : num -> num -> num -(** Euclidean division: remainder. *) - -val ( **/ ) : num -> num -> num -(** Same as {!Num.power_num}. *) - -val power_num : num -> num -> num -(** Exponentiation *) - -val abs_num : num -> num -(** Absolute value. *) - -val succ_num : num -> num -(** [succ n] is [n+1] *) - -val pred_num : num -> num -(** [pred n] is [n-1] *) - -val incr_num : num ref -> unit -(** [incr r] is [r:=!r+1], where [r] is a reference to a number. *) - -val decr_num : num ref -> unit -(** [decr r] is [r:=!r-1], where [r] is a reference to a number. *) - -val is_integer_num : num -> bool -(** Test if a number is an integer *) - -(** The four following functions approximate a number by an integer : *) - -val integer_num : num -> num -(** [integer_num n] returns the integer closest to [n]. In case of ties, - rounds towards zero. *) - -val floor_num : num -> num -(** [floor_num n] returns the largest integer smaller or equal to [n]. *) - -val round_num : num -> num -(** [round_num n] returns the integer closest to [n]. In case of ties, - rounds off zero. *) - -val ceiling_num : num -> num -(** [ceiling_num n] returns the smallest integer bigger or equal to [n]. *) - - -val sign_num : num -> int -(** Return [-1], [0] or [1] according to the sign of the argument. *) - -(** {7 Comparisons between numbers} *) - -val ( =/ ) : num -> num -> bool -val ( </ ) : num -> num -> bool -val ( >/ ) : num -> num -> bool -val ( <=/ ) : num -> num -> bool -val ( >=/ ) : num -> num -> bool -val ( <>/ ) : num -> num -> bool -val eq_num : num -> num -> bool -val lt_num : num -> num -> bool -val le_num : num -> num -> bool -val gt_num : num -> num -> bool -val ge_num : num -> num -> bool - -val compare_num : num -> num -> int -(** Return [-1], [0] or [1] if the first argument is less than, - equal to, or greater than the second argument. *) - -val max_num : num -> num -> num -(** Return the greater of the two arguments. *) - -val min_num : num -> num -> num -(** Return the smaller of the two arguments. *) - - -(** {6 Coercions with strings} *) - -val string_of_num : num -> string -(** Convert a number to a string, using fractional notation. *) - -val approx_num_fix : int -> num -> string -(** See {!Num.approx_num_exp}.*) - -val approx_num_exp : int -> num -> string -(** Approximate a number by a decimal. The first argument is the - required precision. The second argument is the number to - approximate. {!Num.approx_num_fix} uses decimal notation; the first - argument is the number of digits after the decimal point. - [approx_num_exp] uses scientific (exponential) notation; the - first argument is the number of digits in the mantissa. *) - -val num_of_string : string -> num -(** Convert a string to a number. *) - -(** {6 Coercions between numerical types} *) - -val int_of_num : num -> int -val num_of_int : int -> num -val nat_of_num : num -> nat -val num_of_nat : nat -> num -val num_of_big_int : big_int -> num -val big_int_of_num : num -> big_int -val ratio_of_num : num -> ratio -val num_of_ratio : ratio -> num -val float_of_num : num -> float - diff --git a/otherlibs/num/ratio.ml b/otherlibs/num/ratio.ml deleted file mode 100644 index 500236420d..0000000000 --- a/otherlibs/num/ratio.ml +++ /dev/null @@ -1,577 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -open Int_misc -open String_misc -open Nat -open Big_int -open Arith_flags - -(* Definition of the type ratio : - Conventions : - - the denominator is always a positive number - - the sign of n/0 is the sign of n -These convention is automatically respected when a ratio is created with -the create_ratio primitive -*) - -type ratio = { mutable numerator : big_int; - mutable denominator : big_int; - mutable normalized : bool} - -let failwith_zero name = - let s = "infinite or undefined rational number" in - failwith (if String.length name = 0 then s else name ^ " " ^ s) - -let numerator_ratio r = r.numerator -and denominator_ratio r = r.denominator - -let null_denominator r = sign_big_int r.denominator = 0 - -let verify_null_denominator r = - if sign_big_int r.denominator = 0 - then (if !error_when_null_denominator_flag - then (failwith_zero "") - else true) - else false - -let sign_ratio r = sign_big_int r.numerator - -(* Physical normalization of rational numbers *) -(* 1/0, 0/0 and -1/0 are the normalized forms for n/0 numbers *) -let normalize_ratio r = - if r.normalized then r - else if verify_null_denominator r then begin - r.numerator <- big_int_of_int (sign_big_int r.numerator); - r.normalized <- true; - r - end else begin - let p = gcd_big_int r.numerator r.denominator in - if eq_big_int p unit_big_int - then begin - r.normalized <- true; r - end else begin - r.numerator <- div_big_int (r.numerator) p; - r.denominator <- div_big_int (r.denominator) p; - r.normalized <- true; r - end - end - -let cautious_normalize_ratio r = - if (!normalize_ratio_flag) then (normalize_ratio r) else r - -let cautious_normalize_ratio_when_printing r = - if (!normalize_ratio_when_printing_flag) then (normalize_ratio r) else r - -let create_ratio bi1 bi2 = - match sign_big_int bi2 with - -1 -> cautious_normalize_ratio - { numerator = minus_big_int bi1; - denominator = minus_big_int bi2; - normalized = false } - | 0 -> if !error_when_null_denominator_flag - then (failwith_zero "create_ratio") - else cautious_normalize_ratio - { numerator = bi1; denominator = bi2; normalized = false } - | _ -> cautious_normalize_ratio - { numerator = bi1; denominator = bi2; normalized = false } - -let create_normalized_ratio bi1 bi2 = - match sign_big_int bi2 with - -1 -> { numerator = minus_big_int bi1; - denominator = minus_big_int bi2; - normalized = true } -| 0 -> if !error_when_null_denominator_flag - then failwith_zero "create_normalized_ratio" - else { numerator = bi1; denominator = bi2; normalized = true } -| _ -> { numerator = bi1; denominator = bi2; normalized = true } - -let is_normalized_ratio r = r.normalized - -let report_sign_ratio r bi = - if sign_ratio r = -1 - then minus_big_int bi - else bi - -let abs_ratio r = - { numerator = abs_big_int r.numerator; - denominator = r.denominator; - normalized = r.normalized } - -let is_integer_ratio r = - eq_big_int ((normalize_ratio r).denominator) unit_big_int - -(* Operations on rational numbers *) - -let add_ratio r1 r2 = - if !normalize_ratio_flag then begin - let p = gcd_big_int ((normalize_ratio r1).denominator) - ((normalize_ratio r2).denominator) in - if eq_big_int p unit_big_int then - {numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator) - (mult_big_int (r2.numerator) r1.denominator); - denominator = mult_big_int (r1.denominator) r2.denominator; - normalized = true} - else begin - let d1 = div_big_int (r1.denominator) p - and d2 = div_big_int (r2.denominator) p in - let n = add_big_int (mult_big_int (r1.numerator) d2) - (mult_big_int d1 r2.numerator) in - let p' = gcd_big_int n p in - { numerator = div_big_int n p'; - denominator = mult_big_int d1 (div_big_int (r2.denominator) p'); - normalized = true } - end - end else - { numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator) - (mult_big_int (r1.denominator) r2.numerator); - denominator = mult_big_int (r1.denominator) r2.denominator; - normalized = false } - -let minus_ratio r = - { numerator = minus_big_int (r.numerator); - denominator = r.denominator; - normalized = r.normalized } - -let add_int_ratio i r = - cautious_normalize_ratio r; - { numerator = add_big_int (mult_int_big_int i r.denominator) r.numerator; - denominator = r.denominator; - normalized = r.normalized } - -let add_big_int_ratio bi r = - cautious_normalize_ratio r; - { numerator = add_big_int (mult_big_int bi r.denominator) r.numerator ; - denominator = r.denominator; - normalized = r.normalized } - -let sub_ratio r1 r2 = add_ratio r1 (minus_ratio r2) - -let mult_ratio r1 r2 = - if !normalize_ratio_flag then begin - let p1 = gcd_big_int ((normalize_ratio r1).numerator) - ((normalize_ratio r2).denominator) - and p2 = gcd_big_int (r2.numerator) r1.denominator in - let (n1, d2) = - if eq_big_int p1 unit_big_int - then (r1.numerator, r2.denominator) - else (div_big_int (r1.numerator) p1, div_big_int (r2.denominator) p1) - and (n2, d1) = - if eq_big_int p2 unit_big_int - then (r2.numerator, r1.denominator) - else (div_big_int r2.numerator p2, div_big_int r1.denominator p2) in - { numerator = mult_big_int n1 n2; - denominator = mult_big_int d1 d2; - normalized = true } - end else - { numerator = mult_big_int (r1.numerator) r2.numerator; - denominator = mult_big_int (r1.denominator) r2.denominator; - normalized = false } - -let mult_int_ratio i r = - if !normalize_ratio_flag then - begin - let p = gcd_big_int ((normalize_ratio r).denominator) (big_int_of_int i) in - if eq_big_int p unit_big_int - then { numerator = mult_big_int (big_int_of_int i) r.numerator; - denominator = r.denominator; - normalized = true } - else { numerator = mult_big_int (div_big_int (big_int_of_int i) p) - r.numerator; - denominator = div_big_int (r.denominator) p; - normalized = true } - end - else - { numerator = mult_int_big_int i r.numerator; - denominator = r.denominator; - normalized = false } - -let mult_big_int_ratio bi r = - if !normalize_ratio_flag then - begin - let p = gcd_big_int ((normalize_ratio r).denominator) bi in - if eq_big_int p unit_big_int - then { numerator = mult_big_int bi r.numerator; - denominator = r.denominator; - normalized = true } - else { numerator = mult_big_int (div_big_int bi p) r.numerator; - denominator = div_big_int (r.denominator) p; - normalized = true } - end - else - { numerator = mult_big_int bi r.numerator; - denominator = r.denominator; - normalized = false } - -let square_ratio r = - cautious_normalize_ratio r; - { numerator = square_big_int r.numerator; - denominator = square_big_int r.denominator; - normalized = r.normalized } - -let inverse_ratio r = - if !error_when_null_denominator_flag && (sign_big_int r.numerator) = 0 - then failwith_zero "inverse_ratio" - else {numerator = report_sign_ratio r r.denominator; - denominator = abs_big_int r.numerator; - normalized = r.normalized} - -let div_ratio r1 r2 = - mult_ratio r1 (inverse_ratio r2) - -(* Integer part of a rational number *) -(* Odd function *) -let integer_ratio r = - if null_denominator r then failwith_zero "integer_ratio" - else if sign_ratio r = 0 then zero_big_int - else report_sign_ratio r (div_big_int (abs_big_int r.numerator) - (abs_big_int r.denominator)) - -(* Floor of a rational number *) -(* Always less or equal to r *) -let floor_ratio r = - verify_null_denominator r; - div_big_int (r.numerator) r.denominator - -(* Round of a rational number *) -(* Odd function, 1/2 -> 1 *) -let round_ratio r = - verify_null_denominator r; - let abs_num = abs_big_int r.numerator in - let bi = div_big_int abs_num r.denominator in - report_sign_ratio r - (if sign_big_int - (sub_big_int - (mult_int_big_int - 2 - (sub_big_int abs_num (mult_big_int (r.denominator) bi))) - r.denominator) = -1 - then bi - else succ_big_int bi) - -let ceiling_ratio r = - if (is_integer_ratio r) - then r.numerator - else succ_big_int (floor_ratio r) - - -(* Comparison operators on rational numbers *) -let eq_ratio r1 r2 = - normalize_ratio r1; - normalize_ratio r2; - eq_big_int (r1.numerator) r2.numerator && - eq_big_int (r1.denominator) r2.denominator - -let compare_ratio r1 r2 = - if verify_null_denominator r1 then - let sign_num_r1 = sign_big_int r1.numerator in - if (verify_null_denominator r2) - then - let sign_num_r2 = sign_big_int r2.numerator in - if sign_num_r1 = 1 && sign_num_r2 = -1 then 1 - else if sign_num_r1 = -1 && sign_num_r2 = 1 then -1 - else 0 - else sign_num_r1 - else if verify_null_denominator r2 then - -(sign_big_int r2.numerator) - else match compare_int (sign_big_int r1.numerator) - (sign_big_int r2.numerator) with - 1 -> 1 - | -1 -> -1 - | _ -> if eq_big_int (r1.denominator) r2.denominator - then compare_big_int (r1.numerator) r2.numerator - else compare_big_int - (mult_big_int (r1.numerator) r2.denominator) - (mult_big_int (r1.denominator) r2.numerator) - - -let lt_ratio r1 r2 = compare_ratio r1 r2 < 0 -and le_ratio r1 r2 = compare_ratio r1 r2 <= 0 -and gt_ratio r1 r2 = compare_ratio r1 r2 > 0 -and ge_ratio r1 r2 = compare_ratio r1 r2 >= 0 - -let max_ratio r1 r2 = if lt_ratio r1 r2 then r2 else r1 -and min_ratio r1 r2 = if gt_ratio r1 r2 then r2 else r1 - -let eq_big_int_ratio bi r = - (is_integer_ratio r) && eq_big_int bi r.numerator - -let compare_big_int_ratio bi r = - normalize_ratio r; - if (verify_null_denominator r) - then -(sign_big_int r.numerator) - else compare_big_int (mult_big_int bi r.denominator) r.numerator - -let lt_big_int_ratio bi r = compare_big_int_ratio bi r < 0 -and le_big_int_ratio bi r = compare_big_int_ratio bi r <= 0 -and gt_big_int_ratio bi r = compare_big_int_ratio bi r > 0 -and ge_big_int_ratio bi r = compare_big_int_ratio bi r >= 0 - -(* Coercions *) - -(* Coercions with type int *) -let int_of_ratio r = - if ((is_integer_ratio r) && (is_int_big_int r.numerator)) - then (int_of_big_int r.numerator) - else failwith "integer argument required" - -and ratio_of_int i = - { numerator = big_int_of_int i; - denominator = unit_big_int; - normalized = true } - -(* Coercions with type nat *) -let ratio_of_nat nat = - { numerator = big_int_of_nat nat; - denominator = unit_big_int; - normalized = true } - -and nat_of_ratio r = - normalize_ratio r; - if not (is_integer_ratio r) then - failwith "nat_of_ratio" - else if sign_big_int r.numerator > -1 then - nat_of_big_int (r.numerator) - else failwith "nat_of_ratio" - -(* Coercions with type big_int *) -let ratio_of_big_int bi = - { numerator = bi; denominator = unit_big_int; normalized = true } - -and big_int_of_ratio r = - normalize_ratio r; - if is_integer_ratio r - then r.numerator - else failwith "big_int_of_ratio" - -let div_int_ratio i r = - verify_null_denominator r; - mult_int_ratio i (inverse_ratio r) - -let div_ratio_int r i = - div_ratio r (ratio_of_int i) - -let div_big_int_ratio bi r = - verify_null_denominator r; - mult_big_int_ratio bi (inverse_ratio r) - -let div_ratio_big_int r bi = - div_ratio r (ratio_of_big_int bi) - -(* Functions on type string *) -(* giving floating point approximations of rational numbers *) - -(* Compares strings that contains only digits, have the same length, - from index i to index i + l *) -let rec compare_num_string s1 s2 i len = - if i >= len then 0 else - let c1 = int_of_char s1.[i] - and c2 = int_of_char s2.[i] in - match compare_int c1 c2 with - | 0 -> compare_num_string s1 s2 (succ i) len - | c -> c;; - -(* Position of the leading digit of the decimal expansion *) -(* of a strictly positive rational number *) -(* if the decimal expansion of a non null rational r is equal to *) -(* sigma for k=-P to N of r_k*10^k then msd_ratio r = N *) -(* Nota : for a big_int we have msd_ratio = nums_digits_big_int -1 *) - -(* Tests if s has only zeros characters from index i to index lim *) -let rec only_zeros s i lim = - i >= lim || s.[i] == '0' && only_zeros s (succ i) lim;; - -(* Nota : for a big_int we have msd_ratio = nums_digits_big_int -1 *) -let msd_ratio r = - cautious_normalize_ratio r; - if null_denominator r then failwith_zero "msd_ratio" - else if sign_big_int r.numerator == 0 then 0 - else begin - let str_num = string_of_big_int r.numerator - and str_den = string_of_big_int r.denominator in - let size_num = String.length str_num - and size_den = String.length str_den in - let size_min = min size_num size_den in - let m = size_num - size_den in - let cmp = compare_num_string str_num str_den 0 size_min in - match cmp with - | 1 -> m - | -1 -> pred m - | _ -> - if m >= 0 then m else - if only_zeros str_den size_min size_den then m - else pred m - end -;; - -(* Decimal approximations of rational numbers *) - -(* Approximation with fix decimal point *) -(* This is an odd function and the last digit is round off *) -(* Format integer_part . decimal_part_with_n_digits *) -let approx_ratio_fix n r = - (* Don't need to normalize *) - if (null_denominator r) then failwith_zero "approx_ratio_fix" - else - let sign_r = sign_ratio r in - if sign_r = 0 - then "+0" (* r = 0 *) - else (* r.numerator and r.denominator are not null numbers - s contains one more digit than desired for the round off operation - and to have enough room in s when including the decimal point *) - if n >= 0 then - let s = - let nat = - (nat_of_big_int - (div_big_int - (base_power_big_int - 10 (succ n) (abs_big_int r.numerator)) - r.denominator)) - in (if sign_r = -1 then "-" else "+") ^ string_of_nat nat in - let l = String.length s in - if round_futur_last_digit s 1 (pred l) - then begin (* if one more char is needed in s *) - let str = (String.make (succ l) '0') in - String.set str 0 (if sign_r = -1 then '-' else '+'); - String.set str 1 '1'; - String.set str (l - n) '.'; - str - end else (* s can contain the final result *) - if l > n + 2 - then begin (* |r| >= 1, set decimal point *) - let l2 = (pred l) - n in - String.blit s l2 s (succ l2) n; - String.set s l2 '.'; s - end else begin (* |r| < 1, there must be 0-characters *) - (* before the significant development, *) - (* with care to the sign of the number *) - let size = n + 3 in - let m = size - l + 2 - and str = String.make size '0' in - - (String.blit (if sign_r = 1 then "+0." else "-0.") 0 str 0 3); - (String.blit s 1 str m (l - 2)); - str - end - else begin - let s = string_of_big_int - (div_big_int - (abs_big_int r.numerator) - (base_power_big_int - 10 (-n) r.denominator)) in - let len = succ (String.length s) in - let s' = String.make len '0' in - String.set s' 0 (if sign_r = -1 then '-' else '+'); - String.blit s 0 s' 1 (pred len); - s' - end - -(* Number of digits of the decimal representation of an int *) -let num_decimal_digits_int n = - String.length (string_of_int n) - -(* Approximation with floating decimal point *) -(* This is an odd function and the last digit is round off *) -(* Format (+/-)(0. n_first_digits e msd)/(1. n_zeros e (msd+1) *) -let approx_ratio_exp n r = - (* Don't need to normalize *) - if (null_denominator r) then failwith_zero "approx_ratio_exp" - else if n <= 0 then invalid_arg "approx_ratio_exp" - else - let sign_r = sign_ratio r - and i = ref (n + 3) in - if sign_r = 0 - then - let s = String.make (n + 5) '0' in - (String.blit "+0." 0 s 0 3); - (String.blit "e0" 0 s !i 2); s - else - let msd = msd_ratio (abs_ratio r) in - let k = n - msd in - let s = - (let nat = nat_of_big_int - (if k < 0 - then - div_big_int (abs_big_int r.numerator) - (base_power_big_int 10 (- k) - r.denominator) - else - div_big_int (base_power_big_int - 10 k (abs_big_int r.numerator)) - r.denominator) in - string_of_nat nat) in - if (round_futur_last_digit s 0 (String.length s)) - then - let m = num_decimal_digits_int (succ msd) in - let str = String.make (n + m + 4) '0' in - (String.blit (if sign_r = -1 then "-1." else "+1.") 0 str 0 3); - String.set str !i ('e'); - incr i; - (if m = 0 - then String.set str !i '0' - else String.blit (string_of_int (succ msd)) 0 str !i m); - str - else - let m = num_decimal_digits_int (succ msd) - and p = n + 3 in - let str = String.make (succ (m + p)) '0' in - (String.blit (if sign_r = -1 then "-0." else "+0.") 0 str 0 3); - (String.blit s 0 str 3 n); - String.set str p 'e'; - (if m = 0 - then String.set str (succ p) '0' - else (String.blit (string_of_int (succ msd)) 0 str (succ p) m)); - str - -(* String approximation of a rational with a fixed number of significant *) -(* digits printed *) -let float_of_rational_string r = - let s = approx_ratio_exp !floating_precision r in - if String.get s 0 = '+' - then (String.sub s 1 (pred (String.length s))) - else s - -(* Coercions with type string *) -let string_of_ratio r = - cautious_normalize_ratio_when_printing r; - if !approx_printing_flag - then float_of_rational_string r - else string_of_big_int r.numerator ^ "/" ^ string_of_big_int r.denominator - -(* XL: j'ai puissamment simplifie "ratio_of_string" en virant la notation - scientifique. *) - -let ratio_of_string s = - let n = index_char s '/' 0 in - if n = -1 then - { numerator = big_int_of_string s; - denominator = unit_big_int; - normalized = true } - else - create_ratio (sys_big_int_of_string s 0 n) - (sys_big_int_of_string s (n+1) (String.length s - n - 1)) - -(* Coercion with type float *) - -let float_of_ratio r = - float_of_string (float_of_rational_string r) - -(* XL: suppression de ratio_of_float *) - -let power_ratio_positive_int r n = - create_ratio (power_big_int_positive_int (r.numerator) n) - (power_big_int_positive_int (r.denominator) n) - -let power_ratio_positive_big_int r bi = - create_ratio (power_big_int_positive_big_int (r.numerator) bi) - (power_big_int_positive_big_int (r.denominator) bi) diff --git a/otherlibs/num/ratio.mli b/otherlibs/num/ratio.mli deleted file mode 100644 index 64fc6b9cdc..0000000000 --- a/otherlibs/num/ratio.mli +++ /dev/null @@ -1,88 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Module [Ratio]: operations on rational numbers *) - -open Nat -open Big_int - -(* Rationals (type [ratio]) are arbitrary-precision rational numbers, - plus the special elements [1/0] (infinity) and [0/0] (undefined). - In constrast with numbers (type [num]), the special cases of - small integers and big integers are not optimized specially. *) - -type ratio - -val null_denominator : ratio -> bool -val numerator_ratio : ratio -> big_int -val denominator_ratio : ratio -> big_int -val sign_ratio : ratio -> int -val normalize_ratio : ratio -> ratio -val cautious_normalize_ratio : ratio -> ratio -val cautious_normalize_ratio_when_printing : ratio -> ratio -val create_ratio : big_int -> big_int -> ratio -val create_normalized_ratio : big_int -> big_int -> ratio -val is_normalized_ratio : ratio -> bool -val report_sign_ratio : ratio -> big_int -> big_int -val abs_ratio : ratio -> ratio -val is_integer_ratio : ratio -> bool -val add_ratio : ratio -> ratio -> ratio -val minus_ratio : ratio -> ratio -val add_int_ratio : int -> ratio -> ratio -val add_big_int_ratio : big_int -> ratio -> ratio -val sub_ratio : ratio -> ratio -> ratio -val mult_ratio : ratio -> ratio -> ratio -val mult_int_ratio : int -> ratio -> ratio -val mult_big_int_ratio : big_int -> ratio -> ratio -val square_ratio : ratio -> ratio -val inverse_ratio : ratio -> ratio -val div_ratio : ratio -> ratio -> ratio -val integer_ratio : ratio -> big_int -val floor_ratio : ratio -> big_int -val round_ratio : ratio -> big_int -val ceiling_ratio : ratio -> big_int -val eq_ratio : ratio -> ratio -> bool -val compare_ratio : ratio -> ratio -> int -val lt_ratio : ratio -> ratio -> bool -val le_ratio : ratio -> ratio -> bool -val gt_ratio : ratio -> ratio -> bool -val ge_ratio : ratio -> ratio -> bool -val max_ratio : ratio -> ratio -> ratio -val min_ratio : ratio -> ratio -> ratio -val eq_big_int_ratio : big_int -> ratio -> bool -val compare_big_int_ratio : big_int -> ratio -> int -val lt_big_int_ratio : big_int -> ratio -> bool -val le_big_int_ratio : big_int -> ratio -> bool -val gt_big_int_ratio : big_int -> ratio -> bool -val ge_big_int_ratio : big_int -> ratio -> bool -val int_of_ratio : ratio -> int -val ratio_of_int : int -> ratio -val ratio_of_nat : nat -> ratio -val nat_of_ratio : ratio -> nat -val ratio_of_big_int : big_int -> ratio -val big_int_of_ratio : ratio -> big_int -val div_int_ratio : int -> ratio -> ratio -val div_ratio_int : ratio -> int -> ratio -val div_big_int_ratio : big_int -> ratio -> ratio -val div_ratio_big_int : ratio -> big_int -> ratio -val approx_ratio_fix : int -> ratio -> string -val approx_ratio_exp : int -> ratio -> string -val float_of_rational_string : ratio -> string -val string_of_ratio : ratio -> string -val ratio_of_string : string -> ratio -val float_of_ratio : ratio -> float -val power_ratio_positive_int : ratio -> int -> ratio -val power_ratio_positive_big_int : ratio -> big_int -> ratio - diff --git a/otherlibs/num/string_misc.ml b/otherlibs/num/string_misc.ml deleted file mode 100644 index b6e33b9b71..0000000000 --- a/otherlibs/num/string_misc.ml +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -let rec index_char str chr pos = - if pos >= String.length str then -1 - else if String.get str pos = chr then pos - else index_char str chr (pos + 1) -;; diff --git a/otherlibs/num/string_misc.mli b/otherlibs/num/string_misc.mli deleted file mode 100644 index ef89c91b82..0000000000 --- a/otherlibs/num/string_misc.mli +++ /dev/null @@ -1,16 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Valerie Menissier-Morain, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -val index_char: string -> char -> int -> int diff --git a/otherlibs/num/test/.depend b/otherlibs/num/test/.depend deleted file mode 100644 index 28fea1f58e..0000000000 --- a/otherlibs/num/test/.depend +++ /dev/null @@ -1,10 +0,0 @@ -end_test.cmo: test.cmo -end_test.cmx: test.cmx -test_big_ints.cmo: test.cmo -test_big_ints.cmx: test.cmx -test_nats.cmo: test.cmo -test_nats.cmx: test.cmx -test_nums.cmo: test.cmo -test_nums.cmx: test.cmx -test_ratios.cmo: test.cmo -test_ratios.cmx: test.cmx diff --git a/otherlibs/num/test/Makefile b/otherlibs/num/test/Makefile deleted file mode 100644 index ce56b35d7e..0000000000 --- a/otherlibs/num/test/Makefile +++ /dev/null @@ -1,61 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../../LICENSE.# -# # -######################################################################### - -# $Id$ - -include ../../../config/Makefile - -CAMLC=../../../boot/ocamlrun ../../../ocamlc -I ../../../stdlib -CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I ../../../stdlib -CC=$(BYTECC) -CFLAGS=-I.. $(BYTECCCOMPOPTS) - -test: test.byt test.opt - if $(SUPPORTS_SHARED_LIBRARIES); then ../../../byterun/ocamlrun -I .. ./test.byt; else ./test.byt; fi - ./test.opt - -TESTFILES=test.cmo \ - test_nats.cmo test_big_ints.cmo test_ratios.cmo test_nums.cmo \ - test_io.cmo end_test.cmo - -TESTOPTFILES=$(TESTFILES:.cmo=.cmx) - -test.byt: $(TESTFILES) ../nums.cma ../libnums.a - $(CAMLC) -ccopt -L.. -o test.byt ../nums.cma $(TESTFILES) - -test.opt: $(TESTOPTFILES) ../nums.cmxa ../libnums.a - $(CAMLOPT) -ccopt -L.. -o test.opt ../nums.cmxa $(TESTOPTFILES) - -test_bng: test_bng.o - $(CC) $(CFLAGS) -o test_bng ../bng.o test_bng.o -lbignum - -$(TESTOPTFILES): ../../../ocamlopt - -.SUFFIXES: .ml .cmo .cmx - -.ml.cmo: - $(CAMLC) -I .. -c $< - -.ml.cmx: - $(CAMLOPT) -I .. -c $< - -ocamlnum: - ocamlmktop -o ocamlnum -custom ../nums.cma ../libnums.a - -clean: - rm -f test.byt test.opt test_bng *.o *.cm? ocamlnum - -depend: - ocamldep *.ml > .depend - -include .depend diff --git a/otherlibs/num/test/Makefile.Mac b/otherlibs/num/test/Makefile.Mac deleted file mode 100644 index 3e01c72205..0000000000 --- a/otherlibs/num/test/Makefile.Mac +++ /dev/null @@ -1,40 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../../LICENSE.# -# # -######################################################################### - -# $Id$ - -CAMLC = ::::boot:ocamlrun ::::ocamlc -I ::::stdlib: -CAMLOPT = ::::boot:ocamlrun ::::ocamlopt -I ::::stdlib: - -test Ä test.byt - :test.byt - -TESTFILES = test.cmo test_nats.cmo test_big_ints.cmo ¶ - test_ratios.cmo test_nums.cmo test_io.cmo end_test.cmo - -test.byt Ä {TESTFILES} ::nums.cma ::libnums.o - alias ocamlc "{CAMLC}" - ::::tools:ocamlc-custom -o test.byt ::nums.cma {TESTFILES} ::libnums.[ox] - -.cmo Ä .ml - {CAMLC} -I :: -c {default}.ml - -ocamlnum Ä - ocamlmktop -o ocamlnum -custom ::nums.cma ::libnums.[ox] - -clean Ä - delete -i test.byt ocamlnum - delete -i Å.cm[io] || set status 0 - -depend Ä - ocamldep Å.ml > Makefile.Mac.depend diff --git a/otherlibs/num/test/Makefile.Mac.depend b/otherlibs/num/test/Makefile.Mac.depend deleted file mode 100644 index bda141c07a..0000000000 --- a/otherlibs/num/test/Makefile.Mac.depend +++ /dev/null @@ -1,10 +0,0 @@ -end_test.cmoÄ test.cmo -end_test.cmxÄ test.cmx -test_big_ints.cmoÄ test.cmo -test_big_ints.cmxÄ test.cmx -test_nats.cmoÄ test.cmo -test_nats.cmxÄ test.cmx -test_nums.cmoÄ test.cmo -test_nums.cmxÄ test.cmx -test_ratios.cmoÄ test.cmo -test_ratios.cmxÄ test.cmx diff --git a/otherlibs/num/test/Makefile.nt b/otherlibs/num/test/Makefile.nt deleted file mode 100644 index 0d342145e7..0000000000 --- a/otherlibs/num/test/Makefile.nt +++ /dev/null @@ -1,59 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../../LICENSE.# -# # -######################################################################### - -# $Id$ - -CAMLC=../../../boot/ocamlrun ../../../ocamlc -I ../../../stdlib -I .. -CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I ../../../stdlib -I .. -CC=$(BYTECC) -CFLAGS=-I.. $(BYTECCCOMPOPTS) - -test: test.byt test.opt - ../../../byterun/ocamlrun -I .. ./test.byt - ./test.opt - -TESTFILES=test.cmo \ - test_nats.cmo test_big_ints.cmo test_ratios.cmo test_nums.cmo \ - test_io.cmo end_test.cmo - -TESTOPTFILES=$(TESTFILES:.cmo=.cmx) - -test.byt: $(TESTFILES) ../nums.cma ../libnums.lib - $(CAMLC) -o test.byt nums.cma $(TESTFILES) - -test.opt: $(TESTOPTFILES) ../nums.cmxa ../libnums.lib - $(CAMLOPT) -o test.opt nums.cmxa $(TESTOPTFILES) - -test_bng.exe: test_bng.o - $(CC) $(CFLAGS) -o test_bng.exe ../bng.o test_bng.o -lbignum - -$(TESTOPTFILES): ../../../ocamlopt - -.SUFFIXES: .ml .cmo .cmx - -.ml.cmo: - $(CAMLC) -c $< - -.ml.cmx: - $(CAMLOPT) -c $< - -ocamltopnum.exe: - ocamlmktop -o ocamltopnum.exe -custom ../nums.cma ../libnums.$(A) - -clean: - rm -f test.byt test.opt test_bng.exe *.$(O) *.cm? ocamltopnum.exe - -depend: - ocamldep *.ml > .depend - -include .depend diff --git a/otherlibs/num/test/end_test.ml b/otherlibs/num/test/end_test.ml deleted file mode 100644 index 57e099eda5..0000000000 --- a/otherlibs/num/test/end_test.ml +++ /dev/null @@ -1 +0,0 @@ -Test.end_tests ();; diff --git a/otherlibs/num/test/test.ml b/otherlibs/num/test/test.ml deleted file mode 100644 index 8426e0ae82..0000000000 --- a/otherlibs/num/test/test.ml +++ /dev/null @@ -1,77 +0,0 @@ -open Printf;; - -let flush_all () = flush stdout; flush stderr;; - -let message s = print_string s; print_newline ();; - -let error_occurred = ref false;; -let immediate_failure = ref true;; - -let error () = - if !immediate_failure then exit 2 else begin - error_occurred := true; flush_all (); false - end;; - -let success () = flush_all (); true;; - -let function_tested = ref "";; - -let testing_function s = - flush_all (); - function_tested := s; - print_newline(); - message s;; - -let test test_number eq_fun (answer, correct_answer) = - flush_all (); - if not (eq_fun answer correct_answer) then begin - fprintf stderr ">>> Bad result (%s, test %d)\n" !function_tested test_number; - error () - end else begin - printf " %d..." test_number; - success () - end;; - -let failure_test test_number fun_to_test arg = - flush_all (); - try - fun_to_test arg; - fprintf stderr ">>> Failure expected (%s, test %d)\n" - !function_tested test_number; - error () - with _ -> - printf " %d..." test_number; - success ();; - -let failwith_test test_number fun_to_test arg correct_failure = - flush_all (); - try - fun_to_test arg; - fprintf stderr ">>> Failure expected (%s, test %d)\n" - !function_tested test_number; - error () - with x -> - if x = correct_failure then begin - printf " %d..." test_number; - success () - end else begin - fprintf stderr ">>> Bad failure (%s, test %d)\n" - !function_tested test_number; - error () - end;; - -let end_tests () = - flush_all (); - print_newline (); - if !error_occurred then begin - prerr_endline "************* TESTS FAILED ****************"; exit 2 - end else begin - prerr_endline "************* TESTS COMPLETED SUCCESSFULLY ****************"; - exit 0 - end;; - -let eq = (==);; -let eq_int = (==);; -let eq_string = (=);; - -let sixtyfour = (1 lsl 31) <> 0;; diff --git a/otherlibs/num/test/test_big_ints.ml b/otherlibs/num/test/test_big_ints.ml deleted file mode 100644 index 61e9ae4df0..0000000000 --- a/otherlibs/num/test/test_big_ints.ml +++ /dev/null @@ -1,468 +0,0 @@ -open Test;; -open Nat;; -open Big_int;; -open Int_misc;; -open List;; - -testing_function "compare_big_int";; - -test 1 -eq_int (compare_big_int zero_big_int zero_big_int, 0);; -test 2 -eq_int (compare_big_int zero_big_int (big_int_of_int 1), (-1));; -test 3 -eq_int (compare_big_int zero_big_int (big_int_of_int (-1)), 1);; -test 4 -eq_int (compare_big_int (big_int_of_int 1) zero_big_int, 1);; -test 5 -eq_int (compare_big_int (big_int_of_int (-1)) zero_big_int, (-1));; -test 6 -eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int 1), 0);; -test 7 -eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), 0);; -test 8 -eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int (-1)), 1);; -test 9 -eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int 1), (-1));; -test 10 -eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int 2), (-1));; -test 11 -eq_int (compare_big_int (big_int_of_int 2) (big_int_of_int 1), 1);; -test 12 -eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), 1);; -test 13 -eq_int (compare_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), (-1));; - - -testing_function "pred_big_int";; - -test 1 -eq_big_int (pred_big_int zero_big_int, big_int_of_int (-1));; -test 2 -eq_big_int (pred_big_int unit_big_int, zero_big_int);; -test 3 -eq_big_int (pred_big_int (big_int_of_int (-1)), big_int_of_int (-2));; - -testing_function "succ_big_int";; - -test 1 -eq_big_int (succ_big_int zero_big_int, unit_big_int);; -test 2 -eq_big_int (succ_big_int unit_big_int, big_int_of_int 2);; -test 3 -eq_big_int (succ_big_int (big_int_of_int (-1)), zero_big_int);; - -testing_function "add_big_int";; - -test 1 -eq_big_int (add_big_int zero_big_int zero_big_int, zero_big_int);; -test 2 -eq_big_int (add_big_int zero_big_int (big_int_of_int 1), - big_int_of_int 1);; -test 3 -eq_big_int (add_big_int (big_int_of_int 1) zero_big_int, - big_int_of_int 1);; -test 4 -eq_big_int (add_big_int zero_big_int (big_int_of_int (-1)), - big_int_of_int (-1));; -test 5 -eq_big_int (add_big_int (big_int_of_int (-1)) zero_big_int, - big_int_of_int (-1));; -test 6 -eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 1), - big_int_of_int 2);; -test 7 -eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 2), - big_int_of_int 3);; -test 8 -eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int 1), - big_int_of_int 3);; -test 9 -eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), - big_int_of_int (-2));; -test 10 -eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), - big_int_of_int (-3));; -test 11 -eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), - big_int_of_int (-3));; -test 12 -eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-1)), - zero_big_int);; -test 13 -eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 1), - zero_big_int);; -test 14 -eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-2)), - big_int_of_int (-1));; -test 15 -eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int 1), - big_int_of_int (-1));; -test 16 -eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 2), - big_int_of_int 1);; -test 17 -eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int (-1)), - big_int_of_int 1);; - - -testing_function "sub_big_int";; - -test 1 -eq_big_int (sub_big_int zero_big_int zero_big_int, zero_big_int);; -test 2 -eq_big_int (sub_big_int zero_big_int (big_int_of_int 1), - big_int_of_int (-1));; -test 3 -eq_big_int (sub_big_int (big_int_of_int 1) zero_big_int, - big_int_of_int 1);; -test 4 -eq_big_int (sub_big_int zero_big_int (big_int_of_int (-1)), - big_int_of_int 1);; -test 5 -eq_big_int (sub_big_int (big_int_of_int (-1)) zero_big_int, - big_int_of_int (-1));; -test 6 -eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 1), - zero_big_int);; -test 7 -eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 2), - big_int_of_int (-1));; -test 8 -eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int 1), - big_int_of_int 1);; -test 9 -eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), - zero_big_int);; -test 10 -eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), - big_int_of_int 1);; -test 11 -eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), - big_int_of_int (-1));; -test 12 -eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-1)), - big_int_of_int 2);; -test 13 -eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 1), - big_int_of_int (-2));; -test 14 -eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-2)), - big_int_of_int 3);; -test 15 -eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int 1), - big_int_of_int (-3));; -test 16 -eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 2), - big_int_of_int (-3));; -test 17 -eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int (-1)), - big_int_of_int 3);; - -testing_function "mult_int_big_int";; - -test 1 -eq_big_int (mult_int_big_int 0 (big_int_of_int 3), zero_big_int);; -test 2 -eq_big_int (mult_int_big_int 1 (big_int_of_int 3), big_int_of_int 3);; -test 3 -eq_big_int (mult_int_big_int 1 zero_big_int, zero_big_int);; -test 4 -eq_big_int (mult_int_big_int 2 (big_int_of_int 3), big_int_of_int 6);; - -testing_function "mult_big_int";; - -test 1 -eq_big_int (mult_big_int zero_big_int zero_big_int, - zero_big_int);; -test 2 -eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int 3), - big_int_of_int 6);; -test 3 -eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int (-3)), - big_int_of_int (-6));; -test 4 -eq_big_int (mult_big_int (big_int_of_string "12724951") - (big_int_of_string "81749606400"), - big_int_of_string "1040259735709286400");; -test 5 -eq_big_int (mult_big_int (big_int_of_string "26542080") - (big_int_of_string "81749606400"), - big_int_of_string "2169804593037312000");; - -testing_function "quomod_big_int";; - -let (quotient, modulo) = - quomod_big_int (big_int_of_int 1) (big_int_of_int 1) in - test 1 eq_big_int (quotient, big_int_of_int 1) && - test 2 eq_big_int (modulo, zero_big_int);; - -let (quotient, modulo) = - quomod_big_int (big_int_of_int 1) (big_int_of_int (-1)) in - test 3 eq_big_int (quotient, big_int_of_int (-1)) && - test 4 eq_big_int (modulo, zero_big_int);; - -let (quotient, modulo) = - quomod_big_int (big_int_of_int (-1)) (big_int_of_int 1) in - test 5 eq_big_int (quotient, big_int_of_int (-1)) && - test 6 eq_big_int (modulo, zero_big_int);; - -let (quotient, modulo) = - quomod_big_int (big_int_of_int 3) (big_int_of_int 2) in - test 7 eq_big_int (quotient, big_int_of_int 1) && - test 8 eq_big_int (modulo, big_int_of_int 1);; - -let (quotient, modulo) = - quomod_big_int (big_int_of_int 5) (big_int_of_int 3) in - test 9 eq_big_int (quotient, big_int_of_int 1) && - test 10 eq_big_int (modulo, big_int_of_int 2);; - -let (quotient, modulo) = - quomod_big_int (big_int_of_int (-5)) (big_int_of_int 3) in - test 11 eq_big_int (quotient, big_int_of_int (-2)) && - test 12 eq_big_int (modulo, big_int_of_int 1);; - -let (quotient, modulo) = - quomod_big_int (big_int_of_int 1) (big_int_of_int 2) in - test 13 eq_big_int (quotient, zero_big_int) && - test 14 eq_big_int (modulo, big_int_of_int 1);; - -let (quotient, modulo) = - quomod_big_int (big_int_of_int (-1)) (big_int_of_int 3) in - test 15 eq_big_int (quotient, minus_big_int unit_big_int) && - test 16 eq_big_int (modulo, big_int_of_int 2);; - -failwith_test 17 -(quomod_big_int (big_int_of_int 1)) zero_big_int -Division_by_zero -;; - -testing_function "gcd_big_int";; - -test 1 -eq_big_int (gcd_big_int zero_big_int zero_big_int, - zero_big_int);; -test 2 -eq_big_int (gcd_big_int zero_big_int (big_int_of_int 1), - big_int_of_int 1);; -test 3 -eq_big_int (gcd_big_int (big_int_of_int 1) zero_big_int, - big_int_of_int 1);; -test 4 -eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 2), - big_int_of_int 1);; -test 5 -eq_big_int (gcd_big_int (big_int_of_int 2) (big_int_of_int 1), - big_int_of_int 1);; -test 6 -eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 1), - big_int_of_int 1);; -test 7 -eq_big_int (gcd_big_int (big_int_of_int 9) (big_int_of_int 16), - big_int_of_int 1);; -test 8 -eq_big_int (gcd_big_int (big_int_of_int 12) (big_int_of_int 16), - big_int_of_int 4);; - -for i = 9 to 28 do - let n1 = Random.int 1000000000 - and n2 = Random.int 100000 in - let _ = - test i eq - (int_of_big_int (gcd_big_int (big_int_of_int n1) (big_int_of_int n2)), - gcd_int n1 n2) in - () -done;; - -testing_function "int_of_big_int";; - -test 1 -eq_int (int_of_big_int (big_int_of_int 1), 1);; - - -testing_function "is_int_big_int";; - -test 1 -eq (is_int_big_int (big_int_of_int 1), true);; -test 2 -eq (is_int_big_int (big_int_of_int (-1)), true);; -test 3 -eq (is_int_big_int (succ_big_int (big_int_of_int biggest_int)), false);; -test 4 -eq (int_of_big_int (big_int_of_int monster_int), monster_int);; -(* Should be true *) -test 5 -eq (is_int_big_int (big_int_of_string (string_of_int biggest_int)), true);; -test 6 -eq (is_int_big_int (big_int_of_string (string_of_int least_int)), true);; -test 7 -eq (is_int_big_int (big_int_of_string (string_of_int monster_int)), true);; - -(* Should be false *) -(* Successor of biggest_int is not an int *) -test 8 -eq (is_int_big_int (succ_big_int (big_int_of_int (biggest_int))), false);; -test 9 -eq (is_int_big_int - (succ_big_int (succ_big_int (big_int_of_int (biggest_int)))), false);; -(* Negation of monster_int (as a big_int) is not an int *) -test 10 -eq (is_int_big_int - (minus_big_int (big_int_of_string (string_of_int monster_int))), false);; - - -testing_function "sys_string_of_big_int";; - -test 1 -eq_string (string_of_big_int (big_int_of_int 1), "1");; - - -testing_function "big_int_of_string";; - -test 1 -eq_big_int (big_int_of_string "1", big_int_of_int 1);; -test 2 -eq_big_int (big_int_of_string "-1", big_int_of_int (-1));; -test 4 -eq_big_int (big_int_of_string "0", zero_big_int);; - -failwith_test 5 big_int_of_string "sdjdkfighdgf" - (Failure "invalid digit");; - -test 6 -eq_big_int (big_int_of_string "123", big_int_of_int 123);; -test 7 -eq_big_int (big_int_of_string "3456", big_int_of_int 3456);; - -test 9 -eq_big_int (big_int_of_string "-3456", big_int_of_int (-3456));; - - -let implode = List.fold_left (^) "";; (* Au diable l'efficacite *) - -let l = rev [ -"174679877494298468451661416292903906557638850173895426081611831060970135303"; -"044177587617233125776581034213405720474892937404345377707655788096850784519"; -"539374048533324740018513057210881137248587265169064879918339714405948322501"; -"445922724181830422326068913963858377101914542266807281471620827145038901025"; -"322784396182858865537924078131032036927586614781817695777639491934361211399"; -"888524140253852859555118862284235219972858420374290985423899099648066366558"; -"238523612660414395240146528009203942793935957539186742012316630755300111472"; -"852707974927265572257203394961525316215198438466177260614187266288417996647"; -"132974072337956513457924431633191471716899014677585762010115338540738783163"; -"739223806648361958204720897858193606022290696766988489073354139289154127309"; -"916985231051926209439373780384293513938376175026016587144157313996556653811"; -"793187841050456120649717382553450099049321059330947779485538381272648295449"; -"847188233356805715432460040567660999184007627415398722991790542115164516290"; -"619821378529926683447345857832940144982437162642295073360087284113248737998"; -"046564369129742074737760485635495880623324782103052289938185453627547195245"; -"688272436219215066430533447287305048225780425168823659431607654712261368560"; -"702129351210471250717394128044019490336608558608922841794819375031757643448"; -"32" -] in - -let bi1 = big_int_of_string (implode (rev l)) in - -let bi2 = big_int_of_string (implode (rev ("3" :: tl l))) in - -test 10 -eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "10")) - (big_int_of_string "2"))) -(* test 11 - && -eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "10e0")) - (big_int_of_string "20e-1"))) && -test 12 -eq_big_int (minus_big_int bi1, - (add_big_int (mult_big_int bi2 (big_int_of_string "-10e0")) - (big_int_of_string "-20e-1"))) && -test 13 -eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "+10e0")) - (big_int_of_string "+20e-1"))) && -test 14 -eq_big_int (minus_big_int bi1, - (add_big_int (mult_big_int bi2 (big_int_of_string "-10e+0")) - (big_int_of_string "-20e-1"))) && -test 15 -eq_big_int (minus_big_int bi1, - (add_big_int (mult_big_int bi2 (big_int_of_string "-1e+1")) - (big_int_of_string "-2e-0"))) && -test 16 -eq_big_int (minus_big_int bi1, - (add_big_int (mult_big_int bi2 (big_int_of_string "-0.1e+2")) - (big_int_of_string "-2.0e-0"))) && -test 17 -eq_big_int (minus_big_int bi1, - (add_big_int (mult_big_int bi2 (big_int_of_string "-1.000e+1")) - (big_int_of_string "-0.02e2")))*) -;; - -testing_function "power_base_int";; - -test 1 -eq_big_int (big_int_of_nat (power_base_int 10 0), unit_big_int) -;; -test 2 -eq_big_int (big_int_of_nat (power_base_int 10 8), big_int_of_int 100000000) -;; -test 3 -eq_big_int (big_int_of_nat (power_base_int 2 (length_of_int + 2)), - big_int_of_nat (let nat = make_nat 2 in - set_digit_nat nat 1 1; - nat)) -;; - -testing_function "base_power_big_int";; - -test 1 -eq_big_int (base_power_big_int 10 0 (big_int_of_int 2), big_int_of_int 2);; -test 2 -eq_big_int (base_power_big_int 10 2 (big_int_of_int 2), big_int_of_int 200);; -test 3 -eq_big_int (base_power_big_int 10 1 (big_int_of_int 123), big_int_of_int 1230) -;; - -testing_function "power_int_positive_big_int";; - -test 1 -eq_big_int (power_int_positive_big_int 2 (big_int_of_int 10), - big_int_of_int 1024);; -test 2 -eq_big_int - (power_int_positive_big_int 2 (big_int_of_int 65), - big_int_of_string "36893488147419103232");; - -test 3 -eq_big_int - (power_int_positive_big_int 3 (big_int_of_string "47"), - big_int_of_string "26588814358957503287787");; - - -testing_function "power_big_int_positive_big_int";; - -test 1 -eq_big_int - (power_big_int_positive_big_int (big_int_of_int 2) (big_int_of_int 10), - big_int_of_int 1024);; - -test 2 -eq_big_int - (power_big_int_positive_big_int (big_int_of_int 2) (big_int_of_int 65), - big_int_of_string "36893488147419103232");; - -test 3 -eq_big_int - (power_big_int_positive_big_int - (big_int_of_string "3") (big_int_of_string "47"), - big_int_of_string "26588814358957503287787");; - -testing_function "square_big_int";; - -test 1 eq_big_int - (square_big_int (big_int_of_string "0"), big_int_of_string "0");; -test 2 eq_big_int - (square_big_int (big_int_of_string "1"), big_int_of_string "1");; -test 3 eq_big_int - (square_big_int (big_int_of_string "-1"), big_int_of_string "1");; -test 4 eq_big_int - (square_big_int (big_int_of_string "-7"), big_int_of_string "49");; diff --git a/otherlibs/num/test/test_bng.c b/otherlibs/num/test/test_bng.c deleted file mode 100644 index 4fedcdfd56..0000000000 --- a/otherlibs/num/test/test_bng.c +++ /dev/null @@ -1,408 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Test harness for the BNG primitives. Use BigNum as a reference. */ - -#include <stdio.h> -#include <stdlib.h> -#include <string.h> - -#include <BigNum.h> - -#include "../../../config/m.h" -#include "bng.h" - -#if defined(__GNUC__) && BNG_ASM_LEVEL > 0 -#if defined(BNG_ARCH_ia32) -#include "bng_ia32.c" -#elif defined(BNG_ARCH_amd64) -#include "bng_amd64.c" -#elif defined(BNG_ARCH_ppc) -#include "bng_ppc.c" -#elif defined (BNG_ARCH_alpha) -#include "bng_alpha.c" -#elif defined (BNG_ARCH_sparc) -#include "bng_sparc.c" -#elif defined (BNG_ARCH_mips) -#include "bng_mips.c" -#endif -#endif - -#include "bng_digit.c" - -/* Random generator for digits. Can either generate "true" PRN numbers - or numbers consisting of long sequences of 0 and 1 bits. */ - -static int rand_skewed = 0; -static int rand_runlength = 0; -static int rand_bit = 0; -static bngdigit rand_seed = 0; - -static bngdigit randdigit(void) -{ - bngdigit res; - int i; - - if (rand_skewed) { - for (i = 0, res = 0; i < BNG_BITS_PER_DIGIT; i++) { - if (rand_runlength == 0) { - rand_runlength = 1 + (rand() % (2 * BNG_BITS_PER_DIGIT)); - rand_bit ^= 1; - } - res = (res << 1) | rand_bit; - rand_runlength--; - } - return res; - } else { - rand_seed = rand_seed * 69069 + 25173; - return rand_seed; - } -} - -/* Test the operations on digits. - This uses double-width integer arithmetic as reference. - This is only available on 32-bit platforms that support a 64-bit int type. -*/ - -#if defined(ARCH_UINT64_TYPE) && !defined(ARCH_SIXTYFOUR) - -typedef ARCH_UINT64_TYPE dbldigit; - -static int test_digit_ops(int i) -{ - bngdigit a1, a2, a3, r1, r2; - int ci, co, n; - - a1 = randdigit(); - a2 = randdigit(); - a3 = randdigit(); - ci = randdigit() & 1; - - BngAdd2(r1,co,a1,a2); - if ((dbldigit) r1 + ((dbldigit) co << BNG_BITS_PER_DIGIT) - != (dbldigit) a1 + (dbldigit) a2) { - printf("Round %d, BngAdd2(%lx,%x,%lx, %lx)\n", i, r1, co, a1, a2); - return 1; - } - - BngAdd2Carry(r1,co,a1,a2,ci); - if ((dbldigit) r1 + ((dbldigit) co << BNG_BITS_PER_DIGIT) - != (dbldigit) a1 + (dbldigit) a2 + (dbldigit) ci) { - printf("Round %d, BngAdd2Carry(%lx,%x,%lx, %lx, %x)\n", i, r1, co, a1, a2, ci); - return 1; - } - - r2 = 0; - BngAdd3(r1,r2,a1,a2,a3); - if ((dbldigit) r1 + ((dbldigit) r2 << BNG_BITS_PER_DIGIT) - != (dbldigit) a1 + (dbldigit) a2 + (dbldigit) a3) { - printf("Round %d, BngAdd3(%lx,%x,%lx, %lx, %lx)\n", i, r1, co, a1, a2, a3); - return 1; - } - - BngSub2(r1,co,a1,a2); - if ((dbldigit) r1 - ((dbldigit) co << BNG_BITS_PER_DIGIT) - != (dbldigit) a1 - (dbldigit) a2) { - printf("Round %d, BngSub2(%lx,%x,%lx, %lx)\n", i, r1, co, a1, a2); - return 1; - } - - BngSub2Carry(r1,co,a1,a2,ci); - if ((dbldigit) r1 - ((dbldigit) co << BNG_BITS_PER_DIGIT) - != (dbldigit) a1 - (dbldigit) a2 - (dbldigit) ci) { - printf("Round %d, BngSub2Carry(%lx,%x,%lx, %lx, %x)\n", i, r1, co, a1, a2, ci); - return 1; - } - - r2 = 0; - BngSub3(r1,r2,a1,a2,a3); - if ((dbldigit) r1 - ((dbldigit) r2 << BNG_BITS_PER_DIGIT) - != (dbldigit) a1 - (dbldigit) a2 - (dbldigit) a3) { - printf("Round %d, BngSub3(%lx,%x,%lx, %lx, %lx)\n", i, r1, co, a1, a2, a3); - return 1; - } - - BngMult(r1,r2,a1,a2); - if ((((dbldigit) r1 << BNG_BITS_PER_DIGIT) | (dbldigit) r2) - != (dbldigit) a1 * (dbldigit) a2) { - printf("Round %d, BngMult(%lx,%lx,%lx, %lx)\n", i, r1, r2, a1, a2); - return 1; - } - - /* Make sure a3 is normalized */ - a3 |= 1L << (BNG_BITS_PER_DIGIT - 1); - if (a1 < a3) { - BngDiv(r1,r2,a1,a2,a3); - if (r1 != (((dbldigit) a1 << BNG_BITS_PER_DIGIT) | (dbldigit) a2) / a3 - || - r2 != (((dbldigit) a1 << BNG_BITS_PER_DIGIT) | (dbldigit) a2) % a3) - { - printf("Round %d, BngDiv(%lx,%lx,%lx, %lx, %lx)\n", i, r1, r2, a1, a2, a3); - return 1; - } - } - - n = bng_leading_zero_bits(a1); - if (a1 == 0) { - if (n != BNG_BITS_PER_DIGIT) { - printf("Round %d, bng_leading_zero(bits(%lx) = %d", i, a1, n); - return 1; - } - } else { - if ((a1 << n) >> n != a1 || - ((a1 << n) & (1L << (BNG_BITS_PER_DIGIT - 1))) == 0) { - printf("Round %d, bng_leading_zero(bits(%lx) = %d", i, a1, n); - return 1; - } - } - return 0; -} - -#endif - -/* Test the bng operations. Use BigNum as a reference. */ - -#define MAX_DIGITS 32 - -void randbng(bng a, bngsize n) -{ - int i; - for (i = 0; i < n; i++) a[i] = randdigit(); -} - -char * bng2string(bng a, bngsize n) -{ - char * buffer = malloc((BNG_BITS_PER_DIGIT / 4 + 1) * MAX_DIGITS); - char temp[BNG_BITS_PER_DIGIT / 4 + 1]; - int i; - - buffer[0] = 0; - for (i = n - 1; i >= 0; i--) { - sprintf(temp, "%lx", a[i]); - strcat(buffer, temp); - if (i > 0) strcat(buffer, "_"); - } - return buffer; -} - -int bngsame(bng a, bng b, bngsize n) -{ - int i; - for (i = 0; i < n; i++) - if (a[i] != b[i]) return 0; - return 1; -} - -int test_bng_ops(int i) -{ - bngsize p, q; - bngdigit a[MAX_DIGITS], b[MAX_DIGITS], c[MAX_DIGITS], d[MAX_DIGITS]; - bngdigit f[2 * MAX_DIGITS], g[2 * MAX_DIGITS], h[2 * MAX_DIGITS]; - bngcarry ci, co, cp; - bngdigit dg, do_, dp; - int amount; - - /* Determine random lengths p and q between 1 and MAX_DIGITS. - Ensure p >= q. */ - p = 1 + (rand() % MAX_DIGITS); - q = 1 + (rand() % MAX_DIGITS); - if (q > p) { bngsize t = p; p = q; q = t; } - - /* Randomly generate bignums a of size p, b of size q */ - randbng(a, p); - randbng(b, q); - ci = rand() & 1; - - /* comparison */ - co = bng_compare(a, p, b, q); - cp = BnnCompare(a, p, b, q); - if (co != cp) { - printf("Round %d, bng_compare(%s, %ld, %s, %ld) = %d\n", - i, bng2string(a, p), p, bng2string(b, q), q, co); - return 1; - } - co = bng_compare(b, q, a, p); - cp = BnnCompare(b, q, a, p); - if (co != cp) { - printf("Round %d, bng_compare(%s, %ld, %s, %ld) = %d\n", - i, bng2string(b, q), q, bng2string(a, p), p, co); - return 1; - } - /* add carry */ - bng_assign(c, a, p); - co = bng_add_carry(c, p, ci); - BnnAssign(d, a, p); - cp = BnnAddCarry(d, p, ci); - if (co != cp || !bngsame(c, d, p)) { - printf("Round %d, bng_add_carry(%s, %ld, %d) -> %s, %d\n", - i, bng2string(a, p), p, ci, bng2string(c, p), co); - return 1; - } - /* add */ - bng_assign(c, a, p); - co = bng_add(c, p, b, q, ci); - BnnAssign(d, a, p); - cp = BnnAdd(d, p, b, q, ci); - if (co != cp || !bngsame(c, d, p)) { - printf("Round %d, bng_add(%s, %ld, %s, %ld, %d) -> %s, %d\n", - i, bng2string(a, p), p, bng2string(b, q), q, ci, - bng2string(c, p), co); - return 1; - } - /* sub carry */ - bng_assign(c, a, p); - co = bng_sub_carry(c, p, ci); - BnnAssign(d, a, p); - cp = BnnSubtractBorrow(d, p, ci ^ 1) ^ 1; - if (co != cp || !bngsame(c, d, p)) { - printf("Round %d, bng_sub_carry(%s, %ld, %d) -> %s, %d\n", - i, bng2string(a, p), p, ci, bng2string(c, p), co); - return 1; - } - /* sub */ - bng_assign(c, a, p); - co = bng_sub(c, p, b, q, ci); - BnnAssign(d, a, p); - cp = BnnSubtract(d, p, b, q, ci ^ 1) ^ 1; - if (co != cp || !bngsame(c, d, p)) { - printf("Round %d, bng_sub(%s, %ld, %s, %ld, %d) -> %s, %d\n", - i, bng2string(a, p), p, bng2string(b, q), q, ci, - bng2string(c, p), co); - return 1; - } - /* shift left */ - amount = rand() % BNG_BITS_PER_DIGIT; - bng_assign(c, a, p); - do_ = bng_shift_left(c, p, amount); - BnnAssign(d, a, p); - dp = BnnShiftLeft(d, p, amount); - if (do_ != dp || !bngsame(c, d, p)) { - printf("Round %d, bng_shift_left(%s, %ld, %d) -> %s, %ld\n", - i, bng2string(a, p), p, amount, bng2string(c, p), do_); - return 1; - } - /* shift right */ - amount = rand() % BNG_BITS_PER_DIGIT; - bng_assign(c, a, p); - do_ = bng_shift_right(c, p, amount); - BnnAssign(d, a, p); - dp = BnnShiftRight(d, p, amount); - if (do_ != dp || !bngsame(c, d, p)) { - printf("Round %d, bng_shift_right(%s, %ld, %d) -> %s, %ld\n", - i, bng2string(a, p), p, amount, bng2string(c, p), do_); - return 1; - } - /* mult_add_digit */ - dg = randdigit(); - if (p >= q + 1) { - bng_assign(c, a, p); - co = bng_mult_add_digit(c, p, b, q, dg); - BnnAssign(d, a, p); - cp = BnnMultiplyDigit(d, p, b, q, dg); - if (co != cp || !bngsame(c, d, p)) { - printf("Round %d, bng_mult_add_digit(%s, %ld, %s, %ld, %ld) -> %s, %d\n", - i, bng2string(a, p), p, bng2string(b, q), q, dg, - bng2string(c, p), co); - return 1; - } - } - /* mult_sub_digit */ - dg = randdigit(); - bng_assign(c, a, p); - do_ = bng_mult_add_digit(c, p, b, q, dg); - bng_assign(d, c, p); - dp = bng_mult_sub_digit(d, p, b, q, dg); - if (do_ != dp || !bngsame(a, d, p)) { - printf("Round %d, bng_mult_sub_digit(%s, %ld, %s, %ld, %ld) -> %s, %ld\n", - i, bng2string(c, p), p, bng2string(b, q), q, dg, - bng2string(d, p), dp); - return 1; - } - /* mult_add */ - randbng(f, 2*p); - bng_assign(g, f, 2*p); - co = bng_mult_add(g, 2*p, a, p, b, q); - BnnAssign(h, f, 2*p); - cp = BnnMultiply(h, 2*p, a, p, b, q); - if (co != cp || !bngsame(g, h, 2*p)) { - printf("Round %d, bng_mult_add(%s, %ld, %s, %ld, %s, %ld) -> %s, %d\n", - i, bng2string(f, 2*p), 2*p, - bng2string(a, p), p, - bng2string(b, q), q, - bng2string(g, 2*p), co); - return 1; - } - /* square_add */ - randbng(f, 2*p); - bng_assign(g, f, 2*p); - co = bng_square_add(g, 2*p, b, q); - BnnAssign(h, f, 2*p); - cp = BnnAdd(h, 2*p, h, 2*p); - cp += BnnMultiply(h, 2*p, b, q, b, q); - if (co != cp || !bngsame(g, h, 2*p)) { - printf("Round %d, bng_square_add(%s, %ld, %s, %ld) -> %s, %d\n", - i, bng2string(f, 2*p), 2*p, - bng2string(b, q), q, - bng2string(g, 2*p), co); - return 1; - } - /* div_rem_digit */ - if (a[p - 1] < dg) { - do_ = bng_div_rem_digit(c, a, p, dg); - dp = BnnDivideDigit(d, a, p, dg); - if (do_ != dp || !bngsame(c, d, p-1)) { - printf("Round %d, bng_div_rem_digit(%s, %s, %ld, %lx) -> %lx\n", - i, bng2string(d, p-1), bng2string(a, p), p, dg, do_); - return 1; - } - } - /* div_rem */ - if (p > q && a[p - 1] < b[q - 1]) { - bng_assign(c, a, p); - bng_div_rem(c, p, b, q); - BnnAssign(d, a, p); - BnnDivide(d, p, b, q); - if (!bngsame(c, d, p)) { - printf("Round %d, bng_div_rem(%s, %ld, %s, %ld) -> %s, %s\n", - i, bng2string(a, p), p, bng2string(b, q), q, - bng2string(c + q, p - q), - bng2string(c, q)); - return 1; - } - } - return 0; -} - -int main(int argc, char ** argv) -{ - int niter = 100000; - int i, err; - - bng_init(); - if (argc >= 2) niter = atoi(argv[1]); -#if defined(ARCH_UINT64_TYPE) && !defined(ARCH_SIXTYFOUR) - printf("Testing single-digit operations\n"); - for (err = 0, i = 1; i < niter; i++) err += test_digit_ops(i); - printf("%d rounds performed, %d errors found\n", niter, err); -#endif - printf("Testing bignum operations\n"); - for (err = 0, i = 1; i < niter; i++) err += test_bng_ops(i); - printf("%d rounds performed, %d errors found\n", niter, err); - printf("Testing bignum operations with skewed PRNG\n"); - rand_skewed = 1; - for (err = 0, i = 1; i < niter; i++) err += test_bng_ops(i); - printf("%d rounds performed, %d errors found\n", niter, err); - return 0; -} diff --git a/otherlibs/num/test/test_io.ml b/otherlibs/num/test/test_io.ml deleted file mode 100644 index 1df11a5fe6..0000000000 --- a/otherlibs/num/test/test_io.ml +++ /dev/null @@ -1,64 +0,0 @@ -open Test -open Nat -open Big_int -open Num - -let intern_extern obj = - let f = Filename.temp_file "testnum" ".data" in - let oc = open_out_bin f in - output_value oc obj; - close_out oc; - let ic = open_in_bin f in - let res = input_value ic in - close_in ic; - Sys.remove f; - res -;; - -testing_function "output_value/input_value on nats";; - -let equal_nat n1 n2 = - eq_nat n1 0 (length_nat n1) n2 0 (length_nat n2) -;; - -List.iter - (fun (i, s) -> - let n = nat_of_string s in - ignore(test i equal_nat (n, intern_extern n))) - [1, "0"; - 2, "1234"; - 3, "8589934592"; - 4, "340282366920938463463374607431768211455"; - 5, String.make 100 '3'; - 6, String.make 1000 '9'; - 7, String.make 20000 '8'] -;; - -testing_function "output_value/input_value on big ints";; - -List.iter - (fun (i, s) -> - let b = big_int_of_string s in - ignore(test i eq_big_int (b, intern_extern b))) - [1, "0"; - 2, "1234"; - 3, "-1234"; - 4, "1040259735709286400"; - 5, "-" ^ String.make 20000 '7'] -;; - -testing_function "output_value/input_value on nums";; - -List.iter - (fun (i, s) -> - let n = num_of_string s in - ignore(test i eq_num (n, intern_extern n))) - [1, "0"; - 2, "1234"; - 3, "-1234"; - 4, "159873568791325097646845892426782"; - 5, "1/4"; - 6, "-15/2"; - 7, "159873568791325097646845892426782/24098772507410987265987"; - 8, String.make 10000 '3' ^ "/" ^ String.make 5000 '7'] -;; diff --git a/otherlibs/num/test/test_nats.ml b/otherlibs/num/test/test_nats.ml deleted file mode 100644 index bfb26f1027..0000000000 --- a/otherlibs/num/test/test_nats.ml +++ /dev/null @@ -1,142 +0,0 @@ -open Test;; -open Nat;; - -(* Can compare nats less than 2**32 *) -let equal_nat n1 n2 = - eq_nat n1 0 (num_digits_nat n1 0 1) - n2 0 (num_digits_nat n2 0 1);; - -testing_function "num_digits_nat";; - -test (-1) eq (false,not true);; -test 0 eq (true,not false);; - -test 1 -eq_int -(let r = make_nat 2 in - set_digit_nat r 1 1; - num_digits_nat r 0 1,1);; - -testing_function "length_nat";; - -test 1 -eq_int -(let r = make_nat 2 in - set_digit_nat r 0 1; - length_nat r,2);; - -testing_function "equal_nat";; - -let zero_nat = make_nat 1 in - -test 1 -equal_nat (zero_nat,zero_nat);; -test 2 -equal_nat (nat_of_int 1,nat_of_int 1);; - -test 3 -equal_nat (nat_of_string "2",nat_of_string "2");; -test 4 -eq (equal_nat (nat_of_string "2")(nat_of_string "3"),false);; - -testing_function "incr_nat";; - -let zero = nat_of_int 0 in -let res = incr_nat zero 0 1 1 in - test 1 - equal_nat (zero, nat_of_int 1) && - test 2 - eq (res,0);; - -let n = nat_of_int 1 in -let res = incr_nat n 0 1 1 in - test 3 - equal_nat (n, nat_of_int 2) && - test 4 - eq (res,0);; - - -testing_function "decr_nat";; - -let n = nat_of_int 1 in -let res = decr_nat n 0 1 0 in - test 1 - equal_nat (n, nat_of_int 0) && - test 2 - eq (res,1);; - -let n = nat_of_int 2 in -let res = decr_nat n 0 1 0 in - test 3 - equal_nat (n, nat_of_int 1) && - test 4 - eq (res,1);; - -testing_function "is_zero_nat";; - -let n = nat_of_int 1 in -test 1 eq (is_zero_nat n 0 1,false) && -test 2 eq (is_zero_nat (make_nat 1) 0 1, true) && -test 3 eq (is_zero_nat (make_nat 2) 0 2, true) && -(let r = make_nat 2 in - set_digit_nat r 1 1; - test 4 eq (is_zero_nat r 0 1, true)) -;; - -testing_function "string_of_nat";; - -let n = make_nat 4;; - -test 1 eq_string (string_of_nat n, "0");; - -complement_nat n 0 (if sixtyfour then 2 else 4);; - -test 2 eq_string (string_of_nat n, "340282366920938463463374607431768211455");; - -testing_function "string_of_nat && nat_of_string";; - -for i = 1 to 20 do - let s = String.make i '0' in - String.set s 0 '1'; - test i eq_string (string_of_nat (nat_of_string s), s) -done;; - -let s = "3333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333" in -test 21 equal_nat ( -nat_of_string s, -(let nat = make_nat 15 in - set_digit_nat nat 0 3; - mult_digit_nat nat 0 15 - (nat_of_string (String.sub s 0 135)) 0 14 - (nat_of_int 10) 0; - nat)) -;; - -test 22 eq_string (string_of_nat(nat_of_string "1073741824"), "1073741824");; - -testing_function "gcd_nat";; - -for i = 1 to 20 do - let n1 = Random.int 1000000000 - and n2 = Random.int 100000 in - let nat1 = nat_of_int n1 - and nat2 = nat_of_int n2 in - gcd_nat nat1 0 1 nat2 0 1; - test i eq (int_of_nat nat1, Int_misc.gcd_int n1 n2) -done -;; - -testing_function "sqrt_nat";; - -test 1 equal_nat (sqrt_nat (nat_of_int 1) 0 1, nat_of_int 1);; -test 2 equal_nat (let n = nat_of_string "8589934592" in - sqrt_nat n 0 (length_nat n), - nat_of_string "92681");; -test 3 equal_nat (let n = nat_of_string "4294967295" in - sqrt_nat n 0 (length_nat n), - nat_of_string "65535");; -test 4 equal_nat (let n = nat_of_string "18446744065119617025" in - sqrt_nat n 0 (length_nat n), - nat_of_string "4294967295");; -test 5 equal_nat (sqrt_nat (nat_of_int 15) 0 1, - nat_of_int 3);; diff --git a/otherlibs/num/test/test_nums.ml b/otherlibs/num/test/test_nums.ml deleted file mode 100644 index 424285808b..0000000000 --- a/otherlibs/num/test/test_nums.ml +++ /dev/null @@ -1,220 +0,0 @@ -open Test;; -open Nat;; -open Big_int;; -open Ratio;; -open Int_misc;; -open Num;; -open Arith_status;; - -testing_function "add_num";; - -test 1 -eq_num (add_num (Int 1) (Int 3), Int 4);; -test 2 -eq_num (add_num (Int 1) (Big_int (big_int_of_int 3)), Int 4);; -test 3 -eq_num (add_num (Int 1) (Ratio (ratio_of_string "3/4")), - Ratio (ratio_of_string "7/4"));; -test 4 -eq_num (add_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), - Ratio (ratio_of_string "7/4"));; -test 5 -eq_num (add_num (Big_int (big_int_of_int 1)) (Big_int (big_int_of_int 3)), - Int 4);; -test 6 -eq_num (add_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), - Ratio (ratio_of_string "7/4"));; -test 7 -eq_num (add_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")), - Ratio (ratio_of_string "17/12"));; -test 8 -eq_num (add_num (Int least_int) (Int 1), - Int (- (pred biggest_int)));; -test 9 -eq_num (add_num (Int biggest_int) (Int 1), - Big_int (minus_big_int (pred_big_int (big_int_of_int least_int))));; - -testing_function "sub_num";; - -test 1 -eq_num (sub_num (Int 1) (Int 3), Int (-2));; -test 2 -eq_num (sub_num (Int 1) (Big_int (big_int_of_int 3)), Int (-2));; -test 3 -eq_num (sub_num (Int 1) (Ratio (ratio_of_string "3/4")), - Ratio (ratio_of_string "1/4"));; -test 4 -eq_num (sub_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), - Ratio (ratio_of_string "1/4"));; -test 5 -eq_num (sub_num (Big_int (big_int_of_int 1)) (Big_int (big_int_of_int 3)), - Int (-2));; -test 7 -eq_num (sub_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), - Ratio (ratio_of_string "1/4"));; -test 8 -eq_num (sub_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")), - Ratio (ratio_of_string "-1/12"));; -test 9 -eq_num (sub_num (Int least_int) (Int (-1)), - Int (- (pred biggest_int)));; -test 10 -eq_num (sub_num (Int (-1)) (Int biggest_int), pred_num (Int least_int));; - -testing_function "mult_num";; - -test 1 -eq_num (mult_num (Int 2) (Int 3), Int 6);; -test 2 -eq_num (mult_num (Int 127) (Int (int_of_string "257")), - Int (int_of_string "32639"));; -test 3 -eq_num (mult_num (Int 257) (Int (int_of_string "260")), - Big_int (big_int_of_string "66820"));; -test 4 -eq_num (mult_num (Int 2) (Big_int (big_int_of_int 3)), Int 6);; -test 5 -eq_num (mult_num (Int 10) (Ratio (ratio_of_string "3/4")), - Ratio (ratio_of_string "15/2"));; -test 6 -eq_num (mult_num (Big_int (big_int_of_int 10)) (Ratio (ratio_of_string "3/4")), - Ratio (ratio_of_string "15/2"));; -test 7 -eq_num (mult_num (Big_int (big_int_of_int 2)) (Big_int (big_int_of_int 3)), - Int 6);; -test 8 -eq_num (mult_num (Big_int (big_int_of_int 10)) (Ratio (ratio_of_string "3/4")), - Ratio (ratio_of_string "15/2"));; -test 9 -eq_num (mult_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")) - , Ratio (ratio_of_string "1/2"));; - -testing_function "div_num";; - -test 1 -eq_num (div_num (Int 6) (Int 3), Int 2);; -test 2 -eq_num (div_num (Int (int_of_string "32639")) - (Int (int_of_string "257")), Int 127);; -test 3 -eq_num (div_num (Big_int (big_int_of_string "66820")) - (Int (int_of_string "257")), - Int 260);; -test 4 -eq_num (div_num (Int 6) (Big_int (big_int_of_int 3)), Int 2);; -test 5 -eq_num (div_num (Ratio (ratio_of_string "15/2")) - (Int 10), - Ratio (ratio_of_string "3/4"));; -test 6 -eq_num (div_num (Big_int (big_int_of_int 6)) (Big_int (big_int_of_int 3)), - Int 2);; -test 7 -eq_num (div_num (Ratio (ratio_of_string "15/2")) - (Big_int (big_int_of_int 10)), - Ratio (ratio_of_string "3/4"));; -test 8 -eq_num (div_num (Ratio (ratio_of_string "15/2")) - (Ratio (ratio_of_string "3/4")), - Big_int (big_int_of_int 10));; -test 9 -eq_num (div_num (Ratio (ratio_of_string "1/2")) - (Ratio (ratio_of_string "3/4")), - Ratio (ratio_of_string "2/3"));; - -testing_function "is_integer_num";; - -test 1 -eq (is_integer_num (Int 3),true);; -test 2 -eq (is_integer_num (Big_int (big_int_of_string "1234567890")),true);; -test 3 -eq (not (is_integer_num (Ratio (ratio_of_string "1/2"))),true);; -test 4 -eq (is_integer_num (Ratio (ratio_of_string "1073774590/32770")),true);; - -testing_function "num_of_ratio";; - -test 1 -eq_num (num_of_ratio (ratio_of_string "4/2"), Int 2);; -test 2 -eq_num (num_of_ratio (ratio_of_string "11811160075/11"), - Big_int (big_int_of_string "1073741825"));; -test 3 -eq_num (num_of_ratio (ratio_of_string "123456789012/1234"), - Ratio (ratio_of_string "61728394506/617"));; - -testing_function "num_of_string";; - -test 1 -eq_num (num_of_string "123/3456", Ratio (ratio_of_string "123/3456"));; -(********* -test 2 -eq_num (num_of_string "12.3/34.56", Ratio (ratio_of_string "1230/3456"));; -test 3 -eq_num (num_of_string "1.23/325.6", Ratio (ratio_of_string "123/32560"));; -test 4 -eq_num (num_of_string "12.3/345.6", Ratio (ratio_of_string "123/3456"));; -set_error_when_null_denominator false;; -test 5 -eq_num (num_of_string "12.3/0.0", Ratio (ratio_of_string "123/0"));; -test 6 -eq_num (num_of_string "0/0", Ratio (ratio_of_string "0/0"));; -set_error_when_null_denominator true;; -*********) -test 7 -eq_num (num_of_string "1234567890", - Big_int (big_int_of_string "1234567890"));; -test 8 -eq_num (num_of_string "12345", Int (int_of_string "12345"));; -(********* -test 9 -eq_num (num_of_string "0.23", Ratio (ratio_of_string "23/100"));; -test 10 -eq_num (num_of_string "0.23", Ratio (ratio_of_string "0.23/1"));; -********) - -failwith_test 11 -num_of_string ("frlshjkurty") (Failure "num_of_string");; - -(******* - -testing_function "immediate numbers";; - -standard arith false;; - -let x = (1/2) in -test 0 eq_string (string_of_num x, "1/2");; - -let y = 12345678901 in -test 1 eq_string (string_of_num y, "12345678901");; -testing_function "immediate numbers";; - -let x = (1/2) in -test 0 eq_string (string_of_num x, "1/2");; - -let y = 12345678901 in -test 1 eq_string (string_of_num y, "12345678901");; - -testing_function "pattern_matching on nums";; - -let f1 = function 0 -> true | _ -> false;; - -test 1 eq (f1 0, true);; - -test 2 eq (f1 1, false);; - -test 3 eq (f1 (0/1), true);; - -test 4 eq (f1 (let n = num_of_string "2000000000000000000000000" in n-n) , - true);; - -test 5 eq (f1 (let n = num_of_string "2000000000000000000000000" in n/n-1) , - true);; - -test 6 eq (f1 (let n = num_of_string "2000000000000000000000000" in n+1) , - false);; - -test 7 eq (f1 (1/2), false);; - -**************) diff --git a/otherlibs/num/test/test_ratios.ml b/otherlibs/num/test/test_ratios.ml deleted file mode 100644 index 45fdce8b15..0000000000 --- a/otherlibs/num/test/test_ratios.ml +++ /dev/null @@ -1,928 +0,0 @@ -open Test;; -open Nat;; -open Big_int;; -open Ratio;; -open Int_misc;; -open Arith_status;; - -set_error_when_null_denominator false;; - -let infinite_failure = "infinite or undefined rational number";; - -testing_function "create_ratio";; - -let r = create_ratio (big_int_of_int 1) (big_int_of_int (-2)) in -test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 2);; - -let r = create_ratio (big_int_of_int 2) (big_int_of_int 3) in -test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) && -test 4 eq_big_int (denominator_ratio r, big_int_of_int 3);; - -set_normalize_ratio true;; - -let r = create_ratio (big_int_of_int 12) (big_int_of_int (-16)) in -test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && -test 6 eq_big_int (denominator_ratio r, big_int_of_int 4);; - -set_normalize_ratio false;; - -let r = create_ratio (big_int_of_int 0) (big_int_of_int 0) in -test 7 eq_big_int (numerator_ratio r, big_int_of_int 0) && -test 8 eq_big_int (denominator_ratio r, big_int_of_int 0);; - -testing_function "create_normalized_ratio";; - -let r = create_normalized_ratio (big_int_of_int 1) (big_int_of_int (-2)) in -test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 2);; - -let r = create_normalized_ratio (big_int_of_int 2) (big_int_of_int 3) in -test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) && -test 4 eq_big_int (denominator_ratio r, big_int_of_int 3);; - -set_normalize_ratio true;; - -let r = create_normalized_ratio (big_int_of_int 12) (big_int_of_int (-16)) in -test 5 eq_big_int (numerator_ratio r, big_int_of_int (-12)) && -test 6 eq_big_int (denominator_ratio r, big_int_of_int 16);; - -set_normalize_ratio false;; - -let r = create_normalized_ratio (big_int_of_int 1) (big_int_of_int 0) in -test 7 eq_big_int (numerator_ratio r, big_int_of_int 1) && -test 8 eq_big_int (denominator_ratio r, big_int_of_int 0);; - -let r = create_normalized_ratio (big_int_of_int 0) (big_int_of_int 0) in -test 9 eq_big_int (numerator_ratio r, big_int_of_int 0) && -test 10 eq_big_int (denominator_ratio r, big_int_of_int 0);; - -testing_function "null_denominator";; - -test 1 - eq (null_denominator (create_ratio (big_int_of_int 1) (big_int_of_int (-2))), - false);; -test 2 eq - (null_denominator (create_ratio (big_int_of_int 1) zero_big_int),true);; - -(***** -testing_function "verify_null_denominator";; - -test 1 - eq (verify_null_denominator (ratio_of_string "0/1"), false);; -test 2 - eq (verify_null_denominator (ratio_of_string "0/0"), true);; -*****) - -testing_function "sign_ratio";; - -test 1 -eq_int (sign_ratio (create_ratio (big_int_of_int (-2)) (big_int_of_int (-3))), - 1);; -test 2 -eq_int (sign_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-3))), - (-1));; -test 3 -eq_int (sign_ratio (create_ratio zero_big_int (big_int_of_int (-3))), 0);; - -testing_function "normalize_ratio";; - -let r = create_ratio (big_int_of_int 12) (big_int_of_int (-16)) in -normalize_ratio r; -test 1 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 4);; - -let r = create_ratio (big_int_of_int (-1)) zero_big_int in -normalize_ratio r; -test 3 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && -test 4 eq_big_int (denominator_ratio r, zero_big_int);; - -testing_function "report_sign_ratio";; - -test 1 -eq_big_int (report_sign_ratio - (create_ratio (big_int_of_int 2) (big_int_of_int (-3))) - (big_int_of_int 1), - big_int_of_int (-1));; -test 2 -eq_big_int (report_sign_ratio - (create_ratio (big_int_of_int 2) (big_int_of_int 3)) - (big_int_of_int 1), - big_int_of_int 1);; - -testing_function "is_integer_ratio";; - -test 1 eq - (is_integer_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-1))), - true);; -test 2 eq - (is_integer_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)), - false);; - -testing_function "add_ratio";; - -let r = add_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 2)) - (create_ratio (big_int_of_int 2) (big_int_of_int 3)) in -test 1 eq_big_int (numerator_ratio r, big_int_of_int 7) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 6);; - -let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) - (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in -test 3 eq_big_int (numerator_ratio r, big_int_of_int 1) && -test 4 eq_big_int (denominator_ratio r, big_int_of_int 6);; - -let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int) - (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in -test 5 eq_big_int (numerator_ratio r, big_int_of_int 4) && -test 6 eq_big_int (denominator_ratio r, zero_big_int);; - -let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) - (create_ratio (big_int_of_int 1) zero_big_int) in -test 7 eq_big_int (numerator_ratio r, big_int_of_int 3) && -test 8 eq_big_int (denominator_ratio r, zero_big_int);; - -let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int) - (create_ratio (big_int_of_int 1) zero_big_int) in -test 9 eq_big_int (numerator_ratio r, zero_big_int) && -test 10 eq_big_int (denominator_ratio r, zero_big_int);; - -let r = add_ratio (create_ratio (big_int_of_string "12724951") - (big_int_of_string "26542080")) - (create_ratio (big_int_of_string "-1") - (big_int_of_string "81749606400")) in -test 11 eq_big_int (numerator_ratio r, - big_int_of_string "1040259735682744320") && -test 12 eq_big_int (denominator_ratio r, - big_int_of_string "2169804593037312000");; - -let r1,r2 = - (create_ratio (big_int_of_string "12724951") - (big_int_of_string "26542080"), - create_ratio (big_int_of_string "-1") - (big_int_of_string "81749606400")) in - -let bi1 = mult_big_int (numerator_ratio r1) (denominator_ratio r2) -and bi2 = mult_big_int (numerator_ratio r2) (denominator_ratio r1) -in -test 1 -eq_big_int (bi1, - big_int_of_string "1040259735709286400") -&& -test 2 -eq_big_int (bi2, - big_int_of_string "-26542080") -&& test 3 -eq_big_int (mult_big_int (denominator_ratio r1) (denominator_ratio r2), - big_int_of_string "2169804593037312000") -&& test 4 -eq_big_int (add_big_int bi1 bi2, - big_int_of_string "1040259735682744320") -;; - -testing_function "sub_ratio";; - -let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) - (create_ratio (big_int_of_int 1) (big_int_of_int 2)) in -test 1 eq_big_int (numerator_ratio r, big_int_of_int 1) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 6);; - -let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int) - (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in -test 3 eq_big_int (numerator_ratio r, big_int_of_int 4) && -test 4 eq_big_int (denominator_ratio r, zero_big_int);; - -let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) - (create_ratio (big_int_of_int 1) zero_big_int) in -test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && -test 6 eq_big_int (denominator_ratio r, zero_big_int);; - -let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int) - (create_ratio (big_int_of_int 1) zero_big_int) in -test 7 eq_big_int (numerator_ratio r, zero_big_int) && -test 8 eq_big_int (denominator_ratio r, zero_big_int);; - -testing_function "mult_ratio";; - -let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) - (create_ratio (big_int_of_int 7) (big_int_of_int 5)) in -test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 15);; - -let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int) - (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in -test 3 eq_big_int (numerator_ratio r, big_int_of_int (-2)) && -test 4 eq_big_int (denominator_ratio r, zero_big_int);; - -let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) - (create_ratio (big_int_of_int 1) zero_big_int) in -test 5 eq_big_int (numerator_ratio r, big_int_of_int 2) && -test 6 eq_big_int (denominator_ratio r, zero_big_int);; - -let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int) - (create_ratio (big_int_of_int 1) zero_big_int) in -test 7 eq_big_int (numerator_ratio r, big_int_of_int 2) && -test 8 eq_big_int (denominator_ratio r, zero_big_int);; - -testing_function "div_ratio";; - -let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) - (create_ratio (big_int_of_int 5) (big_int_of_int 7)) in -test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 15);; - -let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int) - (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in -test 3 eq_big_int (numerator_ratio r, big_int_of_int (-4)) && -test 4 eq_big_int (denominator_ratio r, zero_big_int);; - -let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) - (create_ratio (big_int_of_int 1) zero_big_int) in -test 5 eq_big_int (numerator_ratio r, zero_big_int) && -test 6 eq_big_int (denominator_ratio r, big_int_of_int 3);; - -let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int) - (create_ratio (big_int_of_int 1) zero_big_int) in -test 7 eq_big_int (numerator_ratio r, zero_big_int) && -test 8 eq_big_int (denominator_ratio r, zero_big_int);; - -testing_function "integer_ratio";; - -test 1 -eq_big_int (integer_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - big_int_of_int 1);; -test 2 -eq_big_int (integer_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), - big_int_of_int (-1));; -test 3 -eq_big_int (integer_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int 2)), - big_int_of_int 1);; -test 4 -eq_big_int (integer_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), - big_int_of_int (-1));; - -failwith_test 5 -integer_ratio (create_ratio (big_int_of_int 3) zero_big_int) -(Failure("integer_ratio "^infinite_failure));; - -testing_function "floor_ratio";; - -test 1 -eq_big_int (floor_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - big_int_of_int 1);; -test 2 -eq_big_int (floor_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), - big_int_of_int (-2));; -test 3 -eq_big_int (floor_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int 2)), - big_int_of_int 1);; -test 4 -eq_big_int (floor_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), - big_int_of_int (-2));; - -failwith_test 5 floor_ratio (create_ratio (big_int_of_int 3) zero_big_int) -Division_by_zero;; - - -testing_function "round_ratio";; - -test 1 -eq_big_int (round_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - big_int_of_int 2);; -test 2 -eq_big_int (round_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), - big_int_of_int (-2));; -test 3 -eq_big_int (round_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int 2)), - big_int_of_int 2);; -test 4 -eq_big_int (round_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), - big_int_of_int (-2));; - -failwith_test 5 -round_ratio (create_ratio (big_int_of_int 3) zero_big_int) -Division_by_zero;; - - -testing_function "ceiling_ratio";; - -test 1 -eq_big_int (ceiling_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - big_int_of_int 2);; -test 2 -eq_big_int (ceiling_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), - big_int_of_int (-1));; -test 3 -eq_big_int (ceiling_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int 2)), - big_int_of_int 2);; -test 4 -eq_big_int (ceiling_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), - big_int_of_int (-1));; -test 5 -eq_big_int (ceiling_ratio - (create_ratio (big_int_of_int 4) (big_int_of_int 2)), - big_int_of_int 2);; -failwith_test 6 -ceiling_ratio (create_ratio (big_int_of_int 3) zero_big_int) -Division_by_zero;; - -testing_function "eq_ratio";; - -test 1 -eq_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3), - create_ratio (big_int_of_int (-20)) (big_int_of_int (-12)));; -test 2 -eq_ratio (create_ratio (big_int_of_int 1) zero_big_int, - create_ratio (big_int_of_int 2) zero_big_int);; - -let neq_ratio x y = not (eq_ratio x y);; - -test 3 -neq_ratio (create_ratio (big_int_of_int 1) zero_big_int, - create_ratio (big_int_of_int (-1)) zero_big_int);; -test 4 -neq_ratio (create_ratio (big_int_of_int 1) zero_big_int, - create_ratio zero_big_int zero_big_int);; -test 5 -eq_ratio (create_ratio zero_big_int zero_big_int, - create_ratio zero_big_int zero_big_int);; - -testing_function "compare_ratio";; - -test 1 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) - (create_ratio (big_int_of_int 0) (big_int_of_int 0)), - 0);; -test 2 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) - (create_ratio (big_int_of_int 1) (big_int_of_int 0)), - 0);; -test 3 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) - (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), - 0);; -test 4 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) - (create_ratio (big_int_of_int 0) (big_int_of_int 0)), - 0);; -test 5 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) - (create_ratio (big_int_of_int 0) (big_int_of_int 0)), - 0);; -test 6 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - 0);; -test 7 -eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) - (create_ratio (big_int_of_int 0) (big_int_of_int 0)), - 0);; -test 8 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) - (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), - 0);; -test 9 -eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) - (create_ratio (big_int_of_int 0) (big_int_of_int 0)), - 0);; -test 10 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) - (create_ratio (big_int_of_int 0) (big_int_of_int 1)), - 0);; -test 11 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 1)) - (create_ratio (big_int_of_int 0) (big_int_of_int 0)), - 0);; -test 12 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) - (create_ratio (big_int_of_int 1) (big_int_of_int 0)), - 0);; -test 13 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) - (create_ratio (big_int_of_int 2) (big_int_of_int 0)), - 0);; -test 14 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) - (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), - 1);; -test 15 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) - (create_ratio (big_int_of_int 1) (big_int_of_int 0)), - (-1));; -test 16 -eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) - (create_ratio (big_int_of_int 1) (big_int_of_int 0)), - (-1));; -test 17 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - 1);; -test 18 -eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) - (create_ratio (big_int_of_int 1) (big_int_of_int 0)), - (-1));; -test 19 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) - (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), - 1);; -test 20 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) - (create_ratio (big_int_of_int 0) (big_int_of_int 3)), - 1);; -test 21 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) - (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), - 0);; -test 22 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) - (create_ratio (big_int_of_int (-2)) (big_int_of_int 0)), - 0);; -test 23 -eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) - (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), - 1);; -test 24 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - (-1));; -test 25 -eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) - (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), - 1);; -test 26 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) - (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), - (-1));; -test 27 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) - (create_ratio (big_int_of_int 0) (big_int_of_int 3)), - (-1));; -test 28 -eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) - (create_ratio (big_int_of_int 3) (big_int_of_int 2)), - 1);; -test 29 -eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)) - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - (-1));; -test 30 -eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) - (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)), - 1);; -test 31 -eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)) - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - (-1));; -test 32 -eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)) - (create_ratio (big_int_of_int 0) (big_int_of_int 3)), - 1);; -test 33 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - (-1));; -test 34 -eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)) - (create_ratio (big_int_of_int 0) (big_int_of_int 3)), - (-1));; -test 35 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) - (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), - 1);; -test 36 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) - (create_ratio (big_int_of_int 0) (big_int_of_int 3)), - 0);; - -testing_function "eq_big_int_ratio";; - -test 1 -eq_big_int_ratio (big_int_of_int 3, - (create_ratio (big_int_of_int 3) (big_int_of_int 1)));; -test 2 -eq -(not (eq_big_int_ratio (big_int_of_int 1) - (create_ratio (big_int_of_int 3) (big_int_of_int 1))), -true);; - -test 3 -eq -(not (eq_big_int_ratio (big_int_of_int 1) - (create_ratio (big_int_of_int 3) (big_int_of_int 2))), - true);; - -test 4 -eq -(not (eq_big_int_ratio (big_int_of_int 1) - (create_ratio (big_int_of_int 3) (big_int_of_int 0))), - true);; - -test 5 -eq -(not (eq_big_int_ratio (big_int_of_int 1) - (create_ratio (big_int_of_int (-3)) (big_int_of_int 2))), - true);; - -testing_function "compare_big_int_ratio";; - -test 1 -eq_int (compare_big_int_ratio - (big_int_of_int 1) - (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1));; -test 2 -eq_int (compare_big_int_ratio - (big_int_of_int 1) - (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0);; -test 3 -eq_int (compare_big_int_ratio - (big_int_of_int 1) - (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1);; -test 4 -eq_int (compare_big_int_ratio - (big_int_of_int (-1)) - (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1));; -test 5 -eq_int (compare_big_int_ratio - (big_int_of_int (-1)) - (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0);; -test 6 -eq_int (compare_big_int_ratio - (big_int_of_int (-1)) - (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1);; -test 7 -eq_int (compare_big_int_ratio - (big_int_of_int 1) - (create_ratio (big_int_of_int 1) (big_int_of_int 1)), 0);; -test 8 -eq_int (compare_big_int_ratio - (big_int_of_int 1) - (create_ratio (big_int_of_int 3) (big_int_of_int 2)), (-1));; -test 9 -eq_int (compare_big_int_ratio - (big_int_of_int 1) - (create_ratio (big_int_of_int 2) (big_int_of_int 3)), 1);; - - - -testing_function "int_of_ratio";; - -test 1 -eq_int (int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 2)), - 2);; - -test 2 -eq_int (int_of_ratio - (create_ratio (big_int_of_int biggest_int) (big_int_of_int 1)), - biggest_int);; - -failwith_test 3 -int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 0)) -(Failure "integer argument required");; - -failwith_test 4 -int_of_ratio (create_ratio (succ_big_int (big_int_of_int biggest_int)) - (big_int_of_int 1)) -(Failure "integer argument required");; - -failwith_test 5 -int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 3)) -(Failure "integer argument required");; - -testing_function "ratio_of_int";; - -test 1 -eq_ratio (ratio_of_int 3, - create_ratio (big_int_of_int 3) (big_int_of_int 1));; - -test 2 -eq_ratio (ratio_of_nat (nat_of_int 2), - create_ratio (big_int_of_int 2) (big_int_of_int 1));; - -testing_function "nat_of_ratio";; - -let nat1 = nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 1)) -and nat2 = nat_of_int 3 in -test 1 -eq (eq_nat nat1 0 (length_nat nat1) nat2 0 (length_nat nat2), true) -;; - -failwith_test 2 -nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 0)) -(Failure "nat_of_ratio");; - -failwith_test 3 -nat_of_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 1)) -(Failure "nat_of_ratio");; - -failwith_test 4 -nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)) -(Failure "nat_of_ratio");; - -testing_function "ratio_of_big_int";; - -test 1 -eq_ratio (ratio_of_big_int (big_int_of_int 3), - create_ratio (big_int_of_int 3) (big_int_of_int 1));; - -testing_function "big_int_of_ratio";; - -test 1 -eq_big_int (big_int_of_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int 1)), - big_int_of_int 3);; -test 2 -eq_big_int (big_int_of_ratio - (create_ratio (big_int_of_int (-3)) (big_int_of_int 1)), - big_int_of_int (-3));; - -failwith_test 3 -big_int_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 0)) -(Failure "big_int_of_ratio");; - -testing_function "string_of_ratio";; - -test 1 -eq_string (string_of_ratio - (create_ratio (big_int_of_int 43) (big_int_of_int 35)), - "43/35");; -test 2 -eq_string (string_of_ratio - (create_ratio (big_int_of_int 42) (big_int_of_int 0)), - "1/0");; - -set_normalize_ratio_when_printing false;; - -test 3 -eq_string (string_of_ratio - (create_ratio (big_int_of_int 42) (big_int_of_int 35)), - "42/35");; - -set_normalize_ratio_when_printing true;; - -test 4 -eq_string (string_of_ratio - (create_ratio (big_int_of_int 42) (big_int_of_int 35)), - "6/5");; - -testing_function "ratio_of_string";; - -test 1 -eq_ratio (ratio_of_string ("123/3456"), - create_ratio (big_int_of_int 123) (big_int_of_int 3456));; - -(*********** -test 2 -eq_ratio (ratio_of_string ("12.3/34.56"), - create_ratio (big_int_of_int 1230) (big_int_of_int 3456));; -test 3 -eq_ratio (ratio_of_string ("1.23/325.6"), - create_ratio (big_int_of_int 123) (big_int_of_int 32560));; -test 4 -eq_ratio (ratio_of_string ("12.3/345.6"), - create_ratio (big_int_of_int 123) (big_int_of_int 3456));; -test 5 -eq_ratio (ratio_of_string ("12.3/0.0"), - create_ratio (big_int_of_int 123) (big_int_of_int 0));; -***********) -test 6 -eq_ratio (ratio_of_string ("0/0"), - create_ratio (big_int_of_int 0) (big_int_of_int 0));; - -test 7 -eq_ratio (ratio_of_string "1234567890", - create_ratio (big_int_of_string "1234567890") unit_big_int);; -failwith_test 8 -ratio_of_string "frlshjkurty" (Failure "invalid digit");; - -(*********** -testing_function "msd_ratio";; - -test 1 -eq_int (msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 1)), - 0);; -test 2 -eq_int (msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 12)), - (-2));; -test 3 -eq_int (msd_ratio (create_ratio (big_int_of_int 12) (big_int_of_int 1)), - 1);; -test 4 -eq_int (msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 2)), - (-1));; -test 5 -eq_int (msd_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 1)), - 0);; -test 6 -eq_int (msd_ratio (create_ratio (big_int_of_int 25) (big_int_of_int 21)), - 0);; -test 7 -eq_int (msd_ratio (create_ratio (big_int_of_int 35) (big_int_of_int 21)), - 0);; -test 8 -eq_int (msd_ratio (create_ratio (big_int_of_int 215) (big_int_of_int 31)), - 0);; -test 9 -eq_int (msd_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 30)), - (-2));; -test 10 -eq_int (msd_ratio (create_ratio (big_int_of_int 2345) - (big_int_of_int 23456)), - (-2));; -test 11 -eq_int (msd_ratio (create_ratio (big_int_of_int 2345) - (big_int_of_int 2346)), - (-1));; -test 12 -eq_int (msd_ratio (create_ratio (big_int_of_int 2345) - (big_int_of_int 2344)), - 0);; -test 13 -eq_int (msd_ratio (create_ratio (big_int_of_int 23456) - (big_int_of_int 2345)), - 1);; -test 14 -eq_int (msd_ratio (create_ratio (big_int_of_int 23467) - (big_int_of_int 2345)), - 1);; -failwith_test 15 -msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) -("msd_ratio "^infinite_failure);; -failwith_test 16 -msd_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) -("msd_ratio "^infinite_failure);; -failwith_test 17 -msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) -("msd_ratio "^infinite_failure);; -*************************) - -testing_function "round_futur_last_digit";; - -let s = "+123456" in -test 1 eq (round_futur_last_digit s 1 (pred (String.length s)), - false) && -test 2 eq_string (s, "+123466");; - -let s = "123456" in -test 3 eq (round_futur_last_digit s 0 (String.length s), false) && -test 4 eq_string (s, "123466");; - -let s = "-123456" in -test 5 eq (round_futur_last_digit s 1 (pred (String.length s)), - false) && -test 6 eq_string (s, "-123466");; - -let s = "+123496" in -test 7 eq (round_futur_last_digit s 1 (pred (String.length s)), - false) && -test 8 eq_string (s, "+123506");; - -let s = "123496" in -test 9 eq (round_futur_last_digit s 0 (String.length s), false) && -test 10 eq_string (s, "123506");; - -let s = "-123496" in -test 11 eq (round_futur_last_digit s 1 (pred (String.length s)), - false) && -test 12 eq_string (s, "-123506");; - -let s = "+996" in -test 13 eq (round_futur_last_digit s 1 (pred (String.length s)), - true) && -test 14 eq_string (s, "+006");; - -let s = "996" in -test 15 eq (round_futur_last_digit s 0 (String.length s), true) && -test 16 eq_string (s, "006");; - -let s = "-996" in -test 17 eq (round_futur_last_digit s 1 (pred (String.length s)), - true) && -test 18 eq_string (s, "-006");; - -let s = "+6666666" in -test 19 eq (round_futur_last_digit s 1 (pred (String.length s)), - false) && -test 20 eq_string (s, "+6666676") ;; - -let s = "6666666" in -test 21 eq (round_futur_last_digit s 0 (String.length s), false) && -test 22 eq_string (s, "6666676") ;; - -let s = "-6666666" in -test 23 eq (round_futur_last_digit s 1 (pred (String.length s)), - false) && -test 24 eq_string (s, "-6666676") ;; - -testing_function "approx_ratio_fix";; - -let s = approx_ratio_fix 5 - (create_ratio (big_int_of_int 2) - (big_int_of_int 3)) in -test 1 -eq_string (s, "+0.66667");; - -test 2 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_int 20) - (big_int_of_int 3)), - "+6.66667");; -test 3 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_int 2) - (big_int_of_int 30)), - "+0.06667");; -test 4 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_string "999996") - (big_int_of_string "1000000")), - "+1.00000");; -test 5 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_string "299996") - (big_int_of_string "100000")), - "+2.99996");; -test 6 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_string "2999996") - (big_int_of_string "1000000")), - "+3.00000");; -test 7 -eq_string (approx_ratio_fix 4 - (create_ratio (big_int_of_string "299996") - (big_int_of_string "100000")), - "+3.0000");; -test 8 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_int 29996) - (big_int_of_string "100000")), - "+0.29996");; -test 9 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_int 0) - (big_int_of_int 1)), - "+0");; -failwith_test 10 -(approx_ratio_fix 5) (create_ratio (big_int_of_int 1) (big_int_of_int 0)) -(Failure "approx_ratio_fix infinite or undefined rational number");; -failwith_test 11 -(approx_ratio_fix 5) (create_ratio (big_int_of_int 0) (big_int_of_int 0)) -(Failure "approx_ratio_fix infinite or undefined rational number");; - -testing_function "approx_ratio_exp";; - -test 1 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_int 2) - (big_int_of_int 3)), - "+0.66667e0");; -test 2 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_int 20) - (big_int_of_int 3)), - "+0.66667e1");; -test 3 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_int 2) - (big_int_of_int 30)), - "+0.66667e-1");; -test 4 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_string "999996") - (big_int_of_string "1000000")), - "+1.00000e0");; -test 5 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_string "299996") - (big_int_of_string "100000")), - "+0.30000e1");; -test 6 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_int 29996) - (big_int_of_string "100000")), - "+0.29996e0");; -test 7 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_int 0) - (big_int_of_int 1)), - "+0.00000e0");; -failwith_test 8 -(approx_ratio_exp 5) (create_ratio (big_int_of_int 1) (big_int_of_int 0)) -(Failure "approx_ratio_exp infinite or undefined rational number");; -failwith_test 9 -(approx_ratio_exp 5) (create_ratio (big_int_of_int 0) (big_int_of_int 0)) -(Failure "approx_ratio_exp infinite or undefined rational number");; diff --git a/otherlibs/str/.cvsignore b/otherlibs/str/.cvsignore deleted file mode 100644 index a37b133d05..0000000000 --- a/otherlibs/str/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -libstr.x -*.c.x -so_locations diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend deleted file mode 100644 index c93656bae4..0000000000 --- a/otherlibs/str/.depend +++ /dev/null @@ -1,7 +0,0 @@ -strstubs.o: strstubs.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/fail.h -str.cmo: str.cmi -str.cmx: str.cmi diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile deleted file mode 100644 index 97123ddaa2..0000000000 --- a/otherlibs/str/Makefile +++ /dev/null @@ -1,75 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the str library - -include ../../config/Makefile - -# Compilation options -CC=$(BYTECC) -CFLAGS=-O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -CAMLC=../../ocamlcomp.sh -CAMLOPT=../../ocamlcompopt.sh -COMPFLAGS=-warn-error A -COBJS=strstubs.o -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib - -all: libstr.a str.cmi str.cma - -allopt: libstr.a str.cmi str.cmxa - -libstr.a: $(COBJS) - $(MKLIB) -o str $(COBJS) - -str.cma: str.cmo - $(MKLIB) -ocamlc '$(CAMLC)' -o str str.cmo - -str.cmxa: str.cmx - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o str str.cmx - -str.cmx: ../../ocamlopt - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.a *.so *.o - -install: - if test -f dllstr.so; then cp dllstr.so $(STUBLIBDIR)/dllstr.so; fi - cp libstr.a $(LIBDIR)/libstr.a - cd $(LIBDIR); $(RANLIB) libstr.a - cp str.cma str.cmi str.mli $(LIBDIR) - -installopt: - cp str.cmx str.cmxa str.a $(LIBDIR) - cd $(LIBDIR); $(RANLIB) str.a - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: - gcc -MM $(CFLAGS) *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend - -include .depend diff --git a/otherlibs/str/Makefile.Mac b/otherlibs/str/Makefile.Mac deleted file mode 100644 index c5345acd09..0000000000 --- a/otherlibs/str/Makefile.Mac +++ /dev/null @@ -1,53 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the str library - -# Compilation options -PPCC = mrc -PPCCOptions = -i :::byterun:,:::config: -w 7 {cdbgflag} - -CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib: - -PPCCOBJS = strstubs.c.x - -all Ä libstr.x str.cmi str.cma - -libstr.x Ä {PPCCOBJS} - ppclink {ldbgflag} -xm library -o libstr.x {PPCCOBJS} - -str.cma Ä str.cmo - {CAMLC} -a -o str.cma str.cmo - -partialclean Ä - delete -i Å.cm[aio] || set status 0 - -clean Ä partialclean - delete -i Å.x || set status 0 - -install Ä - duplicate -y libstr.x str.cma str.cmi "{LIBDIR}" - -.cmi Ä .mli - {CAMLC} -c {COMPFLAGS} {default}.mli - -.cmo Ä .ml - {CAMLC} -c {COMPFLAGS} {default}.ml - -depend Ä - begin - MakeDepend -w -objext .x Å.c - :::boot:ocamlrun :::tools:ocamldep Å.mli Å.ml - end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend diff --git a/otherlibs/str/Makefile.Mac.depend b/otherlibs/str/Makefile.Mac.depend deleted file mode 100644 index ddcc070e9b..0000000000 --- a/otherlibs/str/Makefile.Mac.depend +++ /dev/null @@ -1,16 +0,0 @@ -#*** Dependencies: Cut here *** -# These dependencies were produced at 20:33:21 on Tue, Aug 21, 2001 by MakeDepend - -:strstubs.c.x Ä ¶ - :strstubs.c ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"memory.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -str.cmoÄ str.cmi -str.cmxÄ str.cmi diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt deleted file mode 100644 index 3d65d19f00..0000000000 --- a/otherlibs/str/Makefile.nt +++ /dev/null @@ -1,83 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the str library - -include ../../config/Makefile - -# Compilation options -CC=$(BYTECC) -CFLAGS=-I../../byterun -CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../boot -CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -DCOBJS=strstubs.$(DO) -SCOBJS=strstubs.$(SO) - -all: dllstr.dll libstr.$(A) str.cmi str.cma - -allopt: libstr.$(A) str.cmi str.cmxa - -dllstr.dll: $(DCOBJS) - $(call MKDLL,dllstr.dll,tmp.$(A),$(DCOBJS) ../../byterun/ocamlrun.$(A)) - rm tmp.* - -libstr.$(A): $(SCOBJS) - $(call MKLIB,libstr.$(A),$(SCOBJS)) - -str.cma: str.cmo - $(CAMLC) -a -o str.cma str.cmo -dllib -lstr -cclib -lstr - -str.cmxa: str.cmx - $(CAMLOPT) -a -o str.cmxa str.cmx -cclib -lstr - -str.cmx: ../../ocamlopt - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.$(A) *.dll *.$(O) *.$(SO) - -install: - cp dllstr.dll $(STUBLIBDIR)/dllstr.dll - cp libstr.$(A) $(LIBDIR)/libstr.$(A) - cp str.cma str.cmi $(LIBDIR) - -installopt: - cp str.cmx str.cmxa str.$(A) $(LIBDIR) - -.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO) - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(SO) - -depend: - -str.cmo: str.cmi -str.cmx: str.cmi diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml deleted file mode 100644 index ca128aed23..0000000000 --- a/otherlibs/str/str.ml +++ /dev/null @@ -1,716 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** String utilities *) - -let string_before s n = String.sub s 0 n - -let string_after s n = String.sub s n (String.length s - n) - -let first_chars s n = String.sub s 0 n - -let last_chars s n = String.sub s (String.length s - n) n - -(** Representation of character sets **) - -module Charset = - struct - type t = string (* of length 32 *) - - let empty = String.make 32 '\000' - let full = String.make 32 '\255' - - let make_empty () = String.make 32 '\000' - - let add s c = - let i = Char.code c in - s.[i lsr 3] <- Char.chr(Char.code s.[i lsr 3] lor (1 lsl (i land 7))) - - let add_range s c1 c2 = - for i = Char.code c1 to Char.code c2 do add s (Char.chr i) done - - let singleton c = - let s = make_empty () in add s c; s - - let range c1 c2 = - let s = make_empty () in add_range s c1 c2; s - - let complement s = - let r = String.create 32 in - for i = 0 to 31 do - r.[i] <- Char.chr(Char.code s.[i] lxor 0xFF) - done; - r - - let union s1 s2 = - let r = String.create 32 in - for i = 0 to 31 do - r.[i] <- Char.chr(Char.code s1.[i] lor Char.code s2.[i]) - done; - r - - let disjoint s1 s2 = - try - for i = 0 to 31 do - if Char.code s1.[i] land Char.code s2.[i] <> 0 then raise Exit - done; - true - with Exit -> - false - - let iter fn s = - for i = 0 to 31 do - let c = Char.code s.[i] in - if c <> 0 then - for j = 0 to 7 do - if c land (1 lsl j) <> 0 then fn (Char.chr ((i lsl 3) + j)) - done - done - - let expand s = - let r = String.make 256 '\000' in - iter (fun c -> r.[Char.code c] <- '\001') s; - r - - let fold_case s = - let r = make_empty() in - iter (fun c -> add r (Char.lowercase c); add r (Char.uppercase c)) s; - r - - end - -(** Abstract syntax tree for regular expressions *) - -type re_syntax = - Char of char - | String of string - | CharClass of Charset.t - | Seq of re_syntax list - | Alt of re_syntax * re_syntax - | Star of re_syntax - | Plus of re_syntax - | Option of re_syntax - | Group of int * re_syntax - | Refgroup of int - | Bol - | Eol - | Wordboundary - -(** Representation of compiled regular expressions *) - -type regexp = { - prog: int array; (* bytecode instructions *) - cpool: string array; (* constant pool (string literals) *) - normtable: string; (* case folding table (if any) *) - numgroups: int; (* number of \(...\) groups *) - numregisters: int; (* number of nullable Star or Plus *) - startchars: int (* index of set of starting chars, or -1 if none *) -} - -(** Opcodes for bytecode instructions; see strstubs.c for description *) - -let op_CHAR = 0 -let op_CHARNORM = 1 -let op_STRING = 2 -let op_STRINGNORM = 3 -let op_CHARCLASS = 4 -let op_BOL = 5 -let op_EOL = 6 -let op_WORDBOUNDARY = 7 -let op_BEGGROUP = 8 -let op_ENDGROUP = 9 -let op_REFGROUP = 10 -let op_ACCEPT = 11 -let op_SIMPLEOPT = 12 -let op_SIMPLESTAR = 13 -let op_SIMPLEPLUS = 14 -let op_GOTO = 15 -let op_PUSHBACK = 16 -let op_SETMARK = 17 -let op_CHECKPROGRESS = 18 - -(* Encoding of bytecode instructions *) - -let instr opc arg = opc lor (arg lsl 8) - -(* Computing relative displacements for GOTO and PUSHBACK instructions *) - -let displ dest from = dest - from - 1 - -(** Compilation of a regular expression *) - -(* Determine if a regexp can match the empty string *) - -let rec is_nullable = function - Char c -> false - | String s -> s = "" - | CharClass cl -> false - | Seq rl -> List.for_all is_nullable rl - | Alt (r1, r2) -> is_nullable r1 || is_nullable r2 - | Star r -> true - | Plus r -> is_nullable r - | Option r -> true - | Group(n, r) -> is_nullable r - | Refgroup n -> true - | Bol -> true - | Eol -> true - | Wordboundary -> true - -(* first r returns a set of characters C such that: - for all string s, s matches r => the first character of s is in C. - For convenience, return Charset.full if r is nullable. *) - -let rec first = function - Char c -> Charset.singleton c - | String s -> if s = "" then Charset.full else Charset.singleton s.[0] - | CharClass cl -> cl - | Seq rl -> first_seq rl - | Alt (r1, r2) -> Charset.union (first r1) (first r2) - | Star r -> Charset.full - | Plus r -> first r - | Option r -> Charset.full - | Group(n, r) -> first r - | Refgroup n -> Charset.full - | Bol -> Charset.full - | Eol -> Charset.full - | Wordboundary -> Charset.full - -and first_seq = function - [] -> Charset.full - | (Bol | Eol | Wordboundary) :: rl -> first_seq rl - | Star r :: rl -> Charset.union (first r) (first_seq rl) - | Option r :: rl -> Charset.union (first r) (first_seq rl) - | r :: rl -> first r - -(* Transform a Char or CharClass regexp into a character class *) - -let charclass_of_regexp fold_case re = - let cl = - match re with - Char c -> Charset.singleton c - | CharClass cl -> cl - | _ -> assert false in - if fold_case then Charset.fold_case cl else cl - -(* The case fold table: maps characters to their lowercase equivalent *) - -let fold_case_table = - let t = String.create 256 in - for i = 0 to 255 do t.[i] <- Char.lowercase(Char.chr i) done; - t - -module StringMap = Map.Make(struct type t = string let compare = compare end) - -(* Compilation of a regular expression *) - -let compile fold_case re = - - (* Instruction buffering *) - let prog = ref (Array.make 32 0) - and progpos = ref 0 - and cpool = ref StringMap.empty - and cpoolpos = ref 0 - and numgroups = ref 1 - and numregs = ref 0 in - (* Add a new instruction *) - let emit_instr opc arg = - if !progpos >= Array.length !prog then begin - let nprog = Array.make (2 * Array.length !prog) 0 in - Array.blit !prog 0 nprog 0 (Array.length !prog); - prog := nprog - end; - (!prog).(!progpos) <- (instr opc arg); - incr progpos in - (* Reserve an instruction slot and return its position *) - let emit_hole () = - let p = !progpos in incr progpos; p in - (* Fill a reserved instruction slot with a GOTO or PUSHBACK instruction *) - let patch_instr pos opc dest = - (!prog).(pos) <- (instr opc (displ dest pos)) in - (* Return the cpool index for the given string, adding it if not - already there *) - let cpool_index s = - try - StringMap.find s !cpool - with Not_found -> - let p = !cpoolpos in - cpool := StringMap.add s p !cpool; - incr cpoolpos; - p in - (* Allocate fresh register if regexp is nullable *) - let allocate_register_if_nullable r = - if is_nullable r then begin - let n = !numregs in - if n >= 64 then failwith "too many r* or r+ where r is nullable"; - incr numregs; - n - end else - -1 in - (* Main recursive compilation function *) - let rec emit_code = function - Char c -> - if fold_case then - emit_instr op_CHARNORM (Char.code (Char.lowercase c)) - else - emit_instr op_CHAR (Char.code c) - | String s -> - begin match String.length s with - 0 -> () - | 1 -> - if fold_case then - emit_instr op_CHARNORM (Char.code (Char.lowercase s.[0])) - else - emit_instr op_CHAR (Char.code s.[0]) - | _ -> - try - (* null characters are not accepted by the STRING* instructions; - if one is found, split string at null character *) - let i = String.index s '\000' in - emit_code (String (string_before s i)); - emit_instr op_CHAR 0; - emit_code (String (string_after s (i+1))) - with Not_found -> - if fold_case then - emit_instr op_STRINGNORM (cpool_index (String.lowercase s)) - else - emit_instr op_STRING (cpool_index s) - end - | CharClass cl -> - let cl' = if fold_case then Charset.fold_case cl else cl in - emit_instr op_CHARCLASS (cpool_index cl') - | Seq rl -> - emit_seq_code rl - | Alt(r1, r2) -> - (* PUSHBACK lbl1 - <match r1> - GOTO lbl2 - lbl1: <match r2> - lbl2: ... *) - let pos_pushback = emit_hole() in - emit_code r1; - let pos_goto_end = emit_hole() in - let lbl1 = !progpos in - emit_code r2; - let lbl2 = !progpos in - patch_instr pos_pushback op_PUSHBACK lbl1; - patch_instr pos_goto_end op_GOTO lbl2 - | Star r -> - (* Implement longest match semantics for compatibility with old Str *) - (* General translation: - lbl1: PUSHBACK lbl2 - SETMARK regno - <match r> - CHECKPROGRESS regno - GOTO lbl1 - lbl2: - If r cannot match the empty string, code can be simplified: - lbl1: PUSHBACK lbl2 - <match r> - GOTO lbl1 - lbl2: - *) - let regno = allocate_register_if_nullable r in - let lbl1 = emit_hole() in - if regno >= 0 then emit_instr op_SETMARK regno; - emit_code r; - if regno >= 0 then emit_instr op_CHECKPROGRESS regno; - emit_instr op_GOTO (displ lbl1 !progpos); - let lbl2 = !progpos in - patch_instr lbl1 op_PUSHBACK lbl2 - | Plus r -> - (* Implement longest match semantics for compatibility with old Str *) - (* General translation: - lbl1: <match r> - CHECKPROGRESS regno - PUSHBACK lbl2 - SETMARK regno - GOTO lbl1 - lbl2: - If r cannot match the empty string, code can be simplified: - lbl1: <match r> - PUSHBACK lbl2 - GOTO_PLUS lbl1 - lbl2: - *) - let regno = allocate_register_if_nullable r in - let lbl1 = !progpos in - emit_code r; - if regno >= 0 then emit_instr op_CHECKPROGRESS regno; - let pos_pushback = emit_hole() in - if regno >= 0 then emit_instr op_SETMARK regno; - emit_instr op_GOTO (displ lbl1 !progpos); - let lbl2 = !progpos in - patch_instr pos_pushback op_PUSHBACK lbl2 - | Option r -> - (* Implement longest match semantics for compatibility with old Str *) - (* PUSHBACK lbl - <match r> - lbl: - *) - let pos_pushback = emit_hole() in - emit_code r; - let lbl = !progpos in - patch_instr pos_pushback op_PUSHBACK lbl - | Group(n, r) -> - if n >= 32 then failwith "too many \\(...\\) groups"; - emit_instr op_BEGGROUP n; - emit_code r; - emit_instr op_ENDGROUP n; - numgroups := max !numgroups (n+1) - | Refgroup n -> - emit_instr op_REFGROUP n - | Bol -> - emit_instr op_BOL 0 - | Eol -> - emit_instr op_EOL 0 - | Wordboundary -> - emit_instr op_WORDBOUNDARY 0 - - and emit_seq_code = function - [] -> () - | Star(Char _ | CharClass _ as r) :: rl - when disjoint_modulo_case (first r) (first_seq rl) -> - emit_instr op_SIMPLESTAR (cpool_index (charclass_of_regexp fold_case r)); - emit_seq_code rl - | Plus(Char _ | CharClass _ as r) :: rl - when disjoint_modulo_case (first r) (first_seq rl) -> - emit_instr op_SIMPLEPLUS (cpool_index (charclass_of_regexp fold_case r)); - emit_seq_code rl - | Option(Char _ | CharClass _ as r) :: rl - when disjoint_modulo_case (first r) (first_seq rl) -> - emit_instr op_SIMPLEOPT (cpool_index (charclass_of_regexp fold_case r)); - emit_seq_code rl - | r :: rl -> - emit_code r; - emit_seq_code rl - - and disjoint_modulo_case c1 c2 = - if fold_case - then Charset.disjoint (Charset.fold_case c1) (Charset.fold_case c2) - else Charset.disjoint c1 c2 - in - - emit_code re; - emit_instr op_ACCEPT 0; - let start = first re in - let start' = if fold_case then Charset.fold_case start else start in - let start_pos = - if start = Charset.full - then -1 - else cpool_index (Charset.expand start') in - let constantpool = Array.make !cpoolpos "" in - StringMap.iter (fun str idx -> constantpool.(idx) <- str) !cpool; - { prog = Array.sub !prog 0 !progpos; - cpool = constantpool; - normtable = if fold_case then fold_case_table else ""; - numgroups = !numgroups; - numregisters = !numregs; - startchars = start_pos } - -(** Parsing of a regular expression *) - -(* Efficient buffering of sequences *) - -module SeqBuffer = struct - - type t = { sb_chars: Buffer.t; mutable sb_next: re_syntax list } - - let create() = { sb_chars = Buffer.create 16; sb_next = [] } - - let flush buf = - let s = Buffer.contents buf.sb_chars in - Buffer.clear buf.sb_chars; - match String.length s with - 0 -> () - | 1 -> buf.sb_next <- Char s.[0] :: buf.sb_next - | _ -> buf.sb_next <- String s :: buf.sb_next - - let add buf re = - match re with - Char c -> Buffer.add_char buf.sb_chars c - | _ -> flush buf; buf.sb_next <- re :: buf.sb_next - - let extract buf = - flush buf; Seq(List.rev buf.sb_next) - -end - -(* The character class corresponding to `.' *) - -let dotclass = Charset.complement (Charset.singleton '\n') - -(* Parse a regular expression *) - -let parse s = - let len = String.length s in - let group_counter = ref 1 in - - let rec regexp0 i = - let (r, j) = regexp1 i in - regexp0cont r j - and regexp0cont r1 i = - if i + 2 <= len && s.[i] = '\\' && s.[i+1] = '|' then - let (r2, j) = regexp1 (i+2) in - regexp0cont (Alt(r1, r2)) j - else - (r1, i) - and regexp1 i = - regexp1cont (SeqBuffer.create()) i - and regexp1cont sb i = - if i >= len - || i + 2 <= len && s.[i] = '\\' && (let c = s.[i+1] in c = '|' || c = ')') - then - (SeqBuffer.extract sb, i) - else - let (r, j) = regexp2 i in - SeqBuffer.add sb r; - regexp1cont sb j - and regexp2 i = - let (r, j) = regexp3 i in - regexp2cont r j - and regexp2cont r i = - if i >= len then (r, i) else - match s.[i] with - '?' -> regexp2cont (Option r) (i+1) - | '*' -> regexp2cont (Star r) (i+1) - | '+' -> regexp2cont (Plus r) (i+1) - | _ -> (r, i) - and regexp3 i = - match s.[i] with - '\\' -> regexpbackslash (i+1) - | '[' -> let (c, j) = regexpclass0 (i+1) in (CharClass c, j) - | '^' -> (Bol, i+1) - | '$' -> (Eol, i+1) - | '.' -> (CharClass dotclass, i+1) - | c -> (Char c, i+1) - and regexpbackslash i = - if i >= len then (Char '\\', i) else - match s.[i] with - '|' | ')' -> - assert false - | '(' -> - let group_no = !group_counter in - if group_no < 32 then incr group_counter; - let (r, j) = regexp0 (i+1) in - if j + 1 < len && s.[j] = '\\' && s.[j+1] = ')' then - if group_no < 32 - then (Group(group_no, r), j + 2) - else (r, j + 2) - else - failwith "\\( group not closed by \\)" - | '1' .. '9' as c -> - (Refgroup(Char.code c - 48), i + 1) - | 'b' -> - (Wordboundary, i + 1) - | c -> - (Char c, i + 1) - and regexpclass0 i = - if i < len && s.[i] = '^' - then let (c, j) = regexpclass1 (i+1) in (Charset.complement c, j) - else regexpclass1 i - and regexpclass1 i = - let c = Charset.make_empty() in - let j = regexpclass2 c i i in - (c, j) - and regexpclass2 c start i = - if i >= len then failwith "[ class not closed by ]"; - if s.[i] = ']' && i > start then i+1 else begin - let c1 = s.[i] in - if i+2 < len && s.[i+1] = '-' && s.[i+2] <> ']' then begin - let c2 = s.[i+2] in - Charset.add_range c c1 c2; - regexpclass2 c start (i+3) - end else begin - Charset.add c c1; - regexpclass2 c start (i+1) - end - end in - - let (r, j) = regexp0 0 in - if j = len then r else failwith "spurious \\) in regular expression" - -(** Parsing and compilation *) - -let regexp e = compile false (parse e) - -let regexp_case_fold e = compile true (parse e) - -let quote s = - let len = String.length s in - let buf = String.create (2 * len) in - let pos = ref 0 in - for i = 0 to len - 1 do - match s.[i] with - '[' | ']' | '*' | '.' | '\\' | '?' | '+' | '^' | '$' as c -> - buf.[!pos] <- '\\'; buf.[!pos + 1] <- c; pos := !pos + 2 - | c -> - buf.[!pos] <- c; pos := !pos + 1 - done; - String.sub buf 0 !pos - -let regexp_string s = compile false (String s) - -let regexp_string_case_fold s = compile true (String s) - -(** Matching functions **) - -external re_string_match: regexp -> string -> int -> int array - = "re_string_match" -external re_partial_match: regexp -> string -> int -> int array - = "re_partial_match" -external re_search_forward: regexp -> string -> int -> int array - = "re_search_forward" -external re_search_backward: regexp -> string -> int -> int array - = "re_search_backward" - -let last_search_result = ref [||] - -let string_match re s pos = - let res = re_string_match re s pos in - last_search_result := res; - Array.length res > 0 - -let string_partial_match re s pos = - let res = re_partial_match re s pos in - last_search_result := res; - Array.length res > 0 - -let search_forward re s pos = - let res = re_search_forward re s pos in - last_search_result := res; - if Array.length res = 0 then raise Not_found else res.(0) - -let search_backward re s pos = - let res = re_search_backward re s pos in - last_search_result := res; - if Array.length res = 0 then raise Not_found else res.(0) - -let group_beginning n = - let n2 = n + n in - if n < 0 || n2 >= Array.length !last_search_result then - invalid_arg "Str.group_beginning" - else - let pos = !last_search_result.(n2) in - if pos = -1 then raise Not_found else pos - -let group_end n = - let n2 = n + n in - if n < 0 || n2 >= Array.length !last_search_result then - invalid_arg "Str.group_end" - else - let pos = !last_search_result.(n2 + 1) in - if pos = -1 then raise Not_found else pos - -let matched_group n txt = - let n2 = n + n in - if n < 0 || n2 >= Array.length !last_search_result then - invalid_arg "Str.matched_group" - else - let b = !last_search_result.(n2) - and e = !last_search_result.(n2 + 1) in - if b = -1 then raise Not_found else String.sub txt b (e - b) - -let match_beginning () = group_beginning 0 -and match_end () = group_end 0 -and matched_string txt = matched_group 0 txt - -(** Replacement **) - -external re_replacement_text: string -> int array -> string -> string - = "re_replacement_text" - -let replace_matched repl matched = - re_replacement_text repl !last_search_result matched - -let substitute_first expr repl_fun text = - try - let pos = search_forward expr text 0 in - String.concat "" [string_before text pos; - repl_fun text; - string_after text (match_end())] - with Not_found -> - text - -let global_substitute expr repl_fun text = - let rec replace start last_was_empty = - try - let startpos = if last_was_empty then start + 1 else start in - if startpos > String.length text then raise Not_found; - let pos = search_forward expr text startpos in - let end_pos = match_end() in - let repl_text = repl_fun text in - String.sub text start (pos-start) :: - repl_text :: - replace end_pos (end_pos = pos) - with Not_found -> - [string_after text start] in - String.concat "" (replace 0 false) - -let global_replace expr repl text = - global_substitute expr (replace_matched repl) text -and replace_first expr repl text = - substitute_first expr (replace_matched repl) text - -(** Splitting *) - -let bounded_split expr text num = - let start = - if string_match expr text 0 then match_end() else 0 in - let rec split start n = - if start >= String.length text then [] else - if n = 1 then [string_after text start] else - try - let pos = search_forward expr text start in - String.sub text start (pos-start) :: split (match_end()) (n-1) - with Not_found -> - [string_after text start] in - split start num - -let split expr text = bounded_split expr text 0 - -let bounded_split_delim expr text num = - let rec split start n = - if start > String.length text then [] else - if n = 1 then [string_after text start] else - try - let pos = search_forward expr text start in - String.sub text start (pos-start) :: split (match_end()) (n-1) - with Not_found -> - [string_after text start] in - if text = "" then [] else split 0 num - -let split_delim expr text = bounded_split_delim expr text 0 - -type split_result = Text of string | Delim of string - -let bounded_full_split expr text num = - let rec split start n = - if start >= String.length text then [] else - if n = 1 then [Text(string_after text start)] else - try - let pos = search_forward expr text start in - let s = matched_string text in - if pos > start then - Text(String.sub text start (pos-start)) :: - Delim(s) :: - split (match_end()) (n-1) - else - Delim(s) :: - split (match_end()) (n-1) - with Not_found -> - [Text(string_after text start)] in - split 0 num - -let full_split expr text = bounded_full_split expr text 0 diff --git a/otherlibs/str/str.mli b/otherlibs/str/str.mli deleted file mode 100644 index 5aaee9fb34..0000000000 --- a/otherlibs/str/str.mli +++ /dev/null @@ -1,239 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Regular expressions and high-level string processing *) - - -(** {6 Regular expressions} *) - - -type regexp -(** The type of compiled regular expressions. *) - - -val regexp : string -> regexp -(** Compile a regular expression. The syntax for regular expressions - is the same as in Gnu Emacs. The special characters are - [$^.*+?[]]. The following constructs are recognized: - - [. ] matches any character except newline - - [* ] (postfix) matches the previous expression zero, one or - several times - - [+ ] (postfix) matches the previous expression one or - several times - - [? ] (postfix) matches the previous expression once or - not at all - - [[..] ] character set; ranges are denoted with [-], as in [[a-z]]; - an initial [^], as in [[^0-9]], complements the set - - [^ ] matches at beginning of line - - [$ ] matches at end of line - - [\| ] (infix) alternative between two expressions - - [\(..\)] grouping and naming of the enclosed expression - - [\1 ] the text matched by the first [\(...\)] expression - ([\2] for the second expression, and so on up to [\9]) - - [\b ] matches word boundaries - - [\ ] quotes special characters. *) - -val regexp_case_fold : string -> regexp -(** Same as [regexp], but the compiled expression will match text - in a case-insensitive way: uppercase and lowercase letters will - be considered equivalent. *) - -val quote : string -> string -(** [Str.quote s] returns a regexp string that matches exactly - [s] and nothing else. *) - -val regexp_string : string -> regexp -(** [Str.regexp_string s] returns a regular expression - that matches exactly [s] and nothing else.*) - -val regexp_string_case_fold : string -> regexp -(** [Str.regexp_string_case_fold] is similar to {!Str.regexp_string}, - but the regexp matches in a case-insensitive way. *) - - -(** {6 String matching and searching} *) - - -val string_match : regexp -> string -> int -> bool -(** [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. *) - -val search_forward : regexp -> string -> int -> int -(** [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. *) - -val search_backward : regexp -> string -> int -> int -(** Same as {!Str.search_forward}, but the search proceeds towards the - beginning of the string. *) - -val string_partial_match : regexp -> string -> int -> bool -(** Similar to {!Str.string_match}, but succeeds whenever the argument - string is a prefix of a string that matches. This includes - the case of a true complete match. *) - -val matched_string : string -> string -(** [matched_string s] returns the substring of [s] that was matched - by the latest {!Str.string_match}, {!Str.search_forward} or - {!Str.search_backward}. - The user must make sure that the parameter [s] is the same string - that was passed to the matching or searching function. *) - -val match_beginning : unit -> int -(** [match_beginning()] returns the position of the first character - of the substring that was matched by {!Str.string_match}, - {!Str.search_forward} or {!Str.search_backward}. *) - -val match_end : unit -> int -(** [match_end()] returns the position of the character following the - last character of the substring that was matched by [string_match], - [search_forward] or [search_backward]. *) - -val matched_group : int -> string -> string -(** [matched_group n s] returns the substring of [s] that was matched - by the [n]th group [\(...\)] of the regular expression during - the latest {!Str.string_match}, {!Str.search_forward} or - {!Str.search_backward}. - The user must make sure that the parameter [s] is the same string - that was passed to the matching or searching function. - [matched_group n s] raises [Not_found] if the [n]th group - of the regular expression was not matched. This can happen - with groups inside alternatives [\|], options [?] - or repetitions [*]. For instance, the empty string will match - [\(a\)*], but [matched_group 1 ""] will raise [Not_found] - because the first group itself was not matched. *) - -val group_beginning : int -> int -(** [group_beginning n] returns the position of the first character - of the substring that was matched by the [n]th group of - the regular expression. - @raise Not_found if the [n]th group of the regular expression - was not matched. - @raise Invalid_argument if there are fewer than [n] groups in - the regular expression. *) - -val group_end : int -> int -(** [group_end n] returns - the position of the character following the last character of - substring that was matched by the [n]th group of the regular expression. - @raise Not_found if the [n]th group of the regular expression - was not matched. - @raise Invalid_argument if there are fewer than [n] groups in - the regular expression. *) - - -(** {6 Replacement} *) - - -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 : regexp -> string -> string -> string -(** Same as {!Str.global_replace}, except that only the first substring - matching the regular expression is replaced. *) - -val global_substitute : 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 : regexp -> (string -> string) -> string -> string -(** Same as {!Str.global_substitute}, except that only the first substring - matching the regular expression is replaced. *) - -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 - operation. [s] must be the same string that was matched during - this matching operation. *) - - -(** {6 Splitting} *) - - -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 : regexp -> string -> int -> string list -(** Same as {!Str.split}, but splits into at most [n] substrings, - where [n] is the extra integer parameter. *) - -val split_delim : regexp -> string -> string list -(** Same as {!Str.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. - For instance, [split_delim (regexp " ") " abc "] - returns [[""; "abc"; ""]], while [split] with the same - arguments returns [["abc"]]. *) - -val bounded_split_delim : regexp -> string -> int -> string list -(** Same as {!Str.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. *) - -type split_result = - Text of string - | Delim of string - -val full_split : regexp -> string -> split_result list -(** Same as {!Str.split_delim}, but returns - the delimiters as well as the substrings contained between - delimiters. The former are tagged [Delim] in the result list; - the latter are tagged [Text]. For instance, - [full_split (regexp "[{}]") "{ab}"] returns - [[Delim "{"; Text "ab"; Delim "}"]]. *) - -val bounded_full_split : regexp -> string -> int -> split_result list -(** Same as {!Str.bounded_split_delim}, but returns - the delimiters as well as the substrings contained between - delimiters. The former are tagged [Delim] in the result list; - the latter are tagged [Text]. *) - - -(** {6 Extracting substrings} *) - - -val string_before : string -> int -> string -(** [string_before s n] returns the substring of all characters of [s] - that precede position [n] (excluding the character at - position [n]). *) - -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 -> int -> string -(** [first_chars s n] returns the first [n] characters of [s]. - This is the same function as {!Str.string_before}. *) - -val last_chars : string -> int -> string -(** [last_chars s n] returns the last [n] characters of [s]. *) - diff --git a/otherlibs/str/strstubs.c b/otherlibs/str/strstubs.c deleted file mode 100644 index 0b518dcbe0..0000000000 --- a/otherlibs/str/strstubs.c +++ /dev/null @@ -1,527 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <assert.h> -#include <string.h> -#include <ctype.h> -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <fail.h> - -/* The backtracking NFA interpreter */ - -union backtrack_point { - struct { - value * pc; /* with low bit set */ - unsigned char * txt; - } pos; - struct { - unsigned char ** loc; /* with low bit clear */ - unsigned char * val; - } undo; -}; - -#define Set_tag(p) ((value *) ((long)(p) | 1)) -#define Clear_tag(p) ((value *) ((long)(p) & ~1)) -#define Tag_is_set(p) ((long)(p) & 1) - -#define BACKTRACK_STACK_BLOCK_SIZE 500 - -struct backtrack_stack { - struct backtrack_stack * previous; - union backtrack_point point[BACKTRACK_STACK_BLOCK_SIZE]; -}; - -#define Opcode(x) ((x) & 0xFF) -#define Arg(x) ((unsigned long)(x) >> 8) -#define SignedArg(x) ((long)(x) >> 8) - -enum { - CHAR, /* match a single character */ - CHARNORM, /* match a single character, after normalization */ - STRING, /* match a character string */ - STRINGNORM, /* match a character string, after normalization */ - CHARCLASS, /* match a character class */ - BOL, /* match at beginning of line */ - EOL, /* match at end of line */ - WORDBOUNDARY, /* match on a word boundary */ - BEGGROUP, /* record the beginning of a group */ - ENDGROUP, /* record the end of a group */ - REFGROUP, /* match a previously matched group */ - ACCEPT, /* report success */ - SIMPLEOPT, /* match a character class 0 or 1 times */ - SIMPLESTAR, /* match a character class 0, 1 or several times */ - SIMPLEPLUS, /* match a character class 1 or several times */ - GOTO, /* unconditional branch */ - PUSHBACK, /* record a backtrack point -- - where to jump in case of failure */ - SETMARK, /* remember current position in given register # */ - CHECKPROGRESS /* backtrack if no progress was made w.r.t. reg # */ -}; - -/* Accessors in a compiled regexp */ -#define Prog(re) Field(re, 0) -#define Cpool(re) Field(re, 1) -#define Normtable(re) Field(re, 2) -#define Numgroups(re) Int_val(Field(re, 3)) -#define Numregisters(re) Int_val(Field(re, 4)) -#define Startchars(re) Int_val(Field(re, 5)) - -/* Record positions of matched groups */ -#define NUM_GROUPS 32 -struct re_group { - unsigned char * start; - unsigned char * end; -}; -static struct re_group re_group[NUM_GROUPS]; - -/* Record positions reached during matching; used to check progress - in repeated matching of a regexp. */ -#define NUM_REGISTERS 64 -static unsigned char * re_register[NUM_REGISTERS]; - -/* The initial backtracking stack */ -static struct backtrack_stack initial_stack = { NULL, }; - -/* Free a chained list of backtracking stacks */ -static void free_backtrack_stack(struct backtrack_stack * stack) -{ - struct backtrack_stack * prevstack; - while ((prevstack = stack->previous) != NULL) { - stat_free(stack); - stack = prevstack; - } -} - -/* Membership in a bit vector representing a set of booleans */ -#define In_bitset(s,i,tmp) (tmp = (i), ((s)[tmp >> 3] >> (tmp & 7)) & 1) - -/* Determine if a character is a word constituent */ -static unsigned char re_word_letters[32] = { - 0, 0, 0, 0, 0, 0, 0, 0, 254, 255, 255, 7, 254, 255, 255, 7, - 0, 0, 0, 0, 0, 0, 0, 0, 255, 255, 127, 255, 255, 255, 127, 255 -}; -#define Is_word_letter(c) ((re_word_letters[(c) >> 3] >> ((c) & 7)) & 1) - -/* The bytecode interpreter for the NFA */ -static int re_match(value re, - unsigned char * starttxt, - register unsigned char * txt, - register unsigned char * endtxt, - int accept_partial_match) -{ - register value * pc; - long instr; - struct backtrack_stack * stack; - union backtrack_point * sp; - value cpool; - value normtable; - unsigned char c; - union backtrack_point back; - - { int i; - struct re_group * p; - unsigned char ** q; - for (p = &re_group[1], i = Numgroups(re); i > 1; i--, p++) - p->start = p->end = NULL; - for (q = &re_register[0], i = Numregisters(re); i > 0; i--, q++) - *q = NULL; - } - - pc = &Field(Prog(re), 0); - stack = &initial_stack; - sp = stack->point; - cpool = Cpool(re); - normtable = Normtable(re); - re_group[0].start = txt; - - while (1) { - instr = Long_val(*pc++); - switch (Opcode(instr)) { - case CHAR: - if (txt == endtxt) goto prefix_match; - if (*txt != Arg(instr)) goto backtrack; - txt++; - break; - case CHARNORM: - if (txt == endtxt) goto prefix_match; - if (Byte_u(normtable, *txt) != Arg(instr)) goto backtrack; - txt++; - break; - case STRING: { - unsigned char * s = - (unsigned char *) String_val(Field(cpool, Arg(instr))); - while ((c = *s++) != 0) { - if (txt == endtxt) goto prefix_match; - if (c != *txt) goto backtrack; - txt++; - } - break; - } - case STRINGNORM: { - unsigned char * s = - (unsigned char *) String_val(Field(cpool, Arg(instr))); - while ((c = *s++) != 0) { - if (txt == endtxt) goto prefix_match; - if (c != Byte_u(normtable, *txt)) goto backtrack; - txt++; - } - break; - } - case CHARCLASS: - if (txt == endtxt) goto prefix_match; - if (! In_bitset(String_val(Field(cpool, Arg(instr))), *txt, c)) - goto backtrack; - txt++; - break; - case BOL: - if (txt > starttxt && txt[-1] != '\n') goto backtrack; - break; - case EOL: - if (txt < endtxt && *txt != '\n') goto backtrack; - break; - case WORDBOUNDARY: - /* At beginning and end of text: no - At beginning of text: OK if current char is a letter - At end of text: OK if previous char is a letter - Otherwise: - OK if previous char is a letter and current char not a letter - or previous char is not a letter and current char is a letter */ - if (txt == starttxt) { - if (txt == endtxt) goto prefix_match; - if (Is_word_letter(txt[0])) break; - goto backtrack; - } else if (txt == endtxt) { - if (Is_word_letter(txt[-1])) break; - goto backtrack; - } else { - if (Is_word_letter(txt[-1]) != Is_word_letter(txt[0])) break; - goto backtrack; - } - case BEGGROUP: { - int group_no = Arg(instr); - struct re_group * group = &(re_group[group_no]); - back.undo.loc = &(group->start); - back.undo.val = group->start; - group->start = txt; - goto push; - } - case ENDGROUP: { - int group_no = Arg(instr); - struct re_group * group = &(re_group[group_no]); - back.undo.loc = &(group->end); - back.undo.val = group->end; - group->end = txt; - goto push; - } - case REFGROUP: { - int group_no = Arg(instr); - struct re_group * group = &(re_group[group_no]); - unsigned char * s; - if (group->start == NULL || group->end == NULL) goto backtrack; - for (s = group->start; s < group->end; s++) { - if (txt == endtxt) goto prefix_match; - if (*s != *txt) goto backtrack; - txt++; - } - break; - } - case ACCEPT: - goto accept; - case SIMPLEOPT: { - char * set = String_val(Field(cpool, Arg(instr))); - if (txt < endtxt && In_bitset(set, *txt, c)) txt++; - break; - } - case SIMPLESTAR: { - char * set = String_val(Field(cpool, Arg(instr))); - while (txt < endtxt && In_bitset(set, *txt, c)) - txt++; - break; - } - case SIMPLEPLUS: { - char * set = String_val(Field(cpool, Arg(instr))); - if (txt == endtxt) goto prefix_match; - if (! In_bitset(set, *txt, c)) goto backtrack; - txt++; - while (txt < endtxt && In_bitset(set, *txt, c)) - txt++; - break; - } - case GOTO: - pc = pc + SignedArg(instr); - break; - case PUSHBACK: - back.pos.pc = Set_tag(pc + SignedArg(instr)); - back.pos.txt = txt; - goto push; - case SETMARK: { - int reg_no = Arg(instr); - unsigned char ** reg = &(re_register[reg_no]); - back.undo.loc = reg; - back.undo.val = *reg; - *reg = txt; - goto push; - } - case CHECKPROGRESS: { - int reg_no = Arg(instr); - if (re_register[reg_no] == txt) - goto backtrack; - break; - } - default: - assert(0); - } - /* Continue with next instruction */ - continue; - - push: - /* Push an item on the backtrack stack and continue with next instr */ - if (sp == stack->point + BACKTRACK_STACK_BLOCK_SIZE) { - struct backtrack_stack * newstack = - stat_alloc(sizeof(struct backtrack_stack)); - newstack->previous = stack; - stack = newstack; - sp = stack->point; - } - *sp = back; - sp++; - continue; - - prefix_match: - /* We get here when matching failed because the end of text - was encountered. */ - if (accept_partial_match) goto accept; - - backtrack: - /* We get here when matching fails. Backtrack to most recent saved - program point, undoing variable assignments on the way. */ - while (1) { - if (sp == stack->point) { - struct backtrack_stack * prevstack = stack->previous; - if (prevstack == NULL) return 0; - stat_free(stack); - stack = prevstack; - sp = stack->point + BACKTRACK_STACK_BLOCK_SIZE; - } - sp--; - if (Tag_is_set(sp->pos.pc)) { - pc = Clear_tag(sp->pos.pc); - txt = sp->pos.txt; - break; - } else { - *(sp->undo.loc) = sp->undo.val; - } - } - continue; - } - - accept: - /* We get here when the regexp was successfully matched */ - free_backtrack_stack(stack); - re_group[0].end = txt; - return 1; -} - -/* Allocate an integer array containing the positions of the matched groups. - Beginning of group #N is at 2N, end is at 2N+1. - Take position = -1 when group wasn't matched. */ - -static value re_alloc_groups(value re, value str) -{ - CAMLparam1(str); - CAMLlocal1(res); - unsigned char * starttxt = (unsigned char *) String_val(str); - int n = Numgroups(re); - int i; - struct re_group * group; - - res = alloc(n * 2, 0); - for (i = 0; i < n; i++) { - group = &(re_group[i]); - if (group->start == NULL || group->end == NULL) { - Field(res, i * 2) = Val_int(-1); - Field(res, i * 2 + 1) = Val_int(-1); - } else { - Field(res, i * 2) = Val_long(group->start - starttxt); - Field(res, i * 2 + 1) = Val_long(group->end - starttxt); - } - } - CAMLreturn(res); -} - -/* String matching and searching. All functions return the empty array - on failure, and an array of positions on success. */ - -CAMLprim value re_string_match(value re, value str, value pos) -{ - unsigned char * starttxt = &Byte_u(str, 0); - unsigned char * txt = &Byte_u(str, Long_val(pos)); - unsigned char * endtxt = &Byte_u(str, string_length(str)); - - if (txt < starttxt || txt > endtxt) - invalid_argument("Str.string_match"); - if (re_match(re, starttxt, txt, endtxt, 0)) { - return re_alloc_groups(re, str); - } else { - return Atom(0); - } -} - -CAMLprim value re_partial_match(value re, value str, value pos) -{ - unsigned char * starttxt = &Byte_u(str, 0); - unsigned char * txt = &Byte_u(str, Long_val(pos)); - unsigned char * endtxt = &Byte_u(str, string_length(str)); - - if (txt < starttxt || txt > endtxt) - invalid_argument("Str.string_partial_match"); - if (re_match(re, starttxt, txt, endtxt, 1)) { - return re_alloc_groups(re, str); - } else { - return Atom(0); - } -} - -CAMLprim value re_search_forward(value re, value str, value startpos) -{ - unsigned char * starttxt = &Byte_u(str, 0); - unsigned char * txt = &Byte_u(str, Long_val(startpos)); - unsigned char * endtxt = &Byte_u(str, string_length(str)); - unsigned char * startchars; - unsigned char c; - - if (txt < starttxt || txt > endtxt) - invalid_argument("Str.search_forward"); - if (Startchars(re) == -1) { - do { - if (re_match(re, starttxt, txt, endtxt, 0)) - return re_alloc_groups(re, str); - txt++; - } while (txt <= endtxt); - return Atom(0); - } else { - startchars = - (unsigned char *) String_val(Field(Cpool(re), Startchars(re))); - do { - while (txt < endtxt && startchars[*txt] == 0) txt++; - if (re_match(re, starttxt, txt, endtxt, 0)) - return re_alloc_groups(re, str); - txt++; - } while (txt <= endtxt); - return Atom(0); - } -} - -CAMLprim value re_search_backward(value re, value str, value startpos) -{ - unsigned char * starttxt = &Byte_u(str, 0); - unsigned char * txt = &Byte_u(str, Long_val(startpos)); - unsigned char * endtxt = &Byte_u(str, string_length(str)); - unsigned char * startchars; - unsigned char c; - - if (txt < starttxt || txt > endtxt) - invalid_argument("Str.search_backward"); - if (Startchars(re) == -1) { - do { - if (re_match(re, starttxt, txt, endtxt, 0)) - return re_alloc_groups(re, str); - txt--; - } while (txt >= starttxt); - return Atom(0); - } else { - startchars = - (unsigned char *) String_val(Field(Cpool(re), Startchars(re))); - do { - while (txt > starttxt && startchars[*txt] == 0) txt--; - if (re_match(re, starttxt, txt, endtxt, 0)) - return re_alloc_groups(re, str); - txt--; - } while (txt >= starttxt); - return Atom(0); - } -} - -/* Replacement */ - -CAMLprim value re_replacement_text(value repl, value groups, value orig) -{ - CAMLparam3(repl, groups, orig); - CAMLlocal1(res); - mlsize_t start, end, len, n; - char * p, * q; - int c; - - len = 0; - p = String_val(repl); - n = string_length(repl); - while (n > 0) { - c = *p++; n--; - if(c != '\\') - len++; - else { - if (n == 0) failwith("Str.replace: illegal backslash sequence"); - c = *p++; n--; - switch (c) { - case '\\': - len++; break; - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - c -= '0'; - if (c*2 >= Wosize_val(groups)) - failwith("Str.replace: reference to unmatched group"); - start = Long_val(Field(groups, c*2)); - end = Long_val(Field(groups, c*2 + 1)); - if (start == (mlsize_t) -1) - failwith("Str.replace: reference to unmatched group"); - len += end - start; - break; - default: - len += 2; break; - } - } - } - res = alloc_string(len); - p = String_val(repl); - q = String_val(res); - n = string_length(repl); - while (n > 0) { - c = *p++; n--; - if(c != '\\') - *q++ = c; - else { - c = *p++; n--; - switch (c) { - case '\\': - *q++ = '\\'; break; - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - c -= '0'; - start = Long_val(Field(groups, c*2)); - end = Long_val(Field(groups, c*2 + 1)); - len = end - start; - memmove (q, &Byte(orig, start), len); - q += len; - break; - default: - *q++ = '\\'; *q++ = c; break; - } - } - } - CAMLreturn(res); -} - diff --git a/otherlibs/systhreads/.cvsignore b/otherlibs/systhreads/.cvsignore deleted file mode 100644 index b175e39d68..0000000000 --- a/otherlibs/systhreads/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.x -thread.ml -so_locations diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend deleted file mode 100644 index 6fdbf1c669..0000000000 --- a/otherlibs/systhreads/.depend +++ /dev/null @@ -1,27 +0,0 @@ -posix.o: posix.c ../../byterun/alloc.h ../../byterun/misc.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/mlvalues.h ../../byterun/backtrace.h \ - ../../byterun/callback.h ../../byterun/custom.h ../../byterun/fail.h \ - ../../byterun/io.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/printexc.h ../../byterun/roots.h \ - ../../byterun/signals.h ../../byterun/stacks.h ../../byterun/sys.h -win32.o: win32.c ../../byterun/alloc.h ../../byterun/misc.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/mlvalues.h ../../byterun/backtrace.h \ - ../../byterun/callback.h ../../byterun/custom.h ../../byterun/fail.h \ - ../../byterun/io.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/printexc.h ../../byterun/roots.h \ - ../../byterun/signals.h ../../byterun/stacks.h ../../byterun/sys.h -condition.cmi: mutex.cmi -condition.cmo: mutex.cmi condition.cmi -condition.cmx: mutex.cmx condition.cmi -event.cmo: condition.cmi mutex.cmi event.cmi -event.cmx: condition.cmx mutex.cmx event.cmi -mutex.cmo: mutex.cmi -mutex.cmx: mutex.cmi -thread.cmo: thread.cmi -thread.cmx: thread.cmi -threadUnix.cmo: thread.cmi threadUnix.cmi -threadUnix.cmx: thread.cmx threadUnix.cmi diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile deleted file mode 100644 index 1b7eda46fc..0000000000 --- a/otherlibs/systhreads/Makefile +++ /dev/null @@ -1,102 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -include ../../config/Makefile - -CAMLC=../../ocamlcomp.sh -I ../unix -CAMLOPT=../../ocamlcompopt.sh -I ../unix -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A - -BYTECODE_C_OBJS=posix_b.o -NATIVECODE_C_OBJS=posix_n.o - -THREAD_OBJS= thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo - -GENFILES=thread.ml - -all: libthreads.a threads.cma - -allopt: libthreadsnat.a threads.cmxa - -libthreads.a: $(BYTECODE_C_OBJS) - $(MKLIB) -o threads $(BYTECODE_C_OBJS) - -posix_b.o: posix.c - $(BYTECC) -O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \ - -c posix.c - mv posix.o posix_b.o - -# Dynamic linking with -lpthread is risky on many platforms, so -# do not create a shared object for libthreadsnat. -libthreadsnat.a: $(NATIVECODE_C_OBJS) - $(AR) rc libthreadsnat.a $(NATIVECODE_C_OBJS) - -posix_n.o: posix.c - $(NATIVECC) -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) -c posix.c - mv posix.o posix_n.o - -threads.cma: $(THREAD_OBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -o threads $(THREAD_OBJS) \ - -cclib -lunix $(PTHREAD_LINK) - -# See remark above: force static linking of libthreadsnat.a -threads.cmxa: $(THREAD_OBJS:.cmo=.cmx) - $(CAMLOPT) -a -o threads.cmxa $(THREAD_OBJS:.cmo=.cmx) \ - -cclib -lthreadsnat -cclib -lunix -cclib "$(PTHREAD_LINK)" - -$(THREAD_OBJS:.cmo=.cmx): ../../ocamlopt - -thread.ml: thread_posix.ml - ln -s thread_posix.ml thread.ml - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.o *.a *.so - rm -f $(GENFILES) - -install: - if test -f dllthreads.so; then cp dllthreads.so $(STUBLIBDIR)/dllthreads.so; fi - cp libthreads.a $(LIBDIR)/libthreads.a - cd $(LIBDIR); $(RANLIB) libthreads.a - if test -d $(LIBDIR)/threads; then :; else mkdir $(LIBDIR)/threads; fi - cp $(THREAD_OBJS:.cmo=.cmi) threads.cma $(LIBDIR)/threads - rm -f $(LIBDIR)/threads/stdlib.cma - cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli $(LIBDIR) - -installopt: - cp libthreadsnat.a $(LIBDIR)/libthreadsnat.a - cd $(LIBDIR); $(RANLIB) libthreadsnat.a - cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.a $(LIBDIR)/threads - cd $(LIBDIR)/threads; $(RANLIB) threads.a - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c -g $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: $(GENFILES) - gcc -MM -I../../byterun *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend - -include .depend diff --git a/otherlibs/systhreads/Makefile.Mac b/otherlibs/systhreads/Makefile.Mac deleted file mode 100644 index e6e0277986..0000000000 --- a/otherlibs/systhreads/Makefile.Mac +++ /dev/null @@ -1,78 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Damien Doligez, projet Moscova, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# systhread library -# not supported yet: too many bugs in GUSI and in posix.c. - -C = sc -COptions = -includes unix -i ":::byterun:,:::config:,{GUSI}include:" -w 35 ¶ - {cdbgflag} -model far - -PPCC = mrc -PPCCOptions = -includes unix -i ":::byterun:,:::config:,{GUSI}include:" -w 35 ¶ - {cdbgflag} - -CAMLC = :::boot:ocamlrun :::ocamlc -I :::stdlib: -I ::unix: - -C_OBJS = posix.c.o -PPCC_OBJS = posix.c.x - -THREAD_OBJS = thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo -THREAD_INTF = thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi - -GENFILES = thread.ml - -all Ä libthreads.x libthreads.o threads.cma - -libthreads.x Ä {PPCC_OBJS} - ppclink {ldbgflag} -xm library -o libthreads.x {PPCC_OBJS} - -libthreads.o Ä {C_OBJS} - lib {ldbgflag} -o libthreads.o {C_OBJS} - -threads.cma Ä {THREAD_OBJS} - {CAMLC} -a -o threads.cma -custom {THREAD_OBJS} - -thread.ml Ä thread_posix.ml - duplicate -y thread_posix.ml thread.ml - -partialclean Ä - delete -i Å.cmÅ || set status 0 - -clean Ä partialclean - delete -i Å.[ox] || set status 0 - delete -i {GENFILES} - -install Ä - duplicate -y libthreads.x libthreads.o "{LIBDIR}" - if "`exists "{LIBDIR}threads"`" == "" - newfolder "{LIBDIR}threads" - end - duplicate -y {THREAD_INTF} threads.cma "{LIBDIR}threads" - duplicate -y thread.mli mutex.mli condition.mli event.mli threadUnix.mli ¶ - "{LIBDIR}" - -.cmi Ä .mli - {CAMLC} -c {COMPFLAGS} {depdir}{default}.mli - -.cmo Ä .ml - {CAMLC} -c {COMPFLAGS} {depdir}{default}.ml - -depend Ä {GENFILES} - begin - MakeDepend -w -objext .x Å.c - MakeDepend -w Å.c - :::boot:ocamlrun :::tools:ocamldep -I :::stdlib: -I ::unix: Å.mli Å.ml - end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend diff --git a/otherlibs/systhreads/Makefile.Mac.depend b/otherlibs/systhreads/Makefile.Mac.depend deleted file mode 100644 index e9a4ee135a..0000000000 --- a/otherlibs/systhreads/Makefile.Mac.depend +++ /dev/null @@ -1,131 +0,0 @@ -#*** Dependencies: Cut here *** -# These dependencies were produced at 23:43:37 on 27 fŽv 2001 by MakeDepend - -:posix.c.x Ä ¶ - :posix.c ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"memory.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:win32.c.x Ä ¶ - :win32.c ¶ - "{CIncludes}"windows.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"memory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"Quickdraw.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"AppleTalk.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"DateTimeUtils.h - -#*** Dependencies: Cut here *** -# These dependencies were produced at 23:43:42 on 27 fŽv 2001 by MakeDepend - -:posix.c.o Ä ¶ - :posix.c ¶ - "{CIncludes}"errno.h ¶ - "{CIncludes}"string.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"memory.h ¶ - "{CIncludes}"NullDef.h ¶ - "{CIncludes}"SizeTDef.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"MixedMode.h - -:win32.c.o Ä ¶ - :win32.c ¶ - "{CIncludes}"windows.h ¶ - "{CIncludes}"signal.h ¶ - "{CIncludes}"memory.h ¶ - "{CIncludes}"ConditionalMacros.h ¶ - "{CIncludes}"MacWindows.h ¶ - "{CIncludes}"MacMemory.h ¶ - "{CIncludes}"MacTypes.h ¶ - "{CIncludes}"Aliases.h ¶ - "{CIncludes}"AppleEvents.h ¶ - "{CIncludes}"Collections.h ¶ - "{CIncludes}"Drag.h ¶ - "{CIncludes}"Events.h ¶ - "{CIncludes}"Menus.h ¶ - "{CIncludes}"MixedMode.h ¶ - "{CIncludes}"QDOffscreen.h ¶ - "{CIncludes}"Quickdraw.h ¶ - "{CIncludes}"TextCommon.h ¶ - "{CIncludes}"Icons.h ¶ - "{CIncludes}"MacErrors.h ¶ - "{CIncludes}"AppleTalk.h ¶ - "{CIncludes}"Files.h ¶ - "{CIncludes}"Notification.h ¶ - "{CIncludes}"AEDataModel.h ¶ - "{CIncludes}"OSUtils.h ¶ - "{CIncludes}"Endian.h ¶ - "{CIncludes}"Fonts.h ¶ - "{CIncludes}"Processes.h ¶ - "{CIncludes}"Components.h ¶ - "{CIncludes}"QuickdrawText.h ¶ - "{CIncludes}"CodeFragments.h ¶ - "{CIncludes}"UTCUtils.h ¶ - "{CIncludes}"Finder.h ¶ - "{CIncludes}"Patches.h ¶ - "{CIncludes}"DateTimeUtils.h - -condition.cmiÄ mutex.cmi -thread.cmiÄ ::unix:unix.cmi -threadUnix.cmiÄ ::unix:unix.cmi -condition.cmoÄ mutex.cmi condition.cmi -condition.cmxÄ mutex.cmx condition.cmi -event.cmoÄ :::stdlib:array.cmi condition.cmi :::stdlib:list.cmi mutex.cmi ¶ - :::stdlib:queue.cmi :::stdlib:random.cmi event.cmi -event.cmxÄ :::stdlib:array.cmx condition.cmx :::stdlib:list.cmx mutex.cmx ¶ - :::stdlib:queue.cmx :::stdlib:random.cmx event.cmi -mutex.cmoÄ mutex.cmi -mutex.cmxÄ mutex.cmi -thread.cmoÄ :::stdlib:printexc.cmi :::stdlib:printf.cmi :::stdlib:sys.cmi ¶ - ::unix:unix.cmi thread.cmi -thread.cmxÄ :::stdlib:printexc.cmx :::stdlib:printf.cmx :::stdlib:sys.cmx ¶ - ::unix:unix.cmx thread.cmi -thread_posix.cmoÄ :::stdlib:printexc.cmi :::stdlib:printf.cmi ¶ - :::stdlib:sys.cmi ::unix:unix.cmi -thread_posix.cmxÄ :::stdlib:printexc.cmx :::stdlib:printf.cmx ¶ - :::stdlib:sys.cmx ::unix:unix.cmx -thread_win32.cmoÄ :::stdlib:printexc.cmi :::stdlib:printf.cmi ¶ - :::stdlib:sys.cmi ::unix:unix.cmi -thread_win32.cmxÄ :::stdlib:printexc.cmx :::stdlib:printf.cmx ¶ - :::stdlib:sys.cmx ::unix:unix.cmx -threadUnix.cmoÄ thread.cmi ::unix:unix.cmi threadUnix.cmi -threadUnix.cmxÄ thread.cmx ::unix:unix.cmx threadUnix.cmi diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt deleted file mode 100644 index 530a08e5eb..0000000000 --- a/otherlibs/systhreads/Makefile.nt +++ /dev/null @@ -1,96 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -include ../../config/Makefile - -# Compilation options -CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix -CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix - -THREAD_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo - -GENFILES=thread.ml - -all: dllthreads.dll libthreads.$(A) threads.cma - -allopt: libthreadsnat.$(A) threads.cmxa - -dllthreads.dll: win32_b.$(DO) - $(call MKDLL,dllthreads.dll,tmp.$(A),win32_b.$(DO) ../../byterun/ocamlrun.$(A)) - rm tmp.* - -libthreads.$(A): win32_b.$(SO) - $(call MKLIB,libthreads.$(A),win32_b.$(SO)) - -win32_b.$(DO): win32.c - $(BYTECC) -I../../byterun $(DLLCCCOMPOPTS) -c win32.c - mv win32.$(O) win32_b.$(DO) - -win32_b.$(SO): win32.c - $(BYTECC) -I../../byterun $(BYTECCCOMPOPTS) -c win32.c - mv win32.$(O) win32_b.$(SO) - -libthreadsnat.$(A): win32_n.$(O) - $(call MKLIB,libthreadsnat.$(A),win32_n.$(O)) - -win32_n.$(O): win32.c - $(NATIVECC) -DNATIVE_CODE -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) -c win32.c - mv win32.$(O) win32_n.$(O) - -threads.cma: $(THREAD_OBJS) - $(CAMLC) -a -o threads.cma $(THREAD_OBJS) \ - -dllib -lthreads -cclib -lthreads - -threads.cmxa: $(THREAD_OBJS:.cmo=.cmx) - $(CAMLOPT) -a -o threads.cmxa $(THREAD_OBJS:.cmo=.cmx) \ - -cclib -lthreadsnat - -$(THREAD_OBJS:.cmo=.cmx): ../../ocamlopt - -thread.ml: thread_win32.ml - cp thread_win32.ml thread.ml - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.dll *.$(A) *.$(O) - rm -f $(GENFILES) - -install: - cp dllthreads.dll $(STUBLIBDIR)/dllthreads.dll - cp libthreads.$(A) $(LIBDIR)/libthreads.$(A) - mkdir -p $(LIBDIR)/threads - cp $(THREAD_OBJS:.cmo=.cmi) threads.cma $(LIBDIR)/threads - rm -f $(LIBDIR)/threads/stdlib.cma - -installopt: - cp libthreadsnat.$(A) $(LIBDIR)/libthreadsnat.$(A) - cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.$(A) $(LIBDIR)/threads - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c -g $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: - -include .depend diff --git a/otherlibs/systhreads/Tests/Makefile b/otherlibs/systhreads/Tests/Makefile deleted file mode 100644 index 4d860b3e0c..0000000000 --- a/otherlibs/systhreads/Tests/Makefile +++ /dev/null @@ -1,44 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../../LICENSE.# -# # -######################################################################### - -# $Id$ - -PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \ - test7.byt test8.byt test9.byt testA.byt sieve.byt \ - testio.byt testsocket.byt testsignal.byt testsignal2.byt \ - torture.byt - -include ../../../config/Makefile - -CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../unix -I ../../../stdlib - -CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I .. -I ../../unix -I ../../../stdlib - -all: $(PROGS) - -allopt: $(PROGS:.byt=.out) - -clean: - rm -f *.cm* *.byt *.out - rm -f $(PROGS:.byt=.ml) - -%.byt: ../../threads/Tests/%.ml - cp ../../threads/Tests/$*.ml $*.ml - $(CAMLC) -custom -o $*.byt unix.cma threads.cma $*.ml ../libthreads.a ../../unix/libunix.a -cclib -lpthread - -%.out: ../../threads/Tests/%.ml - cp ../../threads/Tests/$*.ml $*.ml - $(CAMLOPT) -o $*.out unix.cmxa threads.cmxa $*.ml ../libthreadsnat.a ../../unix/libunix.a -cclib -lpthread - -$(PROGS): ../threads.cma ../libthreads.a -$(PROGS:.byt=.out): ../threads.cmxa ../libthreadsnat.a diff --git a/otherlibs/systhreads/Tests/Makefile.nt b/otherlibs/systhreads/Tests/Makefile.nt deleted file mode 100644 index bc3cf96afc..0000000000 --- a/otherlibs/systhreads/Tests/Makefile.nt +++ /dev/null @@ -1,43 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../../LICENSE.# -# # -######################################################################### - -# $Id$ - -PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \ - test7.byt test8.byt test9.byt testA.byt sieve.byt \ - testio.byt testsocket.byt testwait.byt testsignal.byt testsignal2.byt \ - torture.byt - -include ../../../config/Makefile - -CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../unix -I ../../../stdlib - -CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I .. -I ../../unix -I ../../../stdlib - -all: $(PROGS) - -allopt: $(PROGS:.byt=.out) - -clean: - rm -f *.cm* *.byt *.out - rm -f $(PROGS:.byt=.ml) - -%.byt: ../../threads/Tests/%.ml - cp ../../threads/Tests/$*.ml $*.ml - $(CAMLC) -custom -o $*.byt unix.cma threads.cma $*.ml ../libthreads.$(A) ../../unix/libunix.$(A) - -%.out: ../../threads/Tests/%.ml - cp ../../threads/Tests/$*.ml $*.ml - $(CAMLOPT) -o $*.out unix.cmxa threads.cmxa $*.ml ../libthreadsnat.$(A) ../../unix/libunix.$(A) -cclib -lpthread - -$(PROGS): ../threads.cma ../libthreads.$(A) diff --git a/otherlibs/systhreads/condition.ml b/otherlibs/systhreads/condition.ml deleted file mode 100644 index 6549c642d8..0000000000 --- a/otherlibs/systhreads/condition.ml +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* Caml Special Light *) -(* *) -(* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1995 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type t -external create: unit -> t = "caml_condition_new" -external wait: t -> Mutex.t -> unit = "caml_condition_wait" -external signal: t -> unit = "caml_condition_signal" -external broadcast: t -> unit = "caml_condition_broadcast" diff --git a/otherlibs/systhreads/condition.mli b/otherlibs/systhreads/condition.mli deleted file mode 100644 index 02c108b7b1..0000000000 --- a/otherlibs/systhreads/condition.mli +++ /dev/null @@ -1,53 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy and Damien Doligez, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Condition variables to synchronize between threads. - - Condition variables are used when one thread wants to wait until another - thread has finished doing something: the former thread ``waits'' on the - condition variable, the latter thread ``signals'' the condition when it - is done. Condition variables should always be protected by a mutex. - The typical use is (if [D] is a shared data structure, [m] its mutex, - and [c] is a condition variable): - {[ - Mutex.lock m; - while (* some predicate P over D is not satisfied *) do - Condition.wait c m - done; - (* Modify D *) - if (* the predicate P over D is now satified *) then Condition.signal c; - Mutex.unlock m - ]} -*) - -type t -(** The type of condition variables. *) - -val create : unit -> t -(** Return a new condition variable. *) - -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. - The mutex [m] is locked again before [wait] returns. *) - -val signal : t -> unit -(** [signal c] restarts one of the processes waiting on the - condition variable [c]. *) - -val broadcast : t -> unit -(** [broadcast c] restarts all processes waiting on the - condition variable [c]. *) diff --git a/otherlibs/systhreads/event.ml b/otherlibs/systhreads/event.ml deleted file mode 100644 index bd47d6526a..0000000000 --- a/otherlibs/systhreads/event.ml +++ /dev/null @@ -1,274 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* David Nowak and 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Events *) -type 'a basic_event = - { poll: unit -> bool; - (* If communication can take place immediately, return true. *) - suspend: unit -> unit; - (* Offer the communication on the channel and get ready - to suspend current process. *) - result: unit -> 'a } - (* Return the result of the communication *) - -type 'a behavior = int ref -> Condition.t -> int -> 'a basic_event - -type 'a event = - Communication of 'a behavior - | Choose of 'a event list - | WrapAbort of 'a event * (unit -> unit) - | Guard of (unit -> 'a event) - -(* Communication channels *) -type 'a channel = - { mutable writes_pending: 'a communication Queue.t; - (* All offers to write on it *) - mutable reads_pending: 'a communication Queue.t } - (* All offers to read from it *) - -(* Communication offered *) -and 'a communication = - { performed: int ref; (* -1 if not performed yet, set to the number *) - (* of the matching communication after rendez-vous. *) - condition: Condition.t; (* To restart the blocked thread. *) - mutable data: 'a option; (* The data sent or received. *) - event_number: int } (* Event number in select *) - -(* Create a channel *) - -let new_channel () = - { writes_pending = Queue.create(); - reads_pending = Queue.create() } - -(* Basic synchronization function *) - -let masterlock = Mutex.create() - -let do_aborts abort_env genev performed = - if abort_env <> [] then begin - if performed >= 0 then begin - let ids_done = snd genev.(performed) in - List.iter - (fun (id,f) -> if not (List.mem id ids_done) then f ()) - abort_env - end else begin - List.iter (fun (_,f) -> f ()) abort_env - end - end - -let basic_sync abort_env genev = - let performed = ref (-1) in - let condition = Condition.create() in - let bev = Array.create (Array.length genev) - (fst (genev.(0)) performed condition 0) in - for i = 1 to Array.length genev - 1 do - bev.(i) <- (fst genev.(i)) performed condition i - done; - (* See if any of the events is already activable *) - let rec poll_events i = - if i >= Array.length bev - then false - else bev.(i).poll() || poll_events (i+1) in - Mutex.lock masterlock; - if not (poll_events 0) then begin - (* Suspend on all events *) - for i = 0 to Array.length bev - 1 do bev.(i).suspend() done; - (* Wait until the condition is signalled *) - Condition.wait condition masterlock - end; - Mutex.unlock masterlock; - (* Extract the result *) - if abort_env = [] then - (* Preserve tail recursion *) - bev.(!performed).result() - else begin - let num = !performed in - let result = bev.(num).result() in - (* Handle the aborts and return the result *) - do_aborts abort_env genev num; - result - end - -(* Apply a random permutation on an array *) - -let scramble_array a = - let len = Array.length a in - if len = 0 then invalid_arg "Event.choose"; - for i = len - 1 downto 1 do - let j = Random.int (i + 1) in - let temp = a.(i) in a.(i) <- a.(j); a.(j) <- temp - done; - a - -(* Main synchronization function *) - -let gensym = let count = ref 0 in fun () -> incr count; !count - -let rec flatten_event - (abort_list : int list) - (accu : ('a behavior * int list) list) - (accu_abort : (int * (unit -> unit)) list) - ev = - match ev with - Communication bev -> ((bev,abort_list) :: accu) , accu_abort - | WrapAbort (ev,fn) -> - let id = gensym () in - flatten_event (id :: abort_list) accu ((id,fn)::accu_abort) ev - | Choose evl -> - let rec flatten_list accu' accu_abort'= function - ev :: l -> - let (accu'',accu_abort'') = - flatten_event abort_list accu' accu_abort' ev in - flatten_list accu'' accu_abort'' l - | [] -> (accu',accu_abort') in - flatten_list accu accu_abort evl - | Guard fn -> flatten_event abort_list accu accu_abort (fn ()) - -let sync ev = - let (evl,abort_env) = flatten_event [] [] [] ev in - basic_sync abort_env (scramble_array(Array.of_list evl)) - -(* Event polling -- like sync, but non-blocking *) - -let basic_poll abort_env genev = - let performed = ref (-1) in - let condition = Condition.create() in - let bev = Array.create(Array.length genev) - (fst genev.(0) performed condition 0) in - for i = 1 to Array.length genev - 1 do - bev.(i) <- fst genev.(i) performed condition i - done; - (* See if any of the events is already activable *) - let rec poll_events i = - if i >= Array.length bev - then false - else bev.(i).poll() || poll_events (i+1) in - Mutex.lock masterlock; - let ready = poll_events 0 in - if ready then begin - (* Extract the result *) - Mutex.unlock masterlock; - let result = Some(bev.(!performed).result()) in - do_aborts abort_env genev !performed; result - end else begin - (* Cancel the communication offers *) - performed := 0; - Mutex.unlock masterlock; - do_aborts abort_env genev (-1); - None - end - -let poll ev = - let (evl,abort_env) = flatten_event [] [] [] ev in - basic_poll abort_env (scramble_array(Array.of_list evl)) - -(* Remove all communication opportunities already synchronized *) - -let cleanup_queue q = - let q' = Queue.create() in - Queue.iter (fun c -> if !(c.performed) = -1 then Queue.add c q') q; - q' - -(* Event construction *) - -let always data = - Communication(fun performed condition evnum -> - { poll = (fun () -> performed := evnum; true); - suspend = (fun () -> ()); - result = (fun () -> data) }) - -let send channel data = - Communication(fun performed condition evnum -> - let wcomm = - { performed = performed; - condition = condition; - data = Some data; - event_number = evnum } in - { poll = (fun () -> - let rec poll () = - let rcomm = Queue.take channel.reads_pending in - if !(rcomm.performed) >= 0 then - poll () - else begin - rcomm.data <- wcomm.data; - performed := evnum; - rcomm.performed := rcomm.event_number; - Condition.signal rcomm.condition - end in - try - poll(); - true - with Queue.Empty -> - false); - suspend = (fun () -> - channel.writes_pending <- cleanup_queue channel.writes_pending; - Queue.add wcomm channel.writes_pending); - result = (fun () -> ()) }) - -let receive channel = - Communication(fun performed condition evnum -> - let rcomm = - { performed = performed; - condition = condition; - data = None; - event_number = evnum } in - { poll = (fun () -> - let rec poll () = - let wcomm = Queue.take channel.writes_pending in - if !(wcomm.performed) >= 0 then - poll () - else begin - rcomm.data <- wcomm.data; - performed := evnum; - wcomm.performed := wcomm.event_number; - Condition.signal wcomm.condition - end in - try - poll(); - true - with Queue.Empty -> - false); - suspend = (fun () -> - channel.reads_pending <- cleanup_queue channel.reads_pending; - Queue.add rcomm channel.reads_pending); - result = (fun () -> - match rcomm.data with - None -> invalid_arg "Event.receive" - | Some res -> res) }) - -let choose evl = Choose evl - -let wrap_abort ev fn = WrapAbort(ev,fn) - -let guard fn = Guard fn - -let rec wrap ev fn = - match ev with - Communication genev -> - Communication(fun performed condition evnum -> - let bev = genev performed condition evnum in - { poll = bev.poll; - suspend = bev.suspend; - result = (fun () -> fn(bev.result())) }) - | Choose evl -> - Choose(List.map (fun ev -> wrap ev fn) evl) - | WrapAbort (ev, f') -> - WrapAbort (wrap ev fn, f') - | Guard gu -> - Guard(fun () -> wrap (gu()) fn) - -(* Convenience functions *) - -let select evl = sync(Choose evl) diff --git a/otherlibs/systhreads/event.mli b/otherlibs/systhreads/event.mli deleted file mode 100644 index 21d5459a57..0000000000 --- a/otherlibs/systhreads/event.mli +++ /dev/null @@ -1,82 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* David Nowak and 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** First-class synchronous communication. - - This module implements synchronous inter-thread communications over - channels. As in John Reppy's Concurrent ML system, the communication - events are first-class values: they can be built and combined - independently before being offered for communication. -*) - -type 'a channel -(** The type of communication channels carrying values of type ['a]. *) - -val new_channel : unit -> 'a channel -(** Return a new channel. *) - -type 'a event -(** The type of communication events returning a result of type ['a]. *) - -(** [send ch v] returns the event consisting in sending the value [v] - over the channel [ch]. The result value of this event is [()]. *) -val send : 'a channel -> 'a -> unit event - -(** [receive ch] returns the event consisting in receiving a value - from the channel [ch]. The result value of this event is the - value received. *) -val receive : 'a channel -> 'a event - -val always : 'a -> 'a event -(** [always v] returns an event that is always ready for - synchronization. The result value of this event is [v]. *) - -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 -> ('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 -> (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. *) - -val guard : (unit -> 'a event) -> 'a event -(** [guard fn] returns the event that, when synchronized, computes - [fn()] and behaves as the resulting event. This allows to - compute events with side-effects at the time of the synchronization - operation. *) - -val sync : 'a event -> 'a -(** ``Synchronize'' on an event: offer all the communication - possibilities specified in the event to the outside world, - and block until one of the communications succeed. The result - value of that communication is returned. *) - -val select : 'a event list -> 'a -(** ``Synchronize'' on an alternative of events. - [select evl] is shorthand for [sync(choose evl)]. *) - -val poll : 'a event -> 'a option -(** Non-blocking version of {!Event.sync}: offer all the communication - possibilities specified in the event to the outside world, - and if one can take place immediately, perform it and return - [Some r] where [r] is the result value of that communication. - Otherwise, return [None] without blocking. *) - diff --git a/otherlibs/systhreads/mutex.ml b/otherlibs/systhreads/mutex.ml deleted file mode 100644 index 4e108f4a9f..0000000000 --- a/otherlibs/systhreads/mutex.ml +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* Caml Special Light *) -(* *) -(* Xavier Leroy and Pascal Cuoq, INRIA Rocquencourt *) -(* *) -(* Copyright 1995 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type t -external create: unit -> t = "caml_mutex_new" -external lock: t -> unit = "caml_mutex_lock" -external try_lock: t -> bool = "caml_mutex_try_lock" -external unlock: t -> unit = "caml_mutex_unlock" diff --git a/otherlibs/systhreads/mutex.mli b/otherlibs/systhreads/mutex.mli deleted file mode 100644 index 0c41c843e8..0000000000 --- a/otherlibs/systhreads/mutex.mli +++ /dev/null @@ -1,50 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy and Damien Doligez, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Locks for mutual exclusion. - - Mutexes (mutual-exclusion locks) are used to implement critical sections - and protect shared mutable data structures against concurrent accesses. - The typical use is (if [m] is the mutex associated with the data structure - [D]): - {[ - Mutex.lock m; - (* Critical section that operates over D *); - Mutex.unlock m - ]} -*) - -type t -(** The type of mutexes. *) - -val create : unit -> t -(** Return a new mutex. *) - -val lock : t -> unit -(** Lock the given mutex. Only one thread can have the mutex locked - at any time. A thread that attempts to lock a mutex already locked - by another thread will suspend until the other thread unlocks - the mutex. *) - -val try_lock : t -> bool -(** Same as {!Mutex.lock}, but does not suspend the calling thread if - the mutex is already locked: just return [false] immediately - in that case. If the mutex is unlocked, lock it and - return [true]. *) - -val unlock : t -> unit -(** Unlock the given mutex. Other threads suspended trying to lock - the mutex will restart. *) - diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c deleted file mode 100644 index cf5f90dfab..0000000000 --- a/otherlibs/systhreads/posix.c +++ /dev/null @@ -1,820 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ -/* */ -/* Copyright 1995 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Thread interface for POSIX 1003.1c threads */ - -#include <errno.h> -#include <string.h> -#include <stdio.h> -#include <stdlib.h> -#include <pthread.h> -#ifdef __sun -#define _POSIX_PTHREAD_SEMANTICS -#endif -#include <signal.h> -#include <sys/time.h> -#ifdef __linux__ -#include <unistd.h> -#endif -#include "alloc.h" -#include "backtrace.h" -#include "callback.h" -#include "custom.h" -#include "fail.h" -#include "io.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "printexc.h" -#include "roots.h" -#include "signals.h" -#ifdef NATIVE_CODE -#include "stack.h" -#else -#include "stacks.h" -#endif -#include "sys.h" - -/* Initial size of stack when a thread is created (4 Ko) */ -#define Thread_stack_size (Stack_size / 4) - -/* Max computation time before rescheduling, in microseconds (50ms) */ -#define Thread_timeout 50000 - -/* The ML value describing a thread (heap-allocated) */ - -struct caml_thread_descr { - value ident; /* Unique integer ID */ - value start_closure; /* The closure to start this thread */ - value terminated; /* Mutex held while the thread is running */ -}; - -#define Ident(v) (((struct caml_thread_descr *)(v))->ident) -#define Start_closure(v) (((struct caml_thread_descr *)(v))->start_closure) -#define Terminated(v) (((struct caml_thread_descr *)(v))->terminated) - -/* The infos on threads (allocated via malloc()) */ - -struct caml_thread_struct { - pthread_t pthread; /* The Posix thread id */ - value descr; /* The heap-allocated descriptor (root) */ - struct caml_thread_struct * next; /* Double linking of running threads */ - struct caml_thread_struct * prev; -#ifdef NATIVE_CODE - char * bottom_of_stack; /* Saved value of caml_bottom_of_stack */ - unsigned long last_retaddr; /* Saved value of caml_last_return_address */ - value * gc_regs; /* Saved value of caml_gc_regs */ - char * exception_pointer; /* Saved value of caml_exception_pointer */ - struct caml__roots_block * local_roots; /* Saved value of local_roots */ - struct longjmp_buffer * exit_buf; /* For thread exit */ -#else - value * stack_low; /* The execution stack for this thread */ - value * stack_high; - value * stack_threshold; - value * sp; /* Saved value of extern_sp for this thread */ - value * trapsp; /* Saved value of trapsp for this thread */ - struct caml__roots_block * local_roots; /* Saved value of local_roots */ - struct longjmp_buffer * external_raise; /* Saved external_raise */ - int backtrace_pos; /* Saved backtrace_pos */ - code_t * backtrace_buffer; /* Saved backtrace_buffer */ - value backtrace_last_exn; /* Saved backtrace_last_exn (root) */ -#endif -}; - -typedef struct caml_thread_struct * caml_thread_t; - -/* The descriptor for the currently executing thread */ - -static caml_thread_t curr_thread = NULL; - -/* The global mutex used to ensure that at most one thread is running - Caml code */ -static pthread_mutex_t caml_mutex; - -/* The key used for storing the thread descriptor in the specific data - of the corresponding Posix thread. */ -static pthread_key_t thread_descriptor_key; - -/* The key used for unlocking I/O channels on exceptions */ -static pthread_key_t last_channel_locked_key; - -/* Identifier for next thread creation */ -static long thread_next_ident = 0; - -/* Forward declarations */ -value caml_threadstatus_new (void); -void caml_threadstatus_terminate (value); -int caml_threadstatus_wait (value); -static void caml_pthread_check (int, char *); - -/* Imports for the native-code compiler */ -extern struct longjmp_buffer caml_termination_jmpbuf; -extern void (*caml_termination_hook)(void *); - -/* Hook for scanning the stacks of the other threads */ - -static void (*prev_scan_roots_hook) (scanning_action); - -static void caml_thread_scan_roots(scanning_action action) -{ - caml_thread_t th; - - th = curr_thread; - do { - (*action)(th->descr, &th->descr); -#ifndef NATIVE_CODE - (*action)(th->backtrace_last_exn, &th->backtrace_last_exn); -#endif - /* Don't rescan the stack of the current thread, it was done already */ - if (th != curr_thread) { -#ifdef NATIVE_CODE - if (th->bottom_of_stack != NULL) - do_local_roots(action, th->bottom_of_stack, th->last_retaddr, - th->gc_regs, th->local_roots); -#else - do_local_roots(action, th->sp, th->stack_high, th->local_roots); -#endif - } - th = th->next; - } while (th != curr_thread); - /* Hook */ - if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action); -} - -/* Hooks for enter_blocking_section and leave_blocking_section */ - -static void (*prev_enter_blocking_section_hook) () = NULL; -static void (*prev_leave_blocking_section_hook) () = NULL; - -static void caml_thread_enter_blocking_section(void) -{ - if (prev_enter_blocking_section_hook != NULL) - (*prev_enter_blocking_section_hook)(); - /* Save the stack-related global variables in the thread descriptor - of the current thread */ -#ifdef NATIVE_CODE - curr_thread->bottom_of_stack = caml_bottom_of_stack; - curr_thread->last_retaddr = caml_last_return_address; - curr_thread->gc_regs = caml_gc_regs; - curr_thread->exception_pointer = caml_exception_pointer; - curr_thread->local_roots = local_roots; -#else - curr_thread->stack_low = stack_low; - curr_thread->stack_high = stack_high; - curr_thread->stack_threshold = stack_threshold; - curr_thread->sp = extern_sp; - curr_thread->trapsp = trapsp; - curr_thread->local_roots = local_roots; - curr_thread->external_raise = external_raise; - curr_thread->backtrace_pos = backtrace_pos; - curr_thread->backtrace_buffer = backtrace_buffer; - curr_thread->backtrace_last_exn = backtrace_last_exn; -#endif - /* Release the global mutex */ - pthread_mutex_unlock(&caml_mutex); -} - -static void caml_thread_leave_blocking_section(void) -{ - /* Re-acquire the global mutex */ - pthread_mutex_lock(&caml_mutex); - /* Update curr_thread to point to the thread descriptor corresponding - to the thread currently executing */ - curr_thread = pthread_getspecific(thread_descriptor_key); - /* Restore the stack-related global variables */ -#ifdef NATIVE_CODE - caml_bottom_of_stack= curr_thread->bottom_of_stack; - caml_last_return_address = curr_thread->last_retaddr; - caml_gc_regs = curr_thread->gc_regs; - caml_exception_pointer = curr_thread->exception_pointer; - local_roots = curr_thread->local_roots; -#else - stack_low = curr_thread->stack_low; - stack_high = curr_thread->stack_high; - stack_threshold = curr_thread->stack_threshold; - extern_sp = curr_thread->sp; - trapsp = curr_thread->trapsp; - local_roots = curr_thread->local_roots; - external_raise = curr_thread->external_raise; - backtrace_pos = curr_thread->backtrace_pos; - backtrace_buffer = curr_thread->backtrace_buffer; - backtrace_last_exn = curr_thread->backtrace_last_exn; -#endif - if (prev_leave_blocking_section_hook != NULL) - (*prev_leave_blocking_section_hook)(); -} - -/* Hooks for I/O locking */ - -static void caml_io_mutex_free(struct channel *chan) -{ - pthread_mutex_t * mutex = chan->mutex; - if (mutex != NULL) { - pthread_mutex_destroy(mutex); - stat_free((char *) mutex); - } -} - -static void caml_io_mutex_lock(struct channel *chan) -{ - if (chan->mutex == NULL) { - pthread_mutex_t * mutex = - (pthread_mutex_t *) stat_alloc(sizeof(pthread_mutex_t)); - pthread_mutex_init(mutex, NULL); - chan->mutex = (void *) mutex; - } - enter_blocking_section(); - pthread_mutex_lock(chan->mutex); - /* Problem: if a signal occurs at this point, - and the signal handler raises an exception, we will not - unlock the mutex. The alternative (doing the setspecific - before locking the mutex is also incorrect, since we could - then unlock a mutex that is unlocked or locked by someone else. */ - pthread_setspecific(last_channel_locked_key, (void *) chan); - leave_blocking_section(); -} - -static void caml_io_mutex_unlock(struct channel *chan) -{ - pthread_mutex_unlock(chan->mutex); - pthread_setspecific(last_channel_locked_key, NULL); -} - -static void caml_io_mutex_unlock_exn(void) -{ - struct channel * chan = pthread_getspecific(last_channel_locked_key); - if (chan != NULL) caml_io_mutex_unlock(chan); -} - -/* The "tick" thread fakes a SIGVTALRM signal at regular intervals. */ - -static void * caml_thread_tick(void * arg) -{ - struct timeval timeout; - sigset_t mask; -#ifdef __linux__ - int tickcount = 0; -#endif - - /* Block all signals so that we don't try to execute - a Caml signal handler */ - sigfillset(&mask); - pthread_sigmask(SIG_BLOCK, &mask, NULL); - while(1) { - /* select() seems to be the most efficient way to suspend the - thread for sub-second intervals */ - timeout.tv_sec = 0; - timeout.tv_usec = Thread_timeout; - select(0, NULL, NULL, NULL, &timeout); - /* This signal should never cause a callback, so don't go through - handle_signal(), tweak the global variable directly. */ - if (pending_signal == 0) pending_signal = SIGVTALRM; -#ifdef NATIVE_CODE - young_limit = young_end; -#else - something_to_do = 1; -#endif -#ifdef __linux__ - /* Hack around LinuxThreads' non-standard signal handling: - if program is killed on a signal, e.g. SIGINT, the current - thread will not die on this signal (because of the signal blocking - above). Hence, periodically check that the thread manager (our - parent process) still exists. */ - tickcount++; - if (tickcount >= 2000000 / Thread_timeout) { /* every 2 secs approx */ - tickcount = 0; - if (getppid() == 1) pthread_exit(NULL); - } -#endif - } - return NULL; /* prevents compiler warning */ -} - -/* Initialize the thread machinery */ - -value caml_thread_initialize(value unit) /* ML */ -{ - pthread_t tick_pthread; - pthread_attr_t attr; - value mu = Val_unit; - value descr; - - /* Protect against repeated initialization (PR#1325) */ - if (curr_thread != NULL) return Val_unit; - Begin_root (mu); - /* Initialize the main mutex */ - caml_pthread_check(pthread_mutex_init(&caml_mutex, NULL), - "Thread.init"); - pthread_mutex_lock(&caml_mutex); - /* Initialize the keys */ - pthread_key_create(&thread_descriptor_key, NULL); - pthread_key_create(&last_channel_locked_key, NULL); - /* Create and initialize the termination semaphore */ - mu = caml_threadstatus_new(); - /* Create a descriptor for the current thread */ - descr = alloc_small(3, 0); - Ident(descr) = Val_long(thread_next_ident); - Start_closure(descr) = Val_unit; - Terminated(descr) = mu; - thread_next_ident++; - /* Create an info block for the current thread */ - curr_thread = - (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct)); - curr_thread->pthread = pthread_self(); - curr_thread->descr = descr; - curr_thread->next = curr_thread; - curr_thread->prev = curr_thread; -#ifdef NATIVE_CODE - curr_thread->exit_buf = &caml_termination_jmpbuf; -#endif - /* The stack-related fields will be filled in at the next - enter_blocking_section */ - /* Associate the thread descriptor with the thread */ - pthread_setspecific(thread_descriptor_key, (void *) curr_thread); - /* Set up the hooks */ - prev_scan_roots_hook = scan_roots_hook; - scan_roots_hook = caml_thread_scan_roots; - prev_enter_blocking_section_hook = enter_blocking_section_hook; - enter_blocking_section_hook = caml_thread_enter_blocking_section; - prev_leave_blocking_section_hook = leave_blocking_section_hook; - leave_blocking_section_hook = caml_thread_leave_blocking_section; -#ifdef NATIVE_CODE - caml_termination_hook = pthread_exit; -#endif - channel_mutex_free = caml_io_mutex_free; - channel_mutex_lock = caml_io_mutex_lock; - channel_mutex_unlock = caml_io_mutex_unlock; - channel_mutex_unlock_exn = caml_io_mutex_unlock_exn; - /* Fork the tick thread */ - pthread_attr_init(&attr); - pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); - caml_pthread_check( - pthread_create(&tick_pthread, &attr, caml_thread_tick, NULL), - "Thread.init"); - End_roots(); - return Val_unit; -} - -/* Thread cleanup at termination */ - -static void caml_thread_stop(void) -{ - caml_thread_t th = curr_thread; - - /* Signal that the thread has terminated */ - caml_threadstatus_terminate(Terminated(th->descr)); - /* Remove th from the doubly-linked list of threads */ - th->next->prev = th->prev; - th->prev->next = th->next; - /* Release the main mutex (forever) */ - async_signal_mode = 1; - pthread_mutex_unlock(&caml_mutex); -#ifndef NATIVE_CODE - /* Free the memory resources */ - stat_free(th->stack_low); - if (th->backtrace_buffer != NULL) free(th->backtrace_buffer); -#endif - /* Free the thread descriptor */ - stat_free(th); -} - -/* Create a thread */ - -static void * caml_thread_start(void * arg) -{ - caml_thread_t th = (caml_thread_t) arg; - value clos; - struct longjmp_buffer termination_buf; - - /* Associate the thread descriptor with the thread */ - pthread_setspecific(thread_descriptor_key, (void *) th); - /* Acquire the global mutex and set up the stack variables */ - leave_blocking_section(); -#ifdef NATIVE_CODE - /* Setup termination handler (for caml_thread_exit) */ - if (sigsetjmp(termination_buf.buf, 0) == 0) { - th->exit_buf = &termination_buf; -#endif - /* Callback the closure */ - clos = Start_closure(th->descr); - modify(&(Start_closure(th->descr)), Val_unit); - callback_exn(clos, Val_unit); - caml_thread_stop(); -#ifdef NATIVE_CODE - } -#endif - /* The thread now stops running */ - return NULL; -} - -value caml_thread_new(value clos) /* ML */ -{ - pthread_attr_t attr; - caml_thread_t th; - value mu = Val_unit; - value descr; - int err; - - Begin_roots2 (clos, mu) - /* Create and initialize the termination semaphore */ - mu = caml_threadstatus_new(); - /* Create a descriptor for the new thread */ - descr = alloc_small(3, 0); - Ident(descr) = Val_long(thread_next_ident); - Start_closure(descr) = clos; - Terminated(descr) = mu; - thread_next_ident++; - /* Create an info block for the current thread */ - th = (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct)); - th->descr = descr; -#ifdef NATIVE_CODE - th->bottom_of_stack = NULL; - th->exception_pointer = NULL; - th->local_roots = NULL; -#else - /* Allocate the stacks */ - th->stack_low = (value *) stat_alloc(Thread_stack_size); - th->stack_high = th->stack_low + Thread_stack_size / sizeof(value); - th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value); - th->sp = th->stack_high; - th->trapsp = th->stack_high; - th->local_roots = NULL; - th->external_raise = NULL; - th->backtrace_pos = 0; - th->backtrace_buffer = NULL; - th->backtrace_last_exn = Val_unit; -#endif - /* Add thread info block to the list of threads */ - th->next = curr_thread->next; - th->prev = curr_thread; - curr_thread->next->prev = th; - curr_thread->next = th; - /* Fork the new thread */ - pthread_attr_init(&attr); - pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); - err = pthread_create(&th->pthread, &attr, caml_thread_start, (void *) th); - if (err != 0) { - /* Fork failed, remove thread info block from list of threads */ - th->next->prev = curr_thread; - curr_thread->next = th->next; -#ifndef NATIVE_CODE - stat_free(th->stack_low); -#endif - stat_free(th); - caml_pthread_check(err, "Thread.create"); - } - End_roots(); - return descr; -} - -/* Return the current thread */ - -value caml_thread_self(value unit) /* ML */ -{ - if (curr_thread == NULL) invalid_argument("Thread.self: not initialized"); - return curr_thread->descr; -} - -/* Return the identifier of a thread */ - -value caml_thread_id(value th) /* ML */ -{ - return Ident(th); -} - -/* Print uncaught exception and backtrace */ - -value caml_thread_uncaught_exception(value exn) /* ML */ -{ - char * msg = format_caml_exception(exn); - fprintf(stderr, "Thread %d killed on uncaught exception %s\n", - Int_val(Ident(curr_thread->descr)), msg); - free(msg); -#ifndef NATIVE_CODE - if (backtrace_active) print_exception_backtrace(); -#endif - fflush(stderr); - return Val_unit; -} - -/* Terminate current thread */ - -value caml_thread_exit(value unit) /* ML */ -{ -#ifdef NATIVE_CODE - /* We cannot call pthread_exit here because on some systems this - raises a C++ exception, and ocamlopt-generated stack frames - cannot be unwound. Instead, we longjmp to the thread creation - point (in caml_thread_start) or to the point in caml_main - where caml_termination_hook will be called. */ - struct longjmp_buffer * exit_buf; - if (curr_thread == NULL) invalid_argument("Thread.exit: not initialized"); - exit_buf = curr_thread->exit_buf; - caml_thread_stop(); - siglongjmp(exit_buf->buf, 1); -#else - /* No such problem in bytecode */ - if (curr_thread == NULL) invalid_argument("Thread.exit: not initialized"); - caml_thread_stop(); - pthread_exit(NULL); -#endif - return Val_unit; /* not reached */ -} - -/* Allow re-scheduling */ - -value caml_thread_yield(value unit) /* ML */ -{ - enter_blocking_section(); - sched_yield(); - leave_blocking_section(); - return Val_unit; -} - -/* Suspend the current thread until another thread terminates */ - -value caml_thread_join(value th) /* ML */ -{ - int retcode = caml_threadstatus_wait(Terminated(th)); - caml_pthread_check(retcode, "Thread.join"); - return Val_unit; -} - -/* Mutex operations */ - -#define Mutex_val(v) (* ((pthread_mutex_t **) Data_custom_val(v))) -#define Max_mutex_number 1000 - -static void caml_mutex_finalize(value wrapper) -{ - pthread_mutex_t * mut = Mutex_val(wrapper); - pthread_mutex_destroy(mut); - stat_free(mut); -} - -static int caml_mutex_condition_compare(value wrapper1, value wrapper2) -{ - pthread_mutex_t * mut1 = Mutex_val(wrapper1); - pthread_mutex_t * mut2 = Mutex_val(wrapper2); - return mut1 == mut2 ? 0 : mut1 < mut2 ? -1 : 1; -} - -static struct custom_operations caml_mutex_ops = { - "_mutex", - caml_mutex_finalize, - caml_mutex_condition_compare, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; - -value caml_mutex_new(value unit) /* ML */ -{ - pthread_mutex_t * mut; - value wrapper; - mut = stat_alloc(sizeof(pthread_mutex_t)); - caml_pthread_check(pthread_mutex_init(mut, NULL), "Mutex.create"); - wrapper = alloc_custom(&caml_mutex_ops, sizeof(pthread_mutex_t *), - 1, Max_mutex_number); - Mutex_val(wrapper) = mut; - return wrapper; -} - -value caml_mutex_lock(value wrapper) /* ML */ -{ - int retcode; - pthread_mutex_t * mut = Mutex_val(wrapper); - Begin_root(wrapper) /* prevent the deallocation of mutex */ - enter_blocking_section(); - retcode = pthread_mutex_lock(mut); - leave_blocking_section(); - End_roots(); - caml_pthread_check(retcode, "Mutex.lock"); - return Val_unit; -} - -value caml_mutex_unlock(value wrapper) /* ML */ -{ - int retcode; - pthread_mutex_t * mut = Mutex_val(wrapper); - Begin_root(wrapper) /* prevent the deallocation of mutex */ - enter_blocking_section(); - retcode = pthread_mutex_unlock(mut); - leave_blocking_section(); - End_roots(); - caml_pthread_check(retcode, "Mutex.unlock"); - return Val_unit; -} - -value caml_mutex_try_lock(value wrapper) /* ML */ -{ - int retcode; - pthread_mutex_t * mut = Mutex_val(wrapper); - retcode = pthread_mutex_trylock(mut); - if (retcode == EBUSY) return Val_false; - caml_pthread_check(retcode, "Mutex.try_lock"); - return Val_true; -} - -/* Conditions operations */ - -#define Condition_val(v) (* ((pthread_cond_t **) Data_custom_val(v))) -#define Max_condition_number 1000 - -static void caml_condition_finalize(value wrapper) -{ - pthread_cond_t * cond = Condition_val(wrapper); - pthread_cond_destroy(cond); - stat_free(cond); -} - -static struct custom_operations caml_condition_ops = { - "_condition", - caml_condition_finalize, - caml_mutex_condition_compare, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; - -value caml_condition_new(value unit) /* ML */ -{ - pthread_cond_t * cond; - value wrapper; - cond = stat_alloc(sizeof(pthread_cond_t)); - caml_pthread_check(pthread_cond_init(cond, NULL), "Condition.create"); - wrapper = alloc_custom(&caml_condition_ops, sizeof(pthread_cond_t *), - 1, Max_condition_number); - Condition_val(wrapper) = cond; - return wrapper; -} - -value caml_condition_wait(value wcond, value wmut) /* ML */ -{ - int retcode; - pthread_cond_t * cond = Condition_val(wcond); - pthread_mutex_t * mut = Mutex_val(wmut); - Begin_roots2(wcond, wmut) /* prevent deallocation of cond and mutex */ - enter_blocking_section(); - retcode = pthread_cond_wait(cond, mut); - leave_blocking_section(); - End_roots(); - caml_pthread_check(retcode, "Condition.wait"); - return Val_unit; -} - -value caml_condition_signal(value wrapper) /* ML */ -{ - int retcode; - pthread_cond_t * cond = Condition_val(wrapper); - Begin_root(wrapper) /* prevent deallocation of condition */ - enter_blocking_section(); - retcode = pthread_cond_signal(cond); - leave_blocking_section(); - End_roots(); - caml_pthread_check(retcode, "Condition.signal"); - return Val_unit; -} - -value caml_condition_broadcast(value wrapper) /* ML */ -{ - int retcode; - pthread_cond_t * cond = Condition_val(wrapper); - Begin_root(wrapper) /* prevent deallocation of condition */ - enter_blocking_section(); - retcode = pthread_cond_broadcast(cond); - leave_blocking_section(); - End_roots(); - caml_pthread_check(retcode, "Condition.broadcast"); - return Val_unit; -} - -/* Thread status blocks */ - -struct caml_threadstatus { - pthread_mutex_t lock; /* mutex for mutual exclusion */ - enum { ALIVE, TERMINATED } status; /* status of thread */ - pthread_cond_t terminated; /* signaled when thread terminates */ -}; - -#define Threadstatus_val(v) \ - (* ((struct caml_threadstatus **) Data_custom_val(v))) -#define Max_threadstatus_number 500 - -static void caml_threadstatus_finalize(value wrapper) -{ - struct caml_threadstatus * ts = Threadstatus_val(wrapper); - pthread_mutex_destroy(&ts->lock); - pthread_cond_destroy(&ts->terminated); - stat_free(ts); -} - -static struct custom_operations caml_threadstatus_ops = { - "_threadstatus", - caml_threadstatus_finalize, - caml_mutex_condition_compare, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; - -value caml_threadstatus_new (void) -{ - struct caml_threadstatus * ts; - value wrapper; - ts = stat_alloc(sizeof(struct caml_threadstatus)); - caml_pthread_check(pthread_mutex_init(&ts->lock, NULL), "Thread.create"); - caml_pthread_check(pthread_cond_init(&ts->terminated, NULL), - "Thread.create"); - ts->status = ALIVE; - wrapper = alloc_custom(&caml_threadstatus_ops, - sizeof(struct caml_threadstatus *), - 1, Max_threadstatus_number); - Threadstatus_val(wrapper) = ts; - return wrapper; -} - -void caml_threadstatus_terminate (value wrapper) -{ - struct caml_threadstatus * ts = Threadstatus_val(wrapper); - pthread_mutex_lock(&ts->lock); - ts->status = TERMINATED; - pthread_mutex_unlock(&ts->lock); - pthread_cond_broadcast(&ts->terminated); -} - -int caml_threadstatus_wait (value wrapper) -{ - struct caml_threadstatus * ts = Threadstatus_val(wrapper); - int retcode; - - Begin_roots1(wrapper) /* prevent deallocation of ts */ - enter_blocking_section(); - retcode = pthread_mutex_lock(&ts->lock); - if (retcode != 0) goto error; - while (ts->status != TERMINATED) { - retcode = pthread_cond_wait(&ts->terminated, &ts->lock); - if (retcode != 0) goto error; - } - retcode = pthread_mutex_unlock(&ts->lock); - error: - leave_blocking_section(); - End_roots(); - return retcode; -} - -/* Synchronous signal wait */ - -value caml_wait_signal(value sigs) /* ML */ -{ -#ifdef HAS_SIGWAIT - sigset_t set; - int retcode, signo; - - sigemptyset(&set); - while (sigs != Val_int(0)) { - int sig = convert_signal_number(Int_val(Field(sigs, 0))); - sigaddset(&set, sig); - sigs = Field(sigs, 1); - } - enter_blocking_section(); - retcode = sigwait(&set, &signo); - leave_blocking_section(); - caml_pthread_check(retcode, "Thread.wait_signal"); - return Val_int(signo); -#else - invalid_argument("Thread.wait_signal not implemented"); - return Val_int(0); /* not reached */ -#endif -} - -/* Error report */ - -static void caml_pthread_check(int retcode, char *msg) -{ - char * err; - int errlen, msglen; - value str; - - if (retcode == 0) return; - err = strerror(retcode); - msglen = strlen(msg); - errlen = strlen(err); - str = alloc_string(msglen + 2 + errlen); - memmove (&Byte(str, 0), msg, msglen); - memmove (&Byte(str, msglen), ": ", 2); - memmove (&Byte(str, msglen + 2), err, errlen); - raise_sys_error(str); -} diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli deleted file mode 100644 index fbc3d6a8cf..0000000000 --- a/otherlibs/systhreads/thread.mli +++ /dev/null @@ -1,111 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1995 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Lightweight threads for Posix [1003.1c] and Win32. *) - -type t -(** The type of thread handles. *) - -(** {6 Thread creation and termination} *) - -val create : ('a -> 'b) -> 'a -> t -(** [Thread.create funct arg] creates a new thread of control, - in which the function application [funct arg] - is executed concurrently with the other threads of the program. - The application of [Thread.create] - returns the handle of the newly created thread. - The new thread terminates when the application [funct arg] - returns, either normally or by raising an uncaught exception. - In the latter case, the exception is printed on standard error, - but not propagated back to the parent thread. Similarly, the - result of the application [funct arg] is discarded and not - directly accessible to the parent thread. *) - -external self : unit -> t = "caml_thread_self" -(** Return the thread currently executing. *) - -external id : t -> int = "caml_thread_id" -(** Return the identifier of the given thread. A thread identifier - is an integer that identifies uniquely the thread. - It can be used to build data structures indexed by threads. *) - -val exit : unit -> unit -(** Terminate prematurely the currently executing thread. *) - -val kill : t -> unit -(** Terminate prematurely the thread whose handle is given. *) - -(** {6 Suspending threads} *) - -val delay: float -> unit -(** [delay d] suspends the execution of the calling thread for - [d] seconds. The other program threads continue to run during - this time. *) - -external join : t -> unit = "caml_thread_join" -(** [join th] suspends the execution of the calling thread - until the thread [th] has terminated. *) - -val wait_read : Unix.file_descr -> unit -(** See {!Thread.wait_write}.*) - -val wait_write : Unix.file_descr -> unit -(** This function does nothing in this implementation. *) - -val wait_timed_read : Unix.file_descr -> float -> bool -(** See {!Thread.wait_timed_read}.*) - -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]) - on the given Unix file descriptor. 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. - - These functions return immediately [true] in the Win32 - implementation. *) - -val select : - 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. - The arguments and results have the same meaning as for - [Unix.select]. - This function is not implemented yet under Win32. *) - -val wait_pid : int -> int * Unix.process_status -(** [wait_pid p] suspends the execution of the calling thread - until the process specified by the process identifier [p] - terminates. Returns the pid of the child caught and - its termination status, as per [Unix.wait]. - This function is not implemented under MacOS. *) - -val wait_signal : int list -> int -(** [wait_signal sigs] suspends the execution of the calling thread - until the process receives one of the signals specified in the - list [sigs]. It then returns the number of the signal received. - Signal handlers attached to the signals in [sigs] will not - be invoked. Do not call [wait_signal] concurrently - from several threads on the same signals. *) - -val yield : unit -> unit -(** Re-schedule the calling thread without suspending it. - This function can be used to give scheduling hints, - telling the scheduler that now is a good time to - switch to other threads. *) diff --git a/otherlibs/systhreads/threadUnix.ml b/otherlibs/systhreads/threadUnix.ml deleted file mode 100644 index 71855ec696..0000000000 --- a/otherlibs/systhreads/threadUnix.ml +++ /dev/null @@ -1,59 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Module [ThreadUnix]: thread-compatible system calls *) - -open Unix - -(*** Process handling *) - -external execv : string -> string array -> unit = "unix_execv" -external execve : string -> string array -> string array -> unit - = "unix_execve" -external execvp : string -> string array -> unit = "unix_execvp" -let wait = Unix.wait -let waitpid = Unix.waitpid -let system = Unix.system -let read = Unix.read -let write = Unix.write -let select = Unix.select - -let timed_read fd buff ofs len timeout = - if Thread.wait_timed_read fd timeout - then Unix.read fd buff ofs len - else raise (Unix_error(ETIMEDOUT, "timed_read", "")) - -let timed_write fd buff ofs len timeout = - if Thread.wait_timed_write fd timeout - then Unix.write fd buff ofs len - else raise (Unix_error(ETIMEDOUT, "timed_write", "")) - -let pipe = Unix.pipe - -let open_process_in = Unix.open_process_in -let open_process_out = Unix.open_process_out -let open_process = Unix.open_process - -external sleep : int -> unit = "unix_sleep" - -let socket = Unix.socket -let accept = Unix.accept -external connect : file_descr -> sockaddr -> unit = "unix_connect" -let recv = Unix.recv -let recvfrom = Unix.recvfrom -let send = Unix.send -let sendto = Unix.sendto - -let open_connection = Unix.open_connection diff --git a/otherlibs/systhreads/threadUnix.mli b/otherlibs/systhreads/threadUnix.mli deleted file mode 100644 index c05346fef3..0000000000 --- a/otherlibs/systhreads/threadUnix.mli +++ /dev/null @@ -1,85 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Thread-compatible system calls. - - @deprecated The functionality of this module has been merged back into - the {!Unix} module. Threaded programs can now call the functions - from module {!Unix} directly, and still get the correct behavior - (block the calling thread, if required, but do not block all threads - in the process). *) - -(** {6 Process handling} *) - -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 : Unix.wait_flag list -> int -> int * Unix.process_status -val system : string -> Unix.process_status - -(** {6 Basic input/output} *) - -val read : Unix.file_descr -> string -> int -> int -> int -val write : Unix.file_descr -> string -> int -> int -> int - -(** {6 Input/output with timeout} *) - -val timed_read : - Unix.file_descr -> - string -> int -> int -> float -> int -(** See {!ThreadUnix.timed_write}. *) - -val timed_write : - Unix.file_descr -> - string -> int -> int -> float -> int -(** Behave as {!ThreadUnix.read} and {!ThreadUnix.write}, except that - [Unix_error(ETIMEDOUT,_,_)] is raised if no data is - available for reading or ready for writing after [d] seconds. - The delay [d] is given in the fifth argument, in seconds. *) - -(** {6 Polling} *) - -val select : - 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 - -(** {6 Pipes and redirections} *) - -val pipe : unit -> Unix.file_descr * Unix.file_descr -val open_process_in: string -> in_channel -val open_process_out: string -> out_channel -val open_process: string -> in_channel * out_channel - -(** {6 Time} *) - -val sleep : int -> unit - -(** {6 Sockets} *) - -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 -> 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/systhreads/thread_posix.ml b/otherlibs/systhreads/thread_posix.ml deleted file mode 100644 index ebd54c4cf6..0000000000 --- a/otherlibs/systhreads/thread_posix.ml +++ /dev/null @@ -1,73 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy and Pascal Cuoq, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* User-level threads *) - -type t - -external thread_initialize : unit -> unit = "caml_thread_initialize" -external thread_new : (unit -> unit) -> t = "caml_thread_new" -external thread_uncaught_exception : exn -> unit = - "caml_thread_uncaught_exception" - -external yield : unit -> unit = "caml_thread_yield" -external self : unit -> t = "caml_thread_self" -external id : t -> int = "caml_thread_id" -external join : t -> unit = "caml_thread_join" -external exit : unit -> unit = "caml_thread_exit" - -(* For new, make sure the function passed to thread_new never - raises an exception. *) - -let create fn arg = - thread_new - (fun () -> - try - fn arg; () - with exn -> - flush stdout; flush stderr; - thread_uncaught_exception exn) - -(* Thread.kill is currently not implemented due to problems with - cleanup handlers on several platforms *) - -let kill th = invalid_arg "Thread.kill: not implemented" - -(* Preemption *) - -let preempt signal = yield() - -(* Initialization of the scheduler *) - -let _ = - ignore(Sys.signal Sys.sigvtalrm (Sys.Signal_handle preempt)); - thread_initialize() - -(* Wait functions *) - -let delay time = ignore(Unix.select [] [] [] time) - -let wait_read fd = () -let wait_write fd = () - -let wait_timed_read fd d = - match Unix.select [fd] [] [] d with ([], _, _) -> false | (_, _, _) -> true -let wait_timed_write fd d = - match Unix.select [] [fd] [] d with (_, [], _) -> false | (_, _, _) -> true -let select = Unix.select - -let wait_pid p = Unix.waitpid [] p - -external wait_signal : int list -> int = "caml_wait_signal" diff --git a/otherlibs/systhreads/thread_win32.ml b/otherlibs/systhreads/thread_win32.ml deleted file mode 100644 index 81691278f3..0000000000 --- a/otherlibs/systhreads/thread_win32.ml +++ /dev/null @@ -1,75 +0,0 @@ -(***********************************************************************) -(* *) -(* Caml Special Light *) -(* *) -(* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1995 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* User-level threads *) - -type t - -external thread_initialize : unit -> unit = "caml_thread_initialize" -external thread_new : (unit -> unit) -> t = "caml_thread_new" - -external yield : unit -> unit = "caml_thread_yield" -external self : unit -> t = "caml_thread_self" -external id : t -> int = "caml_thread_id" -external join : t -> unit = "caml_thread_join" -external thread_uncaught_exception : exn -> unit = - "caml_thread_uncaught_exception" - -(* For new, make sure the function passed to thread_new never - raises an exception. *) - -exception Thread_exit - -let create fn arg = - thread_new - (fun () -> - try - fn arg; () - with Thread_exit -> () - | exn -> - flush stdout; flush stderr; - thread_uncaught_exception exn) - -let exit () = raise Thread_exit - -(* Thread.kill is currently not implemented because there is no way - to do correct cleanup under Win32. *) - -let kill th = invalid_arg "Thread.kill: not implemented" - -(* Preemption *) - -let preempt signal = yield() - -(* Initialization of the scheduler *) - -let _ = - ignore(Sys.signal Sys.sigterm (Sys.Signal_handle preempt)); - thread_initialize() - -(* Wait functions *) - -external delay: float -> unit = "caml_thread_delay" - -let wait_read fd = () -let wait_write fd = () - -let wait_timed_read fd delay = true -let wait_timed_write fd delay = true -let select rd wr ex delay = invalid_arg "Thread.select: not implemented" - -let wait_pid p = Unix.waitpid [] p - -external wait_signal : int list -> int = "caml_wait_signal" diff --git a/otherlibs/systhreads/win32.c b/otherlibs/systhreads/win32.c deleted file mode 100644 index b8cdaef302..0000000000 --- a/otherlibs/systhreads/win32.c +++ /dev/null @@ -1,719 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, INRIA Rocquencourt */ -/* */ -/* Copyright 1995 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Thread interface for Win32 threads */ - -#include <windows.h> -#include <process.h> -#include <signal.h> -#include <stdio.h> -#include <stdlib.h> -#include "alloc.h" -#include "backtrace.h" -#include "callback.h" -#include "custom.h" -#include "fail.h" -#include "io.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "printexc.h" -#include "roots.h" -#include "signals.h" -#ifdef NATIVE_CODE -#include "stack.h" -#else -#include "stacks.h" -#endif -#include "sys.h" - -/* Initial size of stack when a thread is created (4 Ko) */ -#define Thread_stack_size (Stack_size / 4) - -/* Max computation time before rescheduling, in milliseconds (50ms) */ -#define Thread_timeout 50 - -/* Signal used for timer preemption (any unused, legal signal number) */ -#define SIGTIMER SIGTERM - -/* The ML value describing a thread (heap-allocated) */ - -struct caml_thread_handle { - value final_fun; /* Finalization function */ - HANDLE handle; /* Windows handle */ -}; - -struct caml_thread_descr { - value ident; /* Unique integer ID */ - value start_closure; /* The closure to start this thread */ - struct caml_thread_handle * thread_handle; /* Finalized object with handle */ -}; - -#define Ident(v) (((struct caml_thread_descr *)(v))->ident) -#define Start_closure(v) (((struct caml_thread_descr *)(v))->start_closure) -#define Threadhandle(v) (((struct caml_thread_descr *)(v))->thread_handle) - -/* The infos on threads (allocated via malloc()) */ - -struct caml_thread_struct { - HANDLE wthread; /* The Windows thread handle */ - value descr; /* The heap-allocated descriptor (root) */ - struct caml_thread_struct * next; /* Double linking of running threads */ - struct caml_thread_struct * prev; -#ifdef NATIVE_CODE - char * bottom_of_stack; /* Saved value of caml_bottom_of_stack */ - unsigned long last_retaddr; /* Saved value of caml_last_return_address */ - value * gc_regs; /* Saved value of caml_gc_regs */ - char * exception_pointer; /* Saved value of caml_exception_pointer */ - struct caml__roots_block * local_roots; /* Saved value of local_roots */ -#else - value * stack_low; /* The execution stack for this thread */ - value * stack_high; - value * stack_threshold; - value * sp; /* Saved value of extern_sp for this thread */ - value * trapsp; /* Saved value of trapsp for this thread */ - struct caml__roots_block * local_roots; /* Saved value of local_roots */ - struct longjmp_buffer * external_raise; /* Saved external_raise */ - int backtrace_pos; /* Saved backtrace_pos */ - code_t * backtrace_buffer; /* Saved backtrace_buffer */ - value backtrace_last_exn; /* Saved backtrace_last_exn (root) */ -#endif -}; - -typedef struct caml_thread_struct * caml_thread_t; - -/* The descriptor for the currently executing thread (thread-specific) */ - -static caml_thread_t curr_thread = NULL; - -/* The global mutex used to ensure that at most one thread is running - Caml code */ -static HANDLE caml_mutex; - -/* The key used for storing the thread descriptor in the specific data - of the corresponding Posix thread. */ -static DWORD thread_descriptor_key; - -/* The key used for unlocking I/O channels on exceptions */ -static DWORD last_channel_locked_key; - -/* Identifier for next thread creation */ -static long thread_next_ident = 0; - -/* Forward declarations */ - -static void caml_wthread_error (char * msg); - -/* Hook for scanning the stacks of the other threads */ - -static void (*prev_scan_roots_hook) (scanning_action); - -static void caml_thread_scan_roots(scanning_action action) -{ - caml_thread_t th; - - th = curr_thread; - do { - (*action)(th->descr, &th->descr); -#ifndef NATIVE_CODE - (*action)(th->backtrace_last_exn, &th->backtrace_last_exn); -#endif - /* Don't rescan the stack of the current thread, it was done already */ - if (th != curr_thread) { -#ifdef NATIVE_CODE - if (th->bottom_of_stack != NULL) - do_local_roots(action, th->bottom_of_stack, th->last_retaddr, - th->gc_regs, th->local_roots); -#else - do_local_roots(action, th->sp, th->stack_high, th->local_roots); -#endif - } - th = th->next; - } while (th != curr_thread); - /* Hook */ - if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action); -} - -/* Hooks for enter_blocking_section and leave_blocking_section */ - -static void (*prev_enter_blocking_section_hook) () = NULL; -static void (*prev_leave_blocking_section_hook) () = NULL; - -static void caml_thread_enter_blocking_section(void) -{ - if (prev_enter_blocking_section_hook != NULL) - (*prev_enter_blocking_section_hook)(); - /* Save the stack-related global variables in the thread descriptor - of the current thread */ -#ifdef NATIVE_CODE - curr_thread->bottom_of_stack = caml_bottom_of_stack; - curr_thread->last_retaddr = caml_last_return_address; - curr_thread->gc_regs = caml_gc_regs; - curr_thread->exception_pointer = caml_exception_pointer; - curr_thread->local_roots = local_roots; -#else - curr_thread->stack_low = stack_low; - curr_thread->stack_high = stack_high; - curr_thread->stack_threshold = stack_threshold; - curr_thread->sp = extern_sp; - curr_thread->trapsp = trapsp; - curr_thread->local_roots = local_roots; - curr_thread->external_raise = external_raise; - curr_thread->backtrace_pos = backtrace_pos; - curr_thread->backtrace_buffer = backtrace_buffer; - curr_thread->backtrace_last_exn = backtrace_last_exn; -#endif - /* Release the global mutex */ - ReleaseMutex(caml_mutex); -} - -static void caml_thread_leave_blocking_section(void) -{ - /* Re-acquire the global mutex */ - WaitForSingleObject(caml_mutex, INFINITE); - /* Update curr_thread to point to the thread descriptor corresponding - to the thread currently executing */ - curr_thread = TlsGetValue(thread_descriptor_key); - /* Restore the stack-related global variables */ -#ifdef NATIVE_CODE - caml_bottom_of_stack= curr_thread->bottom_of_stack; - caml_last_return_address = curr_thread->last_retaddr; - caml_gc_regs = curr_thread->gc_regs; - caml_exception_pointer = curr_thread->exception_pointer; - local_roots = curr_thread->local_roots; -#else - stack_low = curr_thread->stack_low; - stack_high = curr_thread->stack_high; - stack_threshold = curr_thread->stack_threshold; - extern_sp = curr_thread->sp; - trapsp = curr_thread->trapsp; - local_roots = curr_thread->local_roots; - external_raise = curr_thread->external_raise; - backtrace_pos = curr_thread->backtrace_pos; - backtrace_buffer = curr_thread->backtrace_buffer; - backtrace_last_exn = curr_thread->backtrace_last_exn; -#endif - if (prev_leave_blocking_section_hook != NULL) - (*prev_leave_blocking_section_hook)(); -} - -/* Hooks for I/O locking */ - -static void caml_io_mutex_free(struct channel * chan) -{ - HANDLE mutex = chan->mutex; - if (mutex != NULL) { - CloseHandle(mutex); - } -} - -static void caml_io_mutex_lock(struct channel * chan) -{ - if (chan->mutex == NULL) { - HANDLE mutex = CreateMutex(NULL, FALSE, NULL); - if (mutex == NULL) caml_wthread_error("Thread.iolock"); - chan->mutex = (void *) mutex; - } - enter_blocking_section(); - WaitForSingleObject((HANDLE) chan->mutex, INFINITE); - /* Problem: if a signal occurs at this point, - and the signal handler raises an exception, we will not - unlock the mutex. The alternative (doing the setspecific - before locking the mutex is also incorrect, since we could - then unlock a mutex that is unlocked or locked by someone else. */ - TlsSetValue(last_channel_locked_key, (void *) chan); - leave_blocking_section(); -} - -static void caml_io_mutex_unlock(struct channel * chan) -{ - ReleaseMutex((HANDLE) chan->mutex); - TlsSetValue(last_channel_locked_key, NULL); -} - -static void caml_io_mutex_unlock_exn(void) -{ - struct channel * chan = TlsGetValue(last_channel_locked_key); - if (chan != NULL) caml_io_mutex_unlock(chan); -} - -/* The "tick" thread fakes a signal at regular intervals. */ - -static void caml_thread_tick(void * arg) -{ - while(1) { - Sleep(Thread_timeout); - pending_signal = SIGTIMER; -#ifdef NATIVE_CODE - young_limit = young_end; -#else - something_to_do = 1; -#endif - } -} - -static void caml_thread_finalize(value vthread) -{ - CloseHandle(((struct caml_thread_handle *)vthread)->handle); -} - -/* Initialize the thread machinery */ - -CAMLprim value caml_thread_initialize(value unit) -{ - value vthread = Val_unit; - value descr; - HANDLE tick_thread; - unsigned long tick_id; - - /* Protect against repeated initialization (PR#1325) */ - if (curr_thread != NULL) return Val_unit; - Begin_root (vthread); - /* Initialize the main mutex and acquire it */ - caml_mutex = CreateMutex(NULL, TRUE, NULL); - if (caml_mutex == NULL) caml_wthread_error("Thread.init"); - /* Initialize the TLS keys */ - thread_descriptor_key = TlsAlloc(); - last_channel_locked_key = TlsAlloc(); - /* Create a finalized value to hold thread handle */ - vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value), - caml_thread_finalize, 1, 1000); - ((struct caml_thread_handle *)vthread)->handle = NULL; - /* Create a descriptor for the current thread */ - descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value)); - Ident(descr) = Val_long(thread_next_ident); - Start_closure(descr) = Val_unit; - Threadhandle(descr) = (struct caml_thread_handle *) vthread; - thread_next_ident++; - /* Create an info block for the current thread */ - curr_thread = - (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct)); - DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), - GetCurrentProcess(), &(curr_thread->wthread), - 0, FALSE, DUPLICATE_SAME_ACCESS); - if (curr_thread->wthread == NULL) caml_wthread_error("Thread.init"); - ((struct caml_thread_handle *)vthread)->handle = curr_thread->wthread; - curr_thread->descr = descr; - curr_thread->next = curr_thread; - curr_thread->prev = curr_thread; - /* The stack-related fields will be filled in at the next - enter_blocking_section */ - /* Associate the thread descriptor with the thread */ - TlsSetValue(thread_descriptor_key, (void *) curr_thread); - /* Set up the hooks */ - prev_scan_roots_hook = scan_roots_hook; - scan_roots_hook = caml_thread_scan_roots; - prev_enter_blocking_section_hook = enter_blocking_section_hook; - enter_blocking_section_hook = caml_thread_enter_blocking_section; - prev_leave_blocking_section_hook = leave_blocking_section_hook; - leave_blocking_section_hook = caml_thread_leave_blocking_section; - channel_mutex_free = caml_io_mutex_free; - channel_mutex_lock = caml_io_mutex_lock; - channel_mutex_unlock = caml_io_mutex_unlock; - channel_mutex_unlock_exn = caml_io_mutex_unlock_exn; - /* Fork the tick thread */ - tick_thread = (HANDLE) _beginthread(caml_thread_tick, 0, NULL); - if (tick_thread == (HANDLE)(-1)) caml_wthread_error("Thread.init"); - CloseHandle(tick_thread); - End_roots(); - return Val_unit; -} - -/* Create a thread */ - -static void caml_thread_start(void * arg) -{ - caml_thread_t th = (caml_thread_t) arg; - value clos; - - /* Associate the thread descriptor with the thread */ - TlsSetValue(thread_descriptor_key, (void *) th); - TlsSetValue(last_channel_locked_key, NULL); - /* Acquire the global mutex and set up the stack variables */ - leave_blocking_section(); - /* Callback the closure */ - clos = Start_closure(th->descr); - modify(&(Start_closure(th->descr)), Val_unit); - callback_exn(clos, Val_unit); - /* Remove th from the doubly-linked list of threads */ - th->next->prev = th->prev; - th->prev->next = th->next; - /* Release the main mutex (forever) */ - async_signal_mode = 1; - ReleaseMutex(caml_mutex); -#ifndef NATIVE_CODE - /* Free the memory resources */ - stat_free(th->stack_low); - if (th->backtrace_buffer != NULL) free(th->backtrace_buffer); -#endif - /* Free the thread descriptor */ - stat_free(th); - /* The thread now stops running */ -} - -CAMLprim value caml_thread_new(value clos) -{ - caml_thread_t th; - value vthread = Val_unit; - value descr; - unsigned long th_id; - - Begin_roots2 (clos, vthread) - /* Create a finalized value to hold thread handle */ - vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value), - caml_thread_finalize, 1, 1000); - ((struct caml_thread_handle *)vthread)->handle = NULL; - /* Create a descriptor for the new thread */ - descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value)); - Ident(descr) = Val_long(thread_next_ident); - Start_closure(descr) = clos; - Threadhandle(descr) = (struct caml_thread_handle *) vthread; - thread_next_ident++; - /* Create an info block for the current thread */ - th = (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct)); - th->descr = descr; -#ifdef NATIVE_CODE - th->bottom_of_stack = NULL; - th->exception_pointer = NULL; - th->local_roots = NULL; -#else - /* Allocate the stacks */ - th->stack_low = (value *) stat_alloc(Thread_stack_size); - th->stack_high = th->stack_low + Thread_stack_size / sizeof(value); - th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value); - th->sp = th->stack_high; - th->trapsp = th->stack_high; - th->local_roots = NULL; - th->external_raise = NULL; - th->backtrace_pos = 0; - th->backtrace_buffer = NULL; - th->backtrace_last_exn = Val_unit; -#endif - /* Add thread info block to the list of threads */ - th->next = curr_thread->next; - th->prev = curr_thread; - curr_thread->next->prev = th; - curr_thread->next = th; - /* Fork the new thread */ -#if 0 - th->wthread = - CreateThread(NULL,0, (LPTHREAD_START_ROUTINE) caml_thread_start, - (void *) th, 0, &th_id); - if (th->wthread == NULL) { -#endif - th->wthread = (HANDLE) _beginthread(caml_thread_start, 0, (void *) th); - if (th->wthread == (HANDLE)(-1)) { - /* Fork failed, remove thread info block from list of threads */ - th->next->prev = curr_thread; - curr_thread->next = th->next; -#ifndef NATIVE_CODE - stat_free(th->stack_low); -#endif - stat_free(th); - caml_wthread_error("Thread.create"); - } - ((struct caml_thread_handle *)vthread)->handle = th->wthread; - End_roots(); - return descr; -} - -/* Return the current thread */ - -CAMLprim value caml_thread_self(value unit) -{ - if (curr_thread == NULL) invalid_argument("Thread.self: not initialized"); - return curr_thread->descr; -} - -/* Return the identifier of a thread */ - -CAMLprim value caml_thread_id(value th) -{ - return Ident(th); -} - -/* Print uncaught exception and backtrace */ - -CAMLprim value caml_thread_uncaught_exception(value exn) -{ - char * msg = format_caml_exception(exn); - fprintf(stderr, "Thread %d killed on uncaught exception %s\n", - Int_val(Ident(curr_thread->descr)), msg); - free(msg); -#ifndef NATIVE_CODE - if (backtrace_active) print_exception_backtrace(); -#endif - fflush(stderr); - return Val_unit; -} - -/* Allow re-scheduling */ - -CAMLprim value caml_thread_yield(value unit) -{ - enter_blocking_section(); - Sleep(0); - leave_blocking_section(); - return Val_unit; -} - -/* Suspend the current thread until another thread terminates */ - -CAMLprim value caml_thread_join(value th) -{ - HANDLE h; - Begin_root(th) /* prevent deallocation of handle */ - h = Threadhandle(th)->handle; - enter_blocking_section(); - WaitForSingleObject(h, INFINITE); - leave_blocking_section(); - End_roots(); - return Val_unit; -} - -/* Mutex operations */ - -#define Mutex_val(v) (*((HANDLE *) Data_custom_val(v))) -#define Max_mutex_number 1000 - -static void caml_mutex_finalize(value mut) -{ - CloseHandle(Mutex_val(mut)); -} - -static int caml_mutex_compare(value wrapper1, value wrapper2) -{ - HANDLE h1 = Mutex_val(wrapper1); - HANDLE h2 = Mutex_val(wrapper2); - return h1 == h2 ? 0 : h1 < h2 ? -1 : 1; -} - -static struct custom_operations caml_mutex_ops = { - "_mutex", - caml_mutex_finalize, - caml_mutex_compare, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; - -CAMLprim value caml_mutex_new(value unit) -{ - value mut; - mut = alloc_custom(&caml_mutex_ops, sizeof(HANDLE), 1, Max_mutex_number); - Mutex_val(mut) = CreateMutex(0, FALSE, NULL); - if (Mutex_val(mut) == NULL) caml_wthread_error("Mutex.create"); - return mut; -} - -CAMLprim value caml_mutex_lock(value mut) -{ - int retcode; - Begin_root(mut) /* prevent deallocation of mutex */ - enter_blocking_section(); - retcode = WaitForSingleObject(Mutex_val(mut), INFINITE); - leave_blocking_section(); - End_roots(); - if (retcode == WAIT_FAILED) caml_wthread_error("Mutex.lock"); - return Val_unit; -} - -CAMLprim value caml_mutex_unlock(value mut) -{ - BOOL retcode; - Begin_root(mut) /* prevent deallocation of mutex */ - enter_blocking_section(); - retcode = ReleaseMutex(Mutex_val(mut)); - leave_blocking_section(); - End_roots(); - if (!retcode) caml_wthread_error("Mutex.unlock"); - return Val_unit; -} - -CAMLprim value caml_mutex_try_lock(value mut) -{ - int retcode; - retcode = WaitForSingleObject(Mutex_val(mut), 0); - if (retcode == WAIT_FAILED || retcode == WAIT_ABANDONED) - caml_wthread_error("Mutex.try_lock"); - return Val_bool(retcode == WAIT_OBJECT_0); -} - -/* Delay */ - -CAMLprim value caml_thread_delay(value val) -{ - enter_blocking_section(); - Sleep((DWORD)(Double_val(val)*1000)); /* milliseconds */ - leave_blocking_section(); - return Val_unit; -} - -/* Conditions operations */ - -struct caml_condvar { - unsigned long count; /* Number of waiting threads */ - HANDLE sem; /* Semaphore on which threads are waiting */ -}; - -#define Condition_val(v) ((struct caml_condvar *) Data_custom_val(v)) -#define Max_condition_number 1000 - -static void caml_condition_finalize(value cond) -{ - CloseHandle(Condition_val(cond)->sem); -} - -static int caml_condition_compare(value wrapper1, value wrapper2) -{ - HANDLE h1 = Condition_val(wrapper1)->sem; - HANDLE h2 = Condition_val(wrapper2)->sem; - return h1 == h2 ? 0 : h1 < h2 ? -1 : 1; -} - -static struct custom_operations caml_condition_ops = { - "_condition", - caml_condition_finalize, - caml_condition_compare, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; - -CAMLprim value caml_condition_new(value unit) -{ - value cond; - cond = alloc_custom(&caml_condition_ops, sizeof(struct caml_condvar), - 1, Max_condition_number); - Condition_val(cond)->sem = CreateSemaphore(NULL, 0, 0x7FFFFFFF, NULL); - if (Condition_val(cond)->sem == NULL) - caml_wthread_error("Condition.create"); - Condition_val(cond)->count = 0; - return cond; -} - -CAMLprim value caml_condition_wait(value cond, value mut) -{ - int retcode; - HANDLE m = Mutex_val(mut); - HANDLE s = Condition_val(cond)->sem; - HANDLE handles[2]; - - Condition_val(cond)->count ++; - Begin_roots2(cond, mut) /* prevent deallocation of cond and mutex */ - enter_blocking_section(); - /* Release mutex */ - ReleaseMutex(m); - /* Wait for semaphore to be non-null, and decrement it. - Simultaneously, re-acquire mutex. */ - handles[0] = s; - handles[1] = m; - retcode = WaitForMultipleObjects(2, handles, TRUE, INFINITE); - leave_blocking_section(); - End_roots(); - if (retcode == WAIT_FAILED) caml_wthread_error("Condition.wait"); - return Val_unit; -} - -CAMLprim value caml_condition_signal(value cond) -{ - HANDLE s = Condition_val(cond)->sem; - - if (Condition_val(cond)->count > 0) { - Condition_val(cond)->count --; - Begin_root(cond) /* prevent deallocation of cond */ - enter_blocking_section(); - /* Increment semaphore by 1, waking up one waiter */ - ReleaseSemaphore(s, 1, NULL); - leave_blocking_section(); - End_roots(); - } - return Val_unit; -} - -CAMLprim value caml_condition_broadcast(value cond) -{ - HANDLE s = Condition_val(cond)->sem; - unsigned long c = Condition_val(cond)->count; - - if (c > 0) { - Condition_val(cond)->count = 0; - Begin_root(cond) /* prevent deallocation of cond */ - enter_blocking_section(); - /* Increment semaphore by c, waking up all waiters */ - ReleaseSemaphore(s, c, NULL); - leave_blocking_section(); - End_roots(); - } - return Val_unit; -} - -/* Synchronous signal wait */ - -static HANDLE wait_signal_event[NSIG]; -static int * wait_signal_received[NSIG]; - -static void caml_wait_signal_handler(int signo) -{ - *(wait_signal_received[signo]) = signo; - SetEvent(wait_signal_event[signo]); -} - -typedef void (*sighandler_type)(int); - -CAMLprim value caml_wait_signal(value sigs) -{ - HANDLE event; - int res, s, retcode; - value l; - sighandler_type oldsignals[NSIG]; - - Begin_root(sigs); - event = CreateEvent(NULL, FALSE, FALSE, NULL); - if (event == NULL) - caml_wthread_error("Thread.wait_signal (CreateEvent)"); - res = 0; - for (l = sigs; l != Val_int(0); l = Field(l, 1)) { - s = convert_signal_number(Int_val(Field(l, 0))); - oldsignals[s] = signal(s, caml_wait_signal_handler); - if (oldsignals[s] == SIG_ERR) { - CloseHandle(event); - caml_wthread_error("Thread.wait_signal (signal)"); - } - wait_signal_event[s] = event; - wait_signal_received[s] = &res; - } - enter_blocking_section(); - retcode = WaitForSingleObject(event, INFINITE); - leave_blocking_section(); - for (l = sigs; l != Val_int(0); l = Field(l, 1)) { - s = convert_signal_number(Int_val(Field(l, 0))); - signal(s, oldsignals[s]); - } - CloseHandle(event); - End_roots(); - if (retcode == WAIT_FAILED) - caml_wthread_error("Thread.wait_signal (WaitForSingleObject)"); - return Val_int(res); -} - -/* Error report */ - -static void caml_wthread_error(char * msg) -{ - char errmsg[1024]; - sprintf(errmsg, "%s: error code %lx", msg, GetLastError()); - raise_sys_error(copy_string(errmsg)); -} diff --git a/otherlibs/threads/.cvsignore b/otherlibs/threads/.cvsignore deleted file mode 100644 index fb2df562de..0000000000 --- a/otherlibs/threads/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -marshal.mli -pervasives.mli -unix.mli diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend deleted file mode 100644 index d73c31e4c4..0000000000 --- a/otherlibs/threads/.depend +++ /dev/null @@ -1,27 +0,0 @@ -scheduler.o: scheduler.c ../../byterun/alloc.h ../../byterun/misc.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/mlvalues.h ../../byterun/backtrace.h \ - ../../byterun/callback.h ../../byterun/fail.h ../../byterun/io.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/printexc.h ../../byterun/roots.h ../../byterun/signals.h \ - ../../byterun/stacks.h ../../byterun/sys.h -condition.cmi: mutex.cmi -thread.cmi: unix.cmi -threadUnix.cmi: unix.cmi -condition.cmo: mutex.cmi thread.cmi condition.cmi -condition.cmx: mutex.cmx thread.cmx condition.cmi -event.cmo: condition.cmi mutex.cmi event.cmi -event.cmx: condition.cmx mutex.cmx event.cmi -marshal.cmo: pervasives.cmi marshal.cmi -marshal.cmx: pervasives.cmx marshal.cmi -mutex.cmo: thread.cmi mutex.cmi -mutex.cmx: thread.cmx mutex.cmi -pervasives.cmo: unix.cmi pervasives.cmi -pervasives.cmx: unix.cmx pervasives.cmi -thread.cmo: unix.cmi thread.cmi -thread.cmx: unix.cmx thread.cmi -threadUnix.cmo: thread.cmi unix.cmi threadUnix.cmi -threadUnix.cmx: thread.cmx unix.cmx threadUnix.cmi -unix.cmo: unix.cmi -unix.cmx: unix.cmi diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile deleted file mode 100644 index d76ce536bf..0000000000 --- a/otherlibs/threads/Makefile +++ /dev/null @@ -1,126 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -include ../../config/Makefile - -CC=$(BYTECC) -CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -g -CAMLC=../../ocamlcomp.sh -I ../unix -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A - -C_OBJS=scheduler.o - -CAML_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo - -LIB=../../stdlib - -LIB_OBJS=pervasives.cmo \ - $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/string.cmo \ - $(LIB)/sys.cmo $(LIB)/hashtbl.cmo $(LIB)/sort.cmo \ - marshal.cmo $(LIB)/obj.cmo $(LIB)/int32.cmo $(LIB)/int64.cmo \ - $(LIB)/nativeint.cmo \ - $(LIB)/lexing.cmo $(LIB)/parsing.cmo \ - $(LIB)/set.cmo $(LIB)/map.cmo $(LIB)/stack.cmo $(LIB)/queue.cmo \ - $(LIB)/stream.cmo $(LIB)/buffer.cmo \ - $(LIB)/printf.cmo $(LIB)/format.cmo \ - $(LIB)/scanf.cmo $(LIB)/arg.cmo \ - $(LIB)/printexc.cmo $(LIB)/gc.cmo $(LIB)/digest.cmo $(LIB)/random.cmo \ - $(LIB)/camlinternalOO.cmo \ - $(LIB)/oo.cmo $(LIB)/genlex.cmo $(LIB)/callback.cmo $(LIB)/weak.cmo \ - $(LIB)/lazy.cmo $(LIB)/filename.cmo $(LIB)/complex.cmo \ - $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo $(LIB)/stringLabels.cmo \ - $(LIB)/stdLabels.cmo $(LIB)/moreLabels.cmo - -UNIXLIB=../unix - -UNIXLIB_OBJS=unix.cmo $(UNIXLIB)/unixLabels.cmo - -all: libvmthreads.a threads.cma stdlib.cma unix.cma - -allopt: - -libvmthreads.a: $(C_OBJS) - $(MKLIB) -o threads -oc vmthreads $(C_OBJS) - -threads.cma: $(CAML_OBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -o threads -oc vmthreads $(CAML_OBJS) - -stdlib.cma: $(LIB_OBJS) - $(CAMLC) -a -o stdlib.cma $(LIB_OBJS) - -unix.cma: $(UNIXLIB_OBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -o unix -linkall $(UNIXLIB_OBJS) - -pervasives.cmo: pervasives.mli pervasives.cmi pervasives.ml - $(CAMLC) ${COMPFLAGS} -nopervasives -c pervasives.ml - -pervasives.mli: $(LIB)/pervasives.mli - ln -s $(LIB)/pervasives.mli pervasives.mli - -pervasives.cmi: $(LIB)/pervasives.cmi - ln -s $(LIB)/pervasives.cmi pervasives.cmi - -marshal.cmo: marshal.mli marshal.cmi marshal.ml - $(CAMLC) ${COMPFLAGS} -c marshal.ml - -marshal.mli: $(LIB)/marshal.mli - ln -s $(LIB)/marshal.mli marshal.mli - -marshal.cmi: $(LIB)/marshal.cmi - ln -s $(LIB)/marshal.cmi marshal.cmi - -unix.cmo: unix.mli unix.cmi unix.ml - $(CAMLC) ${COMPFLAGS} -c unix.ml - -unix.mli: $(UNIXLIB)/unix.mli - ln -s $(UNIXLIB)/unix.mli unix.mli - -unix.cmi: $(UNIXLIB)/unix.cmi - ln -s $(UNIXLIB)/unix.cmi unix.cmi - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f libvmthreads.a dllvmthreads.so *.o - rm -f pervasives.mli marshal.mli unix.mli - -install: - if test -f dllvmthreads.so; then cp dllvmthreads.so $(STUBLIBDIR)/.; fi - mkdir -p $(LIBDIR)/vmthreads - cp libvmthreads.a $(LIBDIR)/vmthreads/libvmthreads.a - cd $(LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a - cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi threads.cma stdlib.cma unix.cma $(LIBDIR)/vmthreads - cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli $(LIBDIR)/vmthreads - -installopt: - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: - gcc -MM $(CFLAGS) *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend - -include .depend diff --git a/otherlibs/threads/Tests/.cvsignore b/otherlibs/threads/Tests/.cvsignore deleted file mode 100644 index e6d9e45b70..0000000000 --- a/otherlibs/threads/Tests/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -*.byt diff --git a/otherlibs/threads/Tests/Makefile b/otherlibs/threads/Tests/Makefile deleted file mode 100644 index 6bf52ef059..0000000000 --- a/otherlibs/threads/Tests/Makefile +++ /dev/null @@ -1,38 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../../LICENSE.# -# # -######################################################################### - -# $Id$ - -PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \ - test7.byt test8.byt test9.byt testA.byt sieve.byt \ - testio.byt testsocket.byt testwait.byt testsignal.byt testsignal2.byt \ - testsieve.byt token1.byt token2.byt - -CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../../stdlib -I ../../unix - -include ../../../config/Makefile - -all: $(PROGS) - -clean: - rm -f *.cm* *.byt - -sorts.byt: sorts.ml - $(CAMLC) -o sorts.byt -I ../../graph threads.cma graphics.cma sorts.ml $(LIBS) $(X11_LINK) - -.SUFFIXES: .ml .byt - -.ml.byt: - $(CAMLC) -o $*.byt unix.cma threads.cma $*.ml $(LIBS) - -$(PROGS): ../threads.cma ../libthreads.a diff --git a/otherlibs/threads/Tests/close.ml b/otherlibs/threads/Tests/close.ml deleted file mode 100644 index 21ebb44a6a..0000000000 --- a/otherlibs/threads/Tests/close.ml +++ /dev/null @@ -1,14 +0,0 @@ -let main () = - let (rd, wr) = Unix.pipe() in - Thread.create - (fun () -> - Thread.delay 3.0; - prerr_endline "closing fd..."; - Unix.close rd) - (); - let buf = String.create 10 in - prerr_endline "reading..."; - Unix.read rd buf 0 10; - prerr_endline "read returned" - -let _ = Unix.handle_unix_error main () diff --git a/otherlibs/threads/Tests/sieve.ml b/otherlibs/threads/Tests/sieve.ml deleted file mode 100644 index 72e2656605..0000000000 --- a/otherlibs/threads/Tests/sieve.ml +++ /dev/null @@ -1,33 +0,0 @@ -open Printf -open Thread - -let rec integers n ch = - Event.sync (Event.send ch n); - integers (n+1) ch - -let rec sieve n chin chout = - let m = Event.sync (Event.receive chin) - in if m mod n = 0 - then sieve n chin chout - else Event.sync (Event.send chout m); - sieve n chin chout - -let rec print_primes ch max = - let n = Event.sync (Event.receive ch) - in if n > max - then () - else begin - printf "%d\n" n; flush stdout; - let ch_after_n = Event.new_channel () - in Thread.create (sieve n ch) ch_after_n; - print_primes ch_after_n max - end - -let go max = - let ch = Event.new_channel () - in Thread.create (integers 2) ch; - print_primes ch max;; - -let _ = go 1000 - -;; diff --git a/otherlibs/threads/Tests/sorts.ml b/otherlibs/threads/Tests/sorts.ml deleted file mode 100644 index abc8dc1b5c..0000000000 --- a/otherlibs/threads/Tests/sorts.ml +++ /dev/null @@ -1,228 +0,0 @@ -(* Animation of sorting algorithms. *) - -open Graphics - -(* Information on a given sorting process *) - -type graphic_context = - { array: int array; (* Data to sort *) - x0: int; (* X coordinate, lower left corner *) - y0: int; (* Y coordinate, lower left corner *) - width: int; (* Width in pixels *) - height: int; (* Height in pixels *) - nelts: int; (* Number of elements in the array *) - maxval: int; (* Max val in the array + 1 *) - rad: int (* Dimension of the rectangles *) - } - -(* Array assignment and exchange with screen update *) - -let screen_mutex = Mutex.create() - -let draw gc i v = - fill_rect (gc.x0 + (gc.width * i) / gc.nelts) - (gc.y0 + (gc.height * v) / gc.maxval) - gc.rad gc.rad - -let assign gc i v = - Mutex.lock screen_mutex; - set_color background; draw gc i gc.array.(i); - set_color foreground; draw gc i v; - gc.array.(i) <- v; - Mutex.unlock screen_mutex - -let exchange gc i j = - let val_i = gc.array.(i) in - assign gc i gc.array.(j); - assign gc j val_i - -(* Construction of a graphic context *) - -let initialize name array maxval x y w h = - let (_, label_height) = text_size name in - let rad = (w - 2) / (Array.length array) - 1 in - let gc = - { array = Array.copy array; - x0 = x + 1; (* Leave one pixel left for Y axis *) - y0 = y + 1; (* Leave one pixel below for X axis *) - width = w - 2; (* 1 pixel left, 1 pixel right *) - height = h - 1 - label_height - rad; - nelts = Array.length array; - maxval = maxval; - rad = rad } in - moveto (gc.x0 - 1) (gc.y0 + gc.height); - lineto (gc.x0 - 1) (gc.y0 - 1); - lineto (gc.x0 + gc.width) (gc.y0 - 1); - moveto (gc.x0 - 1) (gc.y0 + gc.height); - draw_string name; - for i = 0 to Array.length array - 1 do - draw gc i array.(i) - done; - gc - -(* Main animation function *) - -let display functs nelts maxval = - let a = Array.create nelts 0 in - for i = 0 to nelts - 1 do - a.(i) <- Random.int maxval - done; - let num_finished = ref 0 in - let lock_finished = Mutex.create() in - let cond_finished = Condition.create() in - for i = 0 to Array.length functs - 1 do - let (name, funct, x, y, w, h) = functs.(i) in - let gc = initialize name a maxval x y w h in - Thread.create - (fun () -> - funct gc; - Mutex.lock lock_finished; - incr num_finished; - Mutex.unlock lock_finished; - Condition.signal cond_finished) - () - done; - Mutex.lock lock_finished; - while !num_finished < Array.length functs do - Condition.wait cond_finished lock_finished - done; - Mutex.unlock lock_finished; - read_key() - -(***** - let delay = ref 0 in - try - while true do - let gc = Queue.take q in - begin match gc.action with - Finished -> () - | Pause f -> - gc.action <- f (); - for i = 0 to !delay do () done; - Queue.add gc q - end; - if key_pressed() then begin - match read_key() with - 'q'|'Q' -> - raise Exit - | '0'..'9' as c -> - delay := (Char.code c - 48) * 500 - | _ -> - () - end - done - with Exit -> () - | Queue.Empty -> read_key(); () -*****) - -(* The sorting functions. *) - -(* Bubble sort *) - -let bubble_sort gc = - let ordered = ref false in - while not !ordered do - ordered := true; - for i = 0 to Array.length gc.array - 2 do - if gc.array.(i+1) < gc.array.(i) then begin - exchange gc i (i+1); - ordered := false - end - done - done - -(* Insertion sort *) - -let insertion_sort gc = - for i = 1 to Array.length gc.array - 1 do - let val_i = gc.array.(i) in - let j = ref (i - 1) in - while !j >= 0 && val_i < gc.array.(!j) do - assign gc (!j + 1) gc.array.(!j); - decr j - done; - assign gc (!j + 1) val_i - done - -(* Selection sort *) - -let selection_sort gc = - for i = 0 to Array.length gc.array - 1 do - let min = ref i in - for j = i+1 to Array.length gc.array - 1 do - if gc.array.(j) < gc.array.(!min) then min := j - done; - exchange gc i !min - done - -(* Quick sort *) - -let quick_sort gc = - let rec quick lo hi = - if lo < hi then begin - let i = ref lo in - let j = ref hi in - let pivot = gc.array.(hi) in - while !i < !j do - while !i < hi && gc.array.(!i) <= pivot do incr i done; - while !j > lo && gc.array.(!j) >= pivot do decr j done; - if !i < !j then exchange gc !i !j - done; - exchange gc !i hi; - quick lo (!i-1); - quick (!i+1) hi - end - in quick 0 (Array.length gc.array - 1) - -(* Merge sort *) - -let merge_sort gc = - let rec merge i l1 l2 = - match (l1, l2) with - ([], []) -> - () - | ([], v2::r2) -> - assign gc i v2; merge (i+1) l1 r2 - | (v1::r1, []) -> - assign gc i v1; merge (i+1) r1 l2 - | (v1::r1, v2::r2) -> - if v1 < v2 - then begin assign gc i v1; merge (i+1) r1 l2 end - else begin assign gc i v2; merge (i+1) l1 r2 end in - let rec msort start len = - if len < 2 then () else begin - let m = len / 2 in - msort start m; - msort (start+m) (len-m); - merge start - (Array.to_list (Array.sub gc.array start m)) - (Array.to_list (Array.sub gc.array (start+m) (len-m))) - end in - msort 0 (Array.length gc.array) - -(* Main program *) - -let animate() = - open_graph ""; - moveto 0 0; draw_string "Press a key to start..."; - let seed = ref 0 in - while not (key_pressed()) do incr seed done; - read_key(); - Random.init !seed; - clear_graph(); - let prompt = "0: fastest ... 9: slowest, press 'q' to quit" in - moveto 0 0; draw_string prompt; - let (_, h) = text_size prompt in - let sx = size_x() / 2 and sy = (size_y() - h) / 3 in - display [| "Bubble", bubble_sort, 0, h, sx, sy; - "Insertion", insertion_sort, 0, h+sy, sx, sy; - "Selection", selection_sort, 0, h+2*sy, sx, sy; - "Quicksort", quick_sort, sx, h, sx, sy; - (** "Heapsort", heap_sort, sx, h+sy, sx, sy; **) - "Mergesort", merge_sort, sx, h+2*sy, sx, sy |] - 100 1000; - close_graph() - -let _ = if !Sys.interactive then () else begin animate(); exit 0 end - -;; diff --git a/otherlibs/threads/Tests/test1.ml b/otherlibs/threads/Tests/test1.ml deleted file mode 100644 index 9d2cf0a5ee..0000000000 --- a/otherlibs/threads/Tests/test1.ml +++ /dev/null @@ -1,57 +0,0 @@ -(* Classic producer-consumer *) - -type 'a prodcons = - { buffer: 'a array; - lock: Mutex.t; - mutable readpos: int; - mutable writepos: int; - notempty: Condition.t; - notfull: Condition.t } - -let create size init = - { buffer = Array.create size init; - lock = Mutex.create(); - readpos = 0; - writepos = 0; - notempty = Condition.create(); - notfull = Condition.create() } - -let put p data = - Mutex.lock p.lock; - while (p.writepos + 1) mod Array.length p.buffer = p.readpos do - Condition.wait p.notfull p.lock - done; - p.buffer.(p.writepos) <- data; - p.writepos <- (p.writepos + 1) mod Array.length p.buffer; - Condition.signal p.notempty; - Mutex.unlock p.lock - -let get p = - Mutex.lock p.lock; - while p.writepos = p.readpos do - Condition.wait p.notempty p.lock - done; - let data = p.buffer.(p.readpos) in - p.readpos <- (p.readpos + 1) mod Array.length p.buffer; - Condition.signal p.notfull; - Mutex.unlock p.lock; - data - -(* Test *) - -let buff = create 20 0 - -let rec produce n = - print_int n; print_string "-->"; print_newline(); - put buff n; - if n < 10000 then produce (n+1) - -let rec consume () = - let n = get buff in - print_string "-->"; print_int n; print_newline(); - if n < 10000 then consume () - -let t1 = Thread.create produce 0 -let _ = consume () - -;; diff --git a/otherlibs/threads/Tests/test2.ml b/otherlibs/threads/Tests/test2.ml deleted file mode 100644 index 926f09078f..0000000000 --- a/otherlibs/threads/Tests/test2.ml +++ /dev/null @@ -1,15 +0,0 @@ -let yield = ref false - -let print_message c = - for i = 1 to 10000 do - print_char c; flush stdout; - if !yield then Thread.yield() - done - -let _ = yield := (Array.length Sys.argv > 1) -let t1 = Thread.create print_message 'a' -let t2 = Thread.create print_message 'b' -let _ = Thread.join t1 -let _ = Thread.join t2 - -;; diff --git a/otherlibs/threads/Tests/test3.ml b/otherlibs/threads/Tests/test3.ml deleted file mode 100644 index c6df3326e4..0000000000 --- a/otherlibs/threads/Tests/test3.ml +++ /dev/null @@ -1,8 +0,0 @@ -let print_message delay c = - while true do - print_char c; flush stdout; Thread.delay delay - done - -let _ = - Thread.create (print_message 0.6666666666) 'a'; - print_message 1.0 'b' diff --git a/otherlibs/threads/Tests/test4.ml b/otherlibs/threads/Tests/test4.ml deleted file mode 100644 index ff84961bb3..0000000000 --- a/otherlibs/threads/Tests/test4.ml +++ /dev/null @@ -1,13 +0,0 @@ -let rec fib n = if n <= 2 then 1 else fib(n-1) + fib(n-2) - -let fibtask n = - while true do - print_int(fib n); print_newline() - done - -let _ = - Thread.create fibtask 28; - while true do - let l = read_line () in - print_string ">> "; print_string l; print_newline() - done diff --git a/otherlibs/threads/Tests/test5.ml b/otherlibs/threads/Tests/test5.ml deleted file mode 100644 index 2baffe024b..0000000000 --- a/otherlibs/threads/Tests/test5.ml +++ /dev/null @@ -1,21 +0,0 @@ -open Event - -let ch = (new_channel() : string channel) - -let rec sender msg = - sync (send ch msg); - sender msg - -let rec receiver name = - print_string (name ^ ": " ^ sync (receive ch) ^ "\n"); - flush stdout; - receiver name - -let _ = - Thread.create sender "hello"; - Thread.create sender "world"; - Thread.create receiver "A"; - receiver "B"; - exit 0 - - diff --git a/otherlibs/threads/Tests/test6.ml b/otherlibs/threads/Tests/test6.ml deleted file mode 100644 index b846858e56..0000000000 --- a/otherlibs/threads/Tests/test6.ml +++ /dev/null @@ -1,17 +0,0 @@ -open Event - -let ch = (new_channel() : string channel) - -let rec f tag msg = - select [ - send ch msg; - wrap (receive ch) (fun x -> print_string(tag ^ ": " ^ x); print_newline()) - ]; - f tag msg - -let _ = - Thread.create (f "A") "hello"; - f "B" "world"; - exit 0 - - diff --git a/otherlibs/threads/Tests/test7.ml b/otherlibs/threads/Tests/test7.ml deleted file mode 100644 index e6bd1d810d..0000000000 --- a/otherlibs/threads/Tests/test7.ml +++ /dev/null @@ -1,28 +0,0 @@ -open Event - -let add_ch = new_channel() -let sub_ch = new_channel() -let read_ch = new_channel() - -let rec accu n = - select [ - wrap (receive add_ch) (fun x -> accu (n+x)); - wrap (receive sub_ch) (fun x -> accu (n-x)); - wrap (send read_ch n) (fun () -> accu n) - ] - -let rec sender chan value = - sync(send chan value); sender chan value - -let read () = - print_int(sync(receive read_ch)); print_newline() - -let main () = - Thread.create accu 0; - Thread.create (sender add_ch) 1; - Thread.create (sender sub_ch) 1; - while true do read() done - -let _ = Printexc.catch main () - - diff --git a/otherlibs/threads/Tests/test8.ml b/otherlibs/threads/Tests/test8.ml deleted file mode 100644 index cc587b0a7c..0000000000 --- a/otherlibs/threads/Tests/test8.ml +++ /dev/null @@ -1,46 +0,0 @@ -open Event - -type 'a buffer_channel = { input: 'a channel; output: 'a channel } - -let new_buffer_channel() = - let ic = new_channel() in - let oc = new_channel() in - let buff = Queue.create() in - let rec buffer_process front rear = - match (front, rear) with - ([], []) -> buffer_process [sync(receive ic)] [] - | (hd::tl, _) -> - select [ - wrap (receive ic) (fun x -> buffer_process front (x::rear)); - wrap (send oc hd) (fun () -> buffer_process tl rear) - ] - | ([], _) -> buffer_process (List.rev rear) [] in - Thread.create (buffer_process []) []; - { input = ic; output = oc } - -let buffer_send bc data = - sync(send bc.input data) - -let buffer_receive bc = - receive bc.output - -(* Test *) - -let box = new_buffer_channel() -let ch = new_channel() - -let f () = - buffer_send box "un"; - buffer_send box "deux"; - sync (send ch 3) - -let g () = - print_int (sync(receive ch)); print_newline(); - print_string (sync(buffer_receive box)); print_newline(); - print_string (sync(buffer_receive box)); print_newline() - -let _ = - Thread.create f (); - g() - - diff --git a/otherlibs/threads/Tests/test9.ml b/otherlibs/threads/Tests/test9.ml deleted file mode 100644 index 1f80beb8f8..0000000000 --- a/otherlibs/threads/Tests/test9.ml +++ /dev/null @@ -1,26 +0,0 @@ -open Event - -type 'a swap_chan = ('a * 'a channel) channel - -let swap msg_out ch = - guard (fun () -> - let ic = new_channel() in - choose [ - wrap (receive ch) (fun (msg_in, oc) -> sync (send oc msg_out); msg_in); - wrap (send ch (msg_out, ic)) (fun () -> sync (receive ic)) - ]) - -let ch = new_channel() - -let f () = - let res = sync (swap "F" ch) in - print_string "f "; print_string res; print_newline() - -let g () = - let res = sync (swap "G" ch) in - print_string "g "; print_string res; print_newline() - -let _ = - let id = Thread.create f () in - g (); - Thread.join id diff --git a/otherlibs/threads/Tests/testA.ml b/otherlibs/threads/Tests/testA.ml deleted file mode 100644 index b1999b87bc..0000000000 --- a/otherlibs/threads/Tests/testA.ml +++ /dev/null @@ -1,24 +0,0 @@ -let private_data = (Hashtbl.create 17 : (Thread.t, string) Hashtbl.t) -let private_data_lock = Mutex.create() - -let set_private_data data = - Mutex.lock private_data_lock; - Hashtbl.add private_data (Thread.self()) data; - Mutex.unlock private_data_lock - -let get_private_data () = - Hashtbl.find private_data (Thread.self()) - -let process id data = - set_private_data data; - print_int id; print_string " --> "; print_string(get_private_data()); - print_newline() - -let _ = - let t1 = Thread.create (process 1) "un" in - let t2 = Thread.create (process 2) "deux" in - let t3 = Thread.create (process 3) "trois" in - let t4 = Thread.create (process 4) "quatre" in - let t5 = Thread.create (process 5) "cinq" in - List.iter Thread.join [t1;t2;t3;t4;t5] - diff --git a/otherlibs/threads/Tests/testexit.ml b/otherlibs/threads/Tests/testexit.ml deleted file mode 100644 index 2045c25a86..0000000000 --- a/otherlibs/threads/Tests/testexit.ml +++ /dev/null @@ -1,22 +0,0 @@ -(* Test Thread.exit *) - -let somethread (name, limit, last) = - let counter = ref 0 in - while true do - incr counter; - if !counter >= limit then begin - print_string (name ^ " exiting\n"); - flush stdout; - if last then exit 0 else Thread.exit() - end; - print_string (name ^ ": " ^ string_of_int !counter ^ "\n"); - flush stdout; - Thread.delay 0.5 - done - -let _ = - let _ = Thread.create somethread ("A", 5, false) in - let _ = Thread.create somethread ("B", 8, false) in - let _ = Thread.create somethread ("C", 11, true) in - somethread ("Main", 3, false) - diff --git a/otherlibs/threads/Tests/testio.ml b/otherlibs/threads/Tests/testio.ml deleted file mode 100644 index 3ed08a88f4..0000000000 --- a/otherlibs/threads/Tests/testio.ml +++ /dev/null @@ -1,119 +0,0 @@ -(* Test a file copy function *) - -let test msg producer consumer src dst = - print_string msg; print_newline(); - let ic = open_in_bin src in - let oc = open_out_bin dst in - let (in_fd, out_fd) = Unix.pipe() in - let ipipe = Unix.in_channel_of_descr in_fd in - let opipe = Unix.out_channel_of_descr out_fd in - let prod = Thread.create producer (ic, opipe) in - let cons = Thread.create consumer (ipipe, oc) in - Thread.join prod; - Thread.join cons; - if Unix.system ("cmp " ^ src ^ " " ^ dst) = Unix.WEXITED 0 - then print_string "passed" - else print_string "FAILED"; - print_newline() - -(* File copy with constant-sized chunks *) - -let copy_file sz (ic, oc) = - let buffer = String.create sz in - let rec copy () = - let n = input ic buffer 0 sz in - if n = 0 then () else begin - output oc buffer 0 n; - copy () - end in - copy(); - close_in ic; - close_out oc - -(* File copy with random-sized chunks *) - -let copy_random sz (ic, oc) = - let buffer = String.create sz in - let rec copy () = - let s = 1 + Random.int sz in - let n = input ic buffer 0 s in - if n = 0 then () else begin - output oc buffer 0 n; - copy () - end in - copy(); - close_in ic; - close_out oc - -(* File copy line per line *) - -let copy_line (ic, oc) = - try - while true do - output_string oc (input_line ic); output_char oc '\n' - done - with End_of_file -> - close_in ic; - close_out oc - -(* Create long lines of text *) - -let make_lines ofile = - let oc = open_out ofile in - for i = 1 to 256 do - output_string oc (String.make (i*16) '.'); output_char oc '\n' - done; - close_out oc - -(* Test input_line on truncated lines *) - -let test_trunc_line ofile = - print_string "truncated line"; print_newline(); - let oc = open_out ofile in - output_string oc "A line without newline!"; - close_out oc; - try - let ic = open_in ofile in - let s = input_line ic in - close_in ic; - if s = "A line without newline!" - then print_string "passed" - else print_string "FAILED"; - print_newline() - with End_of_file -> - print_string "FAILED"; print_newline() - -(* The test *) - -let main() = - let ifile = Sys.argv.(1) in - let ofile = "/tmp/testio" in - test "256-byte chunks, 256-byte chunks" - (copy_file 256) (copy_file 256) ifile ofile; - test "4096-byte chunks, 4096-byte chunks" - (copy_file 4096) (copy_file 4096) ifile ofile; - test "65536-byte chunks, 65536-byte chunks" - (copy_file 65536) (copy_file 65536) ifile ofile; - test "256-byte chunks, 4096-byte chunks" - (copy_file 256) (copy_file 4096) ifile ofile; - test "4096-byte chunks, 256-byte chunks" - (copy_file 4096) (copy_file 256) ifile ofile; - test "4096-byte chunks, 65536-byte chunks" - (copy_file 4096) (copy_file 65536) ifile ofile; - test "263-byte chunks, 4011-byte chunks" - (copy_file 263) (copy_file 4011) ifile ofile; - test "613-byte chunks, 1027-byte chunks" - (copy_file 613) (copy_file 1027) ifile ofile; - test "0...8192 byte chunks" - (copy_random 8192) (copy_random 8192) ifile ofile; - test "line per line, short lines" - copy_line copy_line "/etc/hosts" ofile; - make_lines "/tmp/lines"; - test "line per line, short and long lines" - copy_line copy_line "/tmp/lines" ofile; - test_trunc_line ofile; - Sys.remove "/tmp/lines"; - Sys.remove ofile; - exit 0 - -let _ = Unix.handle_unix_error main (); exit 0 diff --git a/otherlibs/threads/Tests/testsieve.ml b/otherlibs/threads/Tests/testsieve.ml deleted file mode 100644 index 6079d8a8eb..0000000000 --- a/otherlibs/threads/Tests/testsieve.ml +++ /dev/null @@ -1,42 +0,0 @@ -let sieve primes= - Event.sync (Event.send primes 0); - Event.sync (Event.send primes 1); - Event.sync (Event.send primes 2); - let integers = Event.new_channel () in - let rec enumerate n= - Event.sync (Event.send integers n); - enumerate (n + 2) - and filter inpout = - let n = Event.sync (Event.receive inpout) - (* On prepare le terrain pour l'appel recursif *) - and output = Event.new_channel () in - (* Celui qui etait en tete du crible est premier *) - Event.sync (Event.send primes n); - Thread.create filter output; - (* On elimine de la sortie ceux qui sont des multiples de n *) - while true do - let m = Event.sync (Event.receive inpout) in - (* print_int n; print_string ": "; print_int m; print_newline(); *) - if (m mod n) = 0 - then () - else ((Event.sync (Event.send output m));()) - done in - Thread.create filter integers; - Thread.create enumerate 3 - -let premiers = Event.new_channel () - -let main _ = - Thread.create sieve premiers; - while true do - for i = 1 to 100 do - let n = Event.sync (Event.receive premiers) in - print_int n; print_newline() - done; - exit 0 - done - - -let _ = - try main () - with _ -> exit 0;; diff --git a/otherlibs/threads/Tests/testsignal.ml b/otherlibs/threads/Tests/testsignal.ml deleted file mode 100644 index 7781f3377b..0000000000 --- a/otherlibs/threads/Tests/testsignal.ml +++ /dev/null @@ -1,13 +0,0 @@ -let sighandler _ = - print_string "Got ctrl-C, exiting..."; print_newline(); - exit 0 - -let print_message delay c = - while true do - print_char c; flush stdout; Thread.delay delay - done - -let _ = - Sys.signal Sys.sigint (Sys.Signal_handle sighandler); - Thread.create (print_message 0.6666666666) 'a'; - print_message 1.0 'b' diff --git a/otherlibs/threads/Tests/testsignal2.ml b/otherlibs/threads/Tests/testsignal2.ml deleted file mode 100644 index 1f7fc0f91c..0000000000 --- a/otherlibs/threads/Tests/testsignal2.ml +++ /dev/null @@ -1,10 +0,0 @@ -let print_message delay c = - while true do - print_char c; flush stdout; Thread.delay delay - done - -let _ = - let th1 = Thread.create (print_message 0.6666666666) 'a' in - let th2 = Thread.create (print_message 1.0) 'b' in - let s = Thread.wait_signal [Sys.sigint; Sys.sigterm] in - Printf.printf "Got signal %d, exiting...\n" s diff --git a/otherlibs/threads/Tests/testsocket.ml b/otherlibs/threads/Tests/testsocket.ml deleted file mode 100644 index d0f14cbf5b..0000000000 --- a/otherlibs/threads/Tests/testsocket.ml +++ /dev/null @@ -1,31 +0,0 @@ -open Unix - -let engine number address = - print_int number; print_string "> connecting"; print_newline(); - let (ic, oc) = open_connection (ADDR_INET(address, 80)) in - print_int number; print_string "> connected"; print_newline(); - output_string oc "GET / HTTP1.0\r\n\r\n"; flush oc; - try - while true do - let s = input_line ic in - print_int number; print_string ">"; print_string s; print_newline() - done - with End_of_file -> - close_out oc - -let main() = - let addresses = Array.create (Array.length Sys.argv - 1) inet_addr_any in - for i = 1 to Array.length Sys.argv - 1 do - addresses.(i - 1) <- (gethostbyname Sys.argv.(i)).h_addr_list.(0) - done; - let processes = Array.create (Array.length addresses) (Thread.self()) in - for i = 0 to Array.length addresses - 1 do - processes.(i) <- Thread.create (engine i) addresses.(i) - done; - for i = 0 to Array.length processes - 1 do - Thread.join processes.(i) - done - -let _ = Printexc.catch main (); exit 0 - - diff --git a/otherlibs/threads/Tests/token1.ml b/otherlibs/threads/Tests/token1.ml deleted file mode 100644 index fb0ddb2dfd..0000000000 --- a/otherlibs/threads/Tests/token1.ml +++ /dev/null @@ -1,36 +0,0 @@ -(* Performance test for mutexes and conditions *) - -let mut = Mutex.create() - -let niter = ref 0 - -let token = ref 0 - -let process (n, conds, nprocs) = - while true do - Mutex.lock mut; - while !token <> n do - (* Printf.printf "Thread %d waiting (token = %d)\n" n !token; *) - Condition.wait conds.(n) mut - done; - (* Printf.printf "Thread %d got token %d\n" n !token; *) - incr token; - if !token >= nprocs then token := 0; - if n = 0 then begin - decr niter; - if !niter <= 0 then exit 0 - end; - Condition.signal conds.(!token); - Mutex.unlock mut - done - -let main() = - let nprocs = int_of_string Sys.argv.(1) in - let iter = int_of_string Sys.argv.(2) in - let conds = Array.create nprocs (Condition.create()) in - for i = 1 to nprocs - 1 do conds.(i) <- Condition.create() done; - niter := iter; - for i = 0 to nprocs - 1 do Thread.create process (i, conds, nprocs) done; - Thread.delay 3600. - -let _ = main() diff --git a/otherlibs/threads/Tests/token2.ml b/otherlibs/threads/Tests/token2.ml deleted file mode 100644 index 32b897dd13..0000000000 --- a/otherlibs/threads/Tests/token2.ml +++ /dev/null @@ -1,36 +0,0 @@ -(* Performance test for I/O scheduling *) - -let mut = Mutex.create() - -let niter = ref 0 - -let token = ref 0 - -let process (n, ins, outs, nprocs) = - let buf = String.create 1 in - while true do - Unix.read ins.(n) buf 0 1; - (* Printf.printf "Thread %d got the token\n" n; *) - if n = 0 then begin - decr niter; - if !niter <= 0 then exit 0 - end; - let next = if n + 1 >= nprocs then 0 else n + 1 in - (* Printf.printf "Thread %d sending token to thread %d\n" n next; *) - Unix.write outs.(next) buf 0 1 - done - -let main() = - let nprocs = int_of_string Sys.argv.(1) in - let iter = int_of_string Sys.argv.(2) in - let ins = Array.create nprocs Unix.stdin in - let outs = Array.create nprocs Unix.stdout in - for n = 0 to nprocs - 1 do - let (i, o) = Unix.pipe() in ins.(n) <- i; outs.(n) <- o - done; - niter := iter; - for i = 0 to nprocs - 1 do Thread.create process (i, ins, outs, nprocs) done; - Unix.write outs.(0) "X" 0 1; - Thread.delay 3600. - -let _ = main() diff --git a/otherlibs/threads/Tests/torture.ml b/otherlibs/threads/Tests/torture.ml deleted file mode 100644 index b52766dc72..0000000000 --- a/otherlibs/threads/Tests/torture.ml +++ /dev/null @@ -1,46 +0,0 @@ -(* Torture test - lots of GC *) - -let gc_thread () = - while true do -(* print_string "gc"; print_newline(); *) - Gc.minor(); - Thread.yield() - done - -let stdin_thread () = - while true do - print_string "> "; flush stdout; - let s = read_line() in - print_string ">>> "; print_string s; print_newline() - done - -let writer_thread (oc, size) = - while true do -(* print_string "writer "; print_int size; print_newline(); *) - let buff = String.make size 'a' in - Unix.write oc buff 0 size - done - -let reader_thread (ic, size) = - while true do -(* print_string "reader "; print_int size; print_newline(); *) - let buff = String.create size in - let n = Unix.read ic buff 0 size in -(* print_string "reader "; print_int n; print_newline(); *) - for i = 0 to n-1 do - if buff.[i] <> 'a' then prerr_endline "error in reader_thread" - done - done - -let main() = - Thread.create gc_thread (); - let (out1, in1) = Unix.pipe() in - Thread.create writer_thread (in1, 4096); - Thread.create reader_thread (out1, 4096); - let (out2, in2) = Unix.pipe() in - Thread.create writer_thread (in2, 16); - Thread.create reader_thread (out2, 16); - stdin_thread() - -let _ = main() - diff --git a/otherlibs/threads/condition.ml b/otherlibs/threads/condition.ml deleted file mode 100644 index 521711418d..0000000000 --- a/otherlibs/threads/condition.ml +++ /dev/null @@ -1,36 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy and Damien Doligez, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type t = { mutable waiting: Thread.t list } - -let create () = { waiting = [] } - -let wait cond mut = - Thread.critical_section := true; - Mutex.unlock mut; - cond.waiting <- Thread.self() :: cond.waiting; - Thread.sleep(); - Mutex.lock mut - -let signal cond = - match cond.waiting with (* atomic *) - [] -> () - | th :: rem -> cond.waiting <- rem (* atomic *); Thread.wakeup th - -let broadcast cond = - let w = cond.waiting in (* atomic *) - cond.waiting <- []; (* atomic *) - List.iter Thread.wakeup w - diff --git a/otherlibs/threads/condition.mli b/otherlibs/threads/condition.mli deleted file mode 100644 index 02c108b7b1..0000000000 --- a/otherlibs/threads/condition.mli +++ /dev/null @@ -1,53 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy and Damien Doligez, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Condition variables to synchronize between threads. - - Condition variables are used when one thread wants to wait until another - thread has finished doing something: the former thread ``waits'' on the - condition variable, the latter thread ``signals'' the condition when it - is done. Condition variables should always be protected by a mutex. - The typical use is (if [D] is a shared data structure, [m] its mutex, - and [c] is a condition variable): - {[ - Mutex.lock m; - while (* some predicate P over D is not satisfied *) do - Condition.wait c m - done; - (* Modify D *) - if (* the predicate P over D is now satified *) then Condition.signal c; - Mutex.unlock m - ]} -*) - -type t -(** The type of condition variables. *) - -val create : unit -> t -(** Return a new condition variable. *) - -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. - The mutex [m] is locked again before [wait] returns. *) - -val signal : t -> unit -(** [signal c] restarts one of the processes waiting on the - condition variable [c]. *) - -val broadcast : t -> unit -(** [broadcast c] restarts all processes waiting on the - condition variable [c]. *) diff --git a/otherlibs/threads/event.ml b/otherlibs/threads/event.ml deleted file mode 100644 index bd47d6526a..0000000000 --- a/otherlibs/threads/event.ml +++ /dev/null @@ -1,274 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* David Nowak and 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Events *) -type 'a basic_event = - { poll: unit -> bool; - (* If communication can take place immediately, return true. *) - suspend: unit -> unit; - (* Offer the communication on the channel and get ready - to suspend current process. *) - result: unit -> 'a } - (* Return the result of the communication *) - -type 'a behavior = int ref -> Condition.t -> int -> 'a basic_event - -type 'a event = - Communication of 'a behavior - | Choose of 'a event list - | WrapAbort of 'a event * (unit -> unit) - | Guard of (unit -> 'a event) - -(* Communication channels *) -type 'a channel = - { mutable writes_pending: 'a communication Queue.t; - (* All offers to write on it *) - mutable reads_pending: 'a communication Queue.t } - (* All offers to read from it *) - -(* Communication offered *) -and 'a communication = - { performed: int ref; (* -1 if not performed yet, set to the number *) - (* of the matching communication after rendez-vous. *) - condition: Condition.t; (* To restart the blocked thread. *) - mutable data: 'a option; (* The data sent or received. *) - event_number: int } (* Event number in select *) - -(* Create a channel *) - -let new_channel () = - { writes_pending = Queue.create(); - reads_pending = Queue.create() } - -(* Basic synchronization function *) - -let masterlock = Mutex.create() - -let do_aborts abort_env genev performed = - if abort_env <> [] then begin - if performed >= 0 then begin - let ids_done = snd genev.(performed) in - List.iter - (fun (id,f) -> if not (List.mem id ids_done) then f ()) - abort_env - end else begin - List.iter (fun (_,f) -> f ()) abort_env - end - end - -let basic_sync abort_env genev = - let performed = ref (-1) in - let condition = Condition.create() in - let bev = Array.create (Array.length genev) - (fst (genev.(0)) performed condition 0) in - for i = 1 to Array.length genev - 1 do - bev.(i) <- (fst genev.(i)) performed condition i - done; - (* See if any of the events is already activable *) - let rec poll_events i = - if i >= Array.length bev - then false - else bev.(i).poll() || poll_events (i+1) in - Mutex.lock masterlock; - if not (poll_events 0) then begin - (* Suspend on all events *) - for i = 0 to Array.length bev - 1 do bev.(i).suspend() done; - (* Wait until the condition is signalled *) - Condition.wait condition masterlock - end; - Mutex.unlock masterlock; - (* Extract the result *) - if abort_env = [] then - (* Preserve tail recursion *) - bev.(!performed).result() - else begin - let num = !performed in - let result = bev.(num).result() in - (* Handle the aborts and return the result *) - do_aborts abort_env genev num; - result - end - -(* Apply a random permutation on an array *) - -let scramble_array a = - let len = Array.length a in - if len = 0 then invalid_arg "Event.choose"; - for i = len - 1 downto 1 do - let j = Random.int (i + 1) in - let temp = a.(i) in a.(i) <- a.(j); a.(j) <- temp - done; - a - -(* Main synchronization function *) - -let gensym = let count = ref 0 in fun () -> incr count; !count - -let rec flatten_event - (abort_list : int list) - (accu : ('a behavior * int list) list) - (accu_abort : (int * (unit -> unit)) list) - ev = - match ev with - Communication bev -> ((bev,abort_list) :: accu) , accu_abort - | WrapAbort (ev,fn) -> - let id = gensym () in - flatten_event (id :: abort_list) accu ((id,fn)::accu_abort) ev - | Choose evl -> - let rec flatten_list accu' accu_abort'= function - ev :: l -> - let (accu'',accu_abort'') = - flatten_event abort_list accu' accu_abort' ev in - flatten_list accu'' accu_abort'' l - | [] -> (accu',accu_abort') in - flatten_list accu accu_abort evl - | Guard fn -> flatten_event abort_list accu accu_abort (fn ()) - -let sync ev = - let (evl,abort_env) = flatten_event [] [] [] ev in - basic_sync abort_env (scramble_array(Array.of_list evl)) - -(* Event polling -- like sync, but non-blocking *) - -let basic_poll abort_env genev = - let performed = ref (-1) in - let condition = Condition.create() in - let bev = Array.create(Array.length genev) - (fst genev.(0) performed condition 0) in - for i = 1 to Array.length genev - 1 do - bev.(i) <- fst genev.(i) performed condition i - done; - (* See if any of the events is already activable *) - let rec poll_events i = - if i >= Array.length bev - then false - else bev.(i).poll() || poll_events (i+1) in - Mutex.lock masterlock; - let ready = poll_events 0 in - if ready then begin - (* Extract the result *) - Mutex.unlock masterlock; - let result = Some(bev.(!performed).result()) in - do_aborts abort_env genev !performed; result - end else begin - (* Cancel the communication offers *) - performed := 0; - Mutex.unlock masterlock; - do_aborts abort_env genev (-1); - None - end - -let poll ev = - let (evl,abort_env) = flatten_event [] [] [] ev in - basic_poll abort_env (scramble_array(Array.of_list evl)) - -(* Remove all communication opportunities already synchronized *) - -let cleanup_queue q = - let q' = Queue.create() in - Queue.iter (fun c -> if !(c.performed) = -1 then Queue.add c q') q; - q' - -(* Event construction *) - -let always data = - Communication(fun performed condition evnum -> - { poll = (fun () -> performed := evnum; true); - suspend = (fun () -> ()); - result = (fun () -> data) }) - -let send channel data = - Communication(fun performed condition evnum -> - let wcomm = - { performed = performed; - condition = condition; - data = Some data; - event_number = evnum } in - { poll = (fun () -> - let rec poll () = - let rcomm = Queue.take channel.reads_pending in - if !(rcomm.performed) >= 0 then - poll () - else begin - rcomm.data <- wcomm.data; - performed := evnum; - rcomm.performed := rcomm.event_number; - Condition.signal rcomm.condition - end in - try - poll(); - true - with Queue.Empty -> - false); - suspend = (fun () -> - channel.writes_pending <- cleanup_queue channel.writes_pending; - Queue.add wcomm channel.writes_pending); - result = (fun () -> ()) }) - -let receive channel = - Communication(fun performed condition evnum -> - let rcomm = - { performed = performed; - condition = condition; - data = None; - event_number = evnum } in - { poll = (fun () -> - let rec poll () = - let wcomm = Queue.take channel.writes_pending in - if !(wcomm.performed) >= 0 then - poll () - else begin - rcomm.data <- wcomm.data; - performed := evnum; - wcomm.performed := wcomm.event_number; - Condition.signal wcomm.condition - end in - try - poll(); - true - with Queue.Empty -> - false); - suspend = (fun () -> - channel.reads_pending <- cleanup_queue channel.reads_pending; - Queue.add rcomm channel.reads_pending); - result = (fun () -> - match rcomm.data with - None -> invalid_arg "Event.receive" - | Some res -> res) }) - -let choose evl = Choose evl - -let wrap_abort ev fn = WrapAbort(ev,fn) - -let guard fn = Guard fn - -let rec wrap ev fn = - match ev with - Communication genev -> - Communication(fun performed condition evnum -> - let bev = genev performed condition evnum in - { poll = bev.poll; - suspend = bev.suspend; - result = (fun () -> fn(bev.result())) }) - | Choose evl -> - Choose(List.map (fun ev -> wrap ev fn) evl) - | WrapAbort (ev, f') -> - WrapAbort (wrap ev fn, f') - | Guard gu -> - Guard(fun () -> wrap (gu()) fn) - -(* Convenience functions *) - -let select evl = sync(Choose evl) diff --git a/otherlibs/threads/event.mli b/otherlibs/threads/event.mli deleted file mode 100644 index 21d5459a57..0000000000 --- a/otherlibs/threads/event.mli +++ /dev/null @@ -1,82 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* David Nowak and 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** First-class synchronous communication. - - This module implements synchronous inter-thread communications over - channels. As in John Reppy's Concurrent ML system, the communication - events are first-class values: they can be built and combined - independently before being offered for communication. -*) - -type 'a channel -(** The type of communication channels carrying values of type ['a]. *) - -val new_channel : unit -> 'a channel -(** Return a new channel. *) - -type 'a event -(** The type of communication events returning a result of type ['a]. *) - -(** [send ch v] returns the event consisting in sending the value [v] - over the channel [ch]. The result value of this event is [()]. *) -val send : 'a channel -> 'a -> unit event - -(** [receive ch] returns the event consisting in receiving a value - from the channel [ch]. The result value of this event is the - value received. *) -val receive : 'a channel -> 'a event - -val always : 'a -> 'a event -(** [always v] returns an event that is always ready for - synchronization. The result value of this event is [v]. *) - -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 -> ('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 -> (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. *) - -val guard : (unit -> 'a event) -> 'a event -(** [guard fn] returns the event that, when synchronized, computes - [fn()] and behaves as the resulting event. This allows to - compute events with side-effects at the time of the synchronization - operation. *) - -val sync : 'a event -> 'a -(** ``Synchronize'' on an event: offer all the communication - possibilities specified in the event to the outside world, - and block until one of the communications succeed. The result - value of that communication is returned. *) - -val select : 'a event list -> 'a -(** ``Synchronize'' on an alternative of events. - [select evl] is shorthand for [sync(choose evl)]. *) - -val poll : 'a event -> 'a option -(** Non-blocking version of {!Event.sync}: offer all the communication - possibilities specified in the event to the outside world, - and if one can take place immediately, perform it and return - [Some r] where [r] is the result value of that communication. - Otherwise, return [None] without blocking. *) - diff --git a/otherlibs/threads/marshal.ml b/otherlibs/threads/marshal.ml deleted file mode 100644 index 4297b98c87..0000000000 --- a/otherlibs/threads/marshal.ml +++ /dev/null @@ -1,57 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type extern_flags = - No_sharing - | Closures - -external to_string: 'a -> extern_flags list -> string - = "output_value_to_string" - -let to_channel chan v flags = - output_string chan (to_string v flags) - -external to_buffer_unsafe: - string -> int -> int -> 'a -> extern_flags list -> int - = "output_value_to_buffer" - -let to_buffer buff ofs len v flags = - if ofs < 0 || len < 0 || ofs + len > String.length buff - 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" - -let header_size = 20 -let data_size buff ofs = - if ofs < 0 || ofs > String.length buff - header_size - then invalid_arg "Marshal.data_size" - else data_size_unsafe buff ofs -let total_size buff ofs = header_size + data_size buff ofs - -let from_string buff ofs = - if ofs < 0 || ofs > String.length buff - header_size - then invalid_arg "Marshal.from_size" - else begin - let len = data_size_unsafe buff ofs in - if ofs > String.length buff - (header_size + len) - then invalid_arg "Marshal.from_string" - else from_string_unsafe buff ofs - end - -let from_channel = Pervasives.input_value diff --git a/otherlibs/threads/mutex.ml b/otherlibs/threads/mutex.ml deleted file mode 100644 index 2858a2414d..0000000000 --- a/otherlibs/threads/mutex.ml +++ /dev/null @@ -1,39 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy and Damien Doligez, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type t = { mutable locked: bool; mutable waiting: Thread.t list } - -let create () = { locked = false; waiting = [] } - -let rec lock m = - if m.locked then begin (* test and set atomic *) - Thread.critical_section := true; - m.waiting <- Thread.self() :: m.waiting; - Thread.sleep(); - lock m - end else begin - m.locked <- true (* test and set atomic *) - end - -let try_lock m = (* test and set atomic *) - if m.locked then false else begin m.locked <- true; true end - -let unlock m = - (* Don't play with Thread.critical_section here because of Condition.wait *) - let w = m.waiting in (* atomic *) - m.waiting <- []; (* atomic *) - m.locked <- false; (* atomic *) - List.iter Thread.wakeup w - diff --git a/otherlibs/threads/mutex.mli b/otherlibs/threads/mutex.mli deleted file mode 100644 index 0c41c843e8..0000000000 --- a/otherlibs/threads/mutex.mli +++ /dev/null @@ -1,50 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy and Damien Doligez, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Locks for mutual exclusion. - - Mutexes (mutual-exclusion locks) are used to implement critical sections - and protect shared mutable data structures against concurrent accesses. - The typical use is (if [m] is the mutex associated with the data structure - [D]): - {[ - Mutex.lock m; - (* Critical section that operates over D *); - Mutex.unlock m - ]} -*) - -type t -(** The type of mutexes. *) - -val create : unit -> t -(** Return a new mutex. *) - -val lock : t -> unit -(** Lock the given mutex. Only one thread can have the mutex locked - at any time. A thread that attempts to lock a mutex already locked - by another thread will suspend until the other thread unlocks - the mutex. *) - -val try_lock : t -> bool -(** Same as {!Mutex.lock}, but does not suspend the calling thread if - the mutex is already locked: just return [false] immediately - in that case. If the mutex is unlocked, lock it and - return [true]. *) - -val unlock : t -> unit -(** Unlock the given mutex. Other threads suspended trying to lock - the mutex will restart. *) - diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml deleted file mode 100644 index 5b69d844d5..0000000000 --- a/otherlibs/threads/pervasives.ml +++ /dev/null @@ -1,528 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Same as ../../stdlib/pervasives.ml, except that I/O functions have - been redefined to not block the whole process, but only the calling - thread. *) - -(* type 'a option = None | Some of 'a *) - -(* Exceptions *) - -external raise : exn -> 'a = "%raise" - -let failwith s = raise(Failure s) -let invalid_arg s = raise(Invalid_argument s) - -exception Exit - -(* Comparisons *) - -external (=) : 'a -> 'a -> bool = "%equal" -external (<>) : 'a -> 'a -> bool = "%notequal" -external (<) : 'a -> 'a -> bool = "%lessthan" -external (>) : 'a -> 'a -> bool = "%greaterthan" -external (<=) : 'a -> 'a -> bool = "%lessequal" -external (>=) : 'a -> 'a -> bool = "%greaterequal" -external compare: 'a -> 'a -> int = "%compare" - -let min x y = if x <= y then x else y -let max x y = if x >= y then x else y - -external (==) : 'a -> 'a -> bool = "%eq" -external (!=) : 'a -> 'a -> bool = "%noteq" - -(* Boolean operations *) - -external not : bool -> bool = "%boolnot" -external (&) : bool -> bool -> bool = "%sequand" -external (&&) : bool -> bool -> bool = "%sequand" -external (or) : bool -> bool -> bool = "%sequor" -external (||) : bool -> bool -> bool = "%sequor" - -(* Integer operations *) - -external (~-) : int -> int = "%negint" -external succ : int -> int = "%succint" -external pred : int -> int = "%predint" -external (+) : int -> int -> int = "%addint" -external (-) : int -> int -> int = "%subint" -external ( * ) : int -> int -> int = "%mulint" -external (/) : int -> int -> int = "%divint" -external (mod) : int -> int -> int = "%modint" - -let abs x = if x >= 0 then x else -x - -external (land) : int -> int -> int = "%andint" -external (lor) : int -> int -> int = "%orint" -external (lxor) : int -> int -> int = "%xorint" - -let lnot x = x lxor (-1) - -external (lsl) : int -> int -> int = "%lslint" -external (lsr) : int -> int -> int = "%lsrint" -external (asr) : int -> int -> int = "%asrint" - -let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62) -let max_int = min_int - 1 - -(* Floating-point operations *) - -external (~-.) : float -> float = "%negfloat" -external (+.) : float -> float -> float = "%addfloat" -external (-.) : float -> float -> float = "%subfloat" -external ( *. ) : float -> float -> float = "%mulfloat" -external (/.) : float -> float -> float = "%divfloat" -external ( ** ) : float -> float -> float = "power_float" "pow" "float" -external exp : float -> float = "exp_float" "exp" "float" -external acos : float -> float = "acos_float" "acos" "float" -external asin : float -> float = "asin_float" "asin" "float" -external atan : float -> float = "atan_float" "atan" "float" -external atan2 : float -> float -> float = "atan2_float" "atan2" "float" -external cos : float -> float = "cos_float" "cos" "float" -external cosh : float -> float = "cosh_float" "cosh" "float" -external log : float -> float = "log_float" "log" "float" -external log10 : float -> float = "log10_float" "log10" "float" -external sin : float -> float = "sin_float" "sin" "float" -external sinh : float -> float = "sinh_float" "sinh" "float" -external sqrt : float -> float = "sqrt_float" "sqrt" "float" -external tan : float -> float = "tan_float" "tan" "float" -external tanh : float -> float = "tanh_float" "tanh" "float" -external ceil : float -> float = "ceil_float" "ceil" "float" -external floor : float -> float = "floor_float" "floor" "float" -external abs_float : float -> float = "%absfloat" -external mod_float : float -> float -> float = "fmod_float" "fmod" "float" -external frexp : float -> float * int = "frexp_float" -external ldexp : float -> int -> float = "ldexp_float" -external modf : float -> float * float = "modf_float" -external float : int -> float = "%floatofint" -external float_of_int : int -> float = "%floatofint" -external truncate : float -> int = "%intoffloat" -external int_of_float : float -> int = "%intoffloat" -external float_of_bytes : string -> float = "float_of_bytes" -let infinity = - float_of_bytes "\127\240\000\000\000\000\000\000" - (* 0x7F F0 00 00 00 00 00 00 *) -let neg_infinity = - float_of_bytes "\255\240\000\000\000\000\000\000" - (* 0xFF F0 00 00 00 00 00 00 *) -let nan = - float_of_bytes "\127\240\000\000\000\000\000\001" - (* 0x7F F0 00 00 00 00 00 01 *) -let max_float = - float_of_bytes "\127\239\255\255\255\255\255\255" - (* 0x7f ef ff ff ff ff ff ff *) -let min_float = - float_of_bytes "\000\016\000\000\000\000\000\000" - (* 0x00 10 00 00 00 00 00 00 *) -let epsilon_float = - float_of_bytes "\060\176\000\000\000\000\000\000" - (* 0x3c b0 00 00 00 00 00 00 *) -type fpclass = - FP_normal - | FP_subnormal - | FP_zero - | FP_infinite - | FP_nan -external classify_float: float -> fpclass = "classify_float" - -(* String operations -- more in module String *) - -external string_length : string -> int = "%string_length" -external string_create: int -> string = "create_string" -external string_blit : string -> int -> string -> int -> int -> unit - = "blit_string" "noalloc" - -let (^) s1 s2 = - let l1 = string_length s1 and l2 = string_length s2 in - let s = string_create (l1 + l2) in - string_blit s1 0 s 0 l1; - string_blit s2 0 s l1 l2; - s - -(* Character operations -- more in module Char *) - -external int_of_char : char -> int = "%identity" -external unsafe_char_of_int : int -> char = "%identity" -let char_of_int n = - if n < 0 || n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n - -(* Unit operations *) - -external ignore : 'a -> unit = "%ignore" - -(* Pair operations *) - -external fst : 'a * 'b -> 'a = "%field0" -external snd : 'a * 'b -> 'b = "%field1" - -(* References *) - -type 'a ref = { mutable contents: 'a } -external ref: 'a -> 'a ref = "%makemutable" -external (!): 'a ref -> 'a = "%field0" -external (:=): 'a ref -> 'a -> unit = "%setfield0" -external incr: int ref -> unit = "%incr" -external decr: int ref -> unit = "%decr" - -(* String conversion functions *) - -external format_int: string -> int -> string = "format_int" -external format_float: string -> float -> string = "format_float" - -let string_of_bool b = - if b then "true" else "false" -let bool_of_string = function - | "true" -> true - | "false" -> false - | _ -> invalid_arg "bool_of_string" - -let string_of_int n = - format_int "%d" n - -external int_of_string : string -> int = "int_of_string" - -let valid_float_lexem s = - let l = string_length s in - let rec loop i = - if i >= l then s ^ "." else - match s.[i] with - | '0' .. '9' | '-' -> loop (i+1) - | _ -> s - in - loop 0 -;; - -let string_of_float f = valid_float_lexem (format_float "%.12g" f);; - -external float_of_string : string -> float = "float_of_string" - -(* List operations -- more in module List *) - -let rec (@) l1 l2 = - match l1 with - [] -> l2 - | hd :: tl -> hd :: (tl @ l2) - -(* I/O operations *) - -type in_channel -type out_channel - -external open_descriptor_out: int -> out_channel = "caml_open_descriptor_out" -external open_descriptor_in: int -> in_channel = "caml_open_descriptor_in" - -let stdin = open_descriptor_in 0 -let stdout = open_descriptor_out 1 -let stderr = open_descriptor_out 2 - -(* Non-blocking stuff *) - -external thread_wait_read_prim : Unix.file_descr -> unit = "thread_wait_read" -external thread_wait_write_prim : Unix.file_descr -> unit = "thread_wait_write" - -let thread_wait_read fd = thread_wait_read_prim fd -let thread_wait_write fd = thread_wait_write_prim fd - -external inchan_ready : in_channel -> bool = "thread_inchan_ready" -external outchan_ready : out_channel -> int -> bool = "thread_outchan_ready" -external descr_inchan : in_channel -> Unix.file_descr = "channel_descriptor" -external descr_outchan : out_channel -> Unix.file_descr = "channel_descriptor" - -let wait_inchan ic = - if not (inchan_ready ic) then thread_wait_read(descr_inchan ic) - -let wait_outchan oc len = - if not (outchan_ready oc len) then thread_wait_write(descr_outchan oc) - -(* General output functions *) - -type open_flag = - Open_rdonly | Open_wronly | Open_append - | Open_creat | Open_trunc | Open_excl - | Open_binary | Open_text | Open_nonblock - -external open_desc: string -> open_flag list -> int -> int = "sys_open" - -let open_out_gen mode perm name = - open_descriptor_out(open_desc name mode perm) - -let open_out name = - open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name - -let open_out_bin name = - open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name - -external flush_partial : out_channel -> bool = "caml_flush_partial" - -let rec flush oc = - let success = - try - flush_partial oc - with Sys_blocked_io -> - wait_outchan oc (-1); false in - if success then () else flush oc - -external out_channels_list : unit -> out_channel list - = "caml_out_channels_list" - -let flush_all () = - let rec iter = function - [] -> () - | a::l -> - begin try - flush a - with Sys_error _ -> - () (* ignore channels closed during a preceding flush. *) - end; - iter l - in iter (out_channels_list ()) - -external unsafe_output_partial : out_channel -> string -> int -> int -> int - = "caml_output_partial" - -let rec unsafe_output oc buf pos len = - if len > 0 then begin - let written = - try - unsafe_output_partial oc buf pos len - with Sys_blocked_io -> - wait_outchan oc len; 0 in - unsafe_output oc buf (pos + written) (len - written) - end - -external output_char_blocking : out_channel -> char -> unit - = "caml_output_char" -external output_byte_blocking : out_channel -> int -> unit = "caml_output_char" - -let rec output_char oc c = - try - output_char_blocking oc c - with Sys_blocked_io -> - wait_outchan oc 1; output_char oc c - -let output_string oc s = - unsafe_output oc s 0 (string_length s) - -let output oc s ofs len = - if ofs < 0 || len < 0 || ofs > string_length s - 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 - with Sys_blocked_io -> - wait_outchan oc 1; output_byte oc b - -let output_binary_int oc n = - output_byte oc (n asr 24); - output_byte oc (n asr 16); - output_byte oc (n asr 8); - output_byte oc n - -external marshal_to_string : 'a -> unit list -> string - = "output_value_to_string" - -let output_value oc v = output_string oc (marshal_to_string v []) - -external seek_out_blocking : out_channel -> int -> unit = "caml_seek_out" - -let seek_out oc pos = flush oc; seek_out_blocking oc pos - -external pos_out : out_channel -> int = "caml_pos_out" -external out_channel_length : out_channel -> int = "caml_channel_size" -external close_out_channel : out_channel -> unit = "caml_close_channel" - -let close_out oc = (try flush oc with _ -> ()); close_out_channel oc -let close_out_noerr oc = - (try flush oc with _ -> ()); - (try close_out_channel oc with _ -> ()) -external set_binary_mode_out : out_channel -> bool -> unit - = "caml_set_binary_mode" - -(* General input functions *) - -let open_in_gen mode perm name = - open_descriptor_in(open_desc name mode perm) - -let open_in name = - open_in_gen [Open_rdonly; Open_text] 0 name - -let open_in_bin name = - open_in_gen [Open_rdonly; Open_binary] 0 name - -external input_char_blocking : in_channel -> char = "caml_input_char" -external input_byte_blocking : in_channel -> int = "caml_input_char" - -let rec input_char ic = - try - input_char_blocking ic - with Sys_blocked_io -> - wait_inchan ic; input_char ic - -external unsafe_input_blocking : in_channel -> string -> int -> int -> int - = "caml_input" - -let rec unsafe_input ic s ofs len = - try - unsafe_input_blocking ic s ofs len - with Sys_blocked_io -> - wait_inchan ic; unsafe_input ic s ofs len - -let input ic s ofs len = - if ofs < 0 || len < 0 || ofs > string_length s - len - then invalid_arg "input" - else unsafe_input ic s ofs 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 - if r = 0 - then raise End_of_file - else unsafe_really_input ic s (ofs+r) (len-r) - end - -let really_input ic s ofs len = - if ofs < 0 || len < 0 || ofs > string_length s - len - then invalid_arg "really_input" - else unsafe_really_input ic s ofs len - -let input_line ic = - let buf = ref (string_create 128) in - let pos = ref 0 in - begin try - while true do - if !pos = string_length !buf then begin - let newbuf = string_create (2 * !pos) in - string_blit !buf 0 newbuf 0 !pos; - buf := newbuf - end; - let c = input_char ic in - if c = '\n' then raise Exit; - !buf.[!pos] <- c; - incr pos - done - with Exit -> () - | End_of_file -> if !pos = 0 then raise End_of_file - end; - let res = string_create !pos in - string_blit !buf 0 res 0 !pos; - res - -let rec input_byte ic = - try - input_byte_blocking ic - with Sys_blocked_io -> - wait_inchan ic; input_byte ic - -let input_binary_int ic = - let b1 = input_byte ic in - let n1 = if b1 >= 128 then b1 - 256 else b1 in - let b2 = input_byte ic in - let b3 = input_byte ic in - let b4 = input_byte ic in - (n1 lsl 24) + (b2 lsl 16) + (b3 lsl 8) + b4 - -external unmarshal : string -> int -> 'a = "input_value_from_string" -external marshal_data_size : string -> int -> int = "marshal_data_size" - -let input_value ic = - let header = string_create 20 in - really_input ic header 0 20; - let bsize = marshal_data_size header 0 in - let buffer = string_create (20 + bsize) in - string_blit header 0 buffer 0 20; - really_input ic buffer 20 bsize; - unmarshal buffer 0 - -external seek_in : in_channel -> int -> unit = "caml_seek_in" -external pos_in : in_channel -> int = "caml_pos_in" -external in_channel_length : in_channel -> int = "caml_channel_size" -external close_in : in_channel -> unit = "caml_close_channel" -let close_in_noerr ic = (try close_in ic with _ -> ());; -external set_binary_mode_in : in_channel -> bool -> unit - = "caml_set_binary_mode" - -(* Output functions on standard output *) - -let print_char c = output_char stdout c -let print_string s = output_string stdout s -let print_int i = output_string stdout (string_of_int i) -let print_float f = output_string stdout (string_of_float f) -let print_endline s = - output_string stdout s; output_char stdout '\n'; flush stdout -let print_newline () = output_char stdout '\n'; flush stdout - -(* Output functions on standard error *) - -let prerr_char c = output_char stderr c -let prerr_string s = output_string stderr s -let prerr_int i = output_string stderr (string_of_int i) -let prerr_float f = output_string stderr (string_of_float f) -let prerr_endline s = - output_string stderr s; output_char stderr '\n'; flush stderr -let prerr_newline () = output_char stderr '\n'; flush stderr - -(* Input functions on standard input *) - -let read_line () = flush stdout; input_line stdin -let read_int () = int_of_string(read_line()) -let read_float () = float_of_string(read_line()) - -(* Operations on large files *) - -module LargeFile = - struct - external seek_out : out_channel -> int64 -> unit = "caml_seek_out_64" - external pos_out : out_channel -> int64 = "caml_pos_out_64" - external out_channel_length : out_channel -> int64 = "caml_channel_size_64" - external seek_in : in_channel -> int64 -> unit = "caml_seek_in_64" - external pos_in : in_channel -> int64 = "caml_pos_in_64" - external in_channel_length : in_channel -> int64 = "caml_channel_size_64" - end - -(* Formats *) -type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 -external format_of_string : - ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity" -external string_of_format : ('a, 'b, 'c, 'd) format4 -> string = "%identity" - -external string_to_format : string -> ('a, 'b, 'c, 'd) format4 = "%identity" -let (( ^^ ) : ('a, 'b, 'c, 'd) format4 -> ('d, 'b, 'c, 'e) format4 -> - ('a, 'b, 'c, 'e) format4) = fun fmt1 fmt2 -> - string_to_format (string_of_format fmt1 ^ string_of_format fmt2);; - -(* Miscellaneous *) - -external sys_exit : int -> 'a = "sys_exit" - -let exit_function = ref flush_all - -let at_exit f = - let g = !exit_function in - exit_function := (fun () -> f(); g()) - -let do_at_exit () = (!exit_function) () - -let exit retcode = - do_at_exit (); - sys_exit retcode - -external register_named_value: string -> 'a -> unit = "register_named_value" - -let _ = register_named_value "Pervasives.do_at_exit" do_at_exit diff --git a/otherlibs/threads/scheduler.c b/otherlibs/threads/scheduler.c deleted file mode 100644 index 41854ead97..0000000000 --- a/otherlibs/threads/scheduler.c +++ /dev/null @@ -1,876 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* The thread scheduler */ - -#include <string.h> -#include <stdlib.h> -#include <stdio.h> - -#include "alloc.h" -#include "backtrace.h" -#include "callback.h" -#include "config.h" -#include "fail.h" -#include "io.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "printexc.h" -#include "roots.h" -#include "signals.h" -#include "stacks.h" -#include "sys.h" - -#if ! (defined(HAS_SELECT) && \ - defined(HAS_SETITIMER) && \ - defined(HAS_GETTIMEOFDAY) && \ - (defined(HAS_WAITPID) || defined(HAS_WAIT4))) -#include "Cannot compile libthreads, system calls missing" -#endif - -#include <errno.h> -#include <sys/time.h> -#include <sys/types.h> -#include <sys/wait.h> -#include <sys/stat.h> -#include <fcntl.h> -#ifdef HAS_UNISTD -#include <unistd.h> -#endif -#ifdef HAS_SYS_SELECT_H -#include <sys/select.h> -#endif - -#ifndef HAS_WAITPID -#define waitpid(pid,status,opts) wait4(pid,status,opts,NULL) -#endif - -#ifndef O_NONBLOCK -#define O_NONBLOCK O_NDELAY -#endif - -/* Configuration */ - -/* Initial size of stack when a thread is created (4 Ko) */ -#define Thread_stack_size (Stack_size / 4) - -/* Max computation time before rescheduling, in microseconds (50ms) */ -#define Thread_timeout 50000 - -/* The thread descriptors */ - -struct caml_thread_struct { - value ident; /* Unique id (for equality comparisons) */ - struct caml_thread_struct * next; /* Double linking of threads */ - struct caml_thread_struct * prev; - value * stack_low; /* The execution stack for this thread */ - value * stack_high; - value * stack_threshold; - value * sp; - value * trapsp; - value backtrace_pos; /* The backtrace info for this thread */ - code_t * backtrace_buffer; - value backtrace_last_exn; - value status; /* RUNNABLE, KILLED. etc (see below) */ - value fd; /* File descriptor on which we're doing read or write */ - value readfds, writefds, exceptfds; - /* Lists of file descriptors on which we're doing select() */ - value delay; /* Time until which this thread is blocked */ - value joining; /* Thread we're trying to join */ - value waitpid; /* PID of process we're waiting for */ - value retval; /* Value to return when thread resumes */ -}; - -typedef struct caml_thread_struct * caml_thread_t; - -#define RUNNABLE Val_int(0) -#define KILLED Val_int(1) -#define SUSPENDED Val_int(2) -#define BLOCKED_READ Val_int(4) -#define BLOCKED_WRITE Val_int(8) -#define BLOCKED_SELECT Val_int(16) -#define BLOCKED_DELAY Val_int(32) -#define BLOCKED_JOIN Val_int(64) -#define BLOCKED_WAIT Val_int(128) - -#define RESUMED_WAKEUP Val_int(0) -#define RESUMED_DELAY Val_int(1) -#define RESUMED_JOIN Val_int(2) -#define RESUMED_IO Val_int(3) - -#define TAG_RESUMED_SELECT 0 -#define TAG_RESUMED_WAIT 1 - -#define NO_FDS Val_unit -#define NO_DELAY Val_unit -#define NO_JOINING Val_unit -#define NO_WAITPID Val_int(0) - -#define DELAY_INFTY 1E30 /* +infty, for this purpose */ - -/* The thread currently active */ -static caml_thread_t curr_thread = NULL; -/* Identifier for next thread creation */ -static value next_ident = Val_int(0); - -#define Assign(dst,src) modify((value *)&(dst), (value)(src)) - -/* Scan the stacks of the other threads */ - -static void (*prev_scan_roots_hook) (scanning_action); - -static void thread_scan_roots(scanning_action action) -{ - caml_thread_t th, start; - - /* Scan all active descriptors */ - start = curr_thread; - (*action)((value) curr_thread, (value *) &curr_thread); - /* Don't scan curr_thread->sp, this has already been done. - Don't scan local roots either, for the same reason. */ - for (th = start->next; th != start; th = th->next) { - do_local_roots(action, th->sp, th->stack_high, NULL); - } - /* Hook */ - if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action); -} - -/* Forward declarations for async I/O handling */ - -static int stdin_initial_status, stdout_initial_status, stderr_initial_status; -static void thread_restore_std_descr(void); - -/* Initialize the thread machinery */ - -value thread_initialize(value unit) /* ML */ -{ - /* Protect against repeated initialization (PR#1325) */ - if (curr_thread != NULL) return Val_unit; - /* Create a descriptor for the current thread */ - curr_thread = - (caml_thread_t) alloc_shr(sizeof(struct caml_thread_struct) - / sizeof(value), 0); - curr_thread->ident = next_ident; - next_ident = Val_int(Int_val(next_ident) + 1); - curr_thread->next = curr_thread; - curr_thread->prev = curr_thread; - curr_thread->stack_low = stack_low; - curr_thread->stack_high = stack_high; - curr_thread->stack_threshold = stack_threshold; - curr_thread->sp = extern_sp; - curr_thread->trapsp = trapsp; - curr_thread->backtrace_pos = Val_int(backtrace_pos); - curr_thread->backtrace_buffer = backtrace_buffer; - curr_thread->backtrace_last_exn = backtrace_last_exn; - curr_thread->status = RUNNABLE; - curr_thread->fd = Val_int(0); - curr_thread->readfds = NO_FDS; - curr_thread->writefds = NO_FDS; - curr_thread->exceptfds = NO_FDS; - curr_thread->delay = NO_DELAY; - curr_thread->joining = NO_JOINING; - curr_thread->waitpid = NO_WAITPID; - curr_thread->retval = Val_unit; - /* Initialize GC */ - prev_scan_roots_hook = scan_roots_hook; - scan_roots_hook = thread_scan_roots; - /* Set standard file descriptors to non-blocking mode */ - stdin_initial_status = fcntl(0, F_GETFL); - stdout_initial_status = fcntl(1, F_GETFL); - stderr_initial_status = fcntl(2, F_GETFL); - if (stdin_initial_status != -1) - fcntl(0, F_SETFL, stdin_initial_status | O_NONBLOCK); - if (stdout_initial_status != -1) - fcntl(1, F_SETFL, stdout_initial_status | O_NONBLOCK); - if (stderr_initial_status != -1) - fcntl(2, F_SETFL, stderr_initial_status | O_NONBLOCK); - /* Register an at-exit function to restore the standard file descriptors */ - atexit(thread_restore_std_descr); - return Val_unit; -} - -/* Initialize the interval timer used for preemption */ - -value thread_initialize_preemption(value unit) /* ML */ -{ - struct itimerval timer; - - timer.it_interval.tv_sec = 0; - timer.it_interval.tv_usec = Thread_timeout; - timer.it_value = timer.it_interval; - setitimer(ITIMER_VIRTUAL, &timer, NULL); - return Val_unit; -} - -/* Create a thread */ - -value thread_new(value clos) /* ML */ -{ - caml_thread_t th; - /* Allocate the thread and its stack */ - Begin_root(clos); - th = (caml_thread_t) alloc_shr(sizeof(struct caml_thread_struct) - / sizeof(value), 0); - End_roots(); - th->ident = next_ident; - next_ident = Val_int(Int_val(next_ident) + 1); - th->stack_low = (value *) stat_alloc(Thread_stack_size); - th->stack_high = th->stack_low + Thread_stack_size / sizeof(value); - th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value); - th->sp = th->stack_high; - th->trapsp = th->stack_high; - /* Set up a return frame that pretends we're applying the function to (). - This way, the next RETURN instruction will run the function. */ - th->sp -= 5; - th->sp[0] = Val_unit; /* dummy local to be popped by RETURN 1 */ - th->sp[1] = (value) Code_val(clos); - th->sp[2] = clos; - th->sp[3] = Val_long(0); /* no extra args */ - th->sp[4] = Val_unit; /* the () argument */ - /* Fake a C call frame */ - th->sp--; - th->sp[0] = Val_unit; /* a dummy environment */ - /* Finish initialization of th */ - th->backtrace_pos = Val_int(0); - th->backtrace_buffer = NULL; - th->backtrace_last_exn = Val_unit; - /* The thread is initially runnable */ - th->status = RUNNABLE; - th->fd = Val_int(0); - th->readfds = NO_FDS; - th->writefds = NO_FDS; - th->exceptfds = NO_FDS; - th->delay = NO_DELAY; - th->joining = NO_JOINING; - th->waitpid = NO_WAITPID; - th->retval = Val_unit; - /* Insert thread in doubly linked list of threads */ - th->prev = curr_thread->prev; - th->next = curr_thread; - Assign(curr_thread->prev->next, th); - Assign(curr_thread->prev, th); - /* Return thread */ - return (value) th; -} - -/* Return the thread identifier */ - -value thread_id(value th) /* ML */ -{ - return ((caml_thread_t)th)->ident; -} - -/* Return the current time as a floating-point number */ - -static double timeofday(void) -{ - struct timeval tv; - gettimeofday(&tv, NULL); - return (double) tv.tv_sec + (double) tv.tv_usec * 1e-6; -} - -/* Find a runnable thread and activate it */ - -#define FOREACH_THREAD(x) x = curr_thread; do { x = x->next; -#define END_FOREACH(x) } while (x != curr_thread) - -static value alloc_process_status(int pid, int status); -static void add_fdlist_to_set(value fdl, fd_set *set); -static value inter_fdlist_set(value fdl, fd_set *set, int *count); -static void find_bad_fd(int fd, fd_set *set); -static void find_bad_fds(value fdl, fd_set *set); - -static value schedule_thread(void) -{ - caml_thread_t run_thread, th; - fd_set readfds, writefds, exceptfds; - double delay, now; - int need_select, need_wait; - - /* Don't allow preemption during a callback */ - if (callback_depth > 1) return curr_thread->retval; - - /* Save the status of the current thread */ - curr_thread->stack_low = stack_low; - curr_thread->stack_high = stack_high; - curr_thread->stack_threshold = stack_threshold; - curr_thread->sp = extern_sp; - curr_thread->trapsp = trapsp; - curr_thread->backtrace_pos = Val_int(backtrace_pos); - curr_thread->backtrace_buffer = backtrace_buffer; - curr_thread->backtrace_last_exn = backtrace_last_exn; - -try_again: - /* Find if a thread is runnable. - Build fdsets and delay for select. - See if some join or wait operations succeeded. */ - run_thread = NULL; - FD_ZERO(&readfds); - FD_ZERO(&writefds); - FD_ZERO(&exceptfds); - delay = DELAY_INFTY; - now = -1.0; - need_select = 0; - need_wait = 0; - - FOREACH_THREAD(th) - if (th->status <= SUSPENDED) continue; - - if (th->status & (BLOCKED_READ - 1)) { - FD_SET(Int_val(th->fd), &readfds); - need_select = 1; - } - if (th->status & (BLOCKED_WRITE - 1)) { - FD_SET(Int_val(th->fd), &writefds); - need_select = 1; - } - if (th->status & (BLOCKED_SELECT - 1)) { - add_fdlist_to_set(th->readfds, &readfds); - add_fdlist_to_set(th->writefds, &writefds); - add_fdlist_to_set(th->exceptfds, &exceptfds); - need_select = 1; - } - if (th->status & (BLOCKED_DELAY - 1)) { - double th_delay; - if (now < 0.0) now = timeofday(); - th_delay = Double_val(th->delay) - now; - if (th_delay <= 0) { - th->status = RUNNABLE; - Assign(th->retval,RESUMED_DELAY); - } else { - if (th_delay < delay) delay = th_delay; - } - } - if (th->status & (BLOCKED_JOIN - 1)) { - if (((caml_thread_t)(th->joining))->status == KILLED) { - th->status = RUNNABLE; - Assign(th->retval, RESUMED_JOIN); - } - } - if (th->status & (BLOCKED_WAIT - 1)) { - int status, pid; - pid = waitpid(Int_val(th->waitpid), &status, WNOHANG); - if (pid > 0) { - th->status = RUNNABLE; - Assign(th->retval, alloc_process_status(pid, status)); - } else { - need_wait = 1; - } - } - END_FOREACH(th); - - /* Find if a thread is runnable. */ - run_thread = NULL; - FOREACH_THREAD(th) - if (th->status == RUNNABLE) { run_thread = th; break; } - END_FOREACH(th); - - /* Do the select if needed */ - if (need_select || run_thread == NULL) { - struct timeval delay_tv, * delay_ptr; - int retcode; - /* If a thread is blocked on wait, don't block forever */ - if (need_wait && delay > Thread_timeout * 1e-6) { - delay = Thread_timeout * 1e-6; - } - /* Convert delay to a timeval */ - /* If a thread is runnable, just poll */ - if (run_thread != NULL) { - delay_tv.tv_sec = 0; - delay_tv.tv_usec = 0; - delay_ptr = &delay_tv; - } - else if (delay != DELAY_INFTY) { - delay_tv.tv_sec = (unsigned int) delay; - delay_tv.tv_usec = (delay - (double) delay_tv.tv_sec) * 1E6; - delay_ptr = &delay_tv; - } - else { - delay_ptr = NULL; - } - enter_blocking_section(); - retcode = select(FD_SETSIZE, &readfds, &writefds, &exceptfds, delay_ptr); - leave_blocking_section(); - if (retcode == -1) - switch (errno) { - case EINTR: - break; - case EBADF: - /* One of the descriptors in the sets was closed or is bad. - Find it using fstat() and wake up the threads waiting on it - so that they'll get an error when operating on it. */ - FOREACH_THREAD(th) - if (th->status & (BLOCKED_READ - 1)) { - find_bad_fd(Int_val(th->fd), &readfds); - } - if (th->status & (BLOCKED_WRITE - 1)) { - find_bad_fd(Int_val(th->fd), &writefds); - } - if (th->status & (BLOCKED_SELECT - 1)) { - find_bad_fds(th->readfds, &readfds); - find_bad_fds(th->writefds, &writefds); - find_bad_fds(th->exceptfds, &exceptfds); - } - END_FOREACH(th); - retcode = FD_SETSIZE; - break; - default: - sys_error(NO_ARG); - } - if (retcode > 0) { - /* Some descriptors are ready. - Mark the corresponding threads runnable. */ - FOREACH_THREAD(th) - if (retcode <= 0) break; - if ((th->status & (BLOCKED_READ - 1)) && - FD_ISSET(Int_val(th->fd), &readfds)) { - Assign(th->retval, RESUMED_IO); - th->status = RUNNABLE; - if (run_thread == NULL) run_thread = th; /* Found one. */ - /* Wake up only one thread per fd */ - FD_CLR(Int_val(th->fd), &readfds); - retcode--; - } - if ((th->status & (BLOCKED_WRITE - 1)) && - FD_ISSET(Int_val(th->fd), &writefds)) { - Assign(th->retval, RESUMED_IO); - th->status = RUNNABLE; - if (run_thread == NULL) run_thread = th; /* Found one. */ - /* Wake up only one thread per fd */ - FD_CLR(Int_val(th->fd), &readfds); - retcode--; - } - if (th->status & (BLOCKED_SELECT - 1)) { - value r = Val_unit, w = Val_unit, e = Val_unit; - Begin_roots3(r,w,e) - r = inter_fdlist_set(th->readfds, &readfds, &retcode); - w = inter_fdlist_set(th->writefds, &writefds, &retcode); - e = inter_fdlist_set(th->exceptfds, &exceptfds, &retcode); - if (r != NO_FDS || w != NO_FDS || e != NO_FDS) { - value retval = alloc_small(3, TAG_RESUMED_SELECT); - Field(retval, 0) = r; - Field(retval, 1) = w; - Field(retval, 2) = e; - Assign(th->retval, retval); - th->status = RUNNABLE; - if (run_thread == NULL) run_thread = th; /* Found one. */ - } - End_roots(); - } - END_FOREACH(th); - } - /* If we get here with run_thread still NULL, one of the following - may have happened: - - a delay has expired - - a wait() needs to be polled again - - the select() failed (e.g. was interrupted) - In these cases, we go through the loop once more to make the - corresponding threads runnable. */ - if (run_thread == NULL && - (delay != DELAY_INFTY || need_wait || retcode == -1)) - goto try_again; - } - - /* If we haven't something to run at that point, we're in big trouble. */ - if (run_thread == NULL) invalid_argument("Thread: deadlock"); - - /* Free everything the thread was waiting on */ - Assign(run_thread->readfds, NO_FDS); - Assign(run_thread->writefds, NO_FDS); - Assign(run_thread->exceptfds, NO_FDS); - Assign(run_thread->delay, NO_DELAY); - Assign(run_thread->joining, NO_JOINING); - run_thread->waitpid = NO_WAITPID; - - /* Activate the thread */ - curr_thread = run_thread; - stack_low = curr_thread->stack_low; - stack_high = curr_thread->stack_high; - stack_threshold = curr_thread->stack_threshold; - extern_sp = curr_thread->sp; - trapsp = curr_thread->trapsp; - backtrace_pos = Int_val(curr_thread->backtrace_pos); - backtrace_buffer = curr_thread->backtrace_buffer; - backtrace_last_exn = curr_thread->backtrace_last_exn; - return curr_thread->retval; -} - -/* Since context switching is not allowed in callbacks, a thread that - blocks during a callback is a deadlock. */ - -static void check_callback(void) -{ - if (callback_depth > 1) - fatal_error("Thread: deadlock during callback"); -} - -/* Reschedule without suspending the current thread */ - -value thread_yield(value unit) /* ML */ -{ - Assert(curr_thread != NULL); - Assign(curr_thread->retval, Val_unit); - return schedule_thread(); -} - -/* Honor an asynchronous request for re-scheduling */ - -static void thread_reschedule(void) -{ - value accu; - - Assert(curr_thread != NULL); - /* Pop accu from event frame, making it look like a C_CALL frame - followed by a RETURN frame */ - accu = *extern_sp++; - /* Reschedule */ - Assign(curr_thread->retval, accu); - accu = schedule_thread(); - /* Push accu below C_CALL frame so that it looks like an event frame */ - *--extern_sp = accu; -} - -/* Request a re-scheduling as soon as possible */ - -value thread_request_reschedule(value unit) /* ML */ -{ - async_action_hook = thread_reschedule; - something_to_do = 1; - return Val_unit; -} - -/* Suspend the current thread */ - -value thread_sleep(value unit) /* ML */ -{ - Assert(curr_thread != NULL); - check_callback(); - curr_thread->status = SUSPENDED; - return schedule_thread(); -} - -/* Suspend the current thread on a read() or write() request */ - -static value thread_wait_rw(int kind, value fd) -{ - /* Don't do an error if we're not initialized yet - (we can be called from thread-safe Pervasives before initialization), - just return immediately. */ - if (curr_thread == NULL) return RESUMED_WAKEUP; - /* As a special case, if we're in a callback, don't fail but block - the whole process till I/O is possible */ - if (callback_depth > 1) { - fd_set fds; - FD_ZERO(&fds); - FD_SET(Int_val(fd), &fds); - switch(kind) { - case BLOCKED_READ: select(FD_SETSIZE, &fds, NULL, NULL, NULL); break; - case BLOCKED_WRITE: select(FD_SETSIZE, NULL, &fds, NULL, NULL); break; - } - return RESUMED_IO; - } else { - curr_thread->fd = fd; - curr_thread->status = kind; - return schedule_thread(); - } -} - -value thread_wait_read(value fd) -{ - return thread_wait_rw(BLOCKED_READ, fd); -} - -value thread_wait_write(value fd) -{ - return thread_wait_rw(BLOCKED_WRITE, fd); -} - -/* Suspend the current thread on a read() or write() request with timeout */ - -static value thread_wait_timed_rw(int kind, value arg) -{ - double date; - - check_callback(); - curr_thread->fd = Field(arg, 0); - date = timeofday() + Double_val(Field(arg, 1)); - Assign(curr_thread->delay, copy_double(date)); - curr_thread->status = kind | BLOCKED_DELAY; - return schedule_thread(); -} - -value thread_wait_timed_read(value arg) -{ - return thread_wait_timed_rw(BLOCKED_READ, arg); -} - -value thread_wait_timed_write(value arg) -{ - return thread_wait_timed_rw(BLOCKED_WRITE, arg); -} - -/* Suspend the current thread on a select() request */ - -value thread_select(value arg) /* ML */ -{ - double date; - check_callback(); - Assign(curr_thread->readfds, Field(arg, 0)); - Assign(curr_thread->writefds, Field(arg, 1)); - Assign(curr_thread->exceptfds, Field(arg, 2)); - date = Double_val(Field(arg, 3)); - if (date >= 0.0) { - date += timeofday(); - Assign(curr_thread->delay, copy_double(date)); - curr_thread->status = BLOCKED_SELECT | BLOCKED_DELAY; - } else { - curr_thread->status = BLOCKED_SELECT; - } - return schedule_thread(); -} - -/* Primitives to implement suspension on buffered channels */ - -value thread_inchan_ready(value vchan) /* ML */ -{ - struct channel * chan = Channel(vchan); - return Val_bool(chan->curr < chan->max); -} - -value thread_outchan_ready(value vchan, value vsize) /* ML */ -{ - struct channel * chan = Channel(vchan); - long size = Long_val(vsize); - /* Negative size means we want to flush the buffer entirely */ - if (size < 0) { - return Val_bool(chan->curr == chan->buff); - } else { - int free = chan->end - chan->curr; - if (chan->curr == chan->buff) - return Val_bool(size < free); - else - return Val_bool(size <= free); - } -} - -/* Suspend the current thread for some time */ - -value thread_delay(value time) /* ML */ -{ - double date = timeofday() + Double_val(time); - Assert(curr_thread != NULL); - check_callback(); - curr_thread->status = BLOCKED_DELAY; - Assign(curr_thread->delay, copy_double(date)); - return schedule_thread(); -} - -/* Suspend the current thread until another thread terminates */ - -value thread_join(value th) /* ML */ -{ - check_callback(); - Assert(curr_thread != NULL); - if (((caml_thread_t)th)->status == KILLED) return Val_unit; - curr_thread->status = BLOCKED_JOIN; - Assign(curr_thread->joining, th); - return schedule_thread(); -} - -/* Suspend the current thread until a Unix process exits */ - -value thread_wait_pid(value pid) /* ML */ -{ - Assert(curr_thread != NULL); - check_callback(); - curr_thread->status = BLOCKED_WAIT; - curr_thread->waitpid = pid; - return schedule_thread(); -} - -/* Reactivate another thread */ - -value thread_wakeup(value thread) /* ML */ -{ - caml_thread_t th = (caml_thread_t) thread; - switch (th->status) { - case SUSPENDED: - th->status = RUNNABLE; - Assign(th->retval, RESUMED_WAKEUP); - break; - case KILLED: - failwith("Thread.wakeup: killed thread"); - default: - failwith("Thread.wakeup: thread not suspended"); - } - return Val_unit; -} - -/* Return the current thread */ - -value thread_self(value unit) /* ML */ -{ - Assert(curr_thread != NULL); - return (value) curr_thread; -} - -/* Kill a thread */ - -value thread_kill(value thread) /* ML */ -{ - value retval = Val_unit; - caml_thread_t th = (caml_thread_t) thread; - if (th->status == KILLED) failwith("Thread.kill: killed thread"); - /* Don't paint ourselves in a corner */ - if (th == th->next) failwith("Thread.kill: cannot kill the last thread"); - /* This thread is no longer waiting on anything */ - th->status = KILLED; - /* If this is the current thread, activate another one */ - if (th == curr_thread) { - Begin_root(thread); - retval = schedule_thread(); - th = (caml_thread_t) thread; - End_roots(); - } - /* Remove thread from the doubly-linked list */ - Assign(th->prev->next, th->next); - Assign(th->next->prev, th->prev); - /* Free its resources */ - stat_free((char *) th->stack_low); - th->stack_low = NULL; - th->stack_high = NULL; - th->stack_threshold = NULL; - th->sp = NULL; - th->trapsp = NULL; - if (th->backtrace_buffer != NULL) { - free(th->backtrace_buffer); - th->backtrace_buffer = NULL; - } - return retval; -} - -/* Print uncaught exception and backtrace */ - -value thread_uncaught_exception(value exn) /* ML */ -{ - char * msg = format_caml_exception(exn); - fprintf(stderr, "Thread %d killed on uncaught exception %s\n", - Int_val(curr_thread->ident), msg); - free(msg); - if (backtrace_active) print_exception_backtrace(); - fflush(stderr); - return Val_unit; -} - -/* Set a list of file descriptors in a fdset */ - -static void add_fdlist_to_set(value fdl, fd_set *set) -{ - for (/*nothing*/; fdl != NO_FDS; fdl = Field(fdl, 1)) { - int fd = Int_val(Field(fdl, 0)); - /* Ignore funky file descriptors, which can cause crashes */ - if (fd >= 0 && fd < FD_SETSIZE) FD_SET(fd, set); - } -} - -/* Build the intersection of a list and a fdset (the list of file descriptors - which are both in the list and in the fdset). */ - -static value inter_fdlist_set(value fdl, fd_set *set, int *count) -{ - value res = Val_unit; - value cons; - - Begin_roots2(fdl, res); - for (res = NO_FDS; fdl != NO_FDS; fdl = Field(fdl, 1)) { - int fd = Int_val(Field(fdl, 0)); - if (FD_ISSET(fd, set)) { - cons = alloc_small(2, 0); - Field(cons, 0) = Val_int(fd); - Field(cons, 1) = res; - res = cons; - FD_CLR(fd, set); /* wake up only one thread per fd ready */ - (*count)--; - } - } - End_roots(); - return res; -} - -/* Find closed file descriptors in a waiting list and set them to 1 in - the given fdset */ - -static void find_bad_fd(int fd, fd_set *set) -{ - struct stat s; - if (fd >= 0 && fd < FD_SETSIZE && fstat(fd, &s) == -1 && errno == EBADF) - FD_SET(fd, set); -} - -static void find_bad_fds(value fdl, fd_set *set) -{ - for (/*nothing*/; fdl != NO_FDS; fdl = Field(fdl, 1)) - find_bad_fd(Int_val(Field(fdl, 0)), set); -} - -/* Auxiliary function for allocating the result of a waitpid() call */ - -#if !(defined(WIFEXITED) && defined(WEXITSTATUS) && defined(WIFSTOPPED) && \ - defined(WSTOPSIG) && defined(WTERMSIG)) -/* Assume old-style V7 status word */ -#define WIFEXITED(status) (((status) & 0xFF) == 0) -#define WEXITSTATUS(status) (((status) >> 8) & 0xFF) -#define WIFSTOPPED(status) (((status) & 0xFF) == 0xFF) -#define WSTOPSIG(status) (((status) >> 8) & 0xFF) -#define WTERMSIG(status) ((status) & 0x3F) -#endif - -#define TAG_WEXITED 0 -#define TAG_WSIGNALED 1 -#define TAG_WSTOPPED 2 - -static value alloc_process_status(int pid, int status) -{ - value st, res; - - if (WIFEXITED(status)) { - st = alloc_small(1, TAG_WEXITED); - Field(st, 0) = Val_int(WEXITSTATUS(status)); - } - else if (WIFSTOPPED(status)) { - st = alloc_small(1, TAG_WSTOPPED); - Field(st, 0) = Val_int(WSTOPSIG(status)); - } - else { - st = alloc_small(1, TAG_WSIGNALED); - Field(st, 0) = Val_int(WTERMSIG(status)); - } - Begin_root(st); - res = alloc_small(2, TAG_RESUMED_WAIT); - Field(res, 0) = Val_int(pid); - Field(res, 1) = st; - End_roots(); - return res; -} - -/* Restore the standard file descriptors to their initial state */ - -static void thread_restore_std_descr(void) -{ - if (stdin_initial_status != -1) fcntl(0, F_SETFL, stdin_initial_status); - if (stdout_initial_status != -1) fcntl(1, F_SETFL, stdout_initial_status); - if (stderr_initial_status != -1) fcntl(2, F_SETFL, stderr_initial_status); -} diff --git a/otherlibs/threads/thread.ml b/otherlibs/threads/thread.ml deleted file mode 100644 index 31fc7f0781..0000000000 --- a/otherlibs/threads/thread.ml +++ /dev/null @@ -1,141 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* User-level threads *) - -type t - -let critical_section = ref false - -type resumption_status = - Resumed_wakeup - | Resumed_delay - | Resumed_join - | Resumed_io - | Resumed_select of - Unix.file_descr list * Unix.file_descr list * Unix.file_descr list - | Resumed_wait of int * Unix.process_status - -(* It is mucho important that the primitives that reschedule are called - through an ML function call, not directly. That's because when such a - primitive returns, the bytecode interpreter is only semi-obedient: - it takes sp from the new thread, but keeps pc from the old thread. - But that's OK if all calls to rescheduling primitives are immediately - followed by a RETURN operation, which will restore the correct pc - from the stack. Furthermore, the RETURNs must all have the same - frame size, which means that both the primitives and their ML wrappers - must take exactly one argument. *) - -external thread_initialize : unit -> unit = "thread_initialize" -external thread_initialize_preemption : unit -> unit = "thread_initialize_preemption" -external thread_new : (unit -> unit) -> t = "thread_new" -external thread_yield : unit -> unit = "thread_yield" -external thread_request_reschedule : unit -> unit = "thread_request_reschedule" -external thread_sleep : unit -> unit = "thread_sleep" -external thread_wait_read : Unix.file_descr -> unit = "thread_wait_read" -external thread_wait_write : Unix.file_descr -> unit = "thread_wait_write" -external thread_wait_timed_read : - Unix.file_descr * float -> resumption_status (* remember: 1 arg *) - = "thread_wait_timed_read" -external thread_wait_timed_write : - Unix.file_descr * float -> resumption_status (* remember: 1 arg *) - = "thread_wait_timed_write" -external thread_select : - Unix.file_descr list * Unix.file_descr list * (* remember: 1 arg *) - Unix.file_descr list * float -> resumption_status - = "thread_select" -external thread_join : t -> unit = "thread_join" -external thread_delay : float -> unit = "thread_delay" -external thread_wait_pid : int -> resumption_status = "thread_wait_pid" -external thread_wakeup : t -> unit = "thread_wakeup" -external thread_self : unit -> t = "thread_self" -external thread_kill : t -> unit = "thread_kill" -external thread_uncaught_exception : exn -> unit = "thread_uncaught_exception" - -external id : t -> int = "thread_id" - -(* In sleep() below, we rely on the fact that signals are detected - only at function applications and beginning of loops, - making all other operations atomic. *) - -let yield () = thread_yield() -let sleep () = critical_section := false; thread_sleep() -let delay duration = thread_delay duration -let join th = thread_join th -let wakeup pid = thread_wakeup pid -let self () = thread_self() -let kill pid = thread_kill pid -let exit () = thread_kill(thread_self()) - -let select_aux arg = thread_select arg - -let select readfds writefds exceptfds delay = - match select_aux (readfds, writefds, exceptfds, delay) with - Resumed_select(r, w, e) -> (r, w, e) - | _ -> ([], [], []) - -let wait_read fd = thread_wait_read fd -let wait_write fd = thread_wait_write fd - -let wait_timed_read_aux arg = thread_wait_timed_read arg -let wait_timed_write_aux arg = thread_wait_timed_write arg - -let wait_timed_read fd delay = - match wait_timed_read_aux (fd, delay) with Resumed_io -> true | _ -> false - -let wait_timed_write fd delay = - match wait_timed_write_aux (fd, delay) with Resumed_io -> true | _ -> false - -let wait_pid_aux pid = thread_wait_pid pid - -let wait_pid pid = - match wait_pid_aux pid with - Resumed_wait(pid, status) -> (pid, status) - | _ -> invalid_arg "Thread.wait_pid" - -let wait_signal sigs = - let gotsig = ref 0 in - let self = thread_self() in - let sighandler s = gotsig := s; wakeup self in - let oldhdlrs = - List.map (fun s -> Sys.signal s (Sys.Signal_handle sighandler)) sigs in - if !gotsig = 0 then sleep(); - List.iter2 Sys.set_signal sigs oldhdlrs; - !gotsig - -(* For Thread.create, make sure the function passed to thread_new - always terminates by calling Thread.exit. *) - -let create fn arg = - thread_new - (fun () -> - try - fn arg; exit() - with x -> - flush stdout; flush stderr; - thread_uncaught_exception x; - exit()) - -(* Preemption *) - -let preempt signal = - if !critical_section then () else thread_request_reschedule() - -(* Initialization of the scheduler *) - -let _ = - thread_initialize(); - Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle preempt); - thread_initialize_preemption() diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli deleted file mode 100644 index 17a6260b30..0000000000 --- a/otherlibs/threads/thread.mli +++ /dev/null @@ -1,141 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Lightweight threads. *) - -type t -(** The type of thread handles. *) - - -(** {6 Thread creation and termination} *) - -val create : ('a -> 'b) -> 'a -> t -(** [Thread.create funct arg] creates a new thread of control, - in which the function application [funct arg] - is executed concurrently with the other threads of the program. - The application of [Thread.create] - returns the handle of the newly created thread. - The new thread terminates when the application [funct arg] - returns, either normally or by raising an uncaught exception. - In the latter case, the exception is printed on standard error, - but not propagated back to the parent thread. Similarly, the - result of the application [funct arg] is discarded and not - directly accessible to the parent thread. *) - -val self : unit -> t -(** Return the thread currently executing. *) - -external id : t -> int = "thread_id" -(** Return the identifier of the given thread. A thread identifier - is an integer that identifies uniquely the thread. - It can be used to build data structures indexed by threads. *) - -val exit : unit -> unit -(** Terminate prematurely the currently executing thread. *) - -val kill : t -> unit -(** Terminate prematurely the thread whose handle is given. - This functionality is available only with bytecode-level threads. *) - -(** {6 Suspending threads} *) - -val delay : float -> unit -(** [delay d] suspends the execution of the calling thread for - [d] seconds. The other program threads continue to run during - this time. *) - -val join : t -> unit -(** [join th] suspends the execution of the calling thread - until the thread [th] has terminated. *) - -val wait_read : Unix.file_descr -> unit -(** See {!Thread.wait_write}.*) - -val wait_write : Unix.file_descr -> unit -(** Suspend the execution of the calling thread until at least - one character is available for reading ({!Thread.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 -> float -> bool -(** See {!Thread.wait_timed_read}.*) - -val wait_timed_write : Unix.file_descr -> float -> bool -(** Same as {!Thread.wait_read} and {!Thread.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 : - 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. - The arguments and results have the same meaning as for - {!Unix.select}. *) - -val wait_pid : int -> int * Unix.process_status -(** [wait_pid p] suspends the execution of the calling thread - until the Unix process specified by the process identifier [p] - terminates. A pid [p] 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. Returns the pid of the child caught and - its termination status, as per {!Unix.wait}. *) - -val wait_signal : int list -> int -(** [wait_signal sigs] suspends the execution of the calling thread - until the process receives one of the signals specified in the - list [sigs]. It then returns the number of the signal received. - Signal handlers attached to the signals in [sigs] will not - be invoked. Do not call [wait_signal] concurrently - from several threads on the same signals. *) - -val yield : unit -> unit -(** Re-schedule the calling thread without suspending it. - This function can be used to give scheduling hints, - telling the scheduler that now is a good time to - switch to other threads. *) - -(**/**) - -(** {6 Synchronization primitives} - - The following primitives provide the basis for implementing - synchronization functions between threads. Their direct use is - discouraged, as they are very low-level and prone to race conditions - and deadlocks. The modules {!Mutex}, {!Condition} and {!Event} - provide higher-level synchronization primitives. *) - -val critical_section : bool ref -(** Setting this reference to [true] deactivate thread preemption - (the timer interrupt that transfers control from thread to thread), - causing the current thread to run uninterrupted until - [critical_section] is reset to [false] or the current thread - explicitely relinquishes control using [sleep], [delay], - [wait_inchan] or [wait_descr]. *) - -val sleep : unit -> unit -(** Suspend the calling thread until another thread reactivates it - using {!Thread.wakeup}. Just before suspending the thread, - {!Thread.critical_section} is reset to [false]. Resetting - {!Thread.critical_section} and suspending the calling thread is an - atomic operation. *) - -val wakeup : t -> unit -(** Reactivate the given thread. After the call to [wakeup], - the suspended thread will resume execution at some future time. *) - diff --git a/otherlibs/threads/threadUnix.ml b/otherlibs/threads/threadUnix.ml deleted file mode 100644 index 2510bdd993..0000000000 --- a/otherlibs/threads/threadUnix.ml +++ /dev/null @@ -1,60 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Module [ThreadUnix]: thread-compatible system calls *) - -let execv = Unix.execv -let execve = Unix.execve -let execvp = Unix.execvp -let wait = Unix.wait -let waitpid = Unix.waitpid -let system = Unix.system -let read = Unix.read -let write = Unix.write -let select = Unix.select -let pipe = Unix.pipe -let open_process_in = Unix.open_process_in -let open_process_out = Unix.open_process_out -let open_process = Unix.open_process -let open_process_full = Unix.open_process_full -let sleep = Unix.sleep -let socket = Unix.socket -let socketpair = Unix.socketpair -let accept = Unix.accept -let connect = Unix.connect -let recv = Unix.recv -let recvfrom = Unix.recvfrom -let send = Unix.send -let sendto = Unix.sendto -let open_connection = Unix.open_connection -let establish_server = Unix.establish_server - -open Unix - -let rec timed_read fd buff ofs len timeout = - if Thread.wait_timed_read fd timeout - then begin try Unix.read fd buff ofs len - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - timed_read fd buff ofs len timeout - end - else raise (Unix_error(ETIMEDOUT, "timed_read", "")) - -let rec timed_write fd buff ofs len timeout = - if Thread.wait_timed_write fd timeout - then begin try Unix.write fd buff ofs len - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - timed_write fd buff ofs len timeout - end - else raise (Unix_error(ETIMEDOUT, "timed_write", "")) diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli deleted file mode 100644 index e0a4a82b7d..0000000000 --- a/otherlibs/threads/threadUnix.mli +++ /dev/null @@ -1,89 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Thread-compatible system calls. - - @deprecated The functionality of this module has been merged back into - the {!Unix} module. Threaded programs can now call the functions - from module {!Unix} directly, and still get the correct behavior - (block the calling thread, if required, but do not block all threads - in the process). *) - -(** {6 Process handling} *) - -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 : Unix.wait_flag list -> int -> int * Unix.process_status -val system : string -> Unix.process_status - -(** {6 Basic input/output} *) - -val read : Unix.file_descr -> string -> int -> int -> int -val write : Unix.file_descr -> string -> int -> int -> int - -(** {6 Input/output with timeout} *) - -val timed_read : Unix.file_descr -> string -> int -> int -> float -> int -(** See {!ThreadUnix.timed_write}. *) - -val timed_write : Unix.file_descr -> string -> int -> int -> float -> int -(** Behave as {!ThreadUnix.read} and {!ThreadUnix.write}, except that - [Unix_error(ETIMEDOUT,_,_)] is raised if no data is - available for reading or ready for writing after [d] seconds. - The delay [d] is given in the fifth argument, in seconds. *) - -(** {6 Polling} *) - -val select : - 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 - -(** {6 Pipes and redirections} *) - -val pipe : unit -> Unix.file_descr * Unix.file_descr -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 -> string array -> in_channel * out_channel * in_channel - -(** {6 Time} *) - -val sleep : int -> unit - -(** {6 Sockets} *) - -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 -> 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) -> Unix.sockaddr -> unit diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml deleted file mode 100644 index a8f2a06ae5..0000000000 --- a/otherlibs/threads/unix.ml +++ /dev/null @@ -1,929 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* An alternate implementation of the Unix module from ../unix - which is safe in conjunction with bytecode threads. *) - -(* Type definitions that matter for thread operations *) - -type file_descr = int - -type process_status = - WEXITED of int - | WSIGNALED of int - | WSTOPPED of int - -(* We can't call functions from Thread because of type circularities, - so we redefine here the functions that we need *) - -type resumption_status = - Resumed_wakeup - | Resumed_delay - | Resumed_join - | Resumed_io - | Resumed_select of file_descr list * file_descr list * file_descr list - | Resumed_wait of int * process_status - -external thread_initialize : unit -> unit = "thread_initialize" -external thread_wait_read : file_descr -> unit = "thread_wait_read" -external thread_wait_write : file_descr -> unit = "thread_wait_write" -external thread_select : - file_descr list * file_descr list * file_descr list * float - -> resumption_status - = "thread_select" -external thread_wait_pid : int -> resumption_status = "thread_wait_pid" -external thread_delay : float -> unit = "thread_delay" - -let wait_read fd = thread_wait_read fd -let wait_write fd = thread_wait_write fd -let select_aux arg = thread_select arg -let wait_pid_aux pid = thread_wait_pid pid -let delay duration = thread_delay duration - -(* Make sure that threads are initialized (PR#1516). *) - -let _ = thread_initialize() - -(* Back to the Unix module *) - -type error = - E2BIG - | EACCES - | EAGAIN - | EBADF - | EBUSY - | ECHILD - | EDEADLK - | EDOM - | EEXIST - | EFAULT - | EFBIG - | EINTR - | EINVAL - | EIO - | EISDIR - | EMFILE - | EMLINK - | ENAMETOOLONG - | ENFILE - | ENODEV - | ENOENT - | ENOEXEC - | ENOLCK - | ENOMEM - | ENOSPC - | ENOSYS - | ENOTDIR - | ENOTEMPTY - | ENOTTY - | ENXIO - | EPERM - | EPIPE - | ERANGE - | EROFS - | ESPIPE - | ESRCH - | EXDEV - | EWOULDBLOCK - | EINPROGRESS - | EALREADY - | ENOTSOCK - | EDESTADDRREQ - | EMSGSIZE - | EPROTOTYPE - | ENOPROTOOPT - | EPROTONOSUPPORT - | ESOCKTNOSUPPORT - | EOPNOTSUPP - | EPFNOSUPPORT - | EAFNOSUPPORT - | EADDRINUSE - | EADDRNOTAVAIL - | ENETDOWN - | ENETUNREACH - | ENETRESET - | ECONNABORTED - | ECONNRESET - | ENOBUFS - | EISCONN - | ENOTCONN - | ESHUTDOWN - | ETOOMANYREFS - | ETIMEDOUT - | ECONNREFUSED - | EHOSTDOWN - | EHOSTUNREACH - | ELOOP - | EOVERFLOW - | EUNKNOWNERR of int - -exception Unix_error of error * string * string - -let _ = Callback.register_exception "Unix.Unix_error" - (Unix_error(E2BIG, "", "")) - -external error_message : error -> string = "unix_error_message" - -let handle_unix_error f arg = - try - f arg - with Unix_error(err, fun_name, arg) -> - prerr_string Sys.argv.(0); - prerr_string ": \""; - prerr_string fun_name; - prerr_string "\" failed"; - if String.length arg > 0 then begin - prerr_string " on \""; - prerr_string arg; - prerr_string "\"" - end; - prerr_string ": "; - prerr_endline (error_message err); - exit 2 - -external environment : unit -> string array = "unix_environment" -external getenv: string -> string = "sys_getenv" -external putenv: string -> string -> unit = "unix_putenv" - -type interval_timer = - ITIMER_REAL - | ITIMER_VIRTUAL - | ITIMER_PROF - -type interval_timer_status = - { it_interval: float; (* Period *) - it_value: float } (* Current value of the timer *) - -external getitimer: interval_timer -> interval_timer_status = "unix_getitimer" -external setitimer: - interval_timer -> interval_timer_status -> interval_timer_status - = "unix_setitimer" - -type wait_flag = - WNOHANG - | WUNTRACED - -let stdin = 0 -let stdout = 1 -let stderr = 2 - -type open_flag = - O_RDONLY - | O_WRONLY - | O_RDWR - | O_NONBLOCK - | O_APPEND - | O_CREAT - | O_TRUNC - | O_EXCL - | O_NOCTTY - | O_DSYNC - | O_SYNC - | O_RSYNC - -type file_perm = int - - -external openfile : string -> open_flag list -> file_perm -> file_descr - = "unix_open" - -external close : file_descr -> unit = "unix_close" -external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" -external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write" - -let rec read fd buf ofs len = - try - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.read" - else unsafe_read fd buf ofs len - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - wait_read fd; read fd buf ofs len - -let rec write fd buf ofs len = - try - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.write" - else unsafe_write fd buf ofs len - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - wait_write fd; write fd buf ofs len - -external in_channel_of_descr : file_descr -> in_channel - = "caml_open_descriptor_in" -external out_channel_of_descr : file_descr -> out_channel - = "caml_open_descriptor_out" -external descr_of_in_channel : in_channel -> file_descr = "channel_descriptor" -external descr_of_out_channel : out_channel -> file_descr - = "channel_descriptor" - -type seek_command = - SEEK_SET - | SEEK_CUR - | SEEK_END - -external lseek : file_descr -> int -> seek_command -> int = "unix_lseek" -external truncate : string -> int -> unit = "unix_truncate" -external ftruncate : file_descr -> int -> unit = "unix_ftruncate" - -type file_kind = - S_REG - | S_DIR - | S_CHR - | S_BLK - | S_LNK - | S_FIFO - | S_SOCK - -type stats = - { st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int; - st_atime : float; - st_mtime : float; - st_ctime : float } - -external stat : string -> stats = "unix_stat" -external lstat : string -> stats = "unix_lstat" -external fstat : file_descr -> stats = "unix_fstat" -external unlink : string -> unit = "unix_unlink" -external rename : string -> string -> unit = "unix_rename" -external link : string -> string -> unit = "unix_link" - -module LargeFile = - struct - external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64" - external truncate : string -> int64 -> unit = "unix_truncate_64" - external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64" - type stats = - { st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int64; - st_atime : float; - st_mtime : float; - st_ctime : float; - } - external stat : string -> stats = "unix_stat_64" - external lstat : string -> stats = "unix_lstat_64" - external fstat : file_descr -> stats = "unix_fstat_64" - end - -type access_permission = - R_OK - | W_OK - | X_OK - | F_OK - -external chmod : string -> file_perm -> unit = "unix_chmod" -external fchmod : file_descr -> file_perm -> unit = "unix_fchmod" -external chown : string -> int -> int -> unit = "unix_chown" -external fchown : file_descr -> int -> int -> unit = "unix_fchown" -external umask : int -> int = "unix_umask" -external access : string -> access_permission list -> unit = "unix_access" - -external dup : file_descr -> file_descr = "unix_dup" -external dup2 : file_descr -> file_descr -> unit = "unix_dup2" -external set_nonblock : file_descr -> unit = "unix_set_nonblock" -external clear_nonblock : file_descr -> unit = "unix_clear_nonblock" -external set_close_on_exec : file_descr -> unit = "unix_set_close_on_exec" -external clear_close_on_exec : file_descr -> unit = "unix_clear_close_on_exec" - -external mkdir : string -> file_perm -> unit = "unix_mkdir" -external rmdir : string -> unit = "unix_rmdir" -external chdir : string -> unit = "unix_chdir" -external getcwd : unit -> string = "unix_getcwd" -external chroot : string -> unit = "unix_chroot" - -type dir_handle - -external opendir : string -> dir_handle = "unix_opendir" -external readdir : dir_handle -> string = "unix_readdir" -external rewinddir : dir_handle -> unit = "unix_rewinddir" -external closedir : dir_handle -> unit = "unix_closedir" - -external _pipe : unit -> file_descr * file_descr = "unix_pipe" - -let pipe() = - let (out_fd, in_fd as fd_pair) = _pipe() in - set_nonblock in_fd; - set_nonblock out_fd; - fd_pair - -external symlink : string -> string -> unit = "unix_symlink" -external readlink : string -> string = "unix_readlink" -external mkfifo : string -> file_perm -> unit = "unix_mkfifo" - -let select readfds writefds exceptfds delay = - match select_aux (readfds, writefds, exceptfds, delay) with - Resumed_select(r, w, e) -> (r, w, e) - | _ -> ([], [], []) - -type lock_command = - F_ULOCK - | F_LOCK - | F_TLOCK - | F_TEST - | F_RLOCK - | F_TRLOCK - -external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf" - -external _execv : string -> string array -> 'a = "unix_execv" -external _execve : string -> string array -> string array -> 'a = "unix_execve" -external _execvp : string -> string array -> 'a = "unix_execvp" -external _execvpe : string -> string array -> string array -> 'a = "unix_execvpe" - -(* Disable the timer interrupt before doing exec, because some OS - keep sending timer interrupts to the exec'ed code. - Also restore blocking mode on stdin, stdout and stderr, - since this is what most programs expect! *) - -let safe_clear_nonblock fd = - try clear_nonblock fd with Unix_error(_,_,_) -> () -let safe_set_nonblock fd = - try set_nonblock fd with Unix_error(_,_,_) -> () - -let do_exec fn = - let oldtimer = - setitimer ITIMER_VIRTUAL {it_interval = 0.0; it_value = 0.0} in - safe_clear_nonblock stdin; - safe_clear_nonblock stdout; - safe_clear_nonblock stderr; - try - fn () - with Unix_error(_,_,_) as exn -> - ignore(setitimer ITIMER_VIRTUAL oldtimer); - safe_set_nonblock stdin; - safe_set_nonblock stdout; - safe_set_nonblock stderr; - raise exn - -let execv proc args = - do_exec (fun () -> _execv proc args) - -let execve proc args env = - do_exec (fun () -> _execve proc args env) - -let execvp proc args = - do_exec (fun () -> _execvp proc args) - -let execvpe proc args = - do_exec (fun () -> _execvpe proc args) - -external fork : unit -> int = "unix_fork" -external _waitpid : wait_flag list -> int -> int * process_status = "unix_waitpid" - -let wait_pid pid = - match wait_pid_aux pid with - Resumed_wait(pid, status) -> (pid, status) - | _ -> invalid_arg "Thread.wait_pid" - -let wait () = wait_pid (-1) - -let waitpid flags pid = - if List.mem WNOHANG flags - then _waitpid flags pid - else wait_pid pid - -external getpid : unit -> int = "unix_getpid" -external getppid : unit -> int = "unix_getppid" -external nice : int -> int = "unix_nice" - -external kill : int -> int -> unit = "unix_kill" -type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK -external sigprocmask: sigprocmask_command -> int list -> int list - = "unix_sigprocmask" -external sigpending: unit -> int list = "unix_sigpending" -external sigsuspend: int list -> unit = "unix_sigsuspend" - -let pause() = - let sigs = sigprocmask SIG_BLOCK [] in sigsuspend sigs - -type process_times = - { tms_utime : float; - tms_stime : float; - tms_cutime : float; - tms_cstime : float } - -type tm = - { tm_sec : int; - tm_min : int; - tm_hour : int; - tm_mday : int; - tm_mon : int; - tm_year : int; - tm_wday : int; - tm_yday : int; - tm_isdst : bool } - -external time : unit -> float = "unix_time" -external gettimeofday : unit -> float = "unix_gettimeofday" -external gmtime : float -> tm = "unix_gmtime" -external localtime : float -> tm = "unix_localtime" -external mktime : tm -> float * tm = "unix_mktime" -external alarm : int -> int = "unix_alarm" - -let sleep secs = delay (float secs) - -external times : unit -> process_times = "unix_times" -external utimes : string -> float -> float -> unit = "unix_utimes" - -external getuid : unit -> int = "unix_getuid" -external geteuid : unit -> int = "unix_geteuid" -external setuid : int -> unit = "unix_setuid" -external getgid : unit -> int = "unix_getgid" -external getegid : unit -> int = "unix_getegid" -external setgid : int -> unit = "unix_setgid" -external getgroups : unit -> int array = "unix_getgroups" - -type passwd_entry = - { pw_name : string; - pw_passwd : string; - pw_uid : int; - pw_gid : int; - pw_gecos : string; - pw_dir : string; - pw_shell : string } - -type group_entry = - { gr_name : string; - gr_passwd : string; - gr_gid : int; - gr_mem : string array } - - -external getlogin : unit -> string = "unix_getlogin" -external getpwnam : string -> passwd_entry = "unix_getpwnam" -external getgrnam : string -> group_entry = "unix_getgrnam" -external getpwuid : int -> passwd_entry = "unix_getpwuid" -external getgrgid : int -> group_entry = "unix_getgrgid" - -type inet_addr - -external inet_addr_of_string : string -> inet_addr - = "unix_inet_addr_of_string" -external string_of_inet_addr : inet_addr -> string - = "unix_string_of_inet_addr" - -let inet_addr_any = inet_addr_of_string "0.0.0.0" - -type socket_domain = - PF_UNIX - | PF_INET - -type socket_type = - SOCK_STREAM - | SOCK_DGRAM - | SOCK_RAW - | SOCK_SEQPACKET - -type sockaddr = - ADDR_UNIX of string - | ADDR_INET of inet_addr * int - -type shutdown_command = - SHUTDOWN_RECEIVE - | SHUTDOWN_SEND - | SHUTDOWN_ALL - -type msg_flag = - MSG_OOB - | MSG_DONTROUTE - | MSG_PEEK - -type socket_bool_option = - SO_DEBUG - | SO_BROADCAST - | SO_REUSEADDR - | SO_KEEPALIVE - | SO_DONTROUTE - | SO_OOBINLINE - | SO_ACCEPTCONN - -type socket_int_option = - SO_SNDBUF - | SO_RCVBUF - | SO_ERROR - | SO_TYPE - | SO_RCVLOWAT - | SO_SNDLOWAT - -type socket_optint_option = SO_LINGER - -type socket_float_option = - SO_RCVTIMEO - | SO_SNDTIMEO - -external _socket : socket_domain -> socket_type -> int -> file_descr - = "unix_socket" -external _socketpair : - socket_domain -> socket_type -> int -> file_descr * file_descr - = "unix_socketpair" - -let socket dom typ proto = - let s = _socket dom typ proto in - set_nonblock s; - s - -let socketpair dom typ proto = - let (s1, s2 as spair) = _socketpair dom typ proto in - set_nonblock s1; set_nonblock s2; - spair - -external _accept : file_descr -> file_descr * sockaddr = "unix_accept" - -let rec accept req = - wait_read req; - try - let (s, caller as result) = _accept req in - set_nonblock s; - result - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> accept req - -external bind : file_descr -> sockaddr -> unit = "unix_bind" -external listen : file_descr -> int -> unit = "unix_listen" -external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" -external getsockname : file_descr -> sockaddr = "unix_getsockname" -external getpeername : file_descr -> sockaddr = "unix_getpeername" -external getsockopt : file_descr -> socket_bool_option -> bool - = "unix_getsockopt_bool" -external setsockopt : file_descr -> socket_bool_option -> bool -> unit - = "unix_setsockopt_bool" -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" -external getsockopt_optint : file_descr -> socket_optint_option -> int option - = "unix_getsockopt_optint" -external setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit - = "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" - -external _connect : file_descr -> sockaddr -> unit = "unix_connect" - -let connect s addr = - try - _connect s addr - with Unix_error((EINPROGRESS | EWOULDBLOCK | EAGAIN), _, _) -> - wait_write s; - (* Check if it really worked *) - ignore(getpeername s) - -external unsafe_recv : - file_descr -> string -> int -> int -> msg_flag list -> int - = "unix_recv" -external unsafe_recvfrom : - file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr - = "unix_recvfrom" -external unsafe_send : - file_descr -> string -> int -> int -> msg_flag list -> int - = "unix_send" -external unsafe_sendto : - file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int - = "unix_sendto" "unix_sendto_native" - -let rec recv fd buf ofs len flags = - try - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.recv" - else unsafe_recv fd buf ofs len flags - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - wait_read fd; recv fd buf ofs len flags - -let rec recvfrom fd buf ofs len flags = - try - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.recvfrom" - else unsafe_recvfrom fd buf ofs len flags - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - wait_read fd; - recvfrom fd buf ofs len flags - -let rec send fd buf ofs len flags = - try - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.send" - else unsafe_send fd buf ofs len flags - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - wait_write fd; - send fd buf ofs len flags - -let rec sendto fd buf ofs len flags addr = - try - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.sendto" - else unsafe_sendto fd buf ofs len flags addr - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - wait_write fd; - sendto fd buf ofs len flags addr - -type host_entry = - { h_name : string; - h_aliases : string array; - h_addrtype : socket_domain; - h_addr_list : inet_addr array } - -type protocol_entry = - { p_name : string; - p_aliases : string array; - p_proto : int } - -type service_entry = - { s_name : string; - s_aliases : string array; - s_port : int; - s_proto : string } - -external gethostname : unit -> string = "unix_gethostname" -external gethostbyname : string -> host_entry = "unix_gethostbyname" -external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr" -external getprotobyname : string -> protocol_entry - = "unix_getprotobyname" -external getprotobynumber : int -> protocol_entry - = "unix_getprotobynumber" -external getservbyname : string -> string -> service_entry - = "unix_getservbyname" -external getservbyport : int -> string -> service_entry - = "unix_getservbyport" -type terminal_io = { - mutable c_ignbrk: bool; - mutable c_brkint: bool; - mutable c_ignpar: bool; - mutable c_parmrk: bool; - mutable c_inpck: bool; - mutable c_istrip: bool; - mutable c_inlcr: bool; - mutable c_igncr: bool; - mutable c_icrnl: bool; - mutable c_ixon: bool; - mutable c_ixoff: bool; - mutable c_opost: bool; - mutable c_obaud: int; - mutable c_ibaud: int; - mutable c_csize: int; - mutable c_cstopb: int; - mutable c_cread: bool; - mutable c_parenb: bool; - mutable c_parodd: bool; - mutable c_hupcl: bool; - mutable c_clocal: bool; - mutable c_isig: bool; - mutable c_icanon: bool; - mutable c_noflsh: bool; - mutable c_echo: bool; - mutable c_echoe: bool; - mutable c_echok: bool; - mutable c_echonl: bool; - mutable c_vintr: char; - mutable c_vquit: char; - mutable c_verase: char; - mutable c_vkill: char; - mutable c_veof: char; - mutable c_veol: char; - mutable c_vmin: int; - mutable c_vtime: int; - mutable c_vstart: char; - mutable c_vstop: char - } - -external tcgetattr: file_descr -> terminal_io = "unix_tcgetattr" - -type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH - -external tcsetattr: file_descr -> setattr_when -> terminal_io -> unit - = "unix_tcsetattr" -external tcsendbreak: file_descr -> int -> unit = "unix_tcsendbreak" -external tcdrain: file_descr -> unit = "unix_tcdrain" - -type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH - -external tcflush: file_descr -> flush_queue -> unit = "unix_tcflush" - -type flow_action = TCOOFF | TCOON | TCIOFF | TCION - -external tcflow: file_descr -> flow_action -> unit = "unix_tcflow" - -external setsid : unit -> int = "unix_setsid" - -(* High-level process management (system, popen) *) - -let system cmd = - match fork() with - 0 -> begin try - execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] - with _ -> - exit 127 - end - | id -> snd(waitpid [] id) - -let rec safe_dup fd = - let new_fd = dup fd in - if new_fd >= 3 then - new_fd - else begin - let res = safe_dup fd in - close new_fd; - res - end - -let safe_close fd = - try close fd with Unix_error(_,_,_) -> () - -let perform_redirections new_stdin new_stdout new_stderr = - let newnewstdin = safe_dup new_stdin in - let newnewstdout = safe_dup new_stdout in - let newnewstderr = safe_dup new_stderr in - safe_close new_stdin; - safe_close new_stdout; - safe_close new_stderr; - dup2 newnewstdin stdin; close newnewstdin; - dup2 newnewstdout stdout; close newnewstdout; - dup2 newnewstderr stderr; close newnewstderr - -let create_process cmd args new_stdin new_stdout new_stderr = - match fork() with - 0 -> - begin try - perform_redirections new_stdin new_stdout new_stderr; - execvp cmd args - with _ -> - exit 127 - end - | id -> id - -let create_process_env cmd args env new_stdin new_stdout new_stderr = - match fork() with - 0 -> - begin try - perform_redirections new_stdin new_stdout new_stderr; - execvpe cmd args env - with _ -> - exit 127 - end - | id -> id - -type popen_process = - Process of in_channel * out_channel - | Process_in of in_channel - | Process_out of out_channel - | Process_full of in_channel * out_channel * in_channel - -let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t) - -let open_proc cmd proc input output toclose = - match fork() with - 0 -> if input <> stdin then begin dup2 input stdin; close input end; - if output <> stdout then begin dup2 output stdout; close output end; - List.iter close toclose; - execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; - exit 127 - | id -> Hashtbl.add popen_processes proc id - -let open_process_in cmd = - let (in_read, in_write) = pipe() in - let inchan = in_channel_of_descr in_read in - open_proc cmd (Process_in inchan) stdin in_write [in_read]; - close in_write; - inchan - -let open_process_out cmd = - let (out_read, out_write) = pipe() in - let outchan = out_channel_of_descr out_write in - open_proc cmd (Process_out outchan) out_read stdout [out_write]; - close out_read; - outchan - -let open_process cmd = - let (in_read, in_write) = pipe() in - let (out_read, out_write) = pipe() in - let inchan = in_channel_of_descr in_read in - let outchan = out_channel_of_descr out_write in - open_proc cmd (Process(inchan, outchan)) out_read in_write - [in_read; out_write]; - close out_read; - close in_write; - (inchan, outchan) - -let open_proc_full cmd env proc input output error toclose = - match fork() with - 0 -> dup2 input stdin; close input; - dup2 output stdout; close output; - dup2 error stderr; close error; - List.iter close toclose; - execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env; - exit 127 - | id -> Hashtbl.add popen_processes proc id - -let open_process_full cmd env = - let (in_read, in_write) = pipe() in - let (out_read, out_write) = pipe() in - let (err_read, err_write) = pipe() in - let inchan = in_channel_of_descr in_read in - let outchan = out_channel_of_descr out_write in - let errchan = in_channel_of_descr err_read in - open_proc_full cmd env (Process_full(inchan, outchan, errchan)) - out_read in_write err_write [in_read; out_write; err_read]; - close out_read; - close in_write; - close err_write; - (inchan, outchan, errchan) - -let find_proc_id fun_name proc = - try - let pid = Hashtbl.find popen_processes proc in - Hashtbl.remove popen_processes proc; - pid - with Not_found -> - raise(Unix_error(EBADF, fun_name, "")) - -let close_process_in inchan = - let pid = find_proc_id "close_process_in" (Process_in inchan) in - close_in inchan; - snd(waitpid [] pid) - -let close_process_out outchan = - let pid = find_proc_id "close_process_out" (Process_out outchan) in - close_out outchan; - snd(waitpid [] pid) - -let close_process (inchan, outchan) = - let pid = find_proc_id "close_process" (Process(inchan, outchan)) in - close_in inchan; - begin try close_out outchan with Sys_error _ -> () end; - snd(waitpid [] pid) - -let close_process_full (inchan, outchan, errchan) = - let pid = - find_proc_id "close_process_full" - (Process_full(inchan, outchan, errchan)) in - close_in inchan; - begin try close_out outchan with Sys_error _ -> () end; - close_in errchan; - snd(waitpid [] pid) - -(* High-level network functions *) - -let open_connection sockaddr = - let domain = - match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in - let sock = - socket domain SOCK_STREAM 0 in - try - connect sock sockaddr; - (in_channel_of_descr sock, out_channel_of_descr sock) - with exn -> - close sock; raise exn - -let shutdown_connection inchan = - shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND - -let establish_server server_fun sockaddr = - let domain = - match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in - let sock = - socket domain SOCK_STREAM 0 in - setsockopt sock SO_REUSEADDR true; - bind sock sockaddr; - listen sock 5; - while true do - let (s, caller) = accept sock in - (* The "double fork" trick, the process which calls server_fun will not - leave a zombie process *) - match fork() with - 0 -> if fork() <> 0 then exit 0; (* The son exits, the grandson works *) - let inchan = in_channel_of_descr s in - let outchan = out_channel_of_descr s in - server_fun inchan outchan; - close_out outchan; - (* The file descriptor was already closed by close_out. - close_in inchan; - *) - exit 0 - | id -> close s; ignore(waitpid [] id) (* Reclaim the son *) - done - diff --git a/otherlibs/unix/.cvsignore b/otherlibs/unix/.cvsignore deleted file mode 100644 index 074dd28a45..0000000000 --- a/otherlibs/unix/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -so_locations diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend deleted file mode 100644 index cb4704c71f..0000000000 --- a/otherlibs/unix/.depend +++ /dev/null @@ -1,283 +0,0 @@ -accept.o: accept.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ - socketaddr.h -access.o: access.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h unixsupport.h -addrofstr.o: addrofstr.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/fail.h unixsupport.h socketaddr.h -alarm.o: alarm.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -bind.o: bind.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h \ - socketaddr.h -chdir.o: chdir.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -chmod.o: chmod.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -chown.o: chown.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -chroot.o: chroot.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -close.o: close.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -closedir.o: closedir.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -connect.o: connect.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/signals.h unixsupport.h socketaddr.h -cst2constr.o: cst2constr.c ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/fail.h cst2constr.h -cstringv.o: cstringv.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h -dup.o: dup.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -dup2.o: dup2.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -envir.o: envir.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h -errmsg.o: errmsg.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h -execv.o: execv.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h -execve.o: execve.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h -execvp.o: execvp.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h -exit.o: exit.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -fchmod.o: fchmod.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -fchown.o: fchown.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -fcntl.o: fcntl.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -fork.o: fork.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -ftruncate.o: ftruncate.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/io.h unixsupport.h -getcwd.o: getcwd.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h unixsupport.h -getegid.o: getegid.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -geteuid.o: geteuid.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -getgid.o: getgid.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -getgr.o: getgr.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/fail.h ../../byterun/alloc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h -getgroups.o: getgroups.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h unixsupport.h -gethost.o: gethost.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/fail.h ../../byterun/signals.h \ - unixsupport.h socketaddr.h -gethostname.o: gethostname.c ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h -getlogin.o: getlogin.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h unixsupport.h -getpeername.o: getpeername.c ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h socketaddr.h -getpid.o: getpid.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -getppid.o: getppid.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -getproto.o: getproto.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h -getpw.o: getpw.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h -getserv.o: getserv.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h -getsockname.o: getsockname.c ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h socketaddr.h -gettimeofday.o: gettimeofday.c ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h -getuid.o: getuid.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -gmtime.o: gmtime.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h -itimer.o: itimer.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h -kill.o: kill.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/fail.h unixsupport.h ../../byterun/signals.h -link.o: link.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -listen.o: listen.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -lockf.o: lockf.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -lseek.o: lseek.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/io.h unixsupport.h -mkdir.o: mkdir.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -mkfifo.o: mkfifo.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -nice.o: nice.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -open.o: open.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h -opendir.o: opendir.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -pipe.o: pipe.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h unixsupport.h -putenv.o: putenv.c ../../byterun/memory.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/misc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h -read.o: read.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h -readdir.o: readdir.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/fail.h ../../byterun/alloc.h unixsupport.h -readlink.o: readlink.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h unixsupport.h -rename.o: rename.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -rewinddir.o: rewinddir.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -rmdir.o: rmdir.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -select.o: select.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h -sendrecv.o: sendrecv.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ - socketaddr.h -setgid.o: setgid.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -setsid.o: setsid.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -setuid.o: setuid.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -shutdown.o: shutdown.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -signals.o: signals.c ../../byterun/alloc.h ../../byterun/misc.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h -sleep.o: sleep.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/signals.h unixsupport.h -socket.o: socket.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -socketaddr.o: socketaddr.c ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h socketaddr.h -socketpair.o: socketpair.c ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h -sockopt.o: sockopt.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h unixsupport.h socketaddr.h -stat.o: stat.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \ - unixsupport.h cst2constr.h ../../byterun/io.h -strofaddr.o: strofaddr.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h unixsupport.h socketaddr.h -symlink.o: symlink.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -termios.o: termios.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h unixsupport.h -time.o: time.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h unixsupport.h -times.o: times.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h -truncate.o: truncate.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/io.h unixsupport.h -umask.o: umask.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -unixsupport.o: unixsupport.c ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/callback.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \ - unixsupport.h cst2constr.h -unlink.o: unlink.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -utimes.o: utimes.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h unixsupport.h -wait.o: wait.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h -write.o: write.c ../../byterun/mlvalues.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/misc.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h -unixLabels.cmi: unix.cmi -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 deleted file mode 100644 index 2121ce76df..0000000000 --- a/otherlibs/unix/Makefile +++ /dev/null @@ -1,92 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the Unix interface library - -include ../../config/Makefile - -# Compilation options -CC=$(BYTECC) -CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -CAMLC=../../ocamlcomp.sh -CAMLOPT=../../ocamlcompopt.sh -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A - -OBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \ - chown.o chroot.o close.o closedir.o connect.o cst2constr.o cstringv.o \ - dup.o dup2.o envir.o errmsg.o execv.o execve.o execvp.o exit.o \ - fchmod.o fchown.o fcntl.o fork.o ftruncate.o getcwd.o getegid.o \ - geteuid.o getgid.o getgr.o getgroups.o gethost.o gethostname.o \ - getlogin.o getpeername.o getpid.o getppid.o getproto.o getpw.o \ - gettimeofday.o getserv.o getsockname.o getuid.o \ - gmtime.o itimer.o kill.o link.o listen.o lockf.o lseek.o mkdir.o \ - mkfifo.o nice.o open.o opendir.o pipe.o putenv.o read.o \ - readdir.o readlink.o rename.o rewinddir.o rmdir.o select.o sendrecv.o \ - setgid.o setsid.o setuid.o shutdown.o signals.o \ - sleep.o socket.o socketaddr.o \ - socketpair.o sockopt.o stat.o strofaddr.o symlink.o termios.o \ - time.o times.o truncate.o umask.o unixsupport.o unlink.o \ - utimes.o wait.o write.o - -MLOBJS=unix.cmo unixLabels.cmo - -all: libunix.a unix.cma - -allopt: libunix.a unix.cmxa - -libunix.a: $(OBJS) - $(MKLIB) -o unix $(OBJS) - -unix.cma: $(MLOBJS) - $(MKLIB) -o unix -ocamlc '$(CAMLC)' -linkall $(MLOBJS) - -unix.cmxa: $(MLOBJS:.cmo=.cmx) - $(MKLIB) -o unix -ocamlopt '$(CAMLOPT)' -linkall $(MLOBJS:.cmo=.cmx) - -unix.cmx: ../../ocamlopt - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.a *.o *.so - -install: - if test -f dllunix.so; then cp dllunix.so $(STUBLIBDIR)/dllunix.so; fi - cp libunix.a $(LIBDIR)/libunix.a - cd $(LIBDIR); $(RANLIB) libunix.a - cp unix.cma $(MLOBJS:.cmo=.cmi) $(MLOBJS:.cmo=.mli) $(LIBDIR) - -installopt: - cp $(MLOBJS:.cmo=.cmx) unix.cmxa unix.a $(LIBDIR) - cd $(LIBDIR); $(RANLIB) unix.a - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) -nolabels $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) -nolabels $< - -depend: - gcc -MM $(CFLAGS) *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend - -include .depend diff --git a/otherlibs/unix/accept.c b/otherlibs/unix/accept.c deleted file mode 100644 index 3247c43dce..0000000000 --- a/otherlibs/unix/accept.c +++ /dev/null @@ -1,52 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <signals.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include "socketaddr.h" - -CAMLprim value unix_accept(value sock) -{ - int retcode; - value res; - value a; - union sock_addr_union addr; - socklen_param_type addr_len; - - addr_len = sizeof(addr); - enter_blocking_section(); - retcode = accept(Int_val(sock), &addr.s_gen, &addr_len); - leave_blocking_section(); - if (retcode == -1) uerror("accept", Nothing); - a = alloc_sockaddr(&addr, addr_len); - Begin_root (a); - res = alloc_small(2, 0); - Field(res, 0) = Val_int(retcode); - Field(res, 1) = a; - End_roots(); - return res; -} - -#else - -CAMLprim value unix_accept(value sock) { invalid_argument("accept not implemented"); } - -#endif diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c deleted file mode 100644 index 6d81c2bcd3..0000000000 --- a/otherlibs/unix/access.c +++ /dev/null @@ -1,51 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" - -#ifdef HAS_UNISTD -# include <unistd.h> -#else -# ifndef _WIN32 -# include <sys/file.h> -# ifndef R_OK -# define R_OK 4/* test for read permission */ -# define W_OK 2/* test for write permission */ -# define X_OK 1/* test for execute (search) permission */ -# define F_OK 0/* test for presence of file */ -# endif -# else -# define R_OK 4/* test for read permission */ -# define W_OK 2/* test for write permission */ -# define X_OK 1/* test for execute (search) permission */ -# define F_OK 0/* test for presence of file */ -# endif -#endif - -static int access_permission_table[] = { - R_OK, W_OK, X_OK, F_OK -}; - -CAMLprim value unix_access(value path, value perms) -{ - int ret; - ret = access(String_val(path), - convert_flag_list(perms, access_permission_table)); - if (ret == -1) - uerror("access", path); - return Val_unit; -} diff --git a/otherlibs/unix/addrofstr.c b/otherlibs/unix/addrofstr.c deleted file mode 100644 index 140f9c3b0a..0000000000 --- a/otherlibs/unix/addrofstr.c +++ /dev/null @@ -1,44 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <fail.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include "socketaddr.h" - -CAMLprim value unix_inet_addr_of_string(value s) -{ -#ifdef HAS_INET_ATON - struct in_addr address; - if (inet_aton(String_val(s), &address) == 0) - failwith("inet_addr_of_string"); - return alloc_inet_addr(address.s_addr); -#else - unsigned int address; - address = inet_addr(String_val(s)); - if (address == (unsigned int) -1) failwith("inet_addr_of_string"); - return alloc_inet_addr(address); -#endif -} - -#else - -CAMLprim value unix_inet_addr_of_string(value s) -{ invalid_argument("inet_addr_of_string not implemented"); } - -#endif diff --git a/otherlibs/unix/alarm.c b/otherlibs/unix/alarm.c deleted file mode 100644 index 6eb6ebe816..0000000000 --- a/otherlibs/unix/alarm.c +++ /dev/null @@ -1,23 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_alarm(t) - value t; -{ - return Val_int(alarm((unsigned int) Long_val(t))); -} diff --git a/otherlibs/unix/bind.c b/otherlibs/unix/bind.c deleted file mode 100644 index d3520d3f52..0000000000 --- a/otherlibs/unix/bind.c +++ /dev/null @@ -1,40 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include "socketaddr.h" - -CAMLprim value unix_bind(value socket, value address) -{ - int ret; - union sock_addr_union addr; - socklen_param_type addr_len; - - get_sockaddr(address, &addr, &addr_len); - ret = bind(Int_val(socket), &addr.s_gen, addr_len); - if (ret == -1) uerror("bind", Nothing); - return Val_unit; -} - -#else - -CAMLprim value unix_bind(value socket, value address) -{ invalid_argument("bind not implemented"); } - -#endif diff --git a/otherlibs/unix/chdir.c b/otherlibs/unix/chdir.c deleted file mode 100644 index 7901eca0e4..0000000000 --- a/otherlibs/unix/chdir.c +++ /dev/null @@ -1,25 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_chdir(value path) -{ - int ret; - ret = chdir(String_val(path)); - if (ret == -1) uerror("chdir", path); - return Val_unit; -} diff --git a/otherlibs/unix/chmod.c b/otherlibs/unix/chmod.c deleted file mode 100644 index dff837223e..0000000000 --- a/otherlibs/unix/chmod.c +++ /dev/null @@ -1,27 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <sys/types.h> -#include <sys/stat.h> -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_chmod(value path, value perm) -{ - int ret; - ret = chmod(String_val(path), Int_val(perm)); - if (ret == -1) uerror("chmod", path); - return Val_unit; -} diff --git a/otherlibs/unix/chown.c b/otherlibs/unix/chown.c deleted file mode 100644 index bfd164008f..0000000000 --- a/otherlibs/unix/chown.c +++ /dev/null @@ -1,25 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_chown(value path, value uid, value gid) -{ - int ret; - ret = chown(String_val(path), Int_val(uid), Int_val(gid)); - if (ret == -1) uerror("chown", path); - return Val_unit; -} diff --git a/otherlibs/unix/chroot.c b/otherlibs/unix/chroot.c deleted file mode 100644 index 24f49877d5..0000000000 --- a/otherlibs/unix/chroot.c +++ /dev/null @@ -1,25 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_chroot(value path) -{ - int ret; - ret = chroot(String_val(path)); - if (ret == -1) uerror("chroot", path); - return Val_unit; -} diff --git a/otherlibs/unix/close.c b/otherlibs/unix/close.c deleted file mode 100644 index 27e1937df4..0000000000 --- a/otherlibs/unix/close.c +++ /dev/null @@ -1,23 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_close(value fd) -{ - if (close(Int_val(fd)) == -1) uerror("close", Nothing); - return Val_unit; -} diff --git a/otherlibs/unix/closedir.c b/otherlibs/unix/closedir.c deleted file mode 100644 index a168548a9b..0000000000 --- a/otherlibs/unix/closedir.c +++ /dev/null @@ -1,29 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" -#include <sys/types.h> -#ifdef HAS_DIRENT -#include <dirent.h> -#else -#include <sys/dir.h> -#endif - -CAMLprim value unix_closedir(value d) -{ - closedir((DIR *) d); - return Val_unit; -} diff --git a/otherlibs/unix/connect.c b/otherlibs/unix/connect.c deleted file mode 100644 index 2db973b532..0000000000 --- a/otherlibs/unix/connect.c +++ /dev/null @@ -1,43 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <signals.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include "socketaddr.h" - -CAMLprim value unix_connect(value socket, value address) -{ - int retcode; - union sock_addr_union addr; - socklen_param_type addr_len; - - get_sockaddr(address, &addr, &addr_len); - enter_blocking_section(); - retcode = connect(Int_val(socket), &addr.s_gen, addr_len); - leave_blocking_section(); - if (retcode == -1) uerror("connect", Nothing); - return Val_unit; -} - -#else - -CAMLprim value unix_connect(value socket, value address) -{ invalid_argument("connect not implemented"); } - -#endif diff --git a/otherlibs/unix/cst2constr.c b/otherlibs/unix/cst2constr.c deleted file mode 100644 index 9035160dcc..0000000000 --- a/otherlibs/unix/cst2constr.c +++ /dev/null @@ -1,26 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <fail.h> -#include "cst2constr.h" - -value cst_to_constr(int n, int *tbl, int size, int deflt) -{ - int i; - for (i = 0; i < size; i++) - if (n == tbl[i]) return Val_int(i); - return Val_int(deflt); -} diff --git a/otherlibs/unix/cst2constr.h b/otherlibs/unix/cst2constr.h deleted file mode 100644 index 2ee2ce50ba..0000000000 --- a/otherlibs/unix/cst2constr.h +++ /dev/null @@ -1,20 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#ifdef __STDC__ -value cst_to_constr(int, int *, int, int); -#else -value cst_to_constr(); -#endif diff --git a/otherlibs/unix/cstringv.c b/otherlibs/unix/cstringv.c deleted file mode 100644 index d7bd396412..0000000000 --- a/otherlibs/unix/cstringv.c +++ /dev/null @@ -1,32 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <memory.h> -#include "unixsupport.h" - -char ** cstringvect(value arg) -{ - char ** res; - mlsize_t size, i; - - size = Wosize_val(arg); - res = (char **) stat_alloc((size + 1) * sizeof(char *)); - for (i = 0; i < size; i++) res[i] = String_val(Field(arg, i)); - res[size] = NULL; - return res; -} - - diff --git a/otherlibs/unix/dup.c b/otherlibs/unix/dup.c deleted file mode 100644 index 5935d0b440..0000000000 --- a/otherlibs/unix/dup.c +++ /dev/null @@ -1,25 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_dup(value fd) -{ - int ret; - ret = dup(Int_val(fd)); - if (ret == -1) uerror("dup", Nothing); - return Val_int(ret); -} diff --git a/otherlibs/unix/dup2.c b/otherlibs/unix/dup2.c deleted file mode 100644 index beb987133b..0000000000 --- a/otherlibs/unix/dup2.c +++ /dev/null @@ -1,49 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -#ifdef HAS_DUP2 - -CAMLprim value unix_dup2(value fd1, value fd2) -{ - if (dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing); - return Val_unit; -} - -#else - -static int do_dup2(int fd1, int fd2) -{ - int fd; - int res; - - fd = dup(fd1); - if (fd == -1) return -1; - if (fd == fd2) return 0; - res = do_dup2(fd1, fd2); - close(fd); - return res; -} - -CAMLprim value unix_dup2(value fd1, value fd2) -{ - close(Int_val(fd2)); - if (do_dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing); - return Val_unit; -} - -#endif diff --git a/otherlibs/unix/envir.c b/otherlibs/unix/envir.c deleted file mode 100644 index d17aaa4106..0000000000 --- a/otherlibs/unix/envir.c +++ /dev/null @@ -1,26 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> - -#ifndef _WIN32 -extern char ** environ; -#endif - -CAMLprim value unix_environment(void) -{ - return copy_string_array((const char**)environ); -} diff --git a/otherlibs/unix/errmsg.c b/otherlibs/unix/errmsg.c deleted file mode 100644 index ca09364eeb..0000000000 --- a/otherlibs/unix/errmsg.c +++ /dev/null @@ -1,49 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <errno.h> -#include <mlvalues.h> -#include <alloc.h> - -extern int error_table[]; - -#ifdef HAS_STRERROR - -extern char * strerror(int); - -CAMLprim value unix_error_message(value err) -{ - int errnum; - errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)]; - return copy_string(strerror(errnum)); -} - -#else - -extern int sys_nerr; -extern char *sys_errlist[]; - -CAMLprim value unix_error_message(value err) -{ - int errnum; - errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)]; - if (errnum < 0 || errnum >= sys_nerr) { - return copy_string("Unknown error"); - } else { - return copy_string(sys_errlist[errnum]); - } -} - -#endif diff --git a/otherlibs/unix/execv.c b/otherlibs/unix/execv.c deleted file mode 100644 index b7cd800986..0000000000 --- a/otherlibs/unix/execv.c +++ /dev/null @@ -1,32 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <memory.h> -#include "unixsupport.h" - -extern char ** cstringvect(); - -CAMLprim value unix_execv(value path, value args) -{ - char ** argv; - argv = cstringvect(args); - (void) execv(String_val(path), argv); - stat_free((char *) argv); - uerror("execv", path); - return Val_unit; /* never reached, but suppress warnings */ - /* from smart compilers */ -} - diff --git a/otherlibs/unix/execve.c b/otherlibs/unix/execve.c deleted file mode 100644 index 0f63aaef96..0000000000 --- a/otherlibs/unix/execve.c +++ /dev/null @@ -1,35 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <memory.h> -#include "unixsupport.h" - -extern char ** cstringvect(); - -CAMLprim value unix_execve(value path, value args, value env) -{ - char ** argv; - char ** envp; - argv = cstringvect(args); - envp = cstringvect(env); - (void) execve(String_val(path), argv, envp); - stat_free((char *) argv); - stat_free((char *) envp); - uerror("execve", path); - return Val_unit; /* never reached, but suppress warnings */ - /* from smart compilers */ -} - diff --git a/otherlibs/unix/execvp.c b/otherlibs/unix/execvp.c deleted file mode 100644 index 960b3bfe1a..0000000000 --- a/otherlibs/unix/execvp.c +++ /dev/null @@ -1,51 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <memory.h> -#include "unixsupport.h" - -extern char ** cstringvect(); -#ifndef _WIN32 -extern char ** environ; -#endif - -CAMLprim value unix_execvp(value path, value args) -{ - char ** argv; - argv = cstringvect(args); - (void) execvp(String_val(path), argv); - stat_free((char *) argv); - uerror("execvp", path); - return Val_unit; /* never reached, but suppress warnings */ - /* from smart compilers */ -} - -CAMLprim value unix_execvpe(value path, value args, value env) -{ - char ** argv; - char ** saved_environ; - argv = cstringvect(args); - saved_environ = environ; - environ = cstringvect(env); - (void) execvp(String_val(path), argv); - stat_free((char *) argv); - stat_free((char *) environ); - environ = saved_environ; - uerror("execvp", path); - return Val_unit; /* never reached, but suppress warnings */ - /* from smart compilers */ -} - diff --git a/otherlibs/unix/exit.c b/otherlibs/unix/exit.c deleted file mode 100644 index 26afea3393..0000000000 --- a/otherlibs/unix/exit.c +++ /dev/null @@ -1,26 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_exit(value n) -{ - _exit(Int_val(n)); - return Val_unit; /* never reached, but suppress warnings */ - /* from smart compilers */ -} - - diff --git a/otherlibs/unix/fchmod.c b/otherlibs/unix/fchmod.c deleted file mode 100644 index f812edf16c..0000000000 --- a/otherlibs/unix/fchmod.c +++ /dev/null @@ -1,34 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <sys/types.h> -#include <sys/stat.h> -#include <mlvalues.h> -#include "unixsupport.h" - -#ifdef HAS_FCHMOD - -CAMLprim value unix_fchmod(value fd, value perm) -{ - if (fchmod(Int_val(fd), Int_val(perm)) == -1) uerror("fchmod", Nothing); - return Val_unit; -} - -#else - -CAMLprim value unix_fchmod(value fd, value perm) -{ invalid_argument("fchmod not implemented"); } - -#endif diff --git a/otherlibs/unix/fchown.c b/otherlibs/unix/fchown.c deleted file mode 100644 index ba74ffeeb2..0000000000 --- a/otherlibs/unix/fchown.c +++ /dev/null @@ -1,33 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -#ifdef HAS_FCHMOD - -CAMLprim value unix_fchown(value fd, value uid, value gid) -{ - if (fchown(Int_val(fd), Int_val(uid), Int_val(gid)) == -1) - uerror("fchown", Nothing); - return Val_unit; -} - -#else - -CAMLprim value unix_fchown(value fd, value uid, value gid) -{ invalid_argument("fchown not implemented"); } - -#endif diff --git a/otherlibs/unix/fcntl.c b/otherlibs/unix/fcntl.c deleted file mode 100644 index 914406eede..0000000000 --- a/otherlibs/unix/fcntl.c +++ /dev/null @@ -1,77 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" -#ifdef HAS_UNISTD -#include <unistd.h> -#endif -#include <fcntl.h> - -#ifndef O_NONBLOCK -#define O_NONBLOCK O_NDELAY -#endif - -CAMLprim value unix_set_nonblock(value fd) -{ - int retcode; - retcode = fcntl(Int_val(fd), F_GETFL, 0); - if (retcode == -1 || - fcntl(Int_val(fd), F_SETFL, retcode | O_NONBLOCK) == -1) - uerror("set_nonblock", Nothing); - return Val_unit; -} - -CAMLprim value unix_clear_nonblock(value fd) -{ - int retcode; - retcode = fcntl(Int_val(fd), F_GETFL, 0); - if (retcode == -1 || - fcntl(Int_val(fd), F_SETFL, retcode & ~O_NONBLOCK) == -1) - uerror("clear_nonblock", Nothing); - return Val_unit; -} - -#ifdef FD_CLOEXEC - -CAMLprim value unix_set_close_on_exec(value fd) -{ - int retcode; - retcode = fcntl(Int_val(fd), F_GETFD, 0); - if (retcode == -1 || - fcntl(Int_val(fd), F_SETFD, retcode | FD_CLOEXEC) == -1) - uerror("set_close_on_exec", Nothing); - return Val_unit; -} - -CAMLprim value unix_clear_close_on_exec(value fd) -{ - int retcode; - retcode = fcntl(Int_val(fd), F_GETFD, 0); - if (retcode == -1 || - fcntl(Int_val(fd), F_SETFD, retcode & ~FD_CLOEXEC) == -1) - uerror("clear_close_on_exec", Nothing); - return Val_unit; -} - -#else - -CAMLprim value unix_set_close_on_exec(value fd) -{ invalid_argument("set_close_on_exec not implemented"); } - -CAMLprim value unix_clear_close_on_exec(value fd) -{ invalid_argument("clear_close_on_exec not implemented"); } - -#endif diff --git a/otherlibs/unix/fork.c b/otherlibs/unix/fork.c deleted file mode 100644 index c78973474f..0000000000 --- a/otherlibs/unix/fork.c +++ /dev/null @@ -1,26 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_fork(value unit) -{ - int ret; - ret = fork(); - if (ret == -1) uerror("fork", Nothing); - return Val_int(ret); -} - diff --git a/otherlibs/unix/ftruncate.c b/otherlibs/unix/ftruncate.c deleted file mode 100644 index 8fe041b475..0000000000 --- a/otherlibs/unix/ftruncate.c +++ /dev/null @@ -1,45 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <sys/types.h> -#include <mlvalues.h> -#include <io.h> -#include "unixsupport.h" -#ifdef HAS_UNISTD -#include <unistd.h> -#endif - -#ifdef HAS_TRUNCATE - -CAMLprim value unix_ftruncate(value fd, value len) -{ - if (ftruncate(Int_val(fd), Long_val(len)) == -1) - uerror("ftruncate", Nothing); - return Val_unit; -} - -CAMLprim value unix_ftruncate_64(value fd, value len) -{ - if (ftruncate(Int_val(fd), File_offset_val(len)) == -1) - uerror("ftruncate", Nothing); - return Val_unit; -} - -#else - -CAMLprim value unix_ftruncate(value fd, value len) -{ invalid_argument("ftruncate not implemented"); } - -#endif diff --git a/otherlibs/unix/getcwd.c b/otherlibs/unix/getcwd.c deleted file mode 100644 index ee96c88b93..0000000000 --- a/otherlibs/unix/getcwd.c +++ /dev/null @@ -1,57 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" - -#if !defined (_WIN32) && !macintosh -#include <sys/param.h> -#endif - -#ifndef PATH_MAX -#ifdef MAXPATHLEN -#define PATH_MAX MAXPATHLEN -#else -#define PATH_MAX 512 -#endif -#endif - -#ifdef HAS_GETCWD - -CAMLprim value unix_getcwd(value unit) -{ - char buff[PATH_MAX]; - if (getcwd(buff, sizeof(buff)) == 0) uerror("getcwd", Nothing); - return copy_string(buff); -} - -#else -#ifdef HAS_GETWD - -CAMLprim value unix_getcwd(value unit) -{ - char buff[PATH_MAX]; - if (getwd(buff) == 0) uerror("getcwd", copy_string(buff)); - return copy_string(buff); -} - -#else - -CAMLprim value unix_getcwd(value unit) -{ invalid_argument("getcwd not implemented"); } - -#endif -#endif diff --git a/otherlibs/unix/getegid.c b/otherlibs/unix/getegid.c deleted file mode 100644 index e9900fb69b..0000000000 --- a/otherlibs/unix/getegid.c +++ /dev/null @@ -1,22 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_getegid(void) -{ - return Val_int(getegid()); -} diff --git a/otherlibs/unix/geteuid.c b/otherlibs/unix/geteuid.c deleted file mode 100644 index fd39879d21..0000000000 --- a/otherlibs/unix/geteuid.c +++ /dev/null @@ -1,22 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_geteuid(void) -{ - return Val_int(geteuid()); -} diff --git a/otherlibs/unix/getgid.c b/otherlibs/unix/getgid.c deleted file mode 100644 index debac27ee7..0000000000 --- a/otherlibs/unix/getgid.c +++ /dev/null @@ -1,22 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_getgid(void) -{ - return Val_int(getgid()); -} diff --git a/otherlibs/unix/getgr.c b/otherlibs/unix/getgr.c deleted file mode 100644 index eefaa5979c..0000000000 --- a/otherlibs/unix/getgr.c +++ /dev/null @@ -1,56 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <fail.h> -#include <alloc.h> -#include <memory.h> -#include "unixsupport.h" -#include <stdio.h> -#include <grp.h> - -static value alloc_group_entry(struct group *entry) -{ - value res; - value name = Val_unit, pass = Val_unit, mem = Val_unit; - - Begin_roots3 (name, pass, mem); - name = copy_string(entry->gr_name); - pass = copy_string(entry->gr_passwd); - mem = copy_string_array((const char**)entry->gr_mem); - res = alloc_small(4, 0); - Field(res,0) = name; - Field(res,1) = pass; - Field(res,2) = Val_int(entry->gr_gid); - Field(res,3) = mem; - End_roots(); - return res; -} - -CAMLprim value unix_getgrnam(value name) -{ - struct group * entry; - entry = getgrnam(String_val(name)); - if (entry == NULL) raise_not_found(); - return alloc_group_entry(entry); -} - -CAMLprim value unix_getgrgid(value gid) -{ - struct group * entry; - entry = getgrgid(Int_val(gid)); - if (entry == NULL) raise_not_found(); - return alloc_group_entry(entry); -} diff --git a/otherlibs/unix/getgroups.c b/otherlibs/unix/getgroups.c deleted file mode 100644 index 7bbcfef163..0000000000 --- a/otherlibs/unix/getgroups.c +++ /dev/null @@ -1,48 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> - -#ifdef HAS_GETGROUPS - -#include <sys/types.h> -#ifdef HAS_UNISTD -#include <unistd.h> -#endif -#include <limits.h> -#include "unixsupport.h" - -CAMLprim value unix_getgroups(value unit) -{ - gid_t gidset[NGROUPS_MAX]; - int n; - value res; - int i; - - n = getgroups(NGROUPS_MAX, gidset); - if (n == -1) uerror("getgroups", Nothing); - res = alloc_tuple(n); - for (i = 0; i < n; i++) - Field(res, i) = Val_int(gidset[i]); - return res; -} - -#else - -CAMLprim value unix_getgroups(value unit) -{ invalid_argument("getgroups not implemented"); } - -#endif diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c deleted file mode 100644 index 5b3252d599..0000000000 --- a/otherlibs/unix/gethost.c +++ /dev/null @@ -1,167 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <string.h> -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <fail.h> -#include <signals.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include "socketaddr.h" -#ifndef _WIN32 -#include <sys/types.h> -#include <netdb.h> -#endif - -#define NETDB_BUFFER_SIZE 10000 - -#ifdef _WIN32 -#define GETHOSTBYADDR_IS_REENTRANT 1 -#define GETHOSTBYNAME_IS_REENTRANT 1 -#endif - -static int entry_h_length; - -extern int socket_domain_table[]; - -static value alloc_one_addr(char const *a) -{ - struct in_addr addr; - memmove (&addr, a, entry_h_length); - return alloc_inet_addr(addr.s_addr); -} - -static value alloc_host_entry(struct hostent *entry) -{ - value res; - value name = Val_unit, aliases = Val_unit; - value addr_list = Val_unit, adr = Val_unit; - - Begin_roots4 (name, aliases, addr_list, adr); - name = copy_string((char *)(entry->h_name)); - aliases = copy_string_array((const char**)entry->h_aliases); - entry_h_length = entry->h_length; -#ifdef h_addr - addr_list = alloc_array(alloc_one_addr, (const char**)entry->h_addr_list); -#else - adr = alloc_one_addr(entry->h_addr); - addr_list = alloc_small(1, 0); - Field(addr_list, 0) = adr; -#endif - res = alloc_small(4, 0); - Field(res, 0) = name; - Field(res, 1) = aliases; - Field(res, 2) = entry->h_addrtype == PF_UNIX ? Val_int(0) : Val_int(1); - Field(res, 3) = addr_list; - End_roots(); - return res; -} - -CAMLprim value unix_gethostbyaddr(value a) -{ - uint32 adr = GET_INET_ADDR(a); - struct hostent * hp; -#if HAS_GETHOSTBYADDR_R == 7 - struct hostent h; - char buffer[NETDB_BUFFER_SIZE]; - int h_errnop; - enter_blocking_section(); - hp = gethostbyaddr_r((char *) &adr, 4, AF_INET, - &h, buffer, sizeof(buffer), &h_errnop); - leave_blocking_section(); -#elif HAS_GETHOSTBYADDR_R == 8 - struct hostent h; - char buffer[NETDB_BUFFER_SIZE]; - int h_errnop, rc; - enter_blocking_section(); - rc = gethostbyaddr_r((char *) &adr, 4, AF_INET, - &h, buffer, sizeof(buffer), &hp, &h_errnop); - leave_blocking_section(); - if (rc != 0) hp = NULL; -#else -#ifdef GETHOSTBYADDR_IS_REENTRANT - enter_blocking_section(); -#endif - hp = gethostbyaddr((char *) &adr, 4, AF_INET); -#ifdef GETHOSTBYADDR_IS_REENTRANT - leave_blocking_section(); -#endif -#endif - if (hp == (struct hostent *) NULL) raise_not_found(); - return alloc_host_entry(hp); -} - -CAMLprim value unix_gethostbyname(value name) -{ - struct hostent * hp; - char * hostname; - -#if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT - hostname = stat_alloc(string_length(name) + 1); - strcpy(hostname, String_val(name)); -#else - hostname = String_val(name); -#endif - -#if HAS_GETHOSTBYNAME_R == 5 - { - struct hostent h; - char buffer[NETDB_BUFFER_SIZE]; - int h_errno; - enter_blocking_section(); - hp = gethostbyname_r(hostname, &h, buffer, sizeof(buffer), &h_errno); - leave_blocking_section(); - } -#elif HAS_GETHOSTBYNAME_R == 6 - { - struct hostent h; - char buffer[NETDB_BUFFER_SIZE]; - int h_errno, rc; - enter_blocking_section(); - rc = gethostbyname_r(hostname, &h, buffer, sizeof(buffer), &hp, &h_errno); - leave_blocking_section(); - if (rc != 0) hp = NULL; - } -#else -#ifdef GETHOSTBYNAME_IS_REENTRANT - enter_blocking_section(); -#endif - hp = gethostbyname(hostname); -#ifdef GETHOSTBYNAME_IS_REENTRANT - leave_blocking_section(); -#endif -#endif - -#if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT - stat_free(hostname); -#endif - - if (hp == (struct hostent *) NULL) raise_not_found(); - return alloc_host_entry(hp); -} - -#else - -CAMLprim value unix_gethostbyaddr(value name) -{ invalid_argument("gethostbyaddr not implemented"); } - -CAMLprim value unix_gethostbyname(value name) -{ invalid_argument("gethostbyname not implemented"); } - -#endif diff --git a/otherlibs/unix/gethostname.c b/otherlibs/unix/gethostname.c deleted file mode 100644 index 777076bf23..0000000000 --- a/otherlibs/unix/gethostname.c +++ /dev/null @@ -1,57 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#if defined (_WIN32) -#include <winsock.h> -#elif !macintosh -#include <sys/param.h> -#endif -#include "unixsupport.h" - -#ifdef HAS_GETHOSTNAME - -#ifndef MAXHOSTNAMELEN -#define MAXHOSTNAMELEN 256 -#endif - -CAMLprim value unix_gethostname(value unit) -{ - char name[MAXHOSTNAMELEN]; - gethostname(name, MAXHOSTNAMELEN); - name[MAXHOSTNAMELEN-1] = 0; - return copy_string(name); -} - -#else -#ifdef HAS_UNAME - -#include <sys/utsname.h> - -CAMLprim value unix_gethostname(value unit) -{ - struct utsname un; - uname(&un); - return copy_string(un.nodename); -} - -#else - -CAMLprim value unix_gethostname(value unit) -{ invalid_argument("gethostname not implemented"); } - -#endif -#endif diff --git a/otherlibs/unix/getlogin.c b/otherlibs/unix/getlogin.c deleted file mode 100644 index de569df7fb..0000000000 --- a/otherlibs/unix/getlogin.c +++ /dev/null @@ -1,29 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" -#include <errno.h> - -extern char * getlogin(void); - -CAMLprim value unix_getlogin(void) -{ - char * name; - name = getlogin(); - if (name == NULL) unix_error(ENOENT, "getlogin", Nothing); - return copy_string(name); -} diff --git a/otherlibs/unix/getpeername.c b/otherlibs/unix/getpeername.c deleted file mode 100644 index c306155644..0000000000 --- a/otherlibs/unix/getpeername.c +++ /dev/null @@ -1,40 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include "socketaddr.h" - -CAMLprim value unix_getpeername(value sock) -{ - int retcode; - union sock_addr_union addr; - socklen_param_type addr_len; - - addr_len = sizeof(sock_addr); - retcode = getpeername(Int_val(sock), &addr.s_gen, &addr_len); - if (retcode == -1) uerror("getpeername", Nothing); - return alloc_sockaddr(&addr, addr_len); -} - -#else - -CAMLprim value unix_getpeername(value sock) -{ invalid_argument("getpeername not implemented"); } - -#endif diff --git a/otherlibs/unix/getpid.c b/otherlibs/unix/getpid.c deleted file mode 100644 index 876c636050..0000000000 --- a/otherlibs/unix/getpid.c +++ /dev/null @@ -1,22 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_getpid(void) -{ - return Val_int(getpid()); -} diff --git a/otherlibs/unix/getppid.c b/otherlibs/unix/getppid.c deleted file mode 100644 index 660c45c9ea..0000000000 --- a/otherlibs/unix/getppid.c +++ /dev/null @@ -1,22 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_getppid(void) -{ - return Val_int(getppid()); -} diff --git a/otherlibs/unix/getproto.c b/otherlibs/unix/getproto.c deleted file mode 100644 index 7ab2d2e1f0..0000000000 --- a/otherlibs/unix/getproto.c +++ /dev/null @@ -1,70 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <fail.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#ifndef _WIN32 -#include <netdb.h> -#else -#include <winsock.h> -#endif - -static value alloc_proto_entry(struct protoent *entry) -{ - value res; - value name = Val_unit, aliases = Val_unit; - - Begin_roots2 (name, aliases); - name = copy_string(entry->p_name); - aliases = copy_string_array((const char**)entry->p_aliases); - res = alloc_small(3, 0); - Field(res,0) = name; - Field(res,1) = aliases; - Field(res,2) = Val_int(entry->p_proto); - End_roots(); - return res; -} - -CAMLprim value unix_getprotobyname(value name) -{ - struct protoent * entry; - entry = getprotobyname(String_val(name)); - if (entry == (struct protoent *) NULL) raise_not_found(); - return alloc_proto_entry(entry); -} - -CAMLprim value unix_getprotobynumber(value proto) -{ - struct protoent * entry; - entry = getprotobynumber(Int_val(proto)); - if (entry == (struct protoent *) NULL) raise_not_found(); - return alloc_proto_entry(entry); -} - -#else - -CAMLprim value unix_getprotobynumber(value proto) -{ invalid_argument("getprotobynumber not implemented"); } - -CAMLprim value unix_getprotobyname(value name) -{ invalid_argument("getprotobyname not implemented"); } - -#endif diff --git a/otherlibs/unix/getpw.c b/otherlibs/unix/getpw.c deleted file mode 100644 index eba9d6c3c3..0000000000 --- a/otherlibs/unix/getpw.c +++ /dev/null @@ -1,65 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <fail.h> -#include "unixsupport.h" -#include <pwd.h> - -static value alloc_passwd_entry(struct passwd *entry) -{ - value res; - value name = Val_unit, passwd = Val_unit, gecos = Val_unit; - value dir = Val_unit, shell = Val_unit; - - Begin_roots5 (name, passwd, gecos, dir, shell); - name = copy_string(entry->pw_name); - passwd = copy_string(entry->pw_passwd); -#ifndef __BEOS__ - gecos = copy_string(entry->pw_gecos); -#else - gecos = copy_string(""); -#endif - dir = copy_string(entry->pw_dir); - shell = copy_string(entry->pw_shell); - res = alloc_small(7, 0); - Field(res,0) = name; - Field(res,1) = passwd; - Field(res,2) = Val_int(entry->pw_uid); - Field(res,3) = Val_int(entry->pw_gid); - Field(res,4) = gecos; - Field(res,5) = dir; - Field(res,6) = shell; - End_roots(); - return res; -} - -CAMLprim value unix_getpwnam(value name) -{ - struct passwd * entry; - entry = getpwnam(String_val(name)); - if (entry == (struct passwd *) NULL) raise_not_found(); - return alloc_passwd_entry(entry); -} - -CAMLprim value unix_getpwuid(value uid) -{ - struct passwd * entry; - entry = getpwuid(Int_val(uid)); - if (entry == (struct passwd *) NULL) raise_not_found(); - return alloc_passwd_entry(entry); -} diff --git a/otherlibs/unix/getserv.c b/otherlibs/unix/getserv.c deleted file mode 100644 index e580225837..0000000000 --- a/otherlibs/unix/getserv.c +++ /dev/null @@ -1,76 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <fail.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include <sys/types.h> - -#ifndef _WIN32 -#include <sys/socket.h> -#include <netinet/in.h> -#include <netdb.h> -#else -#include <winsock.h> -#endif - -static value alloc_service_entry(struct servent *entry) -{ - value res; - value name = Val_unit, aliases = Val_unit, proto = Val_unit; - - Begin_roots3 (name, aliases, proto); - name = copy_string(entry->s_name); - aliases = copy_string_array((const char**)entry->s_aliases); - proto = copy_string(entry->s_proto); - res = alloc_small(4, 0); - Field(res,0) = name; - Field(res,1) = aliases; - Field(res,2) = Val_int(ntohs(entry->s_port)); - Field(res,3) = proto; - End_roots(); - return res; -} - -CAMLprim value unix_getservbyname(value name, value proto) -{ - struct servent * entry; - entry = getservbyname(String_val(name), String_val(proto)); - if (entry == (struct servent *) NULL) raise_not_found(); - return alloc_service_entry(entry); -} - -CAMLprim value unix_getservbyport(value port, value proto) -{ - struct servent * entry; - entry = getservbyport(htons(Int_val(port)), String_val(proto)); - if (entry == (struct servent *) NULL) raise_not_found(); - return alloc_service_entry(entry); -} - -#else - -CAMLprim value unix_getservbyport(value port, value proto) -{ invalid_argument("getservbyport not implemented"); } - -CAMLprim value unix_getservbyname(value name, value proto) -{ invalid_argument("getservbyname not implemented"); } - -#endif diff --git a/otherlibs/unix/getsockname.c b/otherlibs/unix/getsockname.c deleted file mode 100644 index 94990e26d3..0000000000 --- a/otherlibs/unix/getsockname.c +++ /dev/null @@ -1,40 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include "socketaddr.h" - -CAMLprim value unix_getsockname(value sock) -{ - int retcode; - union sock_addr_union addr; - socklen_param_type addr_len; - - addr_len = sizeof(addr); - retcode = getsockname(Int_val(sock), &addr.s_gen, &addr_len); - if (retcode == -1) uerror("getsockname", Nothing); - return alloc_sockaddr(&addr, addr_len); -} - -#else - -CAMLprim value unix_getsockname(value sock) -{ invalid_argument("getsockname not implemented"); } - -#endif diff --git a/otherlibs/unix/gettimeofday.c b/otherlibs/unix/gettimeofday.c deleted file mode 100644 index 97f80f05ee..0000000000 --- a/otherlibs/unix/gettimeofday.c +++ /dev/null @@ -1,37 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" - -#ifdef HAS_GETTIMEOFDAY - -#include <sys/types.h> -#include <sys/time.h> - -CAMLprim value unix_gettimeofday(value unit) -{ - struct timeval tp; - if (gettimeofday(&tp, NULL) == -1) uerror("gettimeofday", Nothing); - return copy_double((double) tp.tv_sec + (double) tp.tv_usec / 1e6); -} - -#else - -CAMLprim value unix_gettimeofday(value unit) -{ invalid_argument("gettimeofday not implemented"); } - -#endif diff --git a/otherlibs/unix/getuid.c b/otherlibs/unix/getuid.c deleted file mode 100644 index 0417665a2c..0000000000 --- a/otherlibs/unix/getuid.c +++ /dev/null @@ -1,22 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_getuid(void) -{ - return Val_int(getuid()); -} diff --git a/otherlibs/unix/gmtime.c b/otherlibs/unix/gmtime.c deleted file mode 100644 index 502a5f9f90..0000000000 --- a/otherlibs/unix/gmtime.c +++ /dev/null @@ -1,93 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include "unixsupport.h" -#include <time.h> -#include <errno.h> - -static value alloc_tm(struct tm *tm) -{ - value res; - res = alloc_small(9, 0); - Field(res,0) = Val_int(tm->tm_sec); - Field(res,1) = Val_int(tm->tm_min); - Field(res,2) = Val_int(tm->tm_hour); - Field(res,3) = Val_int(tm->tm_mday); - Field(res,4) = Val_int(tm->tm_mon); - Field(res,5) = Val_int(tm->tm_year); - Field(res,6) = Val_int(tm->tm_wday); - Field(res,7) = Val_int(tm->tm_yday); - Field(res,8) = tm->tm_isdst ? Val_true : Val_false; - return res; -} - -CAMLprim value unix_gmtime(value t) -{ - time_t clock; - struct tm * tm; - clock = (time_t) Double_val(t); - tm = gmtime(&clock); - if (tm == NULL) unix_error(EINVAL, "gmtime", Nothing); - return alloc_tm(tm); -} - -CAMLprim value unix_localtime(value t) -{ - time_t clock; - struct tm * tm; - clock = (time_t) Double_val(t); - tm = localtime(&clock); - if (tm == NULL) unix_error(EINVAL, "localtime", Nothing); - return alloc_tm(tm); -} - -#ifdef HAS_MKTIME - -CAMLprim value unix_mktime(value t) -{ - struct tm tm; - time_t clock; - value res; - value tmval = Val_unit, clkval = Val_unit; - - Begin_roots2(tmval, clkval); - tm.tm_sec = Int_val(Field(t, 0)); - tm.tm_min = Int_val(Field(t, 1)); - tm.tm_hour = Int_val(Field(t, 2)); - tm.tm_mday = Int_val(Field(t, 3)); - tm.tm_mon = Int_val(Field(t, 4)); - tm.tm_year = Int_val(Field(t, 5)); - tm.tm_wday = Int_val(Field(t, 6)); - tm.tm_yday = Int_val(Field(t, 7)); - tm.tm_isdst = -1; /* tm.tm_isdst = Bool_val(Field(t, 8)); */ - clock = mktime(&tm); - if (clock == (time_t) -1) unix_error(ERANGE, "mktime", Nothing); - tmval = alloc_tm(&tm); - clkval = copy_double((double) clock); - res = alloc_small(2, 0); - Field(res, 0) = clkval; - Field(res, 1) = tmval; - End_roots (); - return res; -} - -#else - -CAMLprim value unix_mktime(value t) { invalid_argument("mktime not implemented"); } - -#endif diff --git a/otherlibs/unix/itimer.c b/otherlibs/unix/itimer.c deleted file mode 100644 index 6e5ea35899..0000000000 --- a/otherlibs/unix/itimer.c +++ /dev/null @@ -1,74 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include "unixsupport.h" - -#ifdef HAS_SETITIMER - -#include <math.h> -#include <sys/time.h> - -static void unix_set_timeval(struct timeval * tv, double d) -{ - double integr, frac; - frac = modf(d, &integr); - /* Round time up so that if d is small but not 0, we end up with - a non-0 timeval. */ - tv->tv_sec = integr; - tv->tv_usec = ceil(1e6 * frac); - if (tv->tv_usec >= 1000000) { tv->tv_sec++; tv->tv_usec = 0; } -} - -static value unix_convert_itimer(struct itimerval *tp) -{ -#define Get_timeval(tv) (double) tv.tv_sec + (double) tv.tv_usec / 1e6 - value res = alloc_small(Double_wosize * 2, Double_array_tag); - Store_double_field(res, 0, Get_timeval(tp->it_interval)); - Store_double_field(res, 1, Get_timeval(tp->it_value)); - return res; -#undef Get_timeval -} - -static int itimers[3] = { ITIMER_REAL, ITIMER_VIRTUAL, ITIMER_PROF }; - -CAMLprim value unix_setitimer(value which, value newval) -{ - struct itimerval new, old; - unix_set_timeval(&new.it_interval, Double_field(newval, 0)); - unix_set_timeval(&new.it_value, Double_field(newval, 1)); - if (setitimer(itimers[Int_val(which)], &new, &old) == -1) - uerror("setitimer", Nothing); - return unix_convert_itimer(&old); -} - -CAMLprim value unix_getitimer(value which) -{ - struct itimerval val; - if (getitimer(itimers[Int_val(which)], &val) == -1) - uerror("getitimer", Nothing); - return unix_convert_itimer(&val); -} - -#else - -CAMLprim value unix_setitimer(value which, value newval) -{ invalid_argument("setitimer not implemented"); } -CAMLprim value unix_getitimer(value which) -{ invalid_argument("getitimer not implemented"); } - -#endif diff --git a/otherlibs/unix/kill.c b/otherlibs/unix/kill.c deleted file mode 100644 index 8d8a47340c..0000000000 --- a/otherlibs/unix/kill.c +++ /dev/null @@ -1,29 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <fail.h> -#include "unixsupport.h" -#include <signal.h> -#include <signals.h> - -CAMLprim value unix_kill(value pid, value signal) -{ - int sig; - sig = convert_signal_number(Int_val(signal)); - if (kill(Int_val(pid), sig) == -1) - uerror("kill", Nothing); - return Val_unit; -} diff --git a/otherlibs/unix/link.c b/otherlibs/unix/link.c deleted file mode 100644 index 181e9c1800..0000000000 --- a/otherlibs/unix/link.c +++ /dev/null @@ -1,23 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_link(value path1, value path2) -{ - if (link(String_val(path1), String_val(path2)) == -1) uerror("link", path2); - return Val_unit; -} diff --git a/otherlibs/unix/listen.c b/otherlibs/unix/listen.c deleted file mode 100644 index d85d854fc8..0000000000 --- a/otherlibs/unix/listen.c +++ /dev/null @@ -1,34 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include <sys/socket.h> - -CAMLprim value unix_listen(value sock, value backlog) -{ - if (listen(Int_val(sock), Int_val(backlog)) == -1) uerror("listen", Nothing); - return Val_unit; -} - -#else - -CAMLprim value unix_listen(value sock, value backlog) -{ invalid_argument("listen not implemented"); } - -#endif diff --git a/otherlibs/unix/lockf.c b/otherlibs/unix/lockf.c deleted file mode 100644 index fd71514f9f..0000000000 --- a/otherlibs/unix/lockf.c +++ /dev/null @@ -1,110 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <errno.h> -#include <fcntl.h> -#include <mlvalues.h> -#include "unixsupport.h" - -#if defined(F_GETLK) && defined(F_SETLK) && defined(F_SETLKW) - -CAMLprim value unix_lockf(value fd, value cmd, value span) -{ - struct flock l; - int ret; - int fildes; - long size; - - fildes = Int_val(fd); - size = Long_val(span); - l.l_whence = 1; - if (size < 0) { - l.l_start = size; - l.l_len = -size; - } else { - l.l_start = 0L; - l.l_len = size; - } - switch (Int_val(cmd)) { - case 0: /* F_ULOCK */ - l.l_type = F_UNLCK; - ret = fcntl(fildes, F_SETLK, &l); - break; - case 1: /* F_LOCK */ - l.l_type = F_WRLCK; - ret = fcntl(fildes, F_SETLKW, &l); - break; - case 2: /* F_TLOCK */ - l.l_type = F_WRLCK; - ret = fcntl(fildes, F_SETLK, &l); - break; - case 3: /* F_TEST */ - l.l_type = F_WRLCK; - ret = fcntl(fildes, F_GETLK, &l); - if (ret != -1) { - if (l.l_type == F_UNLCK) - ret = 0; - else { - errno = EACCES; - ret = -1; - } - } - break; - case 4: /* F_RLOCK */ - l.l_type = F_RDLCK; - ret = fcntl(fildes, F_SETLKW, &l); - break; - case 5: /* F_TRLOCK */ - l.l_type = F_RDLCK; - ret = fcntl(fildes, F_SETLK, &l); - break; - default: - errno = EINVAL; - ret = -1; - } - if (ret == -1) uerror("lockf", Nothing); - return Val_unit; -} - -#else - -#ifdef HAS_LOCKF -#ifdef HAS_UNISTD -#include <unistd.h> -#else -#define F_ULOCK 0 -#define F_LOCK 1 -#define F_TLOCK 2 -#define F_TEST 3 -#endif - -static int lock_command_table[] = { - F_ULOCK, F_LOCK, F_TLOCK, F_TEST, F_LOCK, F_TLOCK -}; - -CAMLprim value unix_lockf(value fd, value cmd, value span) -{ - if (lockf(Int_val(fd), lock_command_table[Int_val(cmd)], Long_val(span)) - == -1) uerror("lockf", Nothing); - return Val_unit; -} - -#else - -CAMLprim value unix_lockf(value fd, value cmd, value span) -{ invalid_argument("lockf not implemented"); } - -#endif -#endif diff --git a/otherlibs/unix/lseek.c b/otherlibs/unix/lseek.c deleted file mode 100644 index 5dfa7e37fd..0000000000 --- a/otherlibs/unix/lseek.c +++ /dev/null @@ -1,57 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <errno.h> -#include <sys/types.h> -#include <mlvalues.h> -#include <alloc.h> -#include <io.h> -#include "unixsupport.h" - -#ifdef HAS_UNISTD -#include <unistd.h> -#else -#define SEEK_SET 0 -#define SEEK_CUR 1 -#define SEEK_END 2 -#endif - -#ifndef EOVERFLOW -#define EOVERFLOW ERANGE -#endif - -static int seek_command_table[] = { - SEEK_SET, SEEK_CUR, SEEK_END -}; - -CAMLprim value unix_lseek(value fd, value ofs, value cmd) -{ - file_offset ret; - ret = lseek(Int_val(fd), Long_val(ofs), - seek_command_table[Int_val(cmd)]); - if (ret == -1) uerror("lseek", Nothing); - if (ret > Max_long) unix_error(EOVERFLOW, "lseek", Nothing); - return Val_long(ret); -} - -CAMLprim value unix_lseek_64(value fd, value ofs, value cmd) -{ - file_offset ret; - ret = lseek(Int_val(fd), File_offset_val(ofs), - seek_command_table[Int_val(cmd)]); - if (ret == -1) uerror("lseek", Nothing); - return Val_file_offset(ret); -} - diff --git a/otherlibs/unix/mkdir.c b/otherlibs/unix/mkdir.c deleted file mode 100644 index 1b8fd6242f..0000000000 --- a/otherlibs/unix/mkdir.c +++ /dev/null @@ -1,25 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <sys/types.h> -#include <sys/stat.h> -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_mkdir(value path, value perm) -{ - if (mkdir(String_val(path), Int_val(perm)) == -1) uerror("mkdir", path); - return Val_unit; -} diff --git a/otherlibs/unix/mkfifo.c b/otherlibs/unix/mkfifo.c deleted file mode 100644 index f260cb74e8..0000000000 --- a/otherlibs/unix/mkfifo.c +++ /dev/null @@ -1,49 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <sys/types.h> -#include <sys/stat.h> -#include <mlvalues.h> -#include "unixsupport.h" - -#ifdef HAS_MKFIFO - -CAMLprim value unix_mkfifo(value path, value mode) -{ - if (mkfifo(String_val(path), Int_val(mode)) == -1) - uerror("mkfifo", path); - return Val_unit; -} - -#else - -#include <sys/types.h> -#include <sys/stat.h> - -#ifdef S_IFIFO - -CAMLprim value unix_mkfifo(value path, value mode) -{ - if (mknod(String_val(path), (Int_val(mode) & 07777) | S_IFIFO, 0) == -1) - uerror("mkfifo", path); - return Val_unit; -} - -#else - -CAMLprim value unix_mkfifo() { invalid_argument("mkfifo not implemented"); } - -#endif -#endif diff --git a/otherlibs/unix/nice.c b/otherlibs/unix/nice.c deleted file mode 100644 index 6018af0c2b..0000000000 --- a/otherlibs/unix/nice.c +++ /dev/null @@ -1,50 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" -#include <errno.h> - -#ifdef HAS_GETPRIORITY - -#include <sys/types.h> -#include <sys/time.h> -#include <sys/resource.h> - -CAMLprim value unix_nice(value incr) -{ - int prio; - errno = 0; - prio = getpriority(PRIO_PROCESS, 0); - if (prio == -1 && errno != 0) - uerror("nice", Nothing); - prio += Int_val(incr); - if (setpriority(PRIO_PROCESS, 0, prio) == -1) - uerror("nice", Nothing); - return Val_int(prio); -} - -#else - -CAMLprim value unix_nice(value incr) -{ - int ret; - errno = 0; - ret = nice(Int_val(incr)); - if (ret == -1 && errno != 0) uerror("nice", Nothing); - return Val_int(ret); -} - -#endif diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c deleted file mode 100644 index 880cbb5c6d..0000000000 --- a/otherlibs/unix/open.c +++ /dev/null @@ -1,57 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <signals.h> -#include "unixsupport.h" -#include <string.h> -#include <fcntl.h> - -#ifndef O_NONBLOCK -#define O_NONBLOCK O_NDELAY -#endif -#ifndef O_DSYNC -#define O_DSYNC 0 -#endif -#ifndef O_SYNC -#define O_SYNC 0 -#endif -#ifndef O_RSYNC -#define O_RSYNC 0 -#endif - -static int open_flag_table[] = { - O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, - O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC -}; - -CAMLprim value unix_open(value path, value flags, value perm) -{ - CAMLparam3(path, flags, perm); - int ret; - char * p; - - p = stat_alloc(string_length(path) + 1); - strcpy(p, String_val(path)); - /* open on a named FIFO can block (PR#1533) */ - enter_blocking_section(); - ret = open(p, convert_flag_list(flags, open_flag_table), Int_val(perm)); - leave_blocking_section(); - stat_free(p); - if (ret == -1) uerror("open", path); - CAMLreturn (Val_int(ret)); -} diff --git a/otherlibs/unix/opendir.c b/otherlibs/unix/opendir.c deleted file mode 100644 index 8852f5332e..0000000000 --- a/otherlibs/unix/opendir.c +++ /dev/null @@ -1,31 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" -#include <sys/types.h> -#ifdef HAS_DIRENT -#include <dirent.h> -#else -#include <sys/dir.h> -#endif - -CAMLprim value unix_opendir(value path) -{ - DIR * d; - d = opendir(String_val(path)); - if (d == (DIR *) NULL) uerror("opendir", path); - return (value) d; -} diff --git a/otherlibs/unix/pipe.c b/otherlibs/unix/pipe.c deleted file mode 100644 index 6b571be658..0000000000 --- a/otherlibs/unix/pipe.c +++ /dev/null @@ -1,29 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" - -CAMLprim value unix_pipe(void) -{ - int fd[2]; - value res; - if (pipe(fd) == -1) uerror("pipe", Nothing); - res = alloc_small(2, 0); - Field(res, 0) = Val_int(fd[0]); - Field(res, 1) = Val_int(fd[1]); - return res; -} diff --git a/otherlibs/unix/putenv.c b/otherlibs/unix/putenv.c deleted file mode 100644 index 962fd7902a..0000000000 --- a/otherlibs/unix/putenv.c +++ /dev/null @@ -1,45 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <stdlib.h> -#include <string.h> - -#include <memory.h> -#include <mlvalues.h> - -#include "unixsupport.h" - -#ifdef HAS_PUTENV - -CAMLprim value unix_putenv(value name, value val) -{ - mlsize_t namelen = string_length(name); - mlsize_t vallen = string_length(val); - char * s = (char *) stat_alloc(namelen + 1 + vallen + 1); - - memmove (s, String_val(name), namelen); - s[namelen] = '='; - memmove (s + namelen + 1, String_val(val), vallen); - s[namelen + 1 + vallen] = 0; - if (putenv(s) == -1) uerror("putenv", name); - return Val_unit; -} - -#else - -CAMLprim value unix_putenv(value name, value val) -{ invalid_argument("putenv not implemented"); } - -#endif diff --git a/otherlibs/unix/read.c b/otherlibs/unix/read.c deleted file mode 100644 index 03a9e6aaa7..0000000000 --- a/otherlibs/unix/read.c +++ /dev/null @@ -1,38 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <string.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> -#include "unixsupport.h" - -CAMLprim value unix_read(value fd, value buf, value ofs, value len) -{ - long numbytes; - int ret; - char iobuf[UNIX_BUFFER_SIZE]; - - Begin_root (buf); - numbytes = Long_val(len); - if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; - enter_blocking_section(); - ret = read(Int_val(fd), iobuf, (int) numbytes); - leave_blocking_section(); - if (ret == -1) uerror("read", Nothing); - memmove (&Byte(buf, Long_val(ofs)), iobuf, ret); - End_roots(); - return Val_int(ret); -} diff --git a/otherlibs/unix/readdir.c b/otherlibs/unix/readdir.c deleted file mode 100644 index 09cbc3726c..0000000000 --- a/otherlibs/unix/readdir.c +++ /dev/null @@ -1,36 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <fail.h> -#include <alloc.h> -#include "unixsupport.h" -#include <sys/types.h> -#ifdef HAS_DIRENT -#include <dirent.h> -typedef struct dirent directory_entry; -#else -#include <sys/dir.h> -typedef struct direct directory_entry; -#endif - -CAMLprim value unix_readdir(value d) -{ - directory_entry * e; - - e = readdir((DIR *) d); - if (e == (directory_entry *) NULL) raise_end_of_file(); - return copy_string(e->d_name); -} diff --git a/otherlibs/unix/readlink.c b/otherlibs/unix/readlink.c deleted file mode 100644 index 6cc4d9ec47..0000000000 --- a/otherlibs/unix/readlink.c +++ /dev/null @@ -1,47 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> - -#ifdef HAS_SYMLINK - -#include <sys/param.h> -#include "unixsupport.h" - -#ifndef PATH_MAX -#ifdef MAXPATHLEN -#define PATH_MAX MAXPATHLEN -#else -#define PATH_MAX 512 -#endif -#endif - -CAMLprim value unix_readlink(value path) -{ - char buffer[PATH_MAX]; - int len; - len = readlink(String_val(path), buffer, sizeof(buffer) - 1); - if (len == -1) uerror("readlink", path); - buffer[len] = '\0'; - return copy_string(buffer); -} - -#else - -CAMLprim value unix_readlink(value path) -{ invalid_argument("readlink not implemented"); } - -#endif diff --git a/otherlibs/unix/rename.c b/otherlibs/unix/rename.c deleted file mode 100644 index 65f33c8b57..0000000000 --- a/otherlibs/unix/rename.c +++ /dev/null @@ -1,25 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <stdio.h> -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_rename(value path1, value path2) -{ - if (rename(String_val(path1), String_val(path2)) == -1) - uerror("rename", path1); - return Val_unit; -} diff --git a/otherlibs/unix/rewinddir.c b/otherlibs/unix/rewinddir.c deleted file mode 100644 index bc01e05598..0000000000 --- a/otherlibs/unix/rewinddir.c +++ /dev/null @@ -1,38 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" -#include <sys/types.h> -#ifdef HAS_DIRENT -#include <dirent.h> -#else -#include <sys/dir.h> -#endif - -#ifdef HAS_REWINDDIR - -CAMLprim value unix_rewinddir(value d) -{ - rewinddir((DIR *) d); - return Val_unit; -} - -#else - -CAMLprim value unix_rewinddir(value d) -{ invalid_argument("rewinddir not implemented"); } - -#endif diff --git a/otherlibs/unix/rmdir.c b/otherlibs/unix/rmdir.c deleted file mode 100644 index 8de223464d..0000000000 --- a/otherlibs/unix/rmdir.c +++ /dev/null @@ -1,23 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_rmdir(value path) -{ - if (rmdir(String_val(path)) == -1) uerror("rmdir", path); - return Val_unit; -} diff --git a/otherlibs/unix/select.c b/otherlibs/unix/select.c deleted file mode 100644 index 43de97709b..0000000000 --- a/otherlibs/unix/select.c +++ /dev/null @@ -1,109 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <signals.h> -#include "unixsupport.h" - -#ifdef HAS_SELECT - -#include <sys/types.h> -#include <sys/time.h> -#ifdef HAS_SYS_SELECT_H -#include <sys/select.h> -#endif -#include <string.h> -#include <unistd.h> - -typedef fd_set file_descr_set; - -static void fdlist_to_fdset(value fdlist, fd_set *fdset, int *maxfd) -{ - value l; - FD_ZERO(fdset); - for (l = fdlist; l != Val_int(0); l = Field(l, 1)) { - int fd = Int_val(Field(l, 0)); - FD_SET(fd, fdset); - if (fd > *maxfd) *maxfd = fd; - } -} - -static value fdset_to_fdlist(value fdlist, fd_set *fdset) -{ - value l; - value res = Val_int(0); - - Begin_roots2(l, res); - for (l = fdlist; l != Val_int(0); l = Field(l, 1)) { - int fd = Int_val(Field(l, 0)); - if (FD_ISSET(fd, fdset)) { - value newres = alloc_small(2, 0); - Field(newres, 0) = Val_int(fd); - Field(newres, 1) = res; - res = newres; - } - } - End_roots(); - return res; -} - -CAMLprim value unix_select(value readfds, value writefds, value exceptfds, - value timeout) -{ - fd_set read, write, except; - int maxfd; - double tm; - struct timeval tv; - struct timeval * tvp; - int retcode; - value res; - - Begin_roots3 (readfds, writefds, exceptfds); - maxfd = -1; - fdlist_to_fdset(readfds, &read, &maxfd); - fdlist_to_fdset(writefds, &write, &maxfd); - fdlist_to_fdset(exceptfds, &except, &maxfd); - tm = Double_val(timeout); - if (tm < 0.0) - tvp = (struct timeval *) NULL; - else { - tv.tv_sec = (int) tm; - tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec)); - tvp = &tv; - } - enter_blocking_section(); - retcode = select(maxfd + 1, &read, &write, &except, tvp); - leave_blocking_section(); - if (retcode == -1) uerror("select", Nothing); - readfds = fdset_to_fdlist(readfds, &read); - writefds = fdset_to_fdlist(writefds, &write); - exceptfds = fdset_to_fdlist(exceptfds, &except); - res = alloc_small(3, 0); - Field(res, 0) = readfds; - Field(res, 1) = writefds; - Field(res, 2) = exceptfds; - End_roots(); - return res; -} - -#else - -CAMLprim value unix_select(value readfds, value writefds, value exceptfds, - value timeout) -{ invalid_argument("select not implemented"); } - -#endif diff --git a/otherlibs/unix/sendrecv.c b/otherlibs/unix/sendrecv.c deleted file mode 100644 index ac9b32e859..0000000000 --- a/otherlibs/unix/sendrecv.c +++ /dev/null @@ -1,139 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <string.h> -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <signals.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS -#include "socketaddr.h" - -static int msg_flag_table[] = { - MSG_OOB, MSG_DONTROUTE, MSG_PEEK -}; - -CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags) -{ - int ret; - long numbytes; - char iobuf[UNIX_BUFFER_SIZE]; - - Begin_root (buff); - numbytes = Long_val(len); - if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; - enter_blocking_section(); - ret = recv(Int_val(sock), iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table)); - leave_blocking_section(); - if (ret == -1) uerror("recv", Nothing); - memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); - End_roots(); - return Val_int(ret); -} - -CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags) -{ - int ret; - long numbytes; - char iobuf[UNIX_BUFFER_SIZE]; - value res; - value adr = Val_unit; - union sock_addr_union addr; - socklen_param_type addr_len; - - Begin_roots2 (buff, adr); - numbytes = Long_val(len); - if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; - addr_len = sizeof(addr); - enter_blocking_section(); - ret = recvfrom(Int_val(sock), iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table), - &addr.s_gen, &addr_len); - leave_blocking_section(); - if (ret == -1) uerror("recvfrom", Nothing); - memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); - adr = alloc_sockaddr(&addr, addr_len); - res = alloc_small(2, 0); - Field(res, 0) = Val_int(ret); - Field(res, 1) = adr; - End_roots(); - return res; -} - -CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags) -{ - int ret; - long numbytes; - char iobuf[UNIX_BUFFER_SIZE]; - - numbytes = Long_val(len); - if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; - memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); - enter_blocking_section(); - ret = send(Int_val(sock), iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table)); - leave_blocking_section(); - if (ret == -1) uerror("send", Nothing); - return Val_int(ret); -} - -CAMLprim value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest) -{ - int ret; - long numbytes; - char iobuf[UNIX_BUFFER_SIZE]; - union sock_addr_union addr; - socklen_param_type addr_len; - - get_sockaddr(dest, &addr, &addr_len); - numbytes = Long_val(len); - if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; - memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); - enter_blocking_section(); - ret = sendto(Int_val(sock), iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table), - &addr.s_gen, addr_len); - leave_blocking_section(); - if (ret == -1) uerror("sendto", Nothing); - return Val_int(ret); -} - -CAMLprim value unix_sendto(value *argv, int argc) -{ - return unix_sendto_native - (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -#else - -CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags) -{ invalid_argument("recv not implemented"); } - -CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags) -{ invalid_argument("recvfrom not implemented"); } - -CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags) -{ invalid_argument("send not implemented"); } - -CAMLprim value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest) -{ invalid_argument("sendto not implemented"); } - -CAMLprim value unix_sendto(value *argv, int argc) -{ invalid_argument("sendto not implemented"); } - -#endif diff --git a/otherlibs/unix/setgid.c b/otherlibs/unix/setgid.c deleted file mode 100644 index bd8810f819..0000000000 --- a/otherlibs/unix/setgid.c +++ /dev/null @@ -1,23 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_setgid(value gid) -{ - if (setgid(Int_val(gid)) == -1) uerror("setgid", Nothing); - return Val_unit; -} diff --git a/otherlibs/unix/setsid.c b/otherlibs/unix/setsid.c deleted file mode 100644 index fed8e0dca0..0000000000 --- a/otherlibs/unix/setsid.c +++ /dev/null @@ -1,30 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" -#ifdef HAS_UNISTD -#include <unistd.h> -#endif - -CAMLprim value unix_setsid(value unit) -{ -#ifdef HAS_SETSID - return Val_int(setsid()); -#else - invalid_argument("setsid not implemented"); - return Val_unit; -#endif -} diff --git a/otherlibs/unix/setuid.c b/otherlibs/unix/setuid.c deleted file mode 100644 index c867f4c68b..0000000000 --- a/otherlibs/unix/setuid.c +++ /dev/null @@ -1,23 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_setuid(value uid) -{ - if (setuid(Int_val(uid)) == -1) uerror("setuid", Nothing); - return Val_unit; -} diff --git a/otherlibs/unix/shutdown.c b/otherlibs/unix/shutdown.c deleted file mode 100644 index f8216bd2e9..0000000000 --- a/otherlibs/unix/shutdown.c +++ /dev/null @@ -1,39 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include <sys/socket.h> - -static int shutdown_command_table[] = { - 0, 1, 2 -}; - -CAMLprim value unix_shutdown(value sock, value cmd) -{ - if (shutdown(Int_val(sock), shutdown_command_table[Int_val(cmd)]) == -1) - uerror("shutdown", Nothing); - return Val_unit; -} - -#else - -CAMLprim value unix_shutdown(value sock, value cmd) -{ invalid_argument("shutdown not implemented"); } - -#endif diff --git a/otherlibs/unix/signals.c b/otherlibs/unix/signals.c deleted file mode 100644 index 95db00bd23..0000000000 --- a/otherlibs/unix/signals.c +++ /dev/null @@ -1,105 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1998 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <errno.h> -#include <signal.h> - -#include <alloc.h> -#include <memory.h> -#include <mlvalues.h> -#include <signals.h> -#include "unixsupport.h" - -#ifndef NSIG -#define NSIG 32 -#endif - -#ifdef POSIX_SIGNALS - -static void decode_sigset(value vset, sigset_t * set) -{ - sigemptyset(set); - while (vset != Val_int(0)) { - int sig = convert_signal_number(Int_val(Field(vset, 0))); - sigaddset(set, sig); - vset = Field(vset, 1); - } -} - -static value encode_sigset(sigset_t * set) -{ - value res = Val_int(0); - int i; - - Begin_root(res) - for (i = 1; i < NSIG; i++) - if (sigismember(set, i)) { - value newcons = alloc_small(2, 0); - Field(newcons, 0) = Val_int(i); - Field(newcons, 1) = res; - res = newcons; - } - End_roots(); - return res; -} - -static int sigprocmask_cmd[3] = { SIG_SETMASK, SIG_BLOCK, SIG_UNBLOCK }; - -CAMLprim value unix_sigprocmask(value vaction, value vset) -{ - int how; - sigset_t set, oldset; - int retcode; - - how = sigprocmask_cmd[Int_val(vaction)]; - decode_sigset(vset, &set); - enter_blocking_section(); - retcode = sigprocmask(how, &set, &oldset); - leave_blocking_section(); - if (retcode == -1) uerror("sigprocmask", Nothing); - return encode_sigset(&oldset); -} - -CAMLprim value unix_sigpending(value unit) -{ - sigset_t pending; - if (sigpending(&pending) == -1) uerror("sigpending", Nothing); - return encode_sigset(&pending); -} - -CAMLprim value unix_sigsuspend(value vset) -{ - sigset_t set; - int retcode; - decode_sigset(vset, &set); - enter_blocking_section(); - retcode = sigsuspend(&set); - leave_blocking_section(); - if (retcode == -1 && errno != EINTR) uerror("sigsuspend", Nothing); - return Val_unit; -} - -#else - -CAMLprim value unix_sigprocmask(value vaction, value vset) -{ invalid_argument("Unix.sigprocmask not available"); } - -CAMLprim value unix_sigpending(value unit) -{ invalid_argument("Unix.sigpending not available"); } - -CAMLprim value unix_sigsuspend(value vset) -{ invalid_argument("Unix.sigsuspend not available"); } - -#endif diff --git a/otherlibs/unix/sleep.c b/otherlibs/unix/sleep.c deleted file mode 100644 index ec14e39d0b..0000000000 --- a/otherlibs/unix/sleep.c +++ /dev/null @@ -1,26 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <signals.h> -#include "unixsupport.h" - -CAMLprim value unix_sleep(value t) -{ - enter_blocking_section(); - sleep(Int_val(t)); - leave_blocking_section(); - return Val_unit; -} diff --git a/otherlibs/unix/socket.c b/otherlibs/unix/socket.c deleted file mode 100644 index a61a1a3094..0000000000 --- a/otherlibs/unix/socket.c +++ /dev/null @@ -1,48 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include <sys/types.h> -#include <sys/socket.h> - -int socket_domain_table[] = { - PF_UNIX, PF_INET -}; - -int socket_type_table[] = { - SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET -}; - -CAMLprim value unix_socket(value domain, value type, value proto) -{ - int retcode; - retcode = socket(socket_domain_table[Int_val(domain)], - socket_type_table[Int_val(type)], - Int_val(proto)); - if (retcode == -1) uerror("socket", Nothing); - return Val_int(retcode); - -} - -#else - -CAMLprim value unix_socket(value domain, value type, value proto) -{ invalid_argument("socket not implemented"); } - -#endif diff --git a/otherlibs/unix/socketaddr.c b/otherlibs/unix/socketaddr.c deleted file mode 100644 index 4be5f12910..0000000000 --- a/otherlibs/unix/socketaddr.c +++ /dev/null @@ -1,110 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <string.h> -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <errno.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include "socketaddr.h" - -#ifdef _WIN32 -#define EAFNOSUPPORT WSAEAFNOSUPPORT -#endif - -value alloc_inet_addr(uint32 a) -{ - value res; - /* Use a string rather than an abstract block so that it can be - marshaled safely. Remember that a is in network byte order, - hence can be marshaled safely. */ - res = alloc_string(sizeof(uint32)); - GET_INET_ADDR(res) = a; - return res; -} - -void get_sockaddr(value mladr, - union sock_addr_union * adr /*out*/, - socklen_param_type * adr_len /*out*/) -{ - switch(Tag_val(mladr)) { -#ifndef _WIN32 - case 0: /* ADDR_UNIX */ - { value path; - mlsize_t len; - path = Field(mladr, 0); - len = string_length(path); - adr->s_unix.sun_family = AF_UNIX; - if (len >= sizeof(adr->s_unix.sun_path)) { - unix_error(ENAMETOOLONG, "", path); - } - memmove (adr->s_unix.sun_path, String_val(path), len + 1); - *adr_len = - ((char *)&(adr->s_unix.sun_path) - (char *)&(adr->s_unix)) - + len; - break; - } -#endif - case 1: /* ADDR_INET */ - { - char * p; - int n; - for (p = (char *) &adr->s_inet, n = sizeof(adr->s_inet); - n > 0; p++, n--) - *p = 0; - adr->s_inet.sin_family = AF_INET; - adr->s_inet.sin_addr.s_addr = GET_INET_ADDR(Field(mladr, 0)); - adr->s_inet.sin_port = htons(Int_val(Field(mladr, 1))); - *adr_len = sizeof(struct sockaddr_in); - break; - } - } -} - -value alloc_sockaddr(union sock_addr_union * adr /*in*/, - socklen_param_type adr_len) -{ - value res; - switch(adr->s_gen.sa_family) { -#ifndef _WIN32 - case AF_UNIX: - { value n = copy_string(adr->s_unix.sun_path); - Begin_root (n); - res = alloc_small(1, 0); - Field(res,0) = n; - End_roots(); - break; - } -#endif - case AF_INET: - { value a = alloc_inet_addr(adr->s_inet.sin_addr.s_addr); - Begin_root (a); - res = alloc_small(2, 1); - Field(res,0) = a; - Field(res,1) = Val_int(ntohs(adr->s_inet.sin_port)); - End_roots(); - break; - } - default: - unix_error(EAFNOSUPPORT, "", Nothing); - } - return res; -} - -#endif diff --git a/otherlibs/unix/socketaddr.h b/otherlibs/unix/socketaddr.h deleted file mode 100644 index 9788a10098..0000000000 --- a/otherlibs/unix/socketaddr.h +++ /dev/null @@ -1,44 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <misc.h> -#include <sys/types.h> -#include <sys/socket.h> -#include <sys/un.h> -#include <netinet/in.h> -#include <arpa/inet.h> - -union sock_addr_union { - struct sockaddr s_gen; - struct sockaddr_un s_unix; - struct sockaddr_in s_inet; -}; - -extern union sock_addr_union sock_addr; - -#ifdef HAS_SOCKLEN_T -typedef socklen_t socklen_param_type; -#else -typedef int socklen_param_type; -#endif - -void get_sockaddr (value mladdr, - union sock_addr_union * addr /*out*/, - socklen_param_type * addr_len /*out*/); -CAMLprim value alloc_sockaddr (union sock_addr_union * addr /*in*/, - socklen_param_type addr_len); -CAMLprim value alloc_inet_addr (uint32 inaddr); - -#define GET_INET_ADDR(v) (*((uint32 *) (v))) diff --git a/otherlibs/unix/socketpair.c b/otherlibs/unix/socketpair.c deleted file mode 100644 index 6c7b4ebc81..0000000000 --- a/otherlibs/unix/socketpair.c +++ /dev/null @@ -1,45 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include <sys/socket.h> - -extern int socket_domain_table[], socket_type_table[]; - -CAMLprim value unix_socketpair(value domain, value type, value proto) -{ - int sv[2]; - value res; - if (socketpair(socket_domain_table[Int_val(domain)], - socket_type_table[Int_val(type)], - Int_val(proto), sv) == -1) - uerror("socketpair", Nothing); - res = alloc_small(2, 0); - Field(res,0) = Val_int(sv[0]); - Field(res,1) = Val_int(sv[1]); - return res; -} - -#else - -CAMLprim value unix_socketpair(value domain, value type, value proto) -{ invalid_argument("socketpair not implemented"); } - -#endif diff --git a/otherlibs/unix/sockopt.c b/otherlibs/unix/sockopt.c deleted file mode 100644 index 3d913dca3b..0000000000 --- a/otherlibs/unix/sockopt.c +++ /dev/null @@ -1,236 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include <sys/time.h> -#include <sys/types.h> -#include <sys/socket.h> - -#include "socketaddr.h" - -#ifndef SO_DEBUG -#define SO_DEBUG (-1) -#endif -#ifndef SO_BROADCAST -#define SO_BROADCAST (-1) -#endif -#ifndef SO_REUSEADDR -#define SO_REUSEADDR (-1) -#endif -#ifndef SO_KEEPALIVE -#define SO_KEEPALIVE (-1) -#endif -#ifndef SO_DONTROUTE -#define SO_DONTROUTE (-1) -#endif -#ifndef SO_OOBINLINE -#define SO_OOBINLINE (-1) -#endif -#ifndef SO_ACCEPTCONN -#define SO_ACCEPTCONN (-1) -#endif -#ifndef SO_SNDBUF -#define SO_SNDBUF (-1) -#endif -#ifndef SO_RCVBUF -#define SO_RCVBUF (-1) -#endif -#ifndef SO_ERROR -#define SO_ERROR (-1) -#endif -#ifndef SO_TYPE -#define SO_TYPE (-1) -#endif -#ifndef SO_RCVLOWAT -#define SO_RCVLOWAT (-1) -#endif -#ifndef SO_SNDLOWAT -#define SO_SNDLOWAT (-1) -#endif -#ifndef SO_LINGER -#define SO_LINGER (-1) -#endif -#ifndef SO_RCVTIMEO -#define SO_RCVTIMEO (-1) -#endif -#ifndef SO_SNDTIMEO -#define SO_SNDTIMEO (-1) -#endif - -static int sockopt_bool[] = { - SO_DEBUG, SO_BROADCAST, SO_REUSEADDR, SO_KEEPALIVE, - SO_DONTROUTE, SO_OOBINLINE, SO_ACCEPTCONN }; - -static int sockopt_int[] = { - SO_SNDBUF, SO_RCVBUF, SO_ERROR, SO_TYPE, SO_RCVLOWAT, SO_SNDLOWAT }; - -static int sockopt_optint[] = { SO_LINGER }; - -static int sockopt_float[] = { SO_RCVTIMEO, SO_SNDTIMEO }; - -CAMLprim value getsockopt_int(int *sockopt, value socket, - int level, value option) -{ - int optval; - socklen_param_type optsize; - - optsize = sizeof(optval); - if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, &optsize) == -1) - uerror("getsockopt", Nothing); - return Val_int(optval); -} - -CAMLprim value setsockopt_int(int *sockopt, value socket, int level, - value option, value status) -{ - int optval = Int_val(status); - if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) - uerror("setsockopt", Nothing); - return Val_unit; -} - -CAMLprim value unix_getsockopt_bool(value socket, value option) { - value res = getsockopt_int(sockopt_bool, socket, SOL_SOCKET, option); - return Val_bool(Int_val(res)); -} - -CAMLprim value unix_setsockopt_bool(value socket, value option, value status) -{ - return setsockopt_int(sockopt_bool, socket, SOL_SOCKET, option, status); -} - -CAMLprim value unix_getsockopt_int(value socket, value option) { - return getsockopt_int(sockopt_int, socket, SOL_SOCKET, option); -} - -CAMLprim value unix_setsockopt_int(value socket, value option, value status) -{ - return setsockopt_int(sockopt_int, socket, SOL_SOCKET, option, status); -} - -CAMLprim value getsockopt_optint(int *sockopt, value socket, - int level, value option) -{ - struct linger optval; - socklen_param_type optsize; - value res = Val_int(0); /* None */ - - optsize = sizeof(optval); - if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, &optsize) == -1) - uerror("getsockopt_optint", Nothing); - if (optval.l_onoff != 0) { - res = alloc_small(1, 0); - Field(res, 0) = Val_int(optval.l_linger); - } - return res; -} - -CAMLprim value setsockopt_optint(int *sockopt, value socket, int level, - value option, value status) -{ - struct linger optval; - - optval.l_onoff = Is_block (status); - if (optval.l_onoff) - optval.l_linger = Int_val (Field (status, 0)); - if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) - uerror("setsockopt_optint", Nothing); - return Val_unit; -} - -CAMLprim value unix_getsockopt_optint(value socket, value option) -{ - return getsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option); -} - -CAMLprim value unix_setsockopt_optint(value socket, value option, value status) -{ - return setsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option, status); -} - -CAMLprim value getsockopt_float(int *sockopt, value socket, - int level, value option) -{ - struct timeval tv; - socklen_param_type optsize; - - optsize = sizeof(tv); - if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &tv, &optsize) == -1) - uerror("getsockopt_float", Nothing); - return copy_double((double) tv.tv_sec + (double) tv.tv_usec / 1e6); -} - -CAMLprim value setsockopt_float(int *sockopt, value socket, int level, - value option, value status) -{ - struct timeval tv; - double tv_f; - - tv_f = Double_val(status); - tv.tv_sec = (int)tv_f; - tv.tv_usec = (int) (1e6 * (tv_f - tv.tv_sec)); - if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &tv, sizeof(tv)) == -1) - uerror("setsockopt_float", Nothing); - return Val_unit; -} - -CAMLprim value unix_getsockopt_float(value socket, value option) -{ - return getsockopt_float(sockopt_float, socket, SOL_SOCKET, option); -} - -CAMLprim value unix_setsockopt_float(value socket, value option, value status) -{ - return setsockopt_float(sockopt_float, socket, SOL_SOCKET, option, status); -} - -#else - -CAMLprim value unix_getsockopt_bool(value socket, value option) -{ invalid_argument("getsockopt not implemented"); } - -CAMLprim value unix_setsockopt_bool(value socket, value option, value status) -{ invalid_argument("setsockopt not implemented"); } - -CAMLprim value unix_getsockopt_int(value socket, value option) -{ invalid_argument("getsockopt_int not implemented"); } - -CAMLprim value unix_setsockopt_int(value socket, value option, value status) -{ invalid_argument("setsockopt_int not implemented"); } - -CAMLprim value unix_getsockopt_optint(value socket, value option) -{ invalid_argument("getsockopt_optint not implemented"); } - -CAMLprim value unix_setsockopt_optint(value socket, value option, value status) -{ invalid_argument("setsockopt_optint not implemented"); } - -CAMLprim value unix_getsockopt_float(value socket, value option) -{ invalid_argument("getsockopt_float not implemented"); } - -CAMLprim value unix_setsockopt_float(value socket, value option, value status) -{ invalid_argument("setsockopt_float not implemented"); } - -#endif diff --git a/otherlibs/unix/stat.c b/otherlibs/unix/stat.c deleted file mode 100644 index 92a752f5e7..0000000000 --- a/otherlibs/unix/stat.c +++ /dev/null @@ -1,140 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <errno.h> -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> -#include "unixsupport.h" -#include "cst2constr.h" -#include <sys/types.h> -#include <sys/stat.h> -#include <io.h> - -#ifndef S_IFLNK -#define S_IFLNK 0 -#endif -#ifndef S_IFIFO -#define S_IFIFO 0 -#endif -#ifndef S_IFSOCK -#define S_IFSOCK 0 -#endif -#ifndef S_IFBLK -#define S_IFBLK 0 -#endif - -#ifndef EOVERFLOW -#define EOVERFLOW ERANGE -#endif - -static int file_kind_table[] = { - S_IFREG, S_IFDIR, S_IFCHR, S_IFBLK, S_IFLNK, S_IFIFO, S_IFSOCK -}; - -static value stat_aux(int use_64, struct stat *buf) -{ - CAMLparam0(); - CAMLlocal5(atime, mtime, ctime, offset, v); - - atime = copy_double((double) buf->st_atime); - mtime = copy_double((double) buf->st_mtime); - ctime = copy_double((double) buf->st_ctime); - offset = use_64 ? Val_file_offset(buf->st_size) : Val_int (buf->st_size); - v = alloc_small(12, 0); - Field (v, 0) = Val_int (buf->st_dev); - Field (v, 1) = Val_int (buf->st_ino); - Field (v, 2) = cst_to_constr(buf->st_mode & S_IFMT, file_kind_table, - sizeof(file_kind_table) / sizeof(int), 0); - Field (v, 3) = Val_int (buf->st_mode & 07777); - Field (v, 4) = Val_int (buf->st_nlink); - Field (v, 5) = Val_int (buf->st_uid); - Field (v, 6) = Val_int (buf->st_gid); - Field (v, 7) = Val_int (buf->st_rdev); - Field (v, 8) = offset; - Field (v, 9) = atime; - Field (v, 10) = mtime; - Field (v, 11) = ctime; - CAMLreturn(v); -} - -CAMLprim value unix_stat(value path) -{ - int ret; - struct stat buf; - ret = stat(String_val(path), &buf); - if (ret == -1) uerror("stat", path); - if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG) - unix_error(EOVERFLOW, "stat", path); - return stat_aux(0, &buf); -} - -CAMLprim value unix_lstat(value path) -{ - int ret; - struct stat buf; -#ifdef HAS_SYMLINK - ret = lstat(String_val(path), &buf); -#else - ret = stat(String_val(path), &buf); -#endif - if (ret == -1) uerror("lstat", path); - if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG) - unix_error(EOVERFLOW, "lstat", path); - return stat_aux(0, &buf); -} - -CAMLprim value unix_fstat(value fd) -{ - int ret; - struct stat buf; - ret = fstat(Int_val(fd), &buf); - if (ret == -1) uerror("fstat", Nothing); - if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG) - unix_error(EOVERFLOW, "fstat", Nothing); - return stat_aux(0, &buf); -} - -CAMLprim value unix_stat_64(value path) -{ - int ret; - struct stat buf; - ret = stat(String_val(path), &buf); - if (ret == -1) uerror("stat", path); - return stat_aux(1, &buf); -} - -CAMLprim value unix_lstat_64(value path) -{ - int ret; - struct stat buf; -#ifdef HAS_SYMLINK - ret = lstat(String_val(path), &buf); -#else - ret = stat(String_val(path), &buf); -#endif - if (ret == -1) uerror("lstat", path); - return stat_aux(1, &buf); -} - -CAMLprim value unix_fstat_64(value fd) -{ - int ret; - struct stat buf; - ret = fstat(Int_val(fd), &buf); - if (ret == -1) uerror("fstat", Nothing); - return stat_aux(1, &buf); -} - diff --git a/otherlibs/unix/strofaddr.c b/otherlibs/unix/strofaddr.c deleted file mode 100644 index f5a594d52c..0000000000 --- a/otherlibs/unix/strofaddr.c +++ /dev/null @@ -1,36 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" - -#ifdef HAS_SOCKETS - -#include "socketaddr.h" - -CAMLprim value unix_string_of_inet_addr(value a) -{ - struct in_addr address; - address.s_addr = GET_INET_ADDR(a); - return copy_string(inet_ntoa(address)); -} - -#else - -CAMLprim value unix_string_of_inet_addr(value a) -{ invalid_argument("string_of_inet_addr not implemented"); } - -#endif diff --git a/otherlibs/unix/symlink.c b/otherlibs/unix/symlink.c deleted file mode 100644 index 8c011152b3..0000000000 --- a/otherlibs/unix/symlink.c +++ /dev/null @@ -1,33 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -#ifdef HAS_SYMLINK - -CAMLprim value unix_symlink(value path1, value path2) -{ - if (symlink(String_val(path1), String_val(path2)) == -1) - uerror("symlink", path2); - return Val_unit; -} - -#else - -CAMLprim value unix_symlink(value path1, value path2) -{ invalid_argument("symlink not implemented"); } - -#endif diff --git a/otherlibs/unix/termios.c b/otherlibs/unix/termios.c deleted file mode 100644 index e3c759444d..0000000000 --- a/otherlibs/unix/termios.c +++ /dev/null @@ -1,316 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" - -#ifdef HAS_TERMIOS - -#include <termios.h> -#include <errno.h> - -static struct termios terminal_status; - -enum { Bool, Enum, Speed, Char, End }; - -enum { Input, Output }; - -#define iflags ((long)(&terminal_status.c_iflag)) -#define oflags ((long)(&terminal_status.c_oflag)) -#define cflags ((long)(&terminal_status.c_cflag)) -#define lflags ((long)(&terminal_status.c_lflag)) - -/* Number of fields in the terminal_io record field. Cf. unix.mli */ - -#define NFIELDS 38 - -/* Structure of the terminal_io record. Cf. unix.mli */ - -static long terminal_io_descr[] = { - /* Input modes */ - Bool, iflags, IGNBRK, - Bool, iflags, BRKINT, - Bool, iflags, IGNPAR, - Bool, iflags, PARMRK, - Bool, iflags, INPCK, - Bool, iflags, ISTRIP, - Bool, iflags, INLCR, - Bool, iflags, IGNCR, - Bool, iflags, ICRNL, - Bool, iflags, IXON, - Bool, iflags, IXOFF, - /* Output modes */ - Bool, oflags, OPOST, - /* Control modes */ - Speed, Output, - Speed, Input, - Enum, cflags, 5, 4, CSIZE, CS5, CS6, CS7, CS8, - Enum, cflags, 1, 2, CSTOPB, 0, CSTOPB, - Bool, cflags, CREAD, - Bool, cflags, PARENB, - Bool, cflags, PARODD, - Bool, cflags, HUPCL, - Bool, cflags, CLOCAL, - /* Local modes */ - Bool, lflags, ISIG, - Bool, lflags, ICANON, - Bool, lflags, NOFLSH, - Bool, lflags, ECHO, - Bool, lflags, ECHOE, - Bool, lflags, ECHOK, - Bool, lflags, ECHONL, - /* Control characters */ - Char, VINTR, - Char, VQUIT, - Char, VERASE, - Char, VKILL, - Char, VEOF, - Char, VEOL, - Char, VMIN, - Char, VTIME, - Char, VSTART, - Char, VSTOP, - End -}; - -#undef iflags -#undef oflags -#undef cflags -#undef lflags - -struct speedtable_entry ; - -static struct { - speed_t speed; - int baud; -} speedtable[] = { - {B50, 50}, - {B75, 75}, - {B110, 110}, - {B134, 134}, - {B150, 150}, - {B300, 300}, - {B600, 600}, - {B1200, 1200}, - {B1800, 1800}, - {B2400, 2400}, - {B4800, 4800}, - {B9600, 9600}, - {B19200, 19200}, - {B38400, 38400}, -#ifdef B57600 - {B57600, 57600}, -#endif -#ifdef B115200 - {B115200, 115200}, -#endif -#ifdef B230400 - {B230400, 230400}, -#endif - {B0, 0} -}; - -#define NSPEEDS (sizeof(speedtable) / sizeof(speedtable[0])) - -static void encode_terminal_status(value *dst) -{ - long * pc; - int i; - - for(pc = terminal_io_descr; *pc != End; dst++) { - switch(*pc++) { - case Bool: - { int * src = (int *) (*pc++); - int msk = *pc++; - *dst = Val_bool(*src & msk); - break; } - case Enum: - { int * src = (int *) (*pc++); - int ofs = *pc++; - int num = *pc++; - int msk = *pc++; - for (i = 0; i < num; i++) { - if ((*src & msk) == pc[i]) { - *dst = Val_int(i + ofs); - break; - } - } - pc += num; - break; } - case Speed: - { int which = *pc++; - speed_t speed = 0; - *dst = Val_int(9600); /* in case no speed in speedtable matches */ - switch (which) { - case Output: - speed = cfgetospeed(&terminal_status); break; - case Input: - speed = cfgetispeed(&terminal_status); break; - } - for (i = 0; i < NSPEEDS; i++) { - if (speed == speedtable[i].speed) { - *dst = Val_int(speedtable[i].baud); - break; - } - } - break; } - case Char: - { int which = *pc++; - *dst = Val_int(terminal_status.c_cc[which]); - break; } - } - } -} - -static void decode_terminal_status(value *src) -{ - long * pc; - int i; - - for (pc = terminal_io_descr; *pc != End; src++) { - switch(*pc++) { - case Bool: - { int * dst = (int *) (*pc++); - int msk = *pc++; - if (Bool_val(*src)) - *dst |= msk; - else - *dst &= ~msk; - break; } - case Enum: - { int * dst = (int *) (*pc++); - int ofs = *pc++; - int num = *pc++; - int msk = *pc++; - i = Int_val(*src) - ofs; - if (i >= 0 && i < num) { - *dst = (*dst & ~msk) | pc[i]; - } else { - unix_error(EINVAL, "tcsetattr", Nothing); - } - pc += num; - break; } - case Speed: - { int which = *pc++; - int baud = Int_val(*src); - int res = 0; - for (i = 0; i < NSPEEDS; i++) { - if (baud == speedtable[i].baud) { - switch (which) { - case Output: - res = cfsetospeed(&terminal_status, speedtable[i].speed); break; - case Input: - res = cfsetispeed(&terminal_status, speedtable[i].speed); break; - } - if (res == -1) uerror("tcsetattr", Nothing); - goto ok; - } - } - unix_error(EINVAL, "tcsetattr", Nothing); - ok: - break; } - case Char: - { int which = *pc++; - terminal_status.c_cc[which] = Int_val(*src); - break; } - } - } -} - -CAMLprim value unix_tcgetattr(value fd) -{ - value res; - - if (tcgetattr(Int_val(fd), &terminal_status) == -1) - uerror("tcgetattr", Nothing); - res = alloc_tuple(NFIELDS); - encode_terminal_status(&Field(res, 0)); - return res; -} - -static int when_flag_table[] = { - TCSANOW, TCSADRAIN, TCSAFLUSH -}; - -CAMLprim value unix_tcsetattr(value fd, value when, value arg) -{ - if (tcgetattr(Int_val(fd), &terminal_status) == -1) - uerror("tcsetattr", Nothing); - decode_terminal_status(&Field(arg, 0)); - if (tcsetattr(Int_val(fd), - when_flag_table[Int_val(when)], - &terminal_status) == -1) - uerror("tcsetattr", Nothing); - return Val_unit; -} - -CAMLprim value unix_tcsendbreak(value fd, value delay) -{ - if (tcsendbreak(Int_val(fd), Int_val(delay)) == -1) - uerror("tcsendbreak", Nothing); - return Val_unit; -} - -CAMLprim value unix_tcdrain(value fd) -{ - if (tcdrain(Int_val(fd)) == -1) uerror("tcdrain", Nothing); - return Val_unit; -} - -static int queue_flag_table[] = { - TCIFLUSH, TCOFLUSH, TCIOFLUSH -}; - -CAMLprim value unix_tcflush(value fd, value queue) -{ - if (tcflush(Int_val(fd), queue_flag_table[Int_val(queue)]) == -1) - uerror("tcflush", Nothing); - return Val_unit; -} - -static int action_flag_table[] = { - TCOOFF, TCOON, TCIOFF, TCION -}; - -CAMLprim value unix_tcflow(value fd, value action) -{ - if (tcflow(Int_val(fd), action_flag_table[Int_val(action)]) == -1) - uerror("tcflow", Nothing); - return Val_unit; -} - -#else - -CAMLprim value unix_tcgetattr(value fd) -{ invalid_argument("tcgetattr not implemented"); } - -CAMLprim value unix_tcsetattr(value fd, value when, value arg) -{ invalid_argument("tcsetattr not implemented"); } - -CAMLprim value unix_tcsendbreak(value fd, value delay) -{ invalid_argument("tcsendbreak not implemented"); } - -CAMLprim value unix_tcdrain(value fd) -{ invalid_argument("tcdrain not implemented"); } - -CAMLprim value unix_tcflush(value fd, value queue) -{ invalid_argument("tcflush not implemented"); } - -CAMLprim value unix_tcflow(value fd, value action) -{ invalid_argument("tcflow not implemented"); } - -#endif - diff --git a/otherlibs/unix/time.c b/otherlibs/unix/time.c deleted file mode 100644 index c63c2eb804..0000000000 --- a/otherlibs/unix/time.c +++ /dev/null @@ -1,24 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <time.h> -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" - -CAMLprim value unix_time(void) -{ - return copy_double((double) time((time_t *) NULL)); -} diff --git a/otherlibs/unix/times.c b/otherlibs/unix/times.c deleted file mode 100644 index c108cbfde3..0000000000 --- a/otherlibs/unix/times.c +++ /dev/null @@ -1,44 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include "unixsupport.h" -#include <time.h> -#include <sys/types.h> -#include <sys/times.h> - -#ifndef CLK_TCK -#ifdef HZ -#define CLK_TCK HZ -#else -#define CLK_TCK 60 -#endif -#endif - -CAMLprim value unix_times(void) -{ - value res; - struct tms buffer; - - times(&buffer); - res = alloc_small(4 * Double_wosize, Double_array_tag); - Store_double_field(res, 0, (double) buffer.tms_utime / CLK_TCK); - Store_double_field(res, 1, (double) buffer.tms_stime / CLK_TCK); - Store_double_field(res, 2, (double) buffer.tms_cutime / CLK_TCK); - Store_double_field(res, 3, (double) buffer.tms_cstime / CLK_TCK); - return res; -} diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c deleted file mode 100644 index 009d3c0e55..0000000000 --- a/otherlibs/unix/truncate.c +++ /dev/null @@ -1,45 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <sys/types.h> -#include <mlvalues.h> -#include <io.h> -#include "unixsupport.h" -#ifdef HAS_UNISTD -#include <unistd.h> -#endif - -#ifdef HAS_TRUNCATE - -CAMLprim value unix_truncate(value path, value len) -{ - if (truncate(String_val(path), Long_val(len)) == -1) - uerror("truncate", path); - return Val_unit; -} - -CAMLprim value unix_truncate_64(value path, value len) -{ - if (truncate(String_val(path), File_offset_val(len)) == -1) - uerror("truncate", path); - return Val_unit; -} - -#else - -CAMLprim value unix_truncate(value path, value len) -{ invalid_argument("truncate not implemented"); } - -#endif diff --git a/otherlibs/unix/umask.c b/otherlibs/unix/umask.c deleted file mode 100644 index 6f5d14fd0c..0000000000 --- a/otherlibs/unix/umask.c +++ /dev/null @@ -1,24 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <sys/types.h> -#include <sys/stat.h> -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_umask(value perm) -{ - return Val_int(umask(Int_val(perm))); -} diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml deleted file mode 100644 index daa24e61ec..0000000000 --- a/otherlibs/unix/unix.ml +++ /dev/null @@ -1,776 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type error = - E2BIG - | EACCES - | EAGAIN - | EBADF - | EBUSY - | ECHILD - | EDEADLK - | EDOM - | EEXIST - | EFAULT - | EFBIG - | EINTR - | EINVAL - | EIO - | EISDIR - | EMFILE - | EMLINK - | ENAMETOOLONG - | ENFILE - | ENODEV - | ENOENT - | ENOEXEC - | ENOLCK - | ENOMEM - | ENOSPC - | ENOSYS - | ENOTDIR - | ENOTEMPTY - | ENOTTY - | ENXIO - | EPERM - | EPIPE - | ERANGE - | EROFS - | ESPIPE - | ESRCH - | EXDEV - | EWOULDBLOCK - | EINPROGRESS - | EALREADY - | ENOTSOCK - | EDESTADDRREQ - | EMSGSIZE - | EPROTOTYPE - | ENOPROTOOPT - | EPROTONOSUPPORT - | ESOCKTNOSUPPORT - | EOPNOTSUPP - | EPFNOSUPPORT - | EAFNOSUPPORT - | EADDRINUSE - | EADDRNOTAVAIL - | ENETDOWN - | ENETUNREACH - | ENETRESET - | ECONNABORTED - | ECONNRESET - | ENOBUFS - | EISCONN - | ENOTCONN - | ESHUTDOWN - | ETOOMANYREFS - | ETIMEDOUT - | ECONNREFUSED - | EHOSTDOWN - | EHOSTUNREACH - | ELOOP - | EOVERFLOW - | EUNKNOWNERR of int - -exception Unix_error of error * string * string - -let _ = Callback.register_exception "Unix.Unix_error" - (Unix_error(E2BIG, "", "")) - -external error_message : error -> string = "unix_error_message" - -let handle_unix_error f arg = - try - f arg - with Unix_error(err, fun_name, arg) -> - prerr_string Sys.argv.(0); - prerr_string ": \""; - prerr_string fun_name; - prerr_string "\" failed"; - if String.length arg > 0 then begin - prerr_string " on \""; - prerr_string arg; - prerr_string "\"" - end; - prerr_string ": "; - prerr_endline (error_message err); - exit 2 - -external environment : unit -> string array = "unix_environment" -external getenv: string -> string = "sys_getenv" -external putenv: string -> string -> unit = "unix_putenv" - -type process_status = - WEXITED of int - | WSIGNALED of int - | WSTOPPED of int - -type wait_flag = - WNOHANG - | WUNTRACED - -external execv : string -> string array -> 'a = "unix_execv" -external execve : string -> string array -> string array -> 'a = "unix_execve" -external execvp : string -> string array -> 'a = "unix_execvp" -external execvpe : string -> string array -> string array -> 'a = "unix_execvpe" -external fork : unit -> int = "unix_fork" -external wait : unit -> int * process_status = "unix_wait" -external waitpid : wait_flag list -> int -> int * process_status = "unix_waitpid" -external getpid : unit -> int = "unix_getpid" -external getppid : unit -> int = "unix_getppid" -external nice : int -> int = "unix_nice" - -type file_descr = int - -let stdin = 0 -let stdout = 1 -let stderr = 2 - -type open_flag = - O_RDONLY - | O_WRONLY - | O_RDWR - | O_NONBLOCK - | O_APPEND - | O_CREAT - | O_TRUNC - | O_EXCL - | O_NOCTTY - | O_DSYNC - | O_SYNC - | O_RSYNC - -type file_perm = int - - -external openfile : string -> open_flag list -> file_perm -> file_descr - = "unix_open" - -external close : file_descr -> unit = "unix_close" -external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" -external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write" - -let read fd buf ofs len = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.read" - else unsafe_read fd buf ofs len -let write fd buf ofs len = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.write" - else unsafe_write fd buf ofs len - -external in_channel_of_descr : file_descr -> in_channel - = "caml_open_descriptor_in" -external out_channel_of_descr : file_descr -> out_channel - = "caml_open_descriptor_out" -external descr_of_in_channel : in_channel -> file_descr = "channel_descriptor" -external descr_of_out_channel : out_channel -> file_descr - = "channel_descriptor" - -type seek_command = - SEEK_SET - | SEEK_CUR - | SEEK_END - -external lseek : file_descr -> int -> seek_command -> int = "unix_lseek" -external truncate : string -> int -> unit = "unix_truncate" -external ftruncate : file_descr -> int -> unit = "unix_ftruncate" - -type file_kind = - S_REG - | S_DIR - | S_CHR - | S_BLK - | S_LNK - | S_FIFO - | S_SOCK - -type stats = - { st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int; - st_atime : float; - st_mtime : float; - st_ctime : float } - -external stat : string -> stats = "unix_stat" -external lstat : string -> stats = "unix_lstat" -external fstat : file_descr -> stats = "unix_fstat" -external unlink : string -> unit = "unix_unlink" -external rename : string -> string -> unit = "unix_rename" -external link : string -> string -> unit = "unix_link" - -module LargeFile = - struct - external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64" - external truncate : string -> int64 -> unit = "unix_truncate_64" - external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64" - type stats = - { st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int64; - st_atime : float; - st_mtime : float; - st_ctime : float; - } - external stat : string -> stats = "unix_stat_64" - external lstat : string -> stats = "unix_lstat_64" - external fstat : file_descr -> stats = "unix_fstat_64" - end - -type access_permission = - R_OK - | W_OK - | X_OK - | F_OK - -external chmod : string -> file_perm -> unit = "unix_chmod" -external fchmod : file_descr -> file_perm -> unit = "unix_fchmod" -external chown : string -> int -> int -> unit = "unix_chown" -external fchown : file_descr -> int -> int -> unit = "unix_fchown" -external umask : int -> int = "unix_umask" -external access : string -> access_permission list -> unit = "unix_access" - -external dup : file_descr -> file_descr = "unix_dup" -external dup2 : file_descr -> file_descr -> unit = "unix_dup2" -external set_nonblock : file_descr -> unit = "unix_set_nonblock" -external clear_nonblock : file_descr -> unit = "unix_clear_nonblock" -external set_close_on_exec : file_descr -> unit = "unix_set_close_on_exec" -external clear_close_on_exec : file_descr -> unit = "unix_clear_close_on_exec" - -external mkdir : string -> file_perm -> unit = "unix_mkdir" -external rmdir : string -> unit = "unix_rmdir" -external chdir : string -> unit = "unix_chdir" -external getcwd : unit -> string = "unix_getcwd" -external chroot : string -> unit = "unix_chroot" - -type dir_handle - -external opendir : string -> dir_handle = "unix_opendir" -external readdir : dir_handle -> string = "unix_readdir" -external rewinddir : dir_handle -> unit = "unix_rewinddir" -external closedir : dir_handle -> unit = "unix_closedir" - -external pipe : unit -> file_descr * file_descr = "unix_pipe" -external symlink : string -> string -> unit = "unix_symlink" -external readlink : string -> string = "unix_readlink" -external mkfifo : string -> file_perm -> unit = "unix_mkfifo" -external select : - file_descr list -> file_descr list -> file_descr list -> float -> - file_descr list * file_descr list * file_descr list = "unix_select" - -type lock_command = - F_ULOCK - | F_LOCK - | F_TLOCK - | F_TEST - | F_RLOCK - | F_TRLOCK - -external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf" -external kill : int -> int -> unit = "unix_kill" -type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK -external sigprocmask: sigprocmask_command -> int list -> int list - = "unix_sigprocmask" -external sigpending: unit -> int list = "unix_sigpending" -external sigsuspend: int list -> unit = "unix_sigsuspend" - -let pause() = - let sigs = sigprocmask SIG_BLOCK [] in sigsuspend sigs - -type process_times = - { tms_utime : float; - tms_stime : float; - tms_cutime : float; - tms_cstime : float } - -type tm = - { tm_sec : int; - tm_min : int; - tm_hour : int; - tm_mday : int; - tm_mon : int; - tm_year : int; - tm_wday : int; - tm_yday : int; - tm_isdst : bool } - -external time : unit -> float = "unix_time" -external gettimeofday : unit -> float = "unix_gettimeofday" -external gmtime : float -> tm = "unix_gmtime" -external localtime : float -> tm = "unix_localtime" -external mktime : tm -> float * tm = "unix_mktime" -external alarm : int -> int = "unix_alarm" -external sleep : int -> unit = "unix_sleep" -external times : unit -> process_times = "unix_times" -external utimes : string -> float -> float -> unit = "unix_utimes" - -type interval_timer = - ITIMER_REAL - | ITIMER_VIRTUAL - | ITIMER_PROF - -type interval_timer_status = - { it_interval: float; (* Period *) - it_value: float } (* Current value of the timer *) - -external getitimer: interval_timer -> interval_timer_status = "unix_getitimer" -external setitimer: - interval_timer -> interval_timer_status -> interval_timer_status - = "unix_setitimer" - -external getuid : unit -> int = "unix_getuid" -external geteuid : unit -> int = "unix_geteuid" -external setuid : int -> unit = "unix_setuid" -external getgid : unit -> int = "unix_getgid" -external getegid : unit -> int = "unix_getegid" -external setgid : int -> unit = "unix_setgid" -external getgroups : unit -> int array = "unix_getgroups" - -type passwd_entry = - { pw_name : string; - pw_passwd : string; - pw_uid : int; - pw_gid : int; - pw_gecos : string; - pw_dir : string; - pw_shell : string } - -type group_entry = - { gr_name : string; - gr_passwd : string; - gr_gid : int; - gr_mem : string array } - - -external getlogin : unit -> string = "unix_getlogin" -external getpwnam : string -> passwd_entry = "unix_getpwnam" -external getgrnam : string -> group_entry = "unix_getgrnam" -external getpwuid : int -> passwd_entry = "unix_getpwuid" -external getgrgid : int -> group_entry = "unix_getgrgid" - -type inet_addr - -external inet_addr_of_string : string -> inet_addr - = "unix_inet_addr_of_string" -external string_of_inet_addr : inet_addr -> string - = "unix_string_of_inet_addr" - -let inet_addr_any = inet_addr_of_string "0.0.0.0" - -type socket_domain = - PF_UNIX - | PF_INET - -type socket_type = - SOCK_STREAM - | SOCK_DGRAM - | SOCK_RAW - | SOCK_SEQPACKET - -type sockaddr = - ADDR_UNIX of string - | ADDR_INET of inet_addr * int - -type shutdown_command = - SHUTDOWN_RECEIVE - | SHUTDOWN_SEND - | SHUTDOWN_ALL - -type msg_flag = - MSG_OOB - | MSG_DONTROUTE - | MSG_PEEK - -type socket_bool_option = - SO_DEBUG - | SO_BROADCAST - | SO_REUSEADDR - | SO_KEEPALIVE - | SO_DONTROUTE - | SO_OOBINLINE - | SO_ACCEPTCONN - -type socket_int_option = - SO_SNDBUF - | SO_RCVBUF - | SO_ERROR - | SO_TYPE - | SO_RCVLOWAT - | SO_SNDLOWAT - -type socket_optint_option = SO_LINGER - -type socket_float_option = - SO_RCVTIMEO - | SO_SNDTIMEO - -external socket : socket_domain -> socket_type -> int -> file_descr - = "unix_socket" -external socketpair : - socket_domain -> socket_type -> int -> file_descr * file_descr - = "unix_socketpair" -external accept : file_descr -> file_descr * sockaddr = "unix_accept" -external bind : file_descr -> sockaddr -> unit = "unix_bind" -external connect : file_descr -> sockaddr -> unit = "unix_connect" -external listen : file_descr -> int -> unit = "unix_listen" -external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" -external getsockname : file_descr -> sockaddr = "unix_getsockname" -external getpeername : file_descr -> sockaddr = "unix_getpeername" - -external unsafe_recv : - file_descr -> string -> int -> int -> msg_flag list -> int - = "unix_recv" -external unsafe_recvfrom : - file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr - = "unix_recvfrom" -external unsafe_send : - file_descr -> string -> int -> int -> msg_flag list -> int - = "unix_send" -external unsafe_sendto : - file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int - = "unix_sendto" "unix_sendto_native" - -let recv fd buf ofs len flags = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.recv" - else unsafe_recv fd buf ofs len flags -let recvfrom fd buf ofs len flags = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.recvfrom" - else unsafe_recvfrom fd buf ofs len flags -let send fd buf ofs len flags = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.send" - else unsafe_send fd buf ofs len flags -let sendto fd buf ofs len flags addr = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.sendto" - else unsafe_sendto fd buf ofs len flags addr - -external getsockopt : file_descr -> socket_bool_option -> bool - = "unix_getsockopt_bool" -external setsockopt : file_descr -> socket_bool_option -> bool -> unit - = "unix_setsockopt_bool" -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" -external getsockopt_optint : file_descr -> socket_optint_option -> int option - = "unix_getsockopt_optint" -external setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit - = "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" - -type host_entry = - { h_name : string; - h_aliases : string array; - h_addrtype : socket_domain; - h_addr_list : inet_addr array } - -type protocol_entry = - { p_name : string; - p_aliases : string array; - p_proto : int } - -type service_entry = - { s_name : string; - s_aliases : string array; - s_port : int; - s_proto : string } - -external gethostname : unit -> string = "unix_gethostname" -external gethostbyname : string -> host_entry = "unix_gethostbyname" -external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr" -external getprotobyname : string -> protocol_entry - = "unix_getprotobyname" -external getprotobynumber : int -> protocol_entry - = "unix_getprotobynumber" -external getservbyname : string -> string -> service_entry - = "unix_getservbyname" -external getservbyport : int -> string -> service_entry - = "unix_getservbyport" -type terminal_io = { - mutable c_ignbrk: bool; - mutable c_brkint: bool; - mutable c_ignpar: bool; - mutable c_parmrk: bool; - mutable c_inpck: bool; - mutable c_istrip: bool; - mutable c_inlcr: bool; - mutable c_igncr: bool; - mutable c_icrnl: bool; - mutable c_ixon: bool; - mutable c_ixoff: bool; - mutable c_opost: bool; - mutable c_obaud: int; - mutable c_ibaud: int; - mutable c_csize: int; - mutable c_cstopb: int; - mutable c_cread: bool; - mutable c_parenb: bool; - mutable c_parodd: bool; - mutable c_hupcl: bool; - mutable c_clocal: bool; - mutable c_isig: bool; - mutable c_icanon: bool; - mutable c_noflsh: bool; - mutable c_echo: bool; - mutable c_echoe: bool; - mutable c_echok: bool; - mutable c_echonl: bool; - mutable c_vintr: char; - mutable c_vquit: char; - mutable c_verase: char; - mutable c_vkill: char; - mutable c_veof: char; - mutable c_veol: char; - mutable c_vmin: int; - mutable c_vtime: int; - mutable c_vstart: char; - mutable c_vstop: char - } - -external tcgetattr: file_descr -> terminal_io = "unix_tcgetattr" - -type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH - -external tcsetattr: file_descr -> setattr_when -> terminal_io -> unit - = "unix_tcsetattr" -external tcsendbreak: file_descr -> int -> unit = "unix_tcsendbreak" -external tcdrain: file_descr -> unit = "unix_tcdrain" - -type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH - -external tcflush: file_descr -> flush_queue -> unit = "unix_tcflush" - -type flow_action = TCOOFF | TCOON | TCIOFF | TCION - -external tcflow: file_descr -> flow_action -> unit = "unix_tcflow" - -external setsid : unit -> int = "unix_setsid" - -(* High-level process management (system, popen) *) - -let system cmd = - match fork() with - 0 -> begin try - execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] - with _ -> - exit 127 - end - | id -> snd(waitpid [] id) - -let rec safe_dup fd = - let new_fd = dup fd in - if new_fd >= 3 then - new_fd - else begin - let res = safe_dup fd in - close new_fd; - res - end - -let safe_close fd = - try close fd with Unix_error(_,_,_) -> () - -let perform_redirections new_stdin new_stdout new_stderr = - let newnewstdin = safe_dup new_stdin in - let newnewstdout = safe_dup new_stdout in - let newnewstderr = safe_dup new_stderr in - safe_close new_stdin; - safe_close new_stdout; - safe_close new_stderr; - dup2 newnewstdin stdin; close newnewstdin; - dup2 newnewstdout stdout; close newnewstdout; - dup2 newnewstderr stderr; close newnewstderr - -let create_process cmd args new_stdin new_stdout new_stderr = - match fork() with - 0 -> - begin try - perform_redirections new_stdin new_stdout new_stderr; - execvp cmd args - with _ -> - exit 127 - end - | id -> id - -let create_process_env cmd args env new_stdin new_stdout new_stderr = - match fork() with - 0 -> - begin try - perform_redirections new_stdin new_stdout new_stderr; - execvpe cmd args env - with _ -> - exit 127 - end - | id -> id - -type popen_process = - Process of in_channel * out_channel - | Process_in of in_channel - | Process_out of out_channel - | Process_full of in_channel * out_channel * in_channel - -let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t) - -let open_proc cmd proc input output toclose = - match fork() with - 0 -> if input <> stdin then begin dup2 input stdin; close input end; - if output <> stdout then begin dup2 output stdout; close output end; - List.iter close toclose; - execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; - exit 127 - | id -> Hashtbl.add popen_processes proc id - -let open_process_in cmd = - let (in_read, in_write) = pipe() in - let inchan = in_channel_of_descr in_read in - open_proc cmd (Process_in inchan) stdin in_write [in_read]; - close in_write; - inchan - -let open_process_out cmd = - let (out_read, out_write) = pipe() in - let outchan = out_channel_of_descr out_write in - open_proc cmd (Process_out outchan) out_read stdout [out_write]; - close out_read; - outchan - -let open_process cmd = - let (in_read, in_write) = pipe() in - let (out_read, out_write) = pipe() in - let inchan = in_channel_of_descr in_read in - let outchan = out_channel_of_descr out_write in - open_proc cmd (Process(inchan, outchan)) out_read in_write - [in_read; out_write]; - close out_read; - close in_write; - (inchan, outchan) - -let open_proc_full cmd env proc input output error toclose = - match fork() with - 0 -> dup2 input stdin; close input; - dup2 output stdout; close output; - dup2 error stderr; close error; - List.iter close toclose; - execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env; - exit 127 - | id -> Hashtbl.add popen_processes proc id - -let open_process_full cmd env = - let (in_read, in_write) = pipe() in - let (out_read, out_write) = pipe() in - let (err_read, err_write) = pipe() in - let inchan = in_channel_of_descr in_read in - let outchan = out_channel_of_descr out_write in - let errchan = in_channel_of_descr err_read in - open_proc_full cmd env (Process_full(inchan, outchan, errchan)) - out_read in_write err_write [in_read; out_write; err_read]; - close out_read; - close in_write; - close err_write; - (inchan, outchan, errchan) - -let find_proc_id fun_name proc = - try - let pid = Hashtbl.find popen_processes proc in - Hashtbl.remove popen_processes proc; - pid - with Not_found -> - raise(Unix_error(EBADF, fun_name, "")) - -let close_process_in inchan = - let pid = find_proc_id "close_process_in" (Process_in inchan) in - close_in inchan; - snd(waitpid [] pid) - -let close_process_out outchan = - let pid = find_proc_id "close_process_out" (Process_out outchan) in - close_out outchan; - snd(waitpid [] pid) - -let close_process (inchan, outchan) = - let pid = find_proc_id "close_process" (Process(inchan, outchan)) in - close_in inchan; - begin try close_out outchan with Sys_error _ -> () end; - snd(waitpid [] pid) - -let close_process_full (inchan, outchan, errchan) = - let pid = - find_proc_id "close_process_full" - (Process_full(inchan, outchan, errchan)) in - close_in inchan; - begin try close_out outchan with Sys_error _ -> () end; - close_in errchan; - snd(waitpid [] pid) - -(* High-level network functions *) - -let open_connection sockaddr = - let domain = - match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in - let sock = - socket domain SOCK_STREAM 0 in - try - connect sock sockaddr; - (in_channel_of_descr sock, out_channel_of_descr sock) - with exn -> - close sock; raise exn - -let shutdown_connection inchan = - shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND - -let establish_server server_fun sockaddr = - let domain = - match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in - let sock = - socket domain SOCK_STREAM 0 in - setsockopt sock SO_REUSEADDR true; - bind sock sockaddr; - listen sock 5; - while true do - let (s, caller) = accept sock in - (* The "double fork" trick, the process which calls server_fun will not - leave a zombie process *) - match fork() with - 0 -> if fork() <> 0 then exit 0; (* The son exits, the grandson works *) - let inchan = in_channel_of_descr s in - let outchan = out_channel_of_descr s in - server_fun inchan outchan; - close_out outchan; - (* The file descriptor was already closed by close_out. - close_in inchan; - *) - exit 0 - | id -> close s; ignore(waitpid [] id) (* Reclaim the son *) - done - diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli deleted file mode 100644 index 4328fed5a9..0000000000 --- a/otherlibs/unix/unix.mli +++ /dev/null @@ -1,1206 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Interface to the Unix system *) - - -(** {6 Error report} *) - - -type error = - 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 *) - | 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 *) - | EOVERFLOW (** File size or position not representable *) - - | EUNKNOWNERR of int (** Unknown error *) -(** The type of error codes. - Errors defined in the POSIX standard - and additional errors from UNIX98 and BSD. - All other errors are mapped to EUNKNOWNERR. -*) - - -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. *) - - -(** {6 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. *) - - -(** {6 Process handling} *) - - -type process_status = - WEXITED of int - (** The process terminated normally by [exit]; - the argument is the return code. *) - | WSIGNALED of int - (** The process was killed by a signal; - the argument is the signal number. *) - | WSTOPPED of int - (** The process was stopped by a signal; the argument is the - signal number. *) -(** The termination status of a process. *) - - -type wait_flag = - WNOHANG (** do not block if no child has - died yet, but immediately return with a pid equal to 0.*) - | WUNTRACED (** report also the children that receive stop signals. *) -(** Flags for {!Unix.waitpid}. *) - -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 : string -> string array -> string array -> unit -(** Same as {!Unix.execv}, except that the third argument provides the - environment to the program executed. *) - -val execvp : string -> string array -> unit -(** Same as {!Unix.execv} respectively, except that - the program is searched in the path. *) - -val execvpe : string -> string array -> string array -> unit -(** Same as {!Unix.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 : wait_flag list -> int -> int * process_status -(** Same as {!Unix.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. *) - - -(** {6 Basic file input/output} *) - - -type file_descr -(** The abstract type of file descriptors. *) - -val stdin : file_descr -(** File descriptor for standard input.*) - -val stdout : file_descr -(** File descriptor for standard output.*) - -val stderr : file_descr -(** File descriptor for standard standard error. *) - -type 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 *) - | O_NOCTTY (** Don't make this dev a controlling tty *) - | O_DSYNC (** Writes complete as `Synchronised I/O data integrity completion' *) - | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *) - | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *) -(** The flags to {!Unix.openfile}. *) - - -type file_perm = int -(** The type of file access rights. *) - -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 -> 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 -> 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 - written. *) - - - -(** {6 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. *) - - -(** {6 Seeking and truncating} *) - - -type seek_command = - SEEK_SET (** indicates positions relative to the beginning of the file *) - | SEEK_CUR (** indicates positions relative to the current position *) - | SEEK_END (** indicates positions relative to the end of the file *) -(** Positioning modes for {!Unix.lseek}. *) - - -val lseek : file_descr -> int -> seek_command -> int -(** Set the current position for a file descriptor *) - -val truncate : string -> int -> unit -(** Truncates the named file to the given size. *) - -val ftruncate : file_descr -> int -> unit -(** Truncates the file corresponding to the given descriptor - to the given size. *) - - -(** {6 File statistics} *) - - -type 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 = - { 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 {!Unix.stat} calls. *) - -val stat : string -> stats -(** Return the informations for the named file. *) - -val lstat : string -> stats -(** Same as {!Unix.stat}, but in case the file is a symbolic link, - return the informations for the link itself. *) - -val fstat : file_descr -> stats -(** Return the informations for the file associated with the given - descriptor. *) - - -(** {6 File operations on large files} *) - -module LargeFile : - sig - val lseek : file_descr -> int64 -> seek_command -> int64 - val truncate : string -> int64 -> unit - val ftruncate : file_descr -> int64 -> unit - type 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 : int64; (** Size in bytes *) - st_atime : float; (** Last access time *) - st_mtime : float; (** Last modification time *) - st_ctime : float; (** Last status change time *) - } - val stat : string -> stats - val lstat : string -> stats - val fstat : file_descr -> stats - end -(** File operations on large files. - This sub-module provides 64-bit variants of the functions - {!Unix.lseek} (for positioning a file descriptor), - {!Unix.truncate} and {!Unix.ftruncate} (for changing the size of a file), - and {!Unix.stat}, {!Unix.lstat} and {!Unix.fstat} (for obtaining - information on files). These alternate functions represent - positions and sizes by 64-bit integers (type [int64]) instead of - regular integers (type [int]), thus allowing operating on files - whose sizes are greater than [max_int]. *) - - -(** {6 Operations on file names} *) - - -val unlink : string -> unit -(** Removes the named file *) - -val rename : string -> string -> unit -(** [rename old new] changes the name of a file from [old] to [new]. *) - -val link : string -> string -> unit -(** [link source dest] creates a hard link named [dest] to the file - named [source]. *) - - -(** {6 File permissions and ownership} *) - - -type access_permission = - R_OK (** Read permission *) - | W_OK (** Write permission *) - | X_OK (** Execution permission *) - | F_OK (** File exists *) -(** Flags for the {!Unix.access} call. *) - - -val chmod : string -> file_perm -> unit -(** Change the permissions of the named file. *) - -val fchmod : file_descr -> file_perm -> unit -(** Change the permissions of an opened file. *) - -val chown : string -> int -> int -> unit -(** Change the owner uid and owner gid of the named file. *) - -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's file mode creation mask, and return the previous - mask. *) - -val access : string -> access_permission list -> unit -(** Check that the process has the given permissions over the named - file. Raise [Unix_error] otherwise. *) - - -(** {6 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 : file_descr -> file_descr -> unit -(** [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already - opened. *) - -val set_nonblock : file_descr -> unit -(** Set 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 clear_nonblock : file_descr -> unit -(** Clear the ``non-blocking'' flag on the given descriptor. - See {!Unix.set_nonblock}.*) - -val set_close_on_exec : file_descr -> unit -(** Set 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. *) - -val clear_close_on_exec : file_descr -> unit -(** Clear the ``close-on-exec'' flag on the given descriptor. - See {!Unix.set_close_on_exec}.*) - - -(** {6 Directories} *) - - -val mkdir : string -> 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 -(** 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. *) - - - -(** {6 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 -> file_perm -> unit -(** Create a named pipe with the given permissions. *) - - -(** {6 High-level process and redirection management} *) - - -val create_process : - 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 - 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. *) - -val create_process_env : - 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 {!Unix.create_process}, except that the extra argument - [env] specifies the environment passed to the program. *) - - -val open_process_in : string -> in_channel -(** High-level pipe and process management. This function - runs the given command in parallel with the program. - The standard output of the command is redirected to a pipe, - which can be read via the returned input channel. - The command is interpreted by the shell [/bin/sh] (cf. [system]). *) - -val open_process_out : string -> out_channel -(** Same as {!Unix.open_process_in}, but redirect the standard input of - the command to a pipe. Data written to the returned output channel - is sent to the standard input of the command. - Warning: writes on output channels are buffered, hence be careful - to call {!Pervasives.flush} at the right times to ensure - correct synchronization. *) - -val open_process : string -> in_channel * out_channel -(** Same as {!Unix.open_process_out}, but redirects both the standard input - and standard output of the command to pipes connected to the two - returned channels. The input channel is connected to the output - of the command, and the output channel to the input of the command. *) - -val open_process_full : - string -> string array -> in_channel * out_channel * in_channel -(** Similar to {!Unix.open_process}, but the second argument specifies - the environment passed to the command. The result is a triple - of channels connected respectively to the standard output, standard input, - and standard error of the command. *) - -val close_process_in : in_channel -> process_status -(** Close channels opened by {!Unix.open_process_in}, - wait for the associated command to terminate, - and return its termination status. *) - -val close_process_out : out_channel -> process_status -(** Close channels opened by {!Unix.open_process_out}, - wait for the associated command to terminate, - and return its termination status. *) - -val close_process : in_channel * out_channel -> process_status -(** Close channels opened by {!Unix.open_process}, - wait for the associated command to terminate, - and return its termination status. *) - -val close_process_full : - in_channel * out_channel * in_channel -> process_status -(** Close channels opened by {!Unix.open_process_full}, - wait for the associated command to terminate, - and return its termination status. *) - - -(** {6 Symbolic links} *) - - -val symlink : string -> 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. *) - - -(** {6 Polling} *) - - -val select : - 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 - 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). *) - -(** {6 Locking} *) - - -type 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 {!Unix.lockf}. *) - -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 - [fd] (as set by {!Unix.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. *) - - -(** {6 Signals} - Note: installation of signal handlers is performed via - the functions {!Sys.signal} and {!Sys.set_signal}. -*) - -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 : 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. *) - - -(** {6 Time functions} *) - - -type 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 = - { 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 {!Unix.time}, but with resolution better than 1 second. *) - -val gmtime : float -> tm -(** Convert a time in seconds, as returned by {!Unix.time}, into a date and - a time. Assumes UTC (Coordinated Universal Time), also known as GMT. *) - -val localtime : float -> tm -(** Convert a time in seconds, as returned by {!Unix.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 {!Unix.time}. The [tm_isdst], - [tm_wday] and [tm_yday] fields of [tm] are ignored. 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, - and the other fields normalized (so that, e.g., 40 October is - changed into 9 November). 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 -> 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. *) - -type interval_timer = - 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. *) -(** The three kinds of interval timers. *) - -type 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. *) - - -(** {6 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 = - { 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 = - { 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]. *) - - -(** {6 Internet addresses} *) - - -type inet_addr -(** The abstract type of Internet addresses. *) - -val inet_addr_of_string : string -> inet_addr -(** 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 string_of_inet_addr : inet_addr -> string -(** See {!Unix.inet_addr_of_string}. *) - -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. *) - - -(** {6 Sockets} *) - - -type socket_domain = - PF_UNIX (** Unix domain *) - | PF_INET (** Internet domain *) -(** The type of socket domains. *) - -type 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 = 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 : 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 : - 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 -> sockaddr -> unit -(** Bind a socket to an address. *) - -val connect : file_descr -> sockaddr -> unit -(** Connect a socket to an address. *) - -val listen : file_descr -> int -> unit -(** Set up a socket for receiving connection requests. The integer - argument is the maximal number of pending requests. *) - -type 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 -> 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 = - MSG_OOB - | MSG_DONTROUTE - | MSG_PEEK -(** The flags for {!Unix.recv}, {!Unix.recvfrom}, - {!Unix.send} and {!Unix.sendto}. *) - -val recv : file_descr -> string -> int -> int -> msg_flag list -> int -(** Receive data from a connected socket. *) - -val recvfrom : - file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr -(** Receive data from an unconnected socket. *) - -val send : file_descr -> string -> int -> int -> msg_flag list -> int -(** Send data over a connected socket. *) - -val sendto : - file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int -(** Send data over an unconnected socket. *) - - - -(** {6 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 {!Unix.getsockopt} - and modified with {!Unix.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 {!Unix.getsockopt_int} - and modified with {!Unix.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 {!Unix.getsockopt_optint} - and modified with {!Unix.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 {!Unix.getsockopt_float} - and modified with {!Unix.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" -(** Same as {!Unix.getsockopt} for an integer-valued socket option. *) - -external setsockopt_int : - file_descr -> socket_int_option -> int -> unit = "unix_setsockopt_int" -(** Same as {!Unix.setsockopt} for an integer-valued socket option. *) - -external getsockopt_optint : - file_descr -> socket_optint_option -> int option = "unix_getsockopt_optint" -(** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *) - -external setsockopt_optint : - file_descr -> socket_optint_option -> int option -> - unit = "unix_setsockopt_optint" -(** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *) - -external getsockopt_float : - file_descr -> socket_float_option -> float = "unix_getsockopt_float" -(** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *) - -external setsockopt_float : - file_descr -> socket_float_option -> float -> unit = "unix_setsockopt_float" -(** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *) - -(** {6 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 {!Pervasives.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 {!Unix.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) -> 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 {!Unix.establish_server} - never returns normally. *) - - -(** {6 Host and protocol databases} *) - - -type 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 = - { p_name : string; - p_aliases : string array; - p_proto : int - } -(** Structure of entries in the [protocols] database. *) - -type 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 -> string -> service_entry -(** Find an entry in [services] with the given name, or raise - [Not_found]. *) - -val getservbyport : int -> string -> service_entry -(** Find an entry in [services] with the given service number, - or raise [Not_found]. *) - - - -(** {6 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 = - { - (* 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 = - TCSANOW - | TCSADRAIN - | TCSAFLUSH - -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]), - 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 -> 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 = - TCIFLUSH - | TCOFLUSH - | TCIOFLUSH - -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, - [TCOFLUSH] flushes data written but not transmitted, and - [TCIOFLUSH] flushes both. *) - -type flow_action = - TCOOFF - | TCOON - | TCIOFF - | TCION - -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, - [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/otherlibs/unix/unixLabels.ml b/otherlibs/unix/unixLabels.ml deleted file mode 100644 index 683f15ec67..0000000000 --- a/otherlibs/unix/unixLabels.ml +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Module [UnixLabels]: labelled Unix module *) - -include Unix diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli deleted file mode 100644 index 536df710c7..0000000000 --- a/otherlibs/unix/unixLabels.mli +++ /dev/null @@ -1,1242 +0,0 @@ -(***********************************************************************) -(* *) -(* 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Interface to the Unix system. - To use as replacement to default {!Unix} module, - add [module Unix = UnixLabels] in your implementation. -*) - -(** {6 Error report} *) - -type error = - Unix.error = - 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 *) - - | 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 *) - | EOVERFLOW (** File size or position not representable *) - - | EUNKNOWNERR of int (** Unknown error *) -(** The type of error codes. - Errors defined in the POSIX standard - and additional errors, mostly BSD. - All other errors are mapped to EUNKNOWNERR. -*) - - -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. *) - - -(** {6 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. *) - -(** {6 Process handling} *) - -type process_status = - Unix.process_status = - WEXITED of int - (** The process terminated normally by [exit]; - the argument is the return code. *) - | WSIGNALED of int - (** The process was killed by a signal; - the argument is the signal number. *) - | WSTOPPED of int - (** The process was stopped by a signal; the argument is the - signal number. *) -(** The termination status of a process. *) - -type wait_flag = - Unix.wait_flag = - WNOHANG (** do not block if no child has - died yet, but immediately return with a pid equal to 0.*) - | WUNTRACED (** report also the children that receive stop signals. *) -(** Flags for {!UnixLabels.waitpid}. *) - - -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 {!UnixLabels.execv}, except that the third argument provides the - environment to the program executed. *) - -val execvp : prog:string -> args:string array -> unit -(** Same as {!UnixLabels.execv} respectively, except that - the program is searched in the path. *) - -val execvpe : prog:string -> args:string array -> env:string array -> unit -(** Same as {!UnixLabels.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 {!UnixLabels.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. *) - - -(** {6 Basic file input/output} *) - - -type file_descr = Unix.file_descr -(** The abstract type of file descriptors. *) - -val stdin : file_descr -(** File descriptor for standard input.*) - -val stdout : file_descr -(** File descriptor for standard output.*) - -val stderr : file_descr -(** File descriptor for standard 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 *) - | O_NOCTTY (** Don't make this dev a controlling tty *) - | O_DSYNC (** Writes complete as `Synchronised I/O data integrity completion' *) - | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *) - | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *) -(** The flags to {!UnixLabels.openfile}. *) - - -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. *) - - -(** {6 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. *) - - - -(** {6 Seeking and truncating} *) - -type seek_command = - Unix.seek_command = - SEEK_SET (** indicates positions relative to the beginning of the file *) - | SEEK_CUR (** indicates positions relative to the current position *) - | SEEK_END (** indicates positions relative to the end of the file *) -(** Positioning modes for {!UnixLabels.lseek}. *) - -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. *) - - - -(** {6 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 {!UnixLabels.stat} calls. *) - - -val stat : string -> stats -(** Return the information for the named file. *) - -val lstat : string -> stats -(** Same as {!UnixLabels.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. *) - -(** {6 Seeking, truncating and statistics on large files} *) - - -module LargeFile : - sig - val lseek : file_descr -> int64 -> mode:seek_command -> int64 - val truncate : string -> len:int64 -> unit - val ftruncate : file_descr -> len:int64 -> unit - type stats = Unix.LargeFile.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 : int64; (** Size in bytes *) - st_atime : float; (** Last access time *) - st_mtime : float; (** Last modification time *) - st_ctime : float; (** Last status change time *) - } - val stat : string -> stats - val lstat : string -> stats - val fstat : file_descr -> stats - end -(** This sub-module provides 64-bit variants of the functions - {!UnixLabels.lseek} (for positioning a file descriptor), - {!UnixLabels.truncate} and {!UnixLabels.ftruncate} - (for changing the size of a file), - and {!UnixLabels.stat}, {!UnixLabels.lstat} and {!UnixLabels.fstat} - (for obtaining information on files). These alternate functions represent - positions and sizes by 64-bit integers (type [int64]) instead of - regular integers (type [int]), thus allowing operating on files - whose sizes are greater than [max_int]. *) - - -(** {6 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]. *) - - - -(** {6 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 {!UnixLabels.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. *) - - - -(** {6 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 -(** Set 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 clear_nonblock : file_descr -> unit -(** Clear the ``non-blocking'' flag on the given descriptor. - See {!UnixLabels.set_nonblock}.*) - -val set_close_on_exec : file_descr -> unit -(** Set 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. *) - -val clear_close_on_exec : file_descr -> unit -(** Clear the ``close-on-exec'' flag on the given descriptor. - See {!UnixLabels.set_close_on_exec}.*) - - - -(** {6 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. *) - - - -(** {6 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. *) - - -(** {6 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 {!UnixLabels.create_process}, except that the extra argument - [env] specifies the environment passed to the program. *) - -val open_process_in : string -> in_channel -(** High-level pipe and process management. These functions - (with {!UnixLabels.open_process_out} and {!UnixLabels.open_process}) - 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 {!Pervasives.flush} at the right times - to ensure correct synchronization. *) - -val open_process_out : string -> out_channel -(** See {!UnixLabels.open_process_in}. *) - -val open_process : string -> in_channel * out_channel -(** See {!UnixLabels.open_process_in}. *) - -val open_process_full : - string -> env:string array -> in_channel * out_channel * in_channel -(** Similar to {!UnixLabels.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 -(** Close channels opened by {!UnixLabels.open_process_in}, - wait for the associated command to terminate, - and return its termination status. *) - -val close_process_out : out_channel -> process_status -(** Close channels opened by {!UnixLabels.open_process_out}, - wait for the associated command to terminate, - and return its termination status. *) - -val close_process : in_channel * out_channel -> process_status -(** Close channels opened by {!UnixLabels.open_process}, - wait for the associated command to terminate, - and return its termination status. *) - -val close_process_full : - in_channel * out_channel * in_channel -> process_status -(** Close channels opened by {!UnixLabels.open_process_full}, - wait for the associated command to terminate, - and return its termination status. *) - - -(** {6 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. *) - - - -(** {6 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). *) - - -(** {6 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 {!UnixLabels.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 {!UnixLabels.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. *) - - -(** {6 Signals} - Note: installation of signal handlers is performed via - the functions {!Sys.signal} and {!Sys.set_signal}. -*) - - -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. *) - - -(** {6 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 {!UnixLabels.time}, but with resolution better than 1 second. *) - -val gmtime : float -> tm -(** Convert a time in seconds, as returned by {!UnixLabels.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 {!UnixLabels.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 {!UnixLabels.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 - (** 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. *) -(** The three kinds of interval timers. *) - - -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. *) - - -(** {6 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]. *) - - - -(** {6 Internet addresses} *) - - -type inet_addr = Unix.inet_addr -(** The abstract type of Internet addresses. *) - -val inet_addr_of_string : string -> inet_addr -(** 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 string_of_inet_addr : inet_addr -> string -(** See {!UnixLabels.inet_addr_of_string}. *) - -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. *) - - -(** {6 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 {!UnixLabels.recv}, {!UnixLabels.recvfrom}, - {!UnixLabels.send} and {!UnixLabels.sendto}. *) - -val recv : - file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> int -(** Receive data from an unconnected socket. *) - -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 -(** Send data over an unconnected socket. *) - -val sendto : - file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> - addr:sockaddr -> int -(** Send data over an unconnected socket. *) - - -(** {6 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 {!UnixLabels.getsockopt} - and modified with {!UnixLabels.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 {!UnixLabels.getsockopt_int} - and modified with {!UnixLabels.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 {!UnixLabels.getsockopt_optint} - and modified with {!UnixLabels.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 {!UnixLabels.getsockopt_float} - and modified with {!UnixLabels.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" -(** Same as {!UnixLabels.getsockopt} for an integer-valued socket option. *) - -external setsockopt_int : - file_descr -> socket_int_option -> int -> unit = "unix_setsockopt_int" -(** Same as {!UnixLabels.setsockopt} for an integer-valued socket option. *) - -external getsockopt_optint : - file_descr -> socket_optint_option -> int option = "unix_getsockopt_optint" -(** Same as {!UnixLabels.getsockopt} for a socket option whose value is an [int option]. *) - -external setsockopt_optint : - file_descr -> socket_optint_option -> int option -> - unit = "unix_setsockopt_optint" -(** Same as {!UnixLabels.setsockopt} for a socket option whose value is an [int option]. *) - -external getsockopt_float : - file_descr -> socket_float_option -> float = "unix_getsockopt_float" -(** Same as {!UnixLabels.getsockopt} for a socket option whose value is a floating-point number. *) - -external setsockopt_float : - file_descr -> socket_float_option -> float -> unit = "unix_setsockopt_float" -(** Same as {!UnixLabels.setsockopt} for a socket option whose value is a floating-point number. *) - - -(** {6 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 {!Pervasives.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 {!UnixLabels.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 {!UnixLabels.establish_server} - never returns normally. *) - - -(** {6 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]. *) - - - -(** {6 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/otherlibs/unix/unixsupport.c b/otherlibs/unix/unixsupport.c deleted file mode 100644 index 2a723924c2..0000000000 --- a/otherlibs/unix/unixsupport.c +++ /dev/null @@ -1,285 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <callback.h> -#include <memory.h> -#include <fail.h> -#include "unixsupport.h" -#include "cst2constr.h" -#include <errno.h> - -#ifndef E2BIG -#define E2BIG (-1) -#endif -#ifndef EACCES -#define EACCES (-1) -#endif -#ifndef EAGAIN -#define EAGAIN (-1) -#endif -#ifndef EBADF -#define EBADF (-1) -#endif -#ifndef EBUSY -#define EBUSY (-1) -#endif -#ifndef ECHILD -#define ECHILD (-1) -#endif -#ifndef EDEADLK -#define EDEADLK (-1) -#endif -#ifndef EDOM -#define EDOM (-1) -#endif -#ifndef EEXIST -#define EEXIST (-1) -#endif - -#ifndef EFAULT -#define EFAULT (-1) -#endif -#ifndef EFBIG -#define EFBIG (-1) -#endif -#ifndef EINTR -#define EINTR (-1) -#endif -#ifndef EINVAL -#define EINVAL (-1) -#endif -#ifndef EIO -#define EIO (-1) -#endif -#ifndef EISDIR -#define EISDIR (-1) -#endif -#ifndef EMFILE -#define EMFILE (-1) -#endif -#ifndef EMLINK -#define EMLINK (-1) -#endif -#ifndef ENAMETOOLONG -#define ENAMETOOLONG (-1) -#endif -#ifndef ENFILE -#define ENFILE (-1) -#endif -#ifndef ENODEV -#define ENODEV (-1) -#endif -#ifndef ENOENT -#define ENOENT (-1) -#endif -#ifndef ENOEXEC -#define ENOEXEC (-1) -#endif -#ifndef ENOLCK -#define ENOLCK (-1) -#endif -#ifndef ENOMEM -#define ENOMEM (-1) -#endif -#ifndef ENOSPC -#define ENOSPC (-1) -#endif -#ifndef ENOSYS -#define ENOSYS (-1) -#endif -#ifndef ENOTDIR -#define ENOTDIR (-1) -#endif -#ifndef ENOTEMPTY -#define ENOTEMPTY (-1) -#endif -#ifndef ENOTTY -#define ENOTTY (-1) -#endif -#ifndef ENXIO -#define ENXIO (-1) -#endif -#ifndef EPERM -#define EPERM (-1) -#endif -#ifndef EPIPE -#define EPIPE (-1) -#endif -#ifndef ERANGE -#define ERANGE (-1) -#endif -#ifndef EROFS -#define EROFS (-1) -#endif -#ifndef ESPIPE -#define ESPIPE (-1) -#endif -#ifndef ESRCH -#define ESRCH (-1) -#endif -#ifndef EXDEV -#define EXDEV (-1) -#endif -#ifndef EWOULDBLOCK -#define EWOULDBLOCK (-1) -#endif -#ifndef EINPROGRESS -#define EINPROGRESS (-1) -#endif -#ifndef EALREADY -#define EALREADY (-1) -#endif -#ifndef ENOTSOCK -#define ENOTSOCK (-1) -#endif -#ifndef EDESTADDRREQ -#define EDESTADDRREQ (-1) -#endif -#ifndef EMSGSIZE -#define EMSGSIZE (-1) -#endif -#ifndef EPROTOTYPE -#define EPROTOTYPE (-1) -#endif -#ifndef ENOPROTOOPT -#define ENOPROTOOPT (-1) -#endif -#ifndef EPROTONOSUPPORT -#define EPROTONOSUPPORT (-1) -#endif -#ifndef ESOCKTNOSUPPORT -#define ESOCKTNOSUPPORT (-1) -#endif -#ifndef EOPNOTSUPP -#define EOPNOTSUPP (-1) -#endif -#ifndef EPFNOSUPPORT -#define EPFNOSUPPORT (-1) -#endif -#ifndef EAFNOSUPPORT -#define EAFNOSUPPORT (-1) -#endif -#ifndef EADDRINUSE -#define EADDRINUSE (-1) -#endif -#ifndef EADDRNOTAVAIL -#define EADDRNOTAVAIL (-1) -#endif -#ifndef ENETDOWN -#define ENETDOWN (-1) -#endif -#ifndef ENETUNREACH -#define ENETUNREACH (-1) -#endif -#ifndef ENETRESET -#define ENETRESET (-1) -#endif -#ifndef ECONNABORTED -#define ECONNABORTED (-1) -#endif -#ifndef ECONNRESET -#define ECONNRESET (-1) -#endif -#ifndef ENOBUFS -#define ENOBUFS (-1) -#endif -#ifndef EISCONN -#define EISCONN (-1) -#endif -#ifndef ENOTCONN -#define ENOTCONN (-1) -#endif -#ifndef ESHUTDOWN -#define ESHUTDOWN (-1) -#endif -#ifndef ETOOMANYREFS -#define ETOOMANYREFS (-1) -#endif -#ifndef ETIMEDOUT -#define ETIMEDOUT (-1) -#endif -#ifndef ECONNREFUSED -#define ECONNREFUSED (-1) -#endif -#ifndef EHOSTDOWN -#define EHOSTDOWN (-1) -#endif -#ifndef EHOSTUNREACH -#define EHOSTUNREACH (-1) -#endif -#ifndef ENOTEMPTY -#define ENOTEMPTY (-1) -#endif -#ifndef ELOOP -#define ELOOP (-1) -#endif -#ifndef EOVERFLOW -#define EOVERFLOW (-1) -#endif - -int error_table[] = { - E2BIG, EACCES, EAGAIN, EBADF, EBUSY, ECHILD, EDEADLK, EDOM, - EEXIST, EFAULT, EFBIG, EINTR, EINVAL, EIO, EISDIR, EMFILE, EMLINK, - ENAMETOOLONG, ENFILE, ENODEV, ENOENT, ENOEXEC, ENOLCK, ENOMEM, ENOSPC, - ENOSYS, ENOTDIR, ENOTEMPTY, ENOTTY, ENXIO, EPERM, EPIPE, ERANGE, - EROFS, ESPIPE, ESRCH, EXDEV, EWOULDBLOCK, EINPROGRESS, EALREADY, - ENOTSOCK, EDESTADDRREQ, EMSGSIZE, EPROTOTYPE, ENOPROTOOPT, - EPROTONOSUPPORT, ESOCKTNOSUPPORT, EOPNOTSUPP, EPFNOSUPPORT, - EAFNOSUPPORT, EADDRINUSE, EADDRNOTAVAIL, ENETDOWN, ENETUNREACH, - ENETRESET, ECONNABORTED, ECONNRESET, ENOBUFS, EISCONN, ENOTCONN, - ESHUTDOWN, ETOOMANYREFS, ETIMEDOUT, ECONNREFUSED, EHOSTDOWN, - EHOSTUNREACH, ELOOP, EOVERFLOW /*, EUNKNOWNERR */ -}; - -static value * unix_error_exn = NULL; - -void unix_error(int errcode, char *cmdname, value cmdarg) -{ - value res; - value name = Val_unit, err = Val_unit, arg = Val_unit; - int errconstr; - - Begin_roots3 (name, err, arg); - arg = cmdarg == Nothing ? copy_string("") : cmdarg; - name = copy_string(cmdname); - errconstr = - cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1); - if (errconstr == Val_int(-1)) { - err = alloc_small(1, 0); - Field(err, 0) = Val_int(errcode); - } else { - err = errconstr; - } - if (unix_error_exn == NULL) { - unix_error_exn = caml_named_value("Unix.Unix_error"); - if (unix_error_exn == NULL) - invalid_argument("Exception Unix.Unix_error not initialized, please link unix.cma"); - } - res = alloc_small(4, 0); - Field(res, 0) = *unix_error_exn; - Field(res, 1) = err; - Field(res, 2) = name; - Field(res, 3) = arg; - End_roots(); - mlraise(res); -} - -void uerror(char *cmdname, value cmdarg) -{ - unix_error(errno, cmdname, cmdarg); -} - diff --git a/otherlibs/unix/unixsupport.h b/otherlibs/unix/unixsupport.h deleted file mode 100644 index defd8e6922..0000000000 --- a/otherlibs/unix/unixsupport.h +++ /dev/null @@ -1,25 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#ifdef HAS_UNISTD -#include <unistd.h> -#endif - -#define Nothing ((value) 0) - -extern void unix_error (int errcode, char * cmdname, value arg) Noreturn; -extern void uerror (char * cmdname, value arg) Noreturn; - -#define UNIX_BUFFER_SIZE 16384 diff --git a/otherlibs/unix/unlink.c b/otherlibs/unix/unlink.c deleted file mode 100644 index 1d956758b3..0000000000 --- a/otherlibs/unix/unlink.c +++ /dev/null @@ -1,23 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_unlink(value path) -{ - if (unlink(String_val(path)) == -1) uerror("unlink", path); - return Val_unit; -} diff --git a/otherlibs/unix/utimes.c b/otherlibs/unix/utimes.c deleted file mode 100644 index 51d34350cf..0000000000 --- a/otherlibs/unix/utimes.c +++ /dev/null @@ -1,71 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -#ifdef HAS_UTIME - -#include <sys/types.h> -#ifndef _WIN32 -#include <utime.h> -#else -#include <sys/utime.h> -#endif - -CAMLprim value unix_utimes(value path, value atime, value mtime) -{ - struct utimbuf times, * t; - times.actime = Double_val(atime); - times.modtime = Double_val(mtime); - if (times.actime || times.modtime) - t = × - else - t = (struct utimbuf *) NULL; - if (utime(String_val(path), t) == -1) uerror("utimes", path); - return Val_unit; -} - -#else - -#ifdef HAS_UTIMES - -#include <sys/types.h> -#include <sys/time.h> - -CAMLprim value unix_utimes(value path, value atime, value mtime) -{ - struct timeval tv[2], * t; - double at = Double_val(atime); - double mt = Double_val(mtime); - tv[0].tv_sec = at; - tv[0].tv_usec = (at - tv[0].tv_sec) * 1000000; - tv[1].tv_sec = mt; - tv[1].tv_usec = (mt - tv[1].tv_sec) * 1000000; - if (tv[0].tv_sec || tv[1].tv_sec) - t = tv; - else - t = (struct timeval *) NULL; - if (utimes(String_val(path), t) == -1) uerror("utimes", path); - return Val_unit; -} - -#else - -CAMLprim value unix_utimes(value path, value atime, value mtime) -{ invalid_argument("utimes not implemented"); } - -#endif -#endif diff --git a/otherlibs/unix/wait.c b/otherlibs/unix/wait.c deleted file mode 100644 index b660a75e44..0000000000 --- a/otherlibs/unix/wait.c +++ /dev/null @@ -1,101 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <signals.h> -#include "unixsupport.h" - -#include <sys/types.h> -#include <sys/wait.h> - -#if !(defined(WIFEXITED) && defined(WEXITSTATUS) && defined(WIFSTOPPED) && \ - defined(WSTOPSIG) && defined(WTERMSIG)) -/* Assume old-style V7 status word */ -#define WIFEXITED(status) (((status) & 0xFF) == 0) -#define WEXITSTATUS(status) (((status) >> 8) & 0xFF) -#define WIFSTOPPED(status) (((status) & 0xFF) == 0xFF) -#define WSTOPSIG(status) (((status) >> 8) & 0xFF) -#define WTERMSIG(status) ((status) & 0x3F) -#endif - -#define TAG_WEXITED 0 -#define TAG_WSIGNALED 1 -#define TAG_WSTOPPED 2 - -static value alloc_process_status(int pid, int status) -{ - value st, res; - - if (WIFEXITED(status)) { - st = alloc_small(1, TAG_WEXITED); - Field(st, 0) = Val_int(WEXITSTATUS(status)); - } - else if (WIFSTOPPED(status)) { - st = alloc_small(1, TAG_WSTOPPED); - Field(st, 0) = Val_int(WSTOPSIG(status)); - } - else { - st = alloc_small(1, TAG_WSIGNALED); - Field(st, 0) = Val_int(WTERMSIG(status)); - } - Begin_root (st); - res = alloc_small(2, 0); - Field(res, 0) = Val_int(pid); - Field(res, 1) = st; - End_roots(); - return res; -} - -CAMLprim value unix_wait(void) -{ - int pid, status; - - enter_blocking_section(); - pid = wait(&status); - leave_blocking_section(); - if (pid == -1) uerror("wait", Nothing); - return alloc_process_status(pid, status); -} - -#if defined(HAS_WAITPID) || defined(HAS_WAIT4) - -#ifndef HAS_WAITPID -#define waitpid(pid,status,opts) wait4(pid,status,opts,NULL) -#endif - -static int wait_flag_table[] = { - WNOHANG, WUNTRACED -}; - -CAMLprim value unix_waitpid(value flags, value pid_req) -{ - int pid, status; - - enter_blocking_section(); - pid = waitpid(Int_val(pid_req), &status, - convert_flag_list(flags, wait_flag_table)); - leave_blocking_section(); - if (pid == -1) uerror("waitpid", Nothing); - return alloc_process_status(pid, status); -} - -#else - -CAMLprim value unix_waitpid(value flags, value pid_req) -{ invalid_argument("waitpid not implemented"); } - -#endif diff --git a/otherlibs/unix/write.c b/otherlibs/unix/write.c deleted file mode 100644 index 0e02437b8c..0000000000 --- a/otherlibs/unix/write.c +++ /dev/null @@ -1,56 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <errno.h> -#include <string.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> -#include "unixsupport.h" - -#ifndef EAGAIN -#define EAGAIN (-1) -#endif -#ifndef EWOULDBLOCK -#define EWOULDBLOCK (-1) -#endif - -CAMLprim value unix_write(value fd, value buf, value vofs, value vlen) -{ - long ofs, len, written; - int numbytes, ret; - char iobuf[UNIX_BUFFER_SIZE]; - - Begin_root (buf); - ofs = Long_val(vofs); - len = Long_val(vlen); - written = 0; - while (len > 0) { - numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; - memmove (iobuf, &Byte(buf, ofs), numbytes); - enter_blocking_section(); - ret = write(Int_val(fd), iobuf, numbytes); - leave_blocking_section(); - if (ret == -1) { - if ((errno == EAGAIN || errno == EWOULDBLOCK) && written > 0) break; - uerror("write", Nothing); - } - written += ret; - ofs += ret; - len -= ret; - } - End_roots(); - return Val_long(written); -} diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt deleted file mode 100644 index 1274182614..0000000000 --- a/otherlibs/win32graph/Makefile.nt +++ /dev/null @@ -1,94 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -include ../../config/Makefile - -# Compilation options -CC=$(BYTECC) -CFLAGS=-I../../byterun -CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -COMPFLAGS=-warn-error A - -COBJS=open.$(O) draw.$(O) dib.$(O) -CAMLOBJS=graphics.cmo -WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32) - -all: dllgraphics.dll libgraphics.$(A) graphics.cma - -allopt: libgraphics.$(A) graphics.cmxa - -dllgraphics.dll: $(COBJS:.$(O)=.$(DO)) - $(call MKDLL,dllgraphics.dll,tmp.$(A),\ - $(COBJS:.$(O)=.$(DO)) ../../byterun/ocamlrun.$(A) $(WIN32LIBS)) - rm tmp.* - -libgraphics.$(A): $(COBJS:.$(O)=.$(SO)) - $(call MKLIB,libgraphics.$(A),$(COBJS:.$(O)=.$(SO))) - -graphics.cma: $(CAMLOBJS) - $(CAMLC) -a -o graphics.cma $(CAMLOBJS) \ - -dllib -lgraphics -cclib -lgraphics -cclib "$(WIN32LIBS)" - -graphics.cmxa: $(CAMLOBJS:.cmo=.cmx) - $(CAMLOPT) -a -o graphics.cmxa $(CAMLOBJS:.cmo=.cmx) \ - -cclib -lgraphics -cclib "$(WIN32LIBS)" - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.$(A) *.dll *.exp *.$(O) - rm -f graphics.ml graphics.mli - rm -f io.h - -install: - cp dllgraphics.dll $(STUBLIBDIR)/dllgraphics.dll - cp libgraphics.$(A) $(LIBDIR)/libgraphics.$(A) - cp graphics.cmi graphics.cma $(LIBDIR) - -installopt: - cp graphics.cmxa graphics.cmx graphics.$(A) $(LIBDIR) - -graphics.ml: ../graph/graphics.ml - cp ../graph/graphics.ml graphics.ml -graphics.mli: ../graph/graphics.mli - cp ../graph/graphics.mli graphics.mli - -.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO) - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(SO) - -depend: - -graphics.cmo: graphics.cmi -graphics.cmx: graphics.cmi -draw.$(SO) draw.$(DO): libgraph.h -open.$(SO) open.$(DO): libgraph.h diff --git a/otherlibs/win32graph/dib.c b/otherlibs/win32graph/dib.c deleted file mode 100644 index d881a02819..0000000000 --- a/otherlibs/win32graph/dib.c +++ /dev/null @@ -1,496 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Developed by Jacob Navia */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -//----------------------------------------------------------------------------- -// DIB.C -// -// This is a collection of useful DIB manipulation/information gathering -// functions. Many functions are supplied simply to take the burden -// of taking into account whether a DIB is a Win30 style or OS/2 style -// DIB away from the application. -// -// The functions in this module assume that the DIB pointers or handles -// passed to them point to a block of memory in one of two formats: -// -// a) BITMAPINFOHEADER + color table + DIB bits (3.0 style DIB) -// b) BITMAPCOREHEADER + color table + DIB bits (OS/2 PM style) -// -// The SDK Reference, Volume 2 describes these data structures. -// -// A number of functions in this module were lifted from SHOWDIB, -// and modified to handle OS/2 DIBs. -// -// The functions in this module could be streamlined (made faster and -// smaller) by removing the OS/2 DIB specific code, and assuming all -// DIBs passed to it are Win30 style DIBs. The DIB file reading code -// would need to be modified to always convert DIBs to Win30 style -// DIBs. The only reason this isn't done in DIBView is because DIBView -// was written to test display and printer drivers (which are supposed -// to support OS/2 DIBs wherever they support Win30 style DIBs). SHOWDIB -// is a great example of how to go about doing this. -//----------------------------------------------------------------------------- - - -#include <windows.h> -#include <memory.h> -#include <string.h> -#include <io.h> -#include <stdio.h> - // Size of window extra bytes (we store a handle to a PALINFO structure). - -#define PAL_CBWNDEXTRA (1 * sizeof (WORD)) - - -typedef struct - { - HPALETTE hPal; // Handle to palette being displayed. - WORD wEntries; // # of entries in the palette. - int nSquareSize; // Size of palette square (see PAL_SIZE) - HWND hInfoWnd; // Handle to the info bar window. - int nRows, nCols; // # of Rows/Columns in window. - int cxSquare, cySquare; // Pixel width/height of palette square. - WORD wEntry; // Currently selected palette square. - } PALINFO, FAR *LPPALINFO; - // Window Words. -#define WW_PAL_HPALINFO 0 // Handle to PALINFO structure. - // The following define is for CopyPaletteChangingFlags(). -#define DONT_CHANGE_FLAGS -1 - // The following is the palette version that goes in a - // LOGPALETTE's palVersion field. -#define PALVERSION 0x300 -// This is an enumeration for the various ways we can display -// a palette in PaletteWndProc(). -enum PAL_SIZE - { - PALSIZE_TINY = 0, - PALSIZE_SMALL, - PALSIZE_MEDIUM, - PALSIZE_LARGE - }; -#define CopyPalette(hPal) CopyPaletteChangingFlags (hPal, DONT_CHANGE_FLAGS) -#define CopyPalForAnimation(hPal) CopyPaletteChangingFlags (hPal, PC_RESERVED) -// WIDTHBYTES takes # of bits in a scan line and rounds up to nearest -// word. -#define WIDTHBYTES(bits) (((bits) + 31) / 32 * 4) - - // Given a pointer to a DIB header, return TRUE if is a Windows 3.0 style - // DIB, false if otherwise (PM style DIB). -#define IS_WIN30_DIB(lpbi) ((*(LPDWORD) (lpbi)) == sizeof (BITMAPINFOHEADER)) - -static WORD PaletteSize (LPSTR lpbi); - -extern void ShowDbgMsg(char *); -static BOOL MyRead (int, LPSTR, DWORD); -/*-------------- DIB header Marker Define -------------------------*/ -#define DIB_HEADER_MARKER ((WORD) ('M' << 8) | 'B') -/*-------------- MyRead Function Define ---------------------------*/ - -// When we read in a DIB, we read it in in chunks. We read half a segment -// at a time. This way we insure that we don't cross any segment -// boundries in _lread() during a read. We don't read in a full segment -// at a time, since _lread takes some "int" type parms instead of -// WORD type params (it'd work, but the compiler would give you warnings)... - -#define BYTES_PER_READ 32767 - -/*-------------- Define for PM DIB -------------------------------*/ -// The constants for RGB, RLE4, RLE8 are already defined inside -// of Windows.h - -#define BI_PM 3L - - -/*-------------- Magic numbers -------------------------------------*/ -// Maximum length of a filename for DOS is 128 characters. - -#define MAX_FILENAME 129 - - -/*-------------- TypeDef Structures -------------------------------*/ - -typedef struct InfoStruct - { - char szName[13]; - char szType[15]; - DWORD cbWidth; - DWORD cbHeight; - DWORD cbColors; - char szCompress[5]; - } INFOSTRUCT; - -// Some macros. -#define RECTWIDTH(lpRect) ((lpRect)->right - (lpRect)->left) -#define RECTHEIGHT(lpRect) ((lpRect)->bottom - (lpRect)->top) -//--------------------------------------------------------------------- -// -// Function: FindDIBBits -// -// Purpose: Given a pointer to a DIB, returns a pointer to the -// DIB's bitmap bits. -// -// Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER -// or BITMAPCOREHEADER) -// -// History: Date Reason -// 6/01/91 Created -// -//--------------------------------------------------------------------- -static LPSTR FindDIBBits (LPSTR lpbi) -{ - return (lpbi + *(LPDWORD)lpbi + PaletteSize (lpbi)); -} - - -//--------------------------------------------------------------------- -// -// Function: DIBNumColors -// -// Purpose: Given a pointer to a DIB, returns a number of colors in -// the DIB's color table. -// -// Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER -// or BITMAPCOREHEADER) -// -// History: Date Reason -// 6/01/91 Created -// -//--------------------------------------------------------------------- -static WORD DIBNumColors (LPSTR lpbi) -{ - WORD wBitCount; - - - // If this is a Windows style DIB, the number of colors in the - // color table can be less than the number of bits per pixel - // allows for (i.e. lpbi->biClrUsed can be set to some value). - // If this is the case, return the appropriate value. - - if (IS_WIN30_DIB (lpbi)) - { - DWORD dwClrUsed; - - dwClrUsed = ((LPBITMAPINFOHEADER) lpbi)->biClrUsed; - - if (dwClrUsed) - return (WORD) dwClrUsed; - } - - - // Calculate the number of colors in the color table based on - // the number of bits per pixel for the DIB. - - if (IS_WIN30_DIB (lpbi)) - wBitCount = ((LPBITMAPINFOHEADER) lpbi)->biBitCount; - else - wBitCount = ((LPBITMAPCOREHEADER) lpbi)->bcBitCount; - - switch (wBitCount) - { - case 1: - return 2; - - case 4: - return 16; - - case 8: - return 256; - - default: - return 0; - } -} - -//--------------------------------------------------------------------- -// -// Function: PaletteSize -// -// Purpose: Given a pointer to a DIB, returns number of bytes -// in the DIB's color table. -// -// Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER -// or BITMAPCOREHEADER) -// -// History: Date Reason -// 6/01/91 Created -// -//--------------------------------------------------------------------- -static WORD PaletteSize (LPSTR lpbi) -{ - if (IS_WIN30_DIB (lpbi)) - return (DIBNumColors (lpbi) * sizeof (RGBQUAD)); - else - return (DIBNumColors (lpbi) * sizeof (RGBTRIPLE)); -} - -//--------------------------------------------------------------------- -// -// Function: DIBHeight -// -// Purpose: Given a pointer to a DIB, returns its height. Note -// that it returns a DWORD (since a Win30 DIB can have -// a DWORD in its height field), but under Win30, the -// high order word isn't used! -// -// Parms: lpDIB == pointer to DIB header (either BITMAPINFOHEADER -// or BITMAPCOREHEADER) -// -// History: Date Reason -// 6/01/91 Created -// -//--------------------------------------------------------------------- -static DWORD DIBHeight (LPSTR lpDIB) -{ - LPBITMAPINFOHEADER lpbmi; - LPBITMAPCOREHEADER lpbmc; - - lpbmi = (LPBITMAPINFOHEADER) lpDIB; - lpbmc = (LPBITMAPCOREHEADER) lpDIB; - - if (lpbmi->biSize == sizeof (BITMAPINFOHEADER)) - return lpbmi->biHeight; - else - return (DWORD) lpbmc->bcHeight; -} - -/************************************************************************* - - Function: ReadDIBFile (int) - - Purpose: Reads in the specified DIB file into a global chunk of - memory. - - Returns: A handle to a dib (hDIB) if successful. - NULL if an error occurs. - - Comments: BITMAPFILEHEADER is stripped off of the DIB. Everything - from the end of the BITMAPFILEHEADER structure on is - returned in the global memory handle. - - History: Date Author Reason - - 6/1/91 Created - 6/27/91 Removed PM bitmap conversion routines. - 6/31/91 Removed logic which overallocated memory - (to account for bad display drivers). - 11/08/91 Again removed logic which overallocated - memory (it had creeped back in!) - -*************************************************************************/ -static HANDLE ReadDIBFile (int hFile,int dwBitsSize) -{ - BITMAPFILEHEADER bmfHeader; - HANDLE hDIB; - LPSTR pDIB; - - - - // Go read the DIB file header and check if it's valid. - - if ((_lread (hFile, (LPSTR) &bmfHeader, sizeof (bmfHeader)) != sizeof (bmfHeader)) || - (bmfHeader.bfType != DIB_HEADER_MARKER)) - { - // ShowDbgMsg("Not a DIB file!"); - return NULL; - } - - // Allocate memory for DIB - - hDIB = GlobalAlloc (GMEM_SHARE|GMEM_MOVEABLE | GMEM_ZEROINIT, dwBitsSize - sizeof(BITMAPFILEHEADER)); - - if (hDIB == 0) - { - // ShowDbgMsg("Couldn't allocate memory!"); - return NULL; - } - - pDIB = GlobalLock (hDIB); - - // Go read the bits. - - if (!MyRead (hFile, pDIB, dwBitsSize - sizeof(BITMAPFILEHEADER))) - { - GlobalUnlock (hDIB); - GlobalFree (hDIB); - // ShowDbgMsg("Error reading file!"); - return NULL; - } - - - GlobalUnlock (hDIB); - return hDIB; -} - -/************************************************************************* - - Function: MyRead (int, LPSTR, DWORD) - - Purpose: Routine to read files greater than 64K in size. - - Returns: TRUE if successful. - FALSE if an error occurs. - - Comments: - - History: Date Reason - - 6/1/91 Created - -*************************************************************************/ -static BOOL MyRead (int hFile, LPSTR lpBuffer, DWORD dwSize) -{ - char *lpInBuf = (char *) lpBuffer; - int nBytes; - - - while (dwSize) - { - nBytes = (int) (dwSize > (DWORD) BYTES_PER_READ ? BYTES_PER_READ : - LOWORD (dwSize)); - - if (_lread (hFile, (LPSTR) lpInBuf, nBytes) != (WORD) nBytes) - return FALSE; - - dwSize -= nBytes; - lpInBuf += nBytes; - } - - return TRUE; -} - -//--------------------------------------------------------------------- -// -// Function: DIBPaint -// -// Purpose: Painting routine for a DIB. Calls StretchDIBits() or -// SetDIBitsToDevice() to paint the DIB. The DIB is -// output to the specified DC, at the coordinates given -// in lpDCRect. The area of the DIB to be output is -// given by lpDIBRect. The specified palette is used. -// -// Parms: hDC == DC to do output to. -// lpDCRect == Rectangle on DC to do output to. -// hDIB == Handle to global memory with a DIB spec -// in it (either a BITMAPINFO or BITMAPCOREINFO -// followed by the DIB bits). -// lpDIBRect == Rect of DIB to output into lpDCRect. -// hPal == Palette to be used. -// -// History: Date Reason -// 6/01/91 Created -// -//--------------------------------------------------------------------- -static void DIBPaint (HDC hDC,LPRECT lpDCRect,HANDLE hDIB) -{ - LPSTR lpDIBHdr, lpDIBBits; - - if (!hDIB) - return; - // Lock down the DIB, and get a pointer to the beginning of the bit - // buffer. - lpDIBHdr = GlobalLock (hDIB); - lpDIBBits = FindDIBBits (lpDIBHdr); - // Make sure to use the stretching mode best for color pictures. - SetStretchBltMode (hDC, COLORONCOLOR); - SetDIBitsToDevice (hDC, // hDC - lpDCRect->left, // DestX - lpDCRect->top, // DestY - RECTWIDTH (lpDCRect), // nDestWidth - RECTHEIGHT (lpDCRect), // nDestHeight - 0, // SrcX - 0, - // (int) DIBHeight (lpDIBHdr), // SrcY - 0, // nStartScan - (WORD) DIBHeight (lpDIBHdr), // nNumScans - lpDIBBits, // lpBits - (LPBITMAPINFO) lpDIBHdr, // lpBitsInfo - DIB_RGB_COLORS); // wUsage - - GlobalUnlock (hDIB); -} - -static unsigned int Getfilesize(char *name) -{ - FILE *f; - unsigned int size; - - f = fopen(name,"rb"); - if (f == NULL) - return 0; - fseek(f,0,SEEK_END); - size = ftell(f); - fclose(f); - return size; -} - - -HANDLE ChargerBitmap(char *FileName,POINT *lppt) -{ - HFILE hFile; - OFSTRUCT ofstruct; - HANDLE result; - LPSTR lpDIBHdr; - unsigned int size; - - size = Getfilesize(FileName); - hFile=OpenFile((LPSTR) FileName, &ofstruct, OF_READ | OF_SHARE_DENY_WRITE); - result = ReadDIBFile(hFile,size); - if (hFile) _lclose(hFile); - if (result) { - LPBITMAPINFOHEADER lpbmi; - LPBITMAPCOREHEADER lpbmc; - - lpDIBHdr = GlobalLock (result); - lpbmi = (LPBITMAPINFOHEADER) lpDIBHdr; - lpbmc = (LPBITMAPCOREHEADER) lpDIBHdr; - - if (lpbmi->biSize == sizeof (BITMAPINFOHEADER)) { - lppt->y = lpbmi->biHeight; - lppt->x = lpbmi->biWidth; - } - else { - lppt->y = lpbmc->bcHeight; - lppt->x = lpbmc->bcWidth; - } - GlobalUnlock(result); - } - return(result); -} - -void DessinerBitmap(HANDLE hDIB,HDC hDC,LPRECT lpDCRect) -{ - DIBPaint (hDC, - lpDCRect, - hDIB); -} - -void AfficheBitmap(char *filename,HDC hDC,int x,int y) -{ - RECT rc; - HANDLE hdib; - POINT pt; - char titi[60]; - - hdib = ChargerBitmap(filename,&pt); - if (hdib == NULL) { - return; - } - rc.top = y; - rc.left = x; - rc.right = pt.x+x; - rc.bottom = pt.y+y; - pt.y += GetSystemMetrics(SM_CYCAPTION); - DessinerBitmap(hdib,hDC,&rc); - GlobalFree(hdib); -} - diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c deleted file mode 100644 index 31166d8136..0000000000 --- a/otherlibs/win32graph/draw.c +++ /dev/null @@ -1,784 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Developed by Jacob Navia, based on code by J-M Geffroy and X Leroy */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <math.h> -#include "mlvalues.h" -#include "alloc.h" -#include "libgraph.h" -#include "custom.h" -#include "memory.h" -HDC gcMetaFile; -int grdisplay_mode; -int grremember_mode; -GR_WINDOW grwindow; - -static void GetCurrentPosition(HDC hDC,POINT *pt) -{ - MoveToEx(hDC,0,0,pt); - MoveToEx(hDC,pt->x,pt->y,0); -} - -static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry, - value vstart, value vend, BOOL fill); - -CAMLprim value gr_plot(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - gr_check_open(); - if(grremember_mode) - SetPixel(grwindow.gcBitmap, x, Wcvt(y),grwindow.CurrentColor); - if(grdisplay_mode) { - SetPixel(grwindow.gc, x, Wcvt(y),grwindow.CurrentColor); - } - return Val_unit; -} - -CAMLprim value gr_moveto(value vx, value vy) -{ - grwindow.grx = Int_val(vx); - grwindow.gry = Int_val(vy); - if(grremember_mode) - MoveToEx(grwindow.gcBitmap,grwindow.grx,Wcvt(grwindow.gry),0); - if (grdisplay_mode) - MoveToEx(grwindow.gc,grwindow.grx,Wcvt(grwindow.gry),0); - return Val_unit; -} - -CAMLprim value gr_current_x(void) -{ - return Val_int(grwindow.grx); -} - -CAMLprim value gr_current_y(void) -{ - return Val_int(grwindow.gry); -} - -CAMLprim value gr_lineto(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - gr_check_open(); - SelectObject(grwindow.gc,grwindow.CurrentPen); - SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); - if (grremember_mode) - LineTo(grwindow.gcBitmap,x,Wcvt(y)); - if (grdisplay_mode) - LineTo(grwindow.gc, x, Wcvt(y)); - grwindow.grx = x; - grwindow.gry = y; - return Val_unit; -} - -CAMLprim value gr_draw_rect(value vx, value vy, value vw, value vh) -{ -#if 0 - int x = Int_val(vx); - int y = Int_val(vy); - int w = Int_val(vw); - int h = Int_val(vh); - - gr_check_open(); - if(grdisplay_mode) { - Rectangle(grwindow.gc,x, Wcvt(y) , x+w, Wcvt(y+h)); - } - if(grremember_mode) { - Rectangle(grwindow.gcBitmap,x, Wcvt(y), x+w, Wcvt(h+y)); - } - return Val_unit; -#else - int x, y, w, h; - POINT pt[5]; - x=Int_val(vx); - y=Int_val(vy); - w=Int_val(vw); - h=Int_val(vh); - - pt[0].x = x; - pt[0].y = Wcvt(y-1); - pt[1].x = x+w; - pt[1].y = pt[0].y; - pt[2].x = pt[1].x; - pt[2].y = Wcvt(y+h-1); - pt[3].x = pt[0].x; - pt[3].y = pt[2].y; - pt[4].x = pt[0].x; - pt[4].y = pt[0].y; - if (grremember_mode) { - Polyline(grwindow.gcBitmap,pt, 5); - } - if (grdisplay_mode) { - Polyline(grwindow.gc,pt, 5); - } - return Val_unit; -#endif -} - -CAMLprim value gr_draw_text(value text,value x) -{ - POINT pt; - int oldmode = SetBkMode(grwindow.gc,TRANSPARENT); - SetBkMode(grwindow.gcBitmap,TRANSPARENT); - SetTextAlign(grwindow.gcBitmap, TA_UPDATECP|TA_BOTTOM); - SetTextAlign(grwindow.gc, TA_UPDATECP|TA_BOTTOM); - if (grremember_mode) { - TextOut(grwindow.gcBitmap,0,0,(char *)text,x); - } - if(grdisplay_mode) { - TextOut(grwindow.gc,0,0,(char *)text,x); - } - GetCurrentPosition(grwindow.gc,&pt); - grwindow.grx = pt.x; - grwindow.gry = grwindow.height - pt.y; - SetBkMode(grwindow.gc,oldmode); - SetBkMode(grwindow.gcBitmap,oldmode); - return Val_unit; -} - -CAMLprim value gr_fill_rect(value vx, value vy, value vw, value vh) -{ - int x = Int_val(vx); - int y = Int_val(vy); - int w = Int_val(vw); - int h = Int_val(vh); - RECT rc; - - gr_check_open(); - rc.left = x; - rc.top = Wcvt(y); - rc.right = x+w; - rc.bottom = Wcvt(y)-h; - if (grdisplay_mode) - FillRect(grwindow.gc,&rc,grwindow.CurrentBrush); - if (grremember_mode) - FillRect(grwindow.gcBitmap,&rc,grwindow.CurrentBrush); - return Val_unit; -} - -CAMLprim value gr_sound(value freq, value vdur) -{ - Beep(freq,vdur); - return Val_unit; -} - -CAMLprim value gr_point_color(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - COLORREF rgb; - unsigned long b,g,r; - - gr_check_open(); - rgb = GetPixel(grwindow.gcBitmap,x,Wcvt(y)); - b = (unsigned long)((rgb & 0xFF0000) >> 16); - g = (unsigned long)((rgb & 0x00FF00) >> 8); - r = (unsigned long)(rgb & 0x0000FF); - return Val_long((r<<16) + (g<<8) + b); -} - -CAMLprim value gr_circle(value x,value y,value radius) -{ - int left,top,right,bottom; - - gr_check_open(); - left = x - radius/2; - top = Wcvt(y) - radius/2; - right = left+radius; - bottom = top+radius; - Ellipse(grwindow.gcBitmap,left,top,right,bottom); - return Val_unit; -} - -CAMLprim value gr_set_window_title(value text) -{ - SetWindowText(grwindow.hwnd,(char *)text); - return Val_unit; -} - -CAMLprim value gr_draw_arc(value *argv, int argc) -{ - return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5], FALSE); -} - -CAMLprim value gr_draw_arc_nat(vx, vy, vrx, vry, vstart, vend) -{ - return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, FALSE); -} - -CAMLprim value gr_set_line_width(value vwidth) -{ - int width = Int_val(vwidth); - HPEN oldPen,newPen; - - gr_check_open(); - oldPen = grwindow.CurrentPen; - newPen = CreatePen(PS_SOLID,width,grwindow.CurrentColor); - SelectObject(grwindow.gcBitmap,newPen); - SelectObject(grwindow.gc,newPen); - DeleteObject(oldPen); - grwindow.CurrentPen = newPen; - return Val_unit; -} - -CAMLprim value gr_set_color(value vcolor) -{ - HBRUSH oldBrush, newBrush; - LOGBRUSH lb; - LOGPEN pen; - HPEN newPen; - int color = Long_val(vcolor); - - int r = (color & 0xFF0000) >> 16, - g = (color & 0x00FF00) >> 8 , - b = color & 0x0000FF; - COLORREF c = RGB(r,g,b); - memset(&lb,0,sizeof(lb)); - memset(&pen,0,sizeof(LOGPEN)); - gr_check_open(); - GetObject(grwindow.CurrentPen,sizeof(LOGPEN),&pen); - pen.lopnColor = c; - newPen = CreatePenIndirect(&pen); - SelectObject(grwindow.gcBitmap,newPen); - SelectObject(grwindow.gc,newPen); - DeleteObject(grwindow.CurrentPen); - grwindow.CurrentPen = newPen; - SetTextColor(grwindow.gc,c); - SetTextColor(grwindow.gcBitmap,c); - oldBrush = grwindow.CurrentBrush; - lb.lbStyle = BS_SOLID; - lb.lbColor = c; - newBrush = CreateBrushIndirect(&lb); - SelectObject(grwindow.gc,newBrush); - SelectObject(grwindow.gcBitmap,newBrush); - DeleteObject(oldBrush); - grwindow.CurrentBrush = newBrush; - grwindow.CurrentColor = c; - return Val_unit; -} - - -static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry, - value vstart, value vend, BOOL fill) -{ - int x, y, r_x, r_y, start, end; - int x1, y1, x2, y2, x3, y3, x4, y4; - double cvt = 3.141592653/180.0; - - r_x = Int_val(vrx); - r_y = Int_val(vry); - if ((r_x < 0) || (r_y < 0)) - invalid_argument("draw_arc: radius must be positive"); - x = Int_val(vx); - y = Int_val(vy); - start = Int_val(vstart); - end = Int_val(vend); - - // Upper-left corner of bounding rect. - x1= x - r_x; - y1= y + r_y; - // Lower-right corner of bounding rect. - x2= x + r_x; - y2= y - r_y; - // Starting point - x3=x + (int)(100.0*cos(cvt*start)); - y3=y + (int)(100.0*sin(cvt*start)); - // Ending point - x4=x + (int)(100.0*cos(cvt*end)); - y4=y + (int)(100.0*sin(cvt*end)); - - if (grremember_mode) { - SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - if( fill ) - Pie(grwindow.gcBitmap,x1, Wcvt(y1), x2, Wcvt(y2), - x3, Wcvt(y3), x4, Wcvt(y4)); - else - Arc(grwindow.gcBitmap,x1, Wcvt(y1), x2, Wcvt(y2), - x3, Wcvt(y3), x4, Wcvt(y4)); - } - if( grdisplay_mode ) { - SelectObject(grwindow.gc,grwindow.CurrentPen); - SelectObject(grwindow.gc,grwindow.CurrentBrush); - if (fill) - Pie(grwindow.gc,x1, Wcvt(y1), x2, Wcvt(y2), - x3, Wcvt(y3), x4, Wcvt(y4)); - else - Arc(grwindow.gc,x1, Wcvt(y1), x2, Wcvt(y2), - x3, Wcvt(y3), x4, Wcvt(y4)); - } - return Val_unit; -} - -CAMLprim value gr_show_bitmap(value filename,int x,int y) -{ - AfficheBitmap(filename,grwindow.gcBitmap,x,Wcvt(y)); - AfficheBitmap(filename,grwindow.gc,x,Wcvt(y)); - return Val_unit; -} - - - -CAMLprim value gr_get_mousex(void) -{ - POINT pt; - GetCursorPos(&pt); - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - return pt.x; -} - -CAMLprim value gr_get_mousey(void) -{ - POINT pt; - GetCursorPos(&pt); - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - return grwindow.height - pt.y - 1; -} - - -static void gr_font(char *fontname) -{ - HFONT hf = CreationFont(fontname); - - if (hf && hf != INVALID_HANDLE_VALUE) { - HFONT oldFont = SelectObject(grwindow.gc,hf); - SelectObject(grwindow.gcBitmap,hf); - DeleteObject(grwindow.CurrentFont); - grwindow.CurrentFont = hf; - } -} - -CAMLprim value gr_set_font(value fontname) -{ - gr_check_open(); - gr_font(String_val(fontname)); - return Val_unit; -} - -CAMLprim value gr_set_text_size (value sz) -{ - return Val_unit; -} - -CAMLprim value gr_draw_char(value chr) -{ - char str[1]; - gr_check_open(); - str[0] = Int_val(chr); - gr_draw_text((value)str, 1); - return Val_unit; -} - -CAMLprim value gr_draw_string(value str) -{ - gr_check_open(); - gr_draw_text(str, string_length(str)); - return Val_unit; -} - -CAMLprim value gr_text_size(value str) -{ - SIZE extent; - value res; - - mlsize_t len = string_length(str); - if (len > 32767) len = 32767; - - GetTextExtentPoint(grwindow.gc,String_val(str), len,&extent); - - res = alloc_tuple(2); - Field(res, 0) = Val_long(extent.cx); - Field(res, 1) = Val_long(extent.cy); - - return res; -} - -#if 0 -static unsigned char gr_queue[SIZE_QUEUE]; -static int gr_head = 0; /* position of next read */ -static int gr_tail = 0; /* position of next write */ - -#define QueueIsEmpty (gr_head == gr_tail) -#define QueueIsFull (gr_head == gr_tail + 1) - -void gr_enqueue_char(unsigned char c) -{ - if (QueueIsFull) return; - gr_queue[gr_tail] = c; - gr_tail++; - if (gr_tail >= SIZE_QUEUE) gr_tail = 0; -} -#endif - -#define Button_down 1 -#define Button_up 2 -#define Key_pressed 4 -#define Mouse_motion 8 -#define Poll 16 -MSG * InspectMessages = NULL; - -CAMLprim value gr_wait_event(value eventlist) -{ - value res; - int mask; - BOOL poll; - int mouse_x, mouse_y, button, key; - int root_x, root_y, win_x, win_y; - int r,i,stop; - unsigned int modifiers; - POINT pt; - MSG msg; - - gr_check_open(); - mask = 0; - poll = FALSE; - while (eventlist != Val_int(0)) { - switch (Int_val(Field(eventlist,0))) { - case 0: /* Button_down */ - mask |= Button_down; - break; - case 1: /* Button_up */ - mask |= Button_up; - break; - case 2: /* Key_pressed */ - mask |= Key_pressed; - break; - case 3: /* Mouse_motion */ - mask |= Mouse_motion; - break; - case 4: /* Poll */ - poll = TRUE; - break; - } - eventlist = Field(eventlist,1); - } - mouse_x = -1; - mouse_y = -1; - button = 0; - key = -1; - - if (poll) { - // Poll uses info on last event stored in global variables - mouse_x = MouseLastX; - mouse_y = MouseLastY; - button = MouseLbuttonDown | MouseMbuttonDown | MouseRbuttonDown; - key = LastKey; - } - else { // Not polled. Block for a message - InspectMessages = &msg; - do { - WaitForSingleObject(EventHandle,INFINITE); - stop = 0; - switch (msg.message) { - case WM_LBUTTONDOWN: - case WM_MBUTTONDOWN: - case WM_RBUTTONDOWN: - button = 1; - if (mask&Button_down) stop = 1; - break; - case WM_LBUTTONUP: - case WM_MBUTTONUP: - case WM_RBUTTONUP: - button = 0; - if (mask&Button_up) stop = 1; - break; - case WM_MOUSEMOVE: - if (mask&Mouse_motion) stop = 1; - break; - case WM_CHAR: - key = msg.wParam & 0xFF; - if (mask&Key_pressed) stop = 1; - break; - case WM_CLOSE: - stop = 1; - break; - } - if (stop) { - pt = msg.pt; - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - mouse_x = pt.x; - mouse_y = grwindow.height- 1 - pt.y; - } - SetEvent(EventProcessedHandle); - } while (! stop); - InspectMessages = NULL; - } - res = alloc_small(5, 0); - Field(res, 0) = Val_int(mouse_x); - Field(res, 1) = Val_int(mouse_y); - Field(res, 2) = Val_bool(button); - Field(res, 3) = Val_bool(key != -1); - Field(res, 4) = Val_int(key & 0xFF); - return res; -} - -CAMLprim value gr_fill_poly(value vect) -{ - int n_points, i; - POINT *p,*poly; - n_points = Wosize_val(vect); - if (n_points < 3) - gr_fail("fill_poly: not enough points",0); - - poly = (POINT *)malloc(n_points*sizeof(POINT)); - - p = poly; - for( i = 0; i < n_points; i++ ){ - p->x = Int_val(Field(Field(vect,i),0)); - p->y = Wcvt(Int_val(Field(Field(vect,i),1))); - p++; - } - if (grremember_mode) { - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - Polygon(grwindow.gcBitmap,poly,n_points); - } - if (grdisplay_mode) { - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - Polygon(grwindow.gc,poly,n_points); - } - free(poly); - - return Val_unit; -} - -CAMLprim value gr_fill_arc(value *argv, int argc) -{ - return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5], TRUE); -} - -CAMLprim value gr_fill_arc_nat(vx, vy, vrx, vry, vstart, vend) -{ - return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, TRUE); -} - -// Image primitives -struct image { - int w; - int h; - HBITMAP data; - HBITMAP mask; -}; - -#define Width(i) (((struct image *)Data_custom_val(i))->w) -#define Height(i) (((struct image *)Data_custom_val(i))->h) -#define Data(i) (((struct image *)Data_custom_val(i))->data) -#define Mask(i) (((struct image *)Data_custom_val(i))->mask) -#define Max_image_mem 53000000 - -static void finalize_image (value i) -{ - DeleteObject (Data(i)); - if (Mask(i) != NULL) DeleteObject(Mask(i)); -} - -static struct custom_operations image_ops = { - "_image", - finalize_image, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; - -CAMLprim value gr_create_image(value vw, value vh) -{ - HBITMAP cbm; - value res; - int w = Int_val(vw); - int h = Int_val(vh); - - if (w < 0 || h < 0) - gr_fail("create_image: width and height must be positive",0); - - cbm = CreateCompatibleBitmap(grwindow.gc, w, h); - res = alloc_custom(&image_ops, sizeof(struct image), - w * h, Max_image_mem); - if (res) { - Width (res) = w; - Height (res) = h; - Data (res) = cbm; - Mask (res) = NULL; - } - return res; -} - -CAMLprim value gr_blit_image (value i, value x, value y) -{ - HBITMAP oldBmp = SelectObject(grwindow.tempDC,Data(i)); - int xsrc = Int_val(x); - int ysrc = Wcvt(Int_val(y) + Height(i) - 1); - BitBlt(grwindow.tempDC,0, 0, Width(i), Height(i), - grwindow.gcBitmap, xsrc, ysrc, SRCCOPY); - SelectObject(grwindow.tempDC,oldBmp); - return Val_unit; -} - - -CAMLprim value gr_draw_image(value i, value x, value y) -{ - HBITMAP oldBmp; - - int xdst = Int_val(x); - int ydst = Wcvt(Int_val(y)+Height(i)-1); - if (Mask(i) == NULL) { - if (grremember_mode) { - oldBmp = SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCCOPY); - SelectObject(grwindow.tempDC,oldBmp); - } - if (grdisplay_mode) { - oldBmp = SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCCOPY); - SelectObject(grwindow.tempDC,oldBmp); - } - } - else { - if (grremember_mode) { - oldBmp = SelectObject(grwindow.tempDC,Mask(i)); - BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCAND); - SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCPAINT); - SelectObject(grwindow.tempDC,oldBmp); - } - if (grdisplay_mode) { - oldBmp = SelectObject(grwindow.tempDC,Mask(i)); - BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCAND); - SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCPAINT); - SelectObject(grwindow.tempDC,oldBmp); - } - } - - return Val_unit; -} - -CAMLprim value gr_make_image(value matrix) -{ - int width, height,has_transp,i,j; - value img; - HBITMAP oldBmp; - height = Wosize_val(matrix); - if (height == 0) { - width = 0; - } - else { - width = Wosize_val(Field(matrix, 0)); - for (i = 1; i < height; i++) { - if (width != (int) Wosize_val(Field(matrix, i))) - gr_fail("make_image: non-rectangular matrix",0); - } - } - Begin_roots1(matrix) - img = gr_create_image(Val_int(width), Val_int(height)); - End_roots(); - has_transp = 0; - oldBmp = SelectObject(grwindow.tempDC,Data(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - int col = Long_val (Field (Field (matrix, i), j)); - if (col == -1){ - has_transp = 1; - SetPixel(grwindow.tempDC,j, i, 0); - } - else { - int red = (col >> 16) & 0xFF; - int green = (col >> 8) & 0xFF; - int blue = col & 0xFF; - SetPixel(grwindow.tempDC,j, i, RGB(red, green, blue)); - } - } - } - SelectObject(grwindow.tempDC,oldBmp); - if (has_transp) { - HBITMAP cbm; - cbm = CreateCompatibleBitmap(grwindow.gc, width, height); - Mask(img) = cbm; - oldBmp = SelectObject(grwindow.tempDC,Mask(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - int col = Long_val (Field (Field (matrix, i), j)); - SetPixel(grwindow.tempDC,j, i, col == -1 ? 0xFFFFFF : 0); - } - } - SelectObject(grwindow.tempDC,oldBmp); - } - return img; -} - -static value alloc_int_vect(mlsize_t size) -{ - value res; - mlsize_t i; - - if (size == 0) return Atom(0); - if (size <= Max_young_wosize) { - res = alloc(size, 0); - } - else { - res = alloc_shr(size, 0); - } - for (i = 0; i < size; i++) { - Field(res, i) = Val_long(0); - } - return res; -} - -CAMLprim value gr_dump_image (value img) -{ - int height = Height(img); - int width = Width(img); - value matrix = Val_unit; - int i, j; - HBITMAP oldBmp; - - Begin_roots2(img, matrix) - matrix = alloc_int_vect (height); - for (i = 0; i < height; i++) { - modify (&Field (matrix, i), alloc_int_vect (width)); - } - End_roots(); - - oldBmp = SelectObject(grwindow.tempDC,Data(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - int col = GetPixel(grwindow.tempDC,j, i); - int blue = (col >> 16) & 0xFF; - int green = (col >> 8) & 0xFF; - int red = col & 0xFF; - Field(Field(matrix, i), j) = Val_long((red << 16) + - (green << 8) + blue); - } - } - SelectObject(grwindow.tempDC,oldBmp); - if (Mask(img) != NULL) { - oldBmp = SelectObject(grwindow.tempDC,Mask(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - if (GetPixel(grwindow.tempDC,j, i) != 0) - Field(Field(matrix, i), j) = - Val_long(-1); - } - } - SelectObject(grwindow.tempDC,oldBmp); - } - return matrix; -} diff --git a/otherlibs/win32graph/libgraph.h b/otherlibs/win32graph/libgraph.h deleted file mode 100644 index 305270a41a..0000000000 --- a/otherlibs/win32graph/libgraph.h +++ /dev/null @@ -1,86 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Jacob Navia, after Xavier Leroy */ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <stdio.h> -#include <windows.h> -#include <windowsx.h> - -struct canvas { - int w, h; /* Dimensions of the drawable */ - HWND win; /* The drawable itself */ - HDC gc; /* The associated graphics context */ -}; - -extern HWND grdisplay; /* The display connection */ -extern COLORREF grbackground; -extern BOOL grdisplay_mode; /* Display-mode flag */ -extern BOOL grremember_mode; /* Remember-mode flag */ -extern int grx, gry; /* Coordinates of the current point */ -extern int grcolor; /* Current *CAML* drawing color (can be -1) */ -extern HFONT * grfont; /* Current font */ - -extern BOOL direct_rgb; -extern int byte_order; -extern int bitmap_unit; -extern int bits_per_pixel; - -#define Wcvt(y) (grwindow.height - 1 - (y)) -#define Bcvt(y) (grwindow.height - 1 - (y)) -#define WtoB(y) ((y) + WindowRect.bottom - grwindow.h) - -#define DEFAULT_SCREEN_WIDTH 1024 -#define DEFAULT_SCREEN_HEIGHT 768 -#define BORDER_WIDTH 2 -#define WINDOW_NAME "Caml graphics" -#define ICON_NAME "Caml graphics" -#define DEFAULT_EVENT_MASK \ - (ExposureMask | KeyPressMask | StructureNotifyMask) -#define DEFAULT_FONT "fixed" -#define SIZE_QUEUE 256 - -void gr_fail(char *fmt, char *arg); -void gr_check_open(void); -CAMLprim value gr_set_color(value vcolor); - -// Windows specific definitions -extern RECT WindowRect; -extern int grCurrentColor; - -typedef struct tagWindow { - HDC gc; - HDC gcBitmap; - HWND hwnd; - HBRUSH CurrentBrush; - HPEN CurrentPen; - DWORD CurrentColor; - int width; - int height; - int grx; - int gry; - HBITMAP hBitmap; - HFONT CurrentFont; - int CurrentFontSize; - HDC tempDC; // For image operations; -} GR_WINDOW; - -extern GR_WINDOW grwindow; -HFONT CreationFont(char *name); -extern int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown; -extern HANDLE EventHandle, EventProcessedHandle; -extern MSG * InspectMessages; -extern int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown; -extern int MouseLastX, MouseLastY; -extern int LastKey; - diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c deleted file mode 100644 index b400862319..0000000000 --- a/otherlibs/win32graph/open.c +++ /dev/null @@ -1,400 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Developed by Jacob Navia, based on code by J-M Geffroy and X Leroy */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <fcntl.h> -#include <signal.h> -#include "mlvalues.h" -#include "libgraph.h" -#include <windows.h> -static value gr_reset(void); -int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown; -int MouseLastX, MouseLastY; -int LastKey = -1; -static long tid; -static HANDLE threadHandle; -HWND grdisplay = NULL; -int grscreen; -COLORREF grwhite, grblack; -COLORREF grbackground; -int grCurrentColor; -struct canvas grbstore; -BOOL grdisplay_mode; -BOOL grremember_mode; -int grx, gry; -int grcolor; -extern HFONT * grfont; -MSG msg; - -HANDLE EventHandle, EventProcessedHandle; -static char *szOcamlWindowClass = "OcamlWindowClass"; -static BOOL gr_initialized = 0; -CAMLprim value gr_clear_graph(void); -HANDLE hInst; -HFONT CreationFont(char *name) -{ - LOGFONT CurrentFont; - memset(&CurrentFont, 0, sizeof(LOGFONT)); - CurrentFont.lfCharSet = ANSI_CHARSET; - CurrentFont.lfWeight = FW_NORMAL; - CurrentFont.lfHeight = grwindow.CurrentFontSize; - CurrentFont.lfPitchAndFamily = (BYTE) (FIXED_PITCH | FF_MODERN); - strcpy(CurrentFont.lfFaceName, name); /* Courier */ - return (CreateFontIndirect(&CurrentFont)); -} - -void SetCoordinates(HWND hwnd) -{ - RECT rc; - - GetClientRect(hwnd,&rc); - grwindow.width = rc.right; - grwindow.height = rc.bottom; - gr_reset(); -} - -void ResetForClose(HWND hwnd) -{ - DeleteObject(grwindow.hBitmap); - memset(&grwindow,0,sizeof(grwindow)); -} - - - -static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam) -{ - PAINTSTRUCT ps; - HDC hdc; - - switch (msg) { - // Create the MDI client invisible window - case WM_CREATE: - break; - case WM_PAINT: - hdc = BeginPaint(hwnd,&ps); - BitBlt(hdc,0,0,grwindow.width,grwindow.height, - grwindow.gcBitmap,0,0,SRCCOPY); - EndPaint(hwnd,&ps); - break; - // Move the child windows - case WM_SIZE: - // Position the MDI client window between the tool and status bars - if (wParam != SIZE_MINIMIZED) { - SetCoordinates(hwnd); - } - - return 0; - // End application - case WM_DESTROY: - ResetForClose(hwnd); - break; - case WM_LBUTTONDOWN: - MouseLbuttonDown = 1; - break; - case WM_LBUTTONUP: - MouseLbuttonDown = 0; - break; - case WM_RBUTTONDOWN: - MouseRbuttonDown = 1; - break; - case WM_RBUTTONUP: - MouseRbuttonDown = 0; - break; - case WM_MBUTTONDOWN: - MouseMbuttonDown = 1; - break; - case WM_MBUTTONUP: - MouseMbuttonDown = 0; - break; - case WM_CHAR: - LastKey = wParam & 0xFF; - break; - case WM_KEYUP: - LastKey = -1; - break; - case WM_MOUSEMOVE: -#if 0 - pt.x = GET_X_LPARAM(lParam); - pt.y = GET_Y_LPARAM(lParam); - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - MouseLastX = pt.x; - MouseLastY = grwindow.height - 1 - pt.y; -#else - MouseLastX = GET_X_LPARAM(lParam); - MouseLastY = grwindow.height - 1 - GET_Y_LPARAM(lParam); -#endif - break; - } - return DefWindowProc(hwnd,msg,wParam,lParam); -} - -int DoRegisterClass(void) -{ - WNDCLASS wc; - - memset(&wc,0,sizeof(WNDCLASS)); - wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS|CS_OWNDC ; - wc.lpfnWndProc = (WNDPROC)GraphicsWndProc; - wc.hInstance = hInst; - wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1); - wc.lpszClassName = szOcamlWindowClass; - wc.lpszMenuName = 0; - wc.hCursor = LoadCursor(NULL,IDC_ARROW); - wc.hIcon = 0; - return RegisterClass(&wc); -} - -static value gr_reset(void) -{ - RECT rc; - int screenx,screeny; - - screenx = GetSystemMetrics(SM_CXSCREEN); - screeny = GetSystemMetrics(SM_CYSCREEN); - GetClientRect(grwindow.hwnd,&rc); - grwindow.gc = GetDC(grwindow.hwnd); - grwindow.width = rc.right; - grwindow.height = rc.bottom; - if (grwindow.gcBitmap == (HDC)0) { - grwindow.hBitmap = CreateCompatibleBitmap(grwindow.gc,screenx,screeny); - grwindow.gcBitmap = CreateCompatibleDC(grwindow.gc); - grwindow.tempDC = CreateCompatibleDC(grwindow.gc); - SelectObject(grwindow.gcBitmap,grwindow.hBitmap); - SetMapMode(grwindow.gcBitmap,MM_TEXT); - MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0); - BitBlt(grwindow.gcBitmap,0,0,screenx,screeny, - grwindow.gcBitmap,0,0,WHITENESS); - grwindow.CurrentFontSize = 15; - grwindow.CurrentFont = CreationFont("Courier"); - } - grwindow.CurrentColor = GetSysColor(COLOR_WINDOWTEXT); - grwindow.grx = 0; - grwindow.gry = 0; - grwindow.CurrentPen = SelectObject(grwindow.gc,GetStockObject(WHITE_PEN)); - SelectObject(grwindow.gc,grwindow.CurrentPen); - SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); - grwindow.CurrentBrush = SelectObject(grwindow.gc,GetStockObject(WHITE_BRUSH)); - SelectObject(grwindow.gc,grwindow.CurrentBrush); - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - gr_set_color(Val_long(0)); - SelectObject(grwindow.gc,grwindow.CurrentFont); - SelectObject(grwindow.gcBitmap,grwindow.CurrentFont); - grdisplay_mode = grremember_mode = 1; - MoveToEx(grwindow.gc,0,grwindow.height-1,0); - MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0); - SetTextAlign(grwindow.gcBitmap,TA_BOTTOM); - SetTextAlign(grwindow.gc,TA_BOTTOM); - return Val_unit; -} - -void SuspendGraphicThread(void) -{ - SuspendThread(threadHandle); -} - -void ResumeGraphicThread(void) -{ - ResumeThread(threadHandle); -} - -/* For handshake between the event handling thread and the main thread */ -static char * open_graph_errmsg; -static HANDLE open_graph_event; - -static DWORD WINAPI gr_open_graph_internal(value arg) -{ - RECT rc; - int ret; - int event; - int x, y, w, h; - int screenx,screeny; - int attributes; - static int registered; - MSG msg; - - gr_initialized = TRUE; - hInst = GetModuleHandle(NULL); - x = y = w = h = CW_USEDEFAULT; - sscanf(String_val(arg), "%dx%d+%d+%d", &w, &h, &x, &y); - - /* Open the display */ - if (grwindow.hwnd == NULL || !IsWindow(grwindow.hwnd)) { - if (!registered) { - registered = DoRegisterClass(); - if (!registered) { - open_graph_errmsg = "Cannot register the window class"; - SetEvent(open_graph_event); - return 1; - } - } - grwindow.hwnd = CreateWindow(szOcamlWindowClass, - WINDOW_NAME, - WS_OVERLAPPEDWINDOW, - x,y, - w,h, - NULL,0,hInst,NULL); - if (grwindow.hwnd == NULL) { - open_graph_errmsg = "Cannot create window"; - SetEvent(open_graph_event); - return 1; - } -#if 0 - if (x != CW_USEDEFAULT) { - rc.left = 0; - rc.top = 0; - rc.right = w; - rc.bottom = h; - AdjustWindowRect(&rc,GetWindowLong(grwindow.hwnd,GWL_STYLE),0); - MoveWindow(grwindow.hwnd,x,y,rc.right-rc.left,rc.bottom-rc.top,1); - } -#endif - } - gr_reset(); - ShowWindow(grwindow.hwnd,SW_SHOWNORMAL); - - /* Position the current point at origin */ - grwindow.grx = 0; - grwindow.gry = 0; - - EventHandle = CreateEvent(NULL,0,0,NULL); - EventProcessedHandle = CreateEvent(NULL,0,0,NULL); - - /* The global data structures are now correctly initialized. - Restart the Caml main thread. */ - open_graph_errmsg = NULL; - SetEvent(open_graph_event); - - /* Enter the message handling loop */ - while (GetMessage(&msg,NULL,0,0)) { - if (InspectMessages != NULL) { - *InspectMessages = msg; - SetEvent(EventHandle); - } - TranslateMessage(&msg); // Translates virtual key codes - DispatchMessage(&msg); // Dispatches message to window - if (!IsWindow(grwindow.hwnd)) - break; - if (InspectMessages != NULL) { - WaitForSingleObject(EventProcessedHandle,INFINITE); - } - } - return 0; -} - -CAMLprim value gr_open_graph(value arg) -{ - long tid; - if (gr_initialized) return Val_unit; - open_graph_event = CreateEvent(NULL, FALSE, FALSE, NULL); - threadHandle = - CreateThread(NULL,0, - (LPTHREAD_START_ROUTINE)gr_open_graph_internal,(void **)arg, - 0, - &tid); - WaitForSingleObject(open_graph_event, INFINITE); - CloseHandle(open_graph_event); - if (open_graph_errmsg != NULL) gr_fail("%s", open_graph_errmsg); - return Val_unit; -} - -CAMLprim value gr_close_graph(void) -{ - if (gr_initialized) { - DeleteDC(grwindow.tempDC); - DeleteDC(grwindow.gcBitmap); - DestroyWindow(grwindow.hwnd); - memset(&grwindow,0,sizeof(grwindow)); - gr_initialized = 0; - } - return Val_unit; -} - -CAMLprim value gr_clear_graph(void) -{ - gr_check_open(); - if(grremember_mode) { - BitBlt(grwindow.gcBitmap,0,0,grwindow.width,grwindow.height, - grwindow.gcBitmap,0,0,WHITENESS); - } - if(grdisplay_mode) { - BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, - grwindow.gc,0,0,WHITENESS); - } - return Val_unit; -} - -CAMLprim value gr_size_x(void) -{ - gr_check_open(); - return Val_int(grwindow.width); -} - -CAMLprim value gr_size_y(void) -{ - gr_check_open(); - return Val_int(grwindow.height); -} - -CAMLprim value gr_synchronize(void) -{ - gr_check_open(); - BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, - grwindow.gcBitmap,0,0,SRCCOPY); - return Val_unit ; -} - -CAMLprim value gr_display_mode(value flag) -{ - grdisplay_mode = (Int_val(flag)) ? 1 : 0; - return Val_unit ; -} - -CAMLprim value gr_remember_mode(value flag) -{ - grremember_mode = (Int_val(flag)) ? 1 : 0; - return Val_unit ; -} - -CAMLprim value gr_sigio_signal(value unit) -{ - return Val_unit; -} - -CAMLprim value gr_sigio_handler(void) -{ - return Val_unit; -} - - -/* Processing of graphic errors */ - -value * caml_named_value (char * name); -static value * graphic_failure_exn = NULL; -void gr_fail(char *fmt, char *arg) -{ - char buffer[1024]; - - if (graphic_failure_exn == NULL) { - graphic_failure_exn = caml_named_value("Graphics.Graphic_failure"); - if (graphic_failure_exn == NULL) - invalid_argument("Exception Graphics.Graphic_failure not initialized, must link graphics.cma"); - } - sprintf(buffer, fmt, arg); - raise_with_string(*graphic_failure_exn, buffer); -} - -void gr_check_open(void) -{ - if (!gr_initialized) gr_fail("graphic screen not opened", NULL); -} - diff --git a/otherlibs/win32unix/.cvsignore b/otherlibs/win32unix/.cvsignore deleted file mode 100644 index 9aaa7161dd..0000000000 --- a/otherlibs/win32unix/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -unixLabels.ml* -unix.mli -unix.lib
\ No newline at end of file diff --git a/otherlibs/win32unix/.depend b/otherlibs/win32unix/.depend deleted file mode 100644 index 6e1130b18a..0000000000 --- a/otherlibs/win32unix/.depend +++ /dev/null @@ -1,5 +0,0 @@ -unix.cmo: unix.cmi -unix.cmx: unix.cmi -unixLabels.cmo: unix.cmi unixLabels.cmi -unixLabels.cmx: unix.cmx unixLabels.cmi -unixLabels.cmi: unix.cmi diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt deleted file mode 100644 index b873b16dda..0000000000 --- a/otherlibs/win32unix/Makefile.nt +++ /dev/null @@ -1,120 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 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, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -include ../../config/Makefile - -# Compilation options -CC=$(BYTECC) -CFLAGS=-I../../byterun -I../unix -CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -COMPFLAGS=-warn-error A - -# Files in this directory -WIN_FILES = accept.c bind.c channels.c close.c \ - close_on.c connect.c createprocess.c dup.c dup2.c errmsg.c \ - getpeername.c getpid.c getsockname.c gettimeofday.c \ - link.c listen.c lockf.c lseek.c nonblock.c \ - mkdir.c open.c pipe.c read.c rename.c \ - select.c sendrecv.c \ - shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \ - system.c unixsupport.c windir.c winwait.c write.c - -# Files from the ../unix directory -UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \ - cstringv.c envir.c execv.c execve.c execvp.c \ - exit.c getcwd.c gethost.c gethostname.c getproto.c \ - getserv.c gmtime.c putenv.c rmdir.c \ - socketaddr.c strofaddr.c time.c unlink.c utimes.c - -ALL_FILES=$(WIN_FILES) $(UNIX_FILES) - -DOBJS=$(ALL_FILES:.c=.$(DO)) -SOBJS=$(ALL_FILES:.c=.$(SO)) - -LIBS=$(call SYSLIB,wsock32) - -CAML_OBJS=unix.cmo unixLabels.cmo -CAMLOPT_OBJS=$(CAML_OBJS:.cmo=.cmx) - -UNIX_CAML_FILES = unix.mli unixLabels.mli unixLabels.ml - -all: dllunix.dll libunix.$(A) unix.cma - -allopt: libunix.$(A) unix.cmxa - -dllunix.dll: $(DOBJS) - $(call MKDLL,dllunix.dll,tmp.$(A),$(DOBJS) ../../byterun/ocamlrun.$(A) $(LIBS)) - rm tmp.* - -libunix.$(A): $(SOBJS) - $(call MKLIB,libunix.$(A),$(SOBJS)) - -$(DOBJS) $(SOBJS): unixsupport.h - -unix.cma: $(CAML_OBJS) - $(CAMLC) -a -linkall -o unix.cma $(CAML_OBJS) \ - -dllib -lunix -cclib -lunix -cclib $(LIBS) - -unix.cmxa: $(CAMLOPT_OBJS) - $(CAMLOPT) -a -linkall -o unix.cmxa $(CAMLOPT_OBJS) \ - -cclib -lunix -cclib $(LIBS) - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.$(A) *.dll *.$(O) - rm -f $(UNIX_FILES) $(UNIX_CAML_FILES) - -install: - cp dllunix.dll $(STUBLIBDIR)/dllunix.dll - cp libunix.$(A) $(LIBDIR)/libunix.$(A) - cp $(CAML_OBJS:.cmo=.cmi) unix.cma $(LIBDIR) - -installopt: - cp unix.cmxa $(CAML_OBJS:.cmo=.cmx) unix.$(A) $(LIBDIR) - -unixLabels.cmo: unixLabels.ml - $(CAMLC) -c $(COMPFLAGS) -nolabels unixLabels.ml - -unixLabels.cmx: unixLabels.ml - $(CAMLOPT) -c $(COMPFLAGS) -nolabels unixLabels.ml - -$(UNIX_FILES) $(UNIX_CAML_FILES): %: ../unix/% - cp ../unix/$* $* - -.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO) - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(SO) - -depend: - -include .depend diff --git a/otherlibs/win32unix/accept.c b/otherlibs/win32unix/accept.c deleted file mode 100644 index ec7068bd3c..0000000000 --- a/otherlibs/win32unix/accept.c +++ /dev/null @@ -1,67 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <signals.h> -#include "unixsupport.h" -#include "socketaddr.h" - -CAMLprim value unix_accept(sock) - value sock; -{ - SOCKET sconn = Socket_val(sock); - SOCKET snew; - value fd = Val_unit, adr = Val_unit, res; - int oldvalue, oldvaluelen, newvalue, retcode; - union sock_addr_union addr; - socklen_param_type addr_len; - int errcode = 0; - - oldvaluelen = sizeof(oldvalue); - retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, - (char *) &oldvalue, &oldvaluelen); - if (retcode == 0) { - /* Set sockets to synchronous mode */ - newvalue = SO_SYNCHRONOUS_NONALERT; - setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, - (char *) &newvalue, sizeof(newvalue)); - } - addr_len = sizeof(sock_addr); - enter_blocking_section(); - snew = accept(sconn, &addr.s_gen, &addr_len); - leave_blocking_section(); - if( snew == INVALID_SOCKET ) - errcode = WSAGetLastError (); - if (retcode == 0) { - /* Restore initial mode */ - setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, - (char *) &oldvalue, oldvaluelen); - } - if (snew == INVALID_SOCKET) { - win32_maperr(errcode); - uerror("accept", Nothing); - } - Begin_roots2 (fd, adr) - fd = win_alloc_socket(snew); - adr = alloc_sockaddr(&addr, addr_len); - res = alloc_small(2, 0); - Field(res, 0) = fd; - Field(res, 1) = adr; - End_roots(); - return res; -} - diff --git a/otherlibs/win32unix/bind.c b/otherlibs/win32unix/bind.c deleted file mode 100644 index 0a17c8d513..0000000000 --- a/otherlibs/win32unix/bind.c +++ /dev/null @@ -1,34 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" -#include "socketaddr.h" - -CAMLprim value unix_bind(socket, address) - value socket, address; -{ - int ret; - union sock_addr_union addr; - socklen_param_type addr_len; - - get_sockaddr(address, &addr, &addr_len); - ret = bind(Socket_val(socket), &addr.s_gen, addr_len); - if (ret == -1) { - win32_maperr(WSAGetLastError()); - uerror("bind", Nothing); - } - return Val_unit; -} diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c deleted file mode 100644 index 176aab9f5c..0000000000 --- a/otherlibs/win32unix/channels.c +++ /dev/null @@ -1,43 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" -#include <fcntl.h> - -extern long _get_osfhandle(int); -extern int _open_osfhandle(long, int); - -CAMLprim value win_fd_handle(value handle) -{ - int fd; - if (CRT_fd_val(handle) != NO_CRT_FD) { - fd = CRT_fd_val(handle); - } else { - fd = _open_osfhandle((long) Handle_val(handle), O_BINARY); - if (fd == -1) uerror("channel_of_descr", Nothing); - CRT_fd_val(handle) = fd; - } - return Val_int(fd); -} - -CAMLprim value win_handle_fd(value vfd) -{ - int crt_fd = Int_val(vfd); - value res = win_alloc_handle_or_socket((HANDLE) _get_osfhandle(crt_fd)); - CRT_fd_val(res) = crt_fd; - return res; -} diff --git a/otherlibs/win32unix/close.c b/otherlibs/win32unix/close.c deleted file mode 100644 index 48cd60e7aa..0000000000 --- a/otherlibs/win32unix/close.c +++ /dev/null @@ -1,33 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_close(value fd) -{ - if (Descr_kind_val(fd) == KIND_SOCKET) { - if (closesocket(Socket_val(fd)) != 0) { - win32_maperr(WSAGetLastError()); - uerror("close", Nothing); - } - } else { - if (! CloseHandle(Handle_val(fd))) { - win32_maperr(GetLastError()); - uerror("close", Nothing); - } - } - return Val_unit; -} diff --git a/otherlibs/win32unix/close_on.c b/otherlibs/win32unix/close_on.c deleted file mode 100644 index 5b2c4ece32..0000000000 --- a/otherlibs/win32unix/close_on.c +++ /dev/null @@ -1,46 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <windows.h> -#include "unixsupport.h" - -int win_set_inherit(value fd, BOOL inherit) -{ - HANDLE oldh, newh; - - oldh = Handle_val(fd); - if (! DuplicateHandle(GetCurrentProcess(), oldh, - GetCurrentProcess(), &newh, - 0L, inherit, DUPLICATE_SAME_ACCESS)) { - win32_maperr(GetLastError()); - return -1; - } - Handle_val(fd) = newh; - CloseHandle(oldh); - return 0; -} - -CAMLprim value win_set_close_on_exec(value fd) -{ - if (win_set_inherit(fd, FALSE) == -1) uerror("set_close_on_exec", Nothing); - return Val_unit; -} - -CAMLprim value win_clear_close_on_exec(value fd) -{ - if (win_set_inherit(fd, TRUE) == -1) uerror("clear_close_on_exec", Nothing); - return Val_unit; -} diff --git a/otherlibs/win32unix/connect.c b/otherlibs/win32unix/connect.c deleted file mode 100644 index 74e62252d8..0000000000 --- a/otherlibs/win32unix/connect.c +++ /dev/null @@ -1,38 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <signals.h> -#include "unixsupport.h" -#include "socketaddr.h" - -CAMLprim value unix_connect(socket, address) - value socket, address; -{ - SOCKET s = Socket_val(socket); - int retcode; - union sock_addr_union addr; - socklen_param_type addr_len; - - get_sockaddr(address, &addr, &addr_len); - enter_blocking_section(); - retcode = connect(s, &addr.s_gen, addr_len); - leave_blocking_section(); - if (retcode == -1) { - win32_maperr(WSAGetLastError()); - uerror("connect", Nothing); - } - return Val_unit; -} diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c deleted file mode 100644 index 8a92d18f03..0000000000 --- a/otherlibs/win32unix/createprocess.c +++ /dev/null @@ -1,87 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <windows.h> -#include <mlvalues.h> -#include <osdeps.h> -#include "unixsupport.h" - -static int win_has_console(void); - -value win_create_process_native(value cmd, value cmdline, value env, - value fd1, value fd2, value fd3) -{ - PROCESS_INFORMATION pi; - STARTUPINFO si; - char * exefile, * envp; - int flags; - - exefile = search_exe_in_path(String_val(cmd)); - if (env != Val_int(0)) { - envp = String_val(Field(env, 0)); - } else { - envp = NULL; - } - /* Prepare stdin/stdout/stderr redirection */ - GetStartupInfo(&si); - si.dwFlags |= STARTF_USESTDHANDLES; - si.hStdInput = Handle_val(fd1); - si.hStdOutput = Handle_val(fd2); - si.hStdError = Handle_val(fd3); - /* If we do not have a console window, then we must create one - before running the process (keep it hidden for apparence). - Also one must suppress spurious flags in si.dwFlags. - Otherwise the redirections are ignored. - If we are starting a GUI application, the newly created - console should not matter. */ - if (win_has_console()) - flags = 0; - else { - flags = CREATE_NEW_CONSOLE; - si.dwFlags = (STARTF_USESHOWWINDOW | STARTF_USESTDHANDLES); - si.wShowWindow = SW_HIDE; - } - /* Create the process */ - if (! CreateProcess(exefile, String_val(cmdline), NULL, NULL, - TRUE, flags, envp, NULL, &si, &pi)) { - win32_maperr(GetLastError()); - uerror("create_process", cmd); - } - CloseHandle(pi.hThread); - /* Return the process handle as pseudo-PID - (this is consistent with the wait() emulation in the MSVC C library */ - return Val_int(pi.hProcess); -} - -CAMLprim value win_create_process(value * argv, int argn) -{ - return win_create_process_native(argv[0], argv[1], argv[2], - argv[3], argv[4], argv[5]); -} - -static int win_has_console(void) -{ - HANDLE h, log; - int i; - - h = CreateFile("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, NULL, - OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); - if (h == INVALID_HANDLE_VALUE) { - return 0; - } else { - CloseHandle(h); - return 1; - } -} diff --git a/otherlibs/win32unix/dup.c b/otherlibs/win32unix/dup.c deleted file mode 100644 index de2ea74499..0000000000 --- a/otherlibs/win32unix/dup.c +++ /dev/null @@ -1,34 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_dup(value fd) -{ - HANDLE newh; - value newfd; - int kind = Descr_kind_val(fd); - if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd), - GetCurrentProcess(), &newh, - 0L, TRUE, DUPLICATE_SAME_ACCESS)) { - win32_maperr(GetLastError()); - return -1; - } - newfd = win_alloc_handle(newh); - Descr_kind_val(newfd) = kind; - return newfd; -} - diff --git a/otherlibs/win32unix/dup2.c b/otherlibs/win32unix/dup2.c deleted file mode 100644 index 4be2d819fb..0000000000 --- a/otherlibs/win32unix/dup2.c +++ /dev/null @@ -1,43 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -extern value win_fd_handle(value); -extern int _dup2(int, int); - -CAMLprim value unix_dup2(value fd1, value fd2) -{ - HANDLE oldh, newh; - - oldh = Handle_val(fd2); - if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd1), - GetCurrentProcess(), &newh, - 0L, TRUE, DUPLICATE_SAME_ACCESS)) { - win32_maperr(GetLastError()); - return -1; - } - Handle_val(fd2) = newh; - if (Descr_kind_val(fd2) == KIND_SOCKET) - closesocket((SOCKET) oldh); - else - CloseHandle(oldh); - Descr_kind_val(fd2) = Descr_kind_val(fd1); - /* Reflect the dup2 on the CRT fds, if any */ - if (CRT_fd_val(fd1) != NO_CRT_FD || CRT_fd_val(fd2) != NO_CRT_FD) - _dup2(Int_val(win_fd_handle(fd1)), Int_val(win_fd_handle(fd2))); - return Val_unit; -} diff --git a/otherlibs/win32unix/errmsg.c b/otherlibs/win32unix/errmsg.c deleted file mode 100644 index 20a8c8d58f..0000000000 --- a/otherlibs/win32unix/errmsg.c +++ /dev/null @@ -1,44 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <stdio.h> -#include <errno.h> -#include <string.h> -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" - -extern int error_table[]; - -CAMLprim value unix_error_message(value err) -{ - int errnum; - char buffer[512]; - - errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)]; - if (errnum > 0) - return copy_string(strerror(errnum)); - if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, - NULL, - -errnum, - 0, - buffer, - sizeof(buffer), - NULL)) - return copy_string(buffer); - sprintf(buffer, "unknown error #%d", errnum); - return copy_string(buffer); -} - diff --git a/otherlibs/win32unix/getpeername.c b/otherlibs/win32unix/getpeername.c deleted file mode 100644 index 4460a7917c..0000000000 --- a/otherlibs/win32unix/getpeername.c +++ /dev/null @@ -1,35 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" -#include "socketaddr.h" - -CAMLprim value unix_getpeername(sock) - value sock; -{ - int retcode; - union sock_addr_union addr; - socklen_param_type addr_len; - - addr_len = sizeof(sock_addr); - retcode = getpeername(Socket_val(sock), - &addr.s_gen, &addr_len); - if (retcode == -1) { - win32_maperr(WSAGetLastError()); - uerror("getpeername", Nothing); - } - return alloc_sockaddr(&addr, addr_len); -} diff --git a/otherlibs/win32unix/getpid.c b/otherlibs/win32unix/getpid.c deleted file mode 100644 index 0892f8f95c..0000000000 --- a/otherlibs/win32unix/getpid.c +++ /dev/null @@ -1,24 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -extern value val_process_id; - -CAMLprim value unix_getpid(value unit) -{ - return val_process_id; -} diff --git a/otherlibs/win32unix/getsockname.c b/otherlibs/win32unix/getsockname.c deleted file mode 100644 index 8a1de78570..0000000000 --- a/otherlibs/win32unix/getsockname.c +++ /dev/null @@ -1,32 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" -#include "socketaddr.h" - -CAMLprim value unix_getsockname(sock) - value sock; -{ - int retcode; - union sock_addr_union addr; - socklen_param_type addr_len; - - addr_len = sizeof(sock_addr); - retcode = getsockname(Socket_val(sock), - &addr.s_gen, &addr_len); - if (retcode == -1) uerror("getsockname", Nothing); - return alloc_sockaddr(&addr, addr_len); -} diff --git a/otherlibs/win32unix/gettimeofday.c b/otherlibs/win32unix/gettimeofday.c deleted file mode 100644 index c7ee376cdd..0000000000 --- a/otherlibs/win32unix/gettimeofday.c +++ /dev/null @@ -1,35 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <time.h> - -#include "unixsupport.h" - -static time_t initial_time = 0; /* 0 means uninitialized */ -static DWORD initial_tickcount; - -CAMLprim value unix_gettimeofday(value unit) -{ - if (initial_time == 0) { - initial_tickcount = GetTickCount(); - initial_time = time(NULL); - return copy_double((double) initial_time); - } else { - return copy_double(initial_time + - (GetTickCount() - initial_tickcount) * 1e-3); - } -} diff --git a/otherlibs/win32unix/link.c b/otherlibs/win32unix/link.c deleted file mode 100644 index 26202ed986..0000000000 --- a/otherlibs/win32unix/link.c +++ /dev/null @@ -1,42 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* File contributed by Lionel Fourquaux */ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <windows.h> -#include <mlvalues.h> -#include <fail.h> -#include "unixsupport.h" - -typedef -BOOL (WINAPI *tCreateHardLink)( - LPCTSTR lpFileName, - LPCTSTR lpExistingFileName, - LPSECURITY_ATTRIBUTES lpSecurityAttributes -); - -CAMLprim value unix_link(value path1, value path2) -{ - HMODULE hModKernel32; - tCreateHardLink pCreateHardLink; - hModKernel32 = GetModuleHandle("KERNEL32.DLL"); - pCreateHardLink = - (tCreateHardLink) GetProcAddress(hModKernel32, "CreateHardLinkA"); - if (pCreateHardLink == NULL) - invalid_argument("Unix.link not implemented"); - if (! pCreateHardLink(String_val(path2), String_val(path1), NULL)) { - win32_maperr(GetLastError()); - uerror("link", path2); - } - return Val_unit; -} diff --git a/otherlibs/win32unix/listen.c b/otherlibs/win32unix/listen.c deleted file mode 100644 index 20789e1a4c..0000000000 --- a/otherlibs/win32unix/listen.c +++ /dev/null @@ -1,27 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_listen(sock, backlog) - value sock, backlog; -{ - if (listen(Socket_val(sock), Int_val(backlog)) == -1) { - win32_maperr(WSAGetLastError()); - uerror("listen", Nothing); - } - return Val_unit; -} diff --git a/otherlibs/win32unix/lockf.c b/otherlibs/win32unix/lockf.c deleted file mode 100644 index 9183052817..0000000000 --- a/otherlibs/win32unix/lockf.c +++ /dev/null @@ -1,206 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Contributed by Tracy Camp, PolyServe Inc., <campt@polyserve.com> */ -/* */ -/* Copyright 2002 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* under the terms of the GNU Library General Public License. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <errno.h> -#include <fcntl.h> -#include <mlvalues.h> -#include <fail.h> -#include "unixsupport.h" -#include <stdio.h> - -/* - -Commands for Unix.lockf: - -type 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 *) - - -val lockf : file_descr -> lock_command -> int -> unitlockf 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 Unix.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. -*/ - -#ifndef INVALID_SET_FILE_POINTER -#define INVALID_SET_FILE_POINTER (-1) -#endif - -static void set_file_pointer(HANDLE h, LARGE_INTEGER dest, - PLARGE_INTEGER cur, DWORD method) -{ - LONG high = dest.HighPart; - DWORD ret = SetFilePointer(h, dest.LowPart, &high, method); - if (ret == INVALID_SET_FILE_POINTER) { - long err = GetLastError(); - if (err != NO_ERROR) { win32_maperr(err); uerror("lockf", Nothing); } - } - if (cur != NULL) { cur->LowPart = ret; cur->HighPart = high; } -} - -CAMLprim value unix_lockf(value fd, value cmd, value span) -{ - int ret; - OVERLAPPED overlap; - DWORD l_start; - DWORD l_len; - HANDLE h; - OSVERSIONINFO VersionInfo; - LARGE_INTEGER cur_position; - LARGE_INTEGER end_position; - LARGE_INTEGER offset_position; - - VersionInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - if(GetVersionEx(&VersionInfo) == 0) - { - invalid_argument("lockf only supported on WIN32_NT platforms: could not determine current platform."); - } -/* file locking only exists on NT versions */ - if(VersionInfo.dwPlatformId != VER_PLATFORM_WIN32_NT) - { - invalid_argument("lockf only supported on WIN32_NT platforms"); - } - - h = Handle_val(fd); - - overlap.Offset = 0; - overlap.OffsetHigh = 0; - overlap.hEvent = 0; - l_len = Long_val(span); - - offset_position.HighPart = 0; - cur_position.HighPart = 0; - end_position.HighPart = 0; - offset_position.LowPart = 0; - cur_position.LowPart = 0; - end_position.LowPart = 0; - - if(l_len == 0) - { -/* save current pointer */ - set_file_pointer(h,offset_position,&cur_position,FILE_CURRENT); -/* set to end and query */ - set_file_pointer(h,offset_position,&end_position,FILE_END); - l_len = end_position.LowPart; -/* restore previous current pointer */ - set_file_pointer(h,cur_position,NULL,FILE_BEGIN); - } - else - { - if (l_len < 0) - { - set_file_pointer(h,offset_position,&cur_position,FILE_CURRENT); - l_len = abs(l_len); - if(l_len > cur_position.LowPart) - { - errno = EINVAL; - uerror("lockf", Nothing); - return Val_unit; - } - overlap.Offset = cur_position.LowPart - l_len; - } - } - switch (Int_val(cmd)) - { - case 0: /* F_ULOCK */ - if(UnlockFileEx(h, 0, l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - case 1: /* F_LOCK */ -/* this should block until write lock is obtained */ - if(LockFileEx(h,LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - case 2: /* F_TLOCK */ -/* - * this should return immediately if write lock can-not - * be obtained. - */ - if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - case 3: /* F_TEST */ -/* - * I'm doing this by aquiring an immediate write - * lock and then releasing it. It is not clear that - * this behavior matches anything in particular, but - * it is not clear the nature of the lock test performed - * by ocaml (unix) currently. - */ - if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - else - { - UnlockFileEx(h, 0, l_len,0,&overlap); - ret = 0; - } - break; - case 4: /* F_RLOCK */ -/* this should block until read lock is obtained */ - if(LockFileEx(h,0,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - case 5: /* F_TRLOCK */ -/* - * this should return immediately if read lock can-not - * be obtained. - */ - if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - default: - errno = EINVAL; - ret = -1; - } - if (ret == -1) uerror("lockf", Nothing); - return Val_unit; -} - diff --git a/otherlibs/win32unix/lseek.c b/otherlibs/win32unix/lseek.c deleted file mode 100644 index acc7b10044..0000000000 --- a/otherlibs/win32unix/lseek.c +++ /dev/null @@ -1,76 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" - -#ifdef HAS_UNISTD -#include <unistd.h> -#else -#define SEEK_SET 0 -#define SEEK_CUR 1 -#define SEEK_END 2 -#endif - -static int seek_command_table[] = { - FILE_BEGIN, FILE_CURRENT, FILE_END -}; - -#ifndef INVALID_SET_FILE_POINTER -#define INVALID_SET_FILE_POINTER (-1) -#endif - -CAMLprim value unix_lseek(value fd, value ofs, value cmd) -{ - long ret; - long ofs_low = Long_val(ofs); - long ofs_high = ofs_low >= 0 ? 0 : -1; - long err; - - ret = SetFilePointer(Handle_val(fd), ofs_low, &ofs_high, - seek_command_table[Int_val(cmd)]); - if (ret == INVALID_SET_FILE_POINTER) { - err = GetLastError(); - if (err != NO_ERROR) { - win32_maperr(err); - uerror("lseek", Nothing); - } - } - if (ofs_high != 0 || ret > Max_long) { - win32_maperr(ERROR_ARITHMETIC_OVERFLOW); - uerror("lseek", Nothing); - } - return Val_long(ret); -} - -CAMLprim value unix_lseek_64(value fd, value ofs, value cmd) -{ - long ret; - long ofs_low = (long) Int64_val(ofs); - long ofs_high = (long) (Int64_val(ofs) >> 32); - long err; - - ret = SetFilePointer(Handle_val(fd), ofs_low, &ofs_high, - seek_command_table[Int_val(cmd)]); - if (ret == INVALID_SET_FILE_POINTER) { - err = GetLastError(); - if (err != NO_ERROR) { - win32_maperr(err); - uerror("lseek", Nothing); - } - } - return copy_int64((int64) ofs_high << 32 | ret); -} diff --git a/otherlibs/win32unix/mkdir.c b/otherlibs/win32unix/mkdir.c deleted file mode 100644 index aae54783bc..0000000000 --- a/otherlibs/win32unix/mkdir.c +++ /dev/null @@ -1,24 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_mkdir(path, perm) - value path, perm; -{ - if (_mkdir(String_val(path)) == -1) uerror("mkdir", path); - return Val_unit; -} diff --git a/otherlibs/win32unix/nonblock.c b/otherlibs/win32unix/nonblock.c deleted file mode 100755 index 733a79d89f..0000000000 --- a/otherlibs/win32unix/nonblock.c +++ /dev/null @@ -1,42 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <signals.h> -#include "unixsupport.h" - -CAMLprim value unix_set_nonblock(socket) - value socket; -{ - u_long non_block = 1; - - if (ioctlsocket(Socket_val(socket), FIONBIO, &non_block) != 0) { - win32_maperr(WSAGetLastError()); - uerror("unix_set_nonblock", Nothing); - } - return Val_unit; -} - -CAMLprim value unix_clear_nonblock(socket) - value socket; -{ - u_long non_block = 0; - - if (ioctlsocket(Socket_val(socket), FIONBIO, &non_block) != 0) { - win32_maperr(WSAGetLastError()); - uerror("unix_clear_nonblock", Nothing); - } - return Val_unit; -} diff --git a/otherlibs/win32unix/open.c b/otherlibs/win32unix/open.c deleted file mode 100644 index 76e73e3aef..0000000000 --- a/otherlibs/win32unix/open.c +++ /dev/null @@ -1,66 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" -#include <fcntl.h> - -static int open_access_flags[8] = { - GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE, 0, 0, 0, 0, 0, -}; - -static int open_create_flags[8] = { - 0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL -}; - -CAMLprim value unix_open(value path, value flags, value perm) -{ - int fileaccess, createflags, fileattrib, filecreate; - SECURITY_ATTRIBUTES attr; - HANDLE h; - - fileaccess = convert_flag_list(flags, open_access_flags); - - createflags = convert_flag_list(flags, open_create_flags); - if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL)) - filecreate = CREATE_NEW; - else if ((createflags & (O_CREAT | O_TRUNC)) == (O_CREAT | O_TRUNC)) - filecreate = CREATE_ALWAYS; - else if (createflags & O_TRUNC) - filecreate = TRUNCATE_EXISTING; - else if (createflags & O_CREAT) - filecreate = OPEN_ALWAYS; - else - filecreate = OPEN_EXISTING; - - if ((createflags & O_CREAT) && (Int_val(perm) & 0200) == 0) - fileattrib = FILE_ATTRIBUTE_READONLY; - else - fileattrib = FILE_ATTRIBUTE_NORMAL; - - attr.nLength = sizeof(attr); - attr.lpSecurityDescriptor = NULL; - attr.bInheritHandle = TRUE; - - h = CreateFile(String_val(path), fileaccess, - FILE_SHARE_READ | FILE_SHARE_WRITE, &attr, - filecreate, fileattrib, NULL); - if (h == INVALID_HANDLE_VALUE) { - win32_maperr(GetLastError()); - uerror("open", path); - } - return win_alloc_handle(h); -} diff --git a/otherlibs/win32unix/pipe.c b/otherlibs/win32unix/pipe.c deleted file mode 100644 index 67e3812989..0000000000 --- a/otherlibs/win32unix/pipe.c +++ /dev/null @@ -1,45 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> -#include "unixsupport.h" -#include <fcntl.h> - -#define SIZEBUF 1024 - -CAMLprim value unix_pipe(value unit) -{ - SECURITY_ATTRIBUTES attr; - HANDLE readh, writeh; - value readfd = Val_unit, writefd = Val_unit, res; - - attr.nLength = sizeof(attr); - attr.lpSecurityDescriptor = NULL; - attr.bInheritHandle = TRUE; - if (! CreatePipe(&readh, &writeh, &attr, SIZEBUF)) { - win32_maperr(GetLastError()); - uerror("pipe", Nothing); - } - Begin_roots2(readfd, writefd) - readfd = win_alloc_handle(readh); - writefd = win_alloc_handle(writeh); - res = alloc_small(2, 0); - Field(res, 0) = readfd; - Field(res, 1) = writefd; - End_roots(); - return res; -} diff --git a/otherlibs/win32unix/read.c b/otherlibs/win32unix/read.c deleted file mode 100644 index 704cec2c7a..0000000000 --- a/otherlibs/win32unix/read.c +++ /dev/null @@ -1,55 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <string.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> -#include "unixsupport.h" - -CAMLprim value unix_read(value fd, value buf, value ofs, value len) -{ - DWORD numbytes, numread; - char iobuf[UNIX_BUFFER_SIZE]; - - Begin_root (buf); - numbytes = Long_val(len); - if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; - if (Descr_kind_val(fd) == KIND_SOCKET) { - int ret; - SOCKET s = Socket_val(fd); - enter_blocking_section(); - ret = recv(s, iobuf, numbytes, 0); - leave_blocking_section(); - if (ret == SOCKET_ERROR) { - win32_maperr(WSAGetLastError()); - uerror("read", Nothing); - } - numread = ret; - } else { - BOOL ret; - HANDLE h = Handle_val(fd); - enter_blocking_section(); - ret = ReadFile(h, iobuf, numbytes, &numread, NULL); - leave_blocking_section(); - if (! ret) { - win32_maperr(GetLastError()); - uerror("read", Nothing); - } - } - memmove (&Byte(buf, Long_val(ofs)), iobuf, numread); - End_roots(); - return Val_int(numread); -} diff --git a/otherlibs/win32unix/rename.c b/otherlibs/win32unix/rename.c deleted file mode 100644 index d84bcd66ac..0000000000 --- a/otherlibs/win32unix/rename.c +++ /dev/null @@ -1,29 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Contributed by Tracy Camp, PolyServe Inc., <campt@polyserve.com> */ -/* */ -/* Copyright 2002 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <stdio.h> -#include <mlvalues.h> -#include "unixsupport.h" - -CAMLprim value unix_rename(value path1, value path2) -{ - if (MoveFileEx(String_val(path1), String_val(path2), - MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH | - MOVEFILE_COPY_ALLOWED) == 0) { - win32_maperr(GetLastError()); - uerror("rename", path1); - } - return Val_unit; -} diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c deleted file mode 100644 index 4fa8e788b8..0000000000 --- a/otherlibs/win32unix/select.c +++ /dev/null @@ -1,99 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <signals.h> -#include "unixsupport.h" - -static void fdlist_to_fdset(value fdlist, fd_set *fdset) -{ - value l; - FD_ZERO(fdset); - for (l = fdlist; l != Val_int(0); l = Field(l, 1)) { - FD_SET(Socket_val(Field(l, 0)), fdset); - } -} - -static value fdset_to_fdlist(value fdlist, fd_set *fdset) -{ - value res = Val_int(0); - Begin_roots2(fdlist, res) - for (/*nothing*/; fdlist != Val_int(0); fdlist = Field(fdlist, 1)) { - value s = Field(fdlist, 0); - if (FD_ISSET(Socket_val(s), fdset)) { - value newres = alloc_small(2, 0); - Field(newres, 0) = s; - Field(newres, 1) = res; - res = newres; - } - } - End_roots(); - return res; -} - -CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout) -{ - fd_set read, write, except; - double tm; - struct timeval tv; - struct timeval * tvp; - int retcode; - value res; - value read_list = Val_unit, write_list = Val_unit, except_list = Val_unit; - - Begin_roots3 (readfds, writefds, exceptfds) - Begin_roots3 (read_list, write_list, except_list) - tm = Double_val(timeout); - if (readfds == Val_int(0) - && writefds == Val_int(0) - && exceptfds == Val_int(0)) { - if ( tm > 0.0 ) { - enter_blocking_section(); - Sleep( (int)(tm * 1000)); - leave_blocking_section(); - } - read_list = write_list = except_list = Val_int(0); - } else { - fdlist_to_fdset(readfds, &read); - fdlist_to_fdset(writefds, &write); - fdlist_to_fdset(exceptfds, &except); - if (tm < 0.0) - tvp = (struct timeval *) NULL; - else { - tv.tv_sec = (int) tm; - tv.tv_usec = (int) (1e6 * (tm - (int) tm)); - tvp = &tv; - } - enter_blocking_section(); - retcode = select(FD_SETSIZE, &read, &write, &except, tvp); - leave_blocking_section(); - if (retcode == -1) { - win32_maperr(WSAGetLastError()); - uerror("select", Nothing); - } - read_list = fdset_to_fdlist(readfds, &read); - write_list = fdset_to_fdlist(writefds, &write); - except_list = fdset_to_fdlist(exceptfds, &except); - } - res = alloc_small(3, 0); - Field(res, 0) = read_list; - Field(res, 1) = write_list; - Field(res, 2) = except_list; - End_roots(); - End_roots(); - return res; -} diff --git a/otherlibs/win32unix/sendrecv.c b/otherlibs/win32unix/sendrecv.c deleted file mode 100644 index 57ca0fdb2f..0000000000 --- a/otherlibs/win32unix/sendrecv.c +++ /dev/null @@ -1,133 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <signals.h> -#include "unixsupport.h" -#include "socketaddr.h" - -static int msg_flag_table[] = { - MSG_OOB, MSG_DONTROUTE, MSG_PEEK -}; - -CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags) -{ - int ret; - long numbytes; - char iobuf[UNIX_BUFFER_SIZE]; - - Begin_root (buff); - numbytes = Long_val(len); - if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; - enter_blocking_section(); - ret = recv(Socket_val(sock), iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table)); - leave_blocking_section(); - if (ret == -1) { - win32_maperr(WSAGetLastError()); - uerror("recv", Nothing); - } - memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); - End_roots(); - return Val_int(ret); -} - -CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags) -{ - int ret; - long numbytes; - char iobuf[UNIX_BUFFER_SIZE]; - value res; - value adr = Val_unit; - union sock_addr_union addr; - socklen_param_type addr_len; - - Begin_roots2 (buff, adr); - numbytes = Long_val(len); - if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; - addr_len = sizeof(sock_addr); - enter_blocking_section(); - ret = recvfrom(Socket_val(sock), - iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table), - &addr.s_gen, &addr_len); - leave_blocking_section(); - if (ret == -1) { - win32_maperr(WSAGetLastError()); - uerror("recvfrom", Nothing); - } - memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); - adr = alloc_sockaddr(&addr, addr_len); - res = alloc_small(2, 0); - Field(res, 0) = Val_int(ret); - Field(res, 1) = adr; - End_roots(); - return res; -} - -CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags) -{ - int ret; - long numbytes; - char iobuf[UNIX_BUFFER_SIZE]; - - numbytes = Long_val(len); - if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; - memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); - enter_blocking_section(); - ret = send(Socket_val(sock), iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table)); - leave_blocking_section(); - if (ret == -1) { - win32_maperr(WSAGetLastError()); - uerror("send", Nothing); - } - return Val_int(ret); -} - -value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest) -{ - int ret; - long numbytes; - char iobuf[UNIX_BUFFER_SIZE]; - union sock_addr_union addr; - socklen_param_type addr_len; - - get_sockaddr(dest, &addr, &addr_len); - numbytes = Long_val(len); - if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; - memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); - enter_blocking_section(); - ret = sendto(Socket_val(sock), - iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table), - &addr.s_gen, addr_len); - leave_blocking_section(); - if (ret == -1) { - win32_maperr(WSAGetLastError()); - uerror("sendto", Nothing); - } - return Val_int(ret); -} - -CAMLprim value unix_sendto(argv, argc) - value * argv; - int argc; -{ - return unix_sendto_native - (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} diff --git a/otherlibs/win32unix/shutdown.c b/otherlibs/win32unix/shutdown.c deleted file mode 100644 index f3d2c6e03f..0000000000 --- a/otherlibs/win32unix/shutdown.c +++ /dev/null @@ -1,32 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -static int shutdown_command_table[] = { - 0, 1, 2 -}; - -CAMLprim value unix_shutdown(sock, cmd) - value sock, cmd; -{ - if (shutdown(Socket_val(sock), - shutdown_command_table[Int_val(cmd)]) == -1) { - win32_maperr(WSAGetLastError()); - uerror("shutdown", Nothing); - } - return Val_unit; -} diff --git a/otherlibs/win32unix/sleep.c b/otherlibs/win32unix/sleep.c deleted file mode 100644 index 421e5f9023..0000000000 --- a/otherlibs/win32unix/sleep.c +++ /dev/null @@ -1,27 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <signals.h> -#include "unixsupport.h" - -CAMLprim value unix_sleep(t) - value t; -{ - enter_blocking_section(); - Sleep(Int_val(t) * 1000); - leave_blocking_section(); - return Val_unit; -} diff --git a/otherlibs/win32unix/socket.c b/otherlibs/win32unix/socket.c deleted file mode 100644 index 079473f81f..0000000000 --- a/otherlibs/win32unix/socket.c +++ /dev/null @@ -1,55 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include "unixsupport.h" - -int socket_domain_table[] = { - PF_UNIX, PF_INET -}; - -int socket_type_table[] = { - SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET -}; - -CAMLprim value unix_socket(domain, type, proto) - value domain, type, proto; -{ - SOCKET s; - int oldvalue, oldvaluelen, newvalue, retcode; - - oldvaluelen = sizeof(oldvalue); - retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, - (char *) &oldvalue, &oldvaluelen); - if (retcode == 0) { - /* Set sockets to synchronous mode */ - newvalue = SO_SYNCHRONOUS_NONALERT; - setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, - (char *) &newvalue, sizeof(newvalue)); - } - s = socket(socket_domain_table[Int_val(domain)], - socket_type_table[Int_val(type)], - Int_val(proto)); - if (retcode == 0) { - /* Restore initial mode */ - setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, - (char *) &oldvalue, oldvaluelen); - } - if (s == INVALID_SOCKET) { - win32_maperr(WSAGetLastError()); - uerror("socket", Nothing); - } - return win_alloc_socket(s); -} diff --git a/otherlibs/win32unix/socketaddr.h b/otherlibs/win32unix/socketaddr.h deleted file mode 100644 index 2b7884f305..0000000000 --- a/otherlibs/win32unix/socketaddr.h +++ /dev/null @@ -1,38 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <misc.h> - -union sock_addr_union { - struct sockaddr s_gen; - struct sockaddr_in s_inet; -}; - -extern union sock_addr_union sock_addr; - -#ifdef HAS_SOCKLEN_T -typedef socklen_t socklen_param_type; -#else -typedef int socklen_param_type; -#endif - -void get_sockaddr (value mladdr, - union sock_addr_union * addr /*out*/, - socklen_param_type * addr_len /*out*/); -value alloc_sockaddr (union sock_addr_union * addr /*in*/, - socklen_param_type addr_len); -value alloc_inet_addr (uint32 inaddr); - -#define GET_INET_ADDR(v) (*((uint32 *) (v))) diff --git a/otherlibs/win32unix/sockopt.c b/otherlibs/win32unix/sockopt.c deleted file mode 100644 index 13d6a03e3e..0000000000 --- a/otherlibs/win32unix/sockopt.c +++ /dev/null @@ -1,157 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <alloc.h> -#include "unixsupport.h" - -static int sockopt_bool[] = { - SO_DEBUG, SO_BROADCAST, SO_REUSEADDR, SO_KEEPALIVE, - SO_DONTROUTE, SO_OOBINLINE, SO_ACCEPTCONN }; - -static int sockopt_int[] = { - SO_SNDBUF, SO_RCVBUF, SO_ERROR, SO_TYPE, SO_RCVLOWAT, SO_SNDLOWAT }; - -static int sockopt_optint[] = { SO_LINGER }; - -static int sockopt_float[] = { SO_RCVTIMEO, SO_SNDTIMEO }; - -CAMLprim value getsockopt_int(int *sockopt, value socket, - int level, value option) -{ - int optval; - int optsize; - - optsize = sizeof(optval); - if (getsockopt(Socket_val(socket), - level, sockopt[Int_val(option)], - (void *) &optval, &optsize) == -1) - uerror("getsockopt", Nothing); - return Val_int(optval); -} - -CAMLprim value setsockopt_int(int *sockopt, value socket, int level, - value option, value status) -{ - int optval = Int_val(status); - if (setsockopt(Socket_val(socket), - level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) - uerror("setsockopt", Nothing); - return Val_unit; -} - -CAMLprim value unix_getsockopt_bool(value socket, value option) { - return getsockopt_int(sockopt_bool, socket, SOL_SOCKET, option); -} - -CAMLprim value unix_setsockopt_bool(value socket, value option, value status) -{ - return setsockopt_int(sockopt_bool, socket, SOL_SOCKET, option, status); -} - -CAMLprim value unix_getsockopt_int(value socket, value option) { - return getsockopt_int(sockopt_int, socket, SOL_SOCKET, option); -} - -CAMLprim value unix_setsockopt_int(value socket, value option, value status) -{ - return setsockopt_int(sockopt_int, socket, SOL_SOCKET, option, status); -} - -CAMLprim value getsockopt_optint(int *sockopt, value socket, - int level, value option) -{ - struct linger optval; - int optsize; - value res = Val_int(0); /* None */ - - optsize = sizeof(optval); - if (getsockopt(Socket_val(socket), - level, sockopt[Int_val(option)], - (void *) &optval, &optsize) == -1) - uerror("getsockopt_optint", Nothing); - if (optval.l_onoff != 0) { - res = alloc_small(1, 0); - Field(res, 0) = Val_int(optval.l_linger); - } - return res; -} - -CAMLprim value setsockopt_optint(int *sockopt, value socket, int level, - value option, value status) -{ - struct linger optval; - - optval.l_onoff = Is_block (status); - if (optval.l_onoff) - optval.l_linger = Int_val (Field (status, 0)); - if (setsockopt(Socket_val(socket), - level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) - uerror("setsockopt_optint", Nothing); - return Val_unit; -} - -CAMLprim value unix_getsockopt_optint(value socket, value option) -{ - return getsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option); -} - -CAMLprim value unix_setsockopt_optint(value socket, value option, value status) -{ - return setsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option, status); -} - -CAMLprim value getsockopt_float(int *sockopt, value socket, - int level, value option) -{ - struct timeval tv; - int optsize; - - optsize = sizeof(tv); - if (getsockopt(Socket_val(socket), - level, sockopt[Int_val(option)], - (void *) &tv, &optsize) == -1) - uerror("getsockopt_float", Nothing); - return copy_double((double) tv.tv_sec + (double) tv.tv_usec / 1e6); -} - -CAMLprim value setsockopt_float(int *sockopt, value socket, int level, - value option, value status) -{ - struct timeval tv; - double tv_f; - - tv_f = Double_val(status); - tv.tv_sec = (int)tv_f; - tv.tv_usec = (int) (1e6 * (tv_f - tv.tv_sec)); - if (setsockopt(Socket_val(socket), - level, sockopt[Int_val(option)], - (void *) &tv, sizeof(tv)) == -1) - uerror("setsockopt_float", Nothing); - return Val_unit; -} - -CAMLprim value unix_getsockopt_float(value socket, value option) -{ - return getsockopt_float(sockopt_float, socket, SOL_SOCKET, option); -} - -CAMLprim value unix_setsockopt_float(value socket, value option, value status) -{ - return setsockopt_float(sockopt_float, socket, SOL_SOCKET, option, status); -} - diff --git a/otherlibs/win32unix/startup.c b/otherlibs/win32unix/startup.c deleted file mode 100644 index ae584e5693..0000000000 --- a/otherlibs/win32unix/startup.c +++ /dev/null @@ -1,43 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -#include <stdio.h> -#include <fcntl.h> -#include <stdlib.h> -#include <mlvalues.h> -#include "unixsupport.h" - -value val_process_id; - -CAMLprim value win_startup(unit) - value unit; -{ - WSADATA wsaData; - int i; - HANDLE h; - - (void) WSAStartup(MAKEWORD(2, 0), &wsaData); - DuplicateHandle(GetCurrentProcess(), GetCurrentProcess(), - GetCurrentProcess(), &h, 0, TRUE, - DUPLICATE_SAME_ACCESS); - val_process_id = Val_int(h); - - return Val_unit; -} - -CAMLprim value win_cleanup(unit) - value unit; -{ - (void) WSACleanup(); - return Val_unit; -} diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c deleted file mode 100644 index 6a1259acd2..0000000000 --- a/otherlibs/win32unix/stat.c +++ /dev/null @@ -1,93 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <errno.h> -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> -#include "unixsupport.h" -#include "cst2constr.h" -#define _INTEGRAL_MAX_BITS 64 -#include <sys/types.h> -#include <sys/stat.h> - -#ifndef S_IFLNK -#define S_IFLNK 0 -#endif -#ifndef S_IFIFO -#define S_IFIFO 0 -#endif -#ifndef S_IFSOCK -#define S_IFSOCK 0 -#endif -#ifndef S_IFBLK -#define S_IFBLK 0 -#endif - -static int file_kind_table[] = { - S_IFREG, S_IFDIR, S_IFCHR, S_IFBLK, S_IFLNK, S_IFIFO, S_IFSOCK -}; - -static value stat_aux(int use_64, struct _stati64 *buf) -{ - value v; - value atime = Val_unit, mtime = Val_unit, ctime = Val_unit; - - Begin_roots3(atime,mtime,ctime) - atime = copy_double((double) buf->st_atime); - mtime = copy_double((double) buf->st_mtime); - ctime = copy_double((double) buf->st_ctime); - v = alloc_small(12, 0); - Field (v, 0) = Val_int (buf->st_dev); - Field (v, 1) = Val_int (buf->st_ino); - Field (v, 2) = cst_to_constr(buf->st_mode & S_IFMT, file_kind_table, - sizeof(file_kind_table) / sizeof(int), 0); - Field (v, 3) = Val_int(buf->st_mode & 07777); - Field (v, 4) = Val_int (buf->st_nlink); - Field (v, 5) = Val_int (buf->st_uid); - Field (v, 6) = Val_int (buf->st_gid); - Field (v, 7) = Val_int (buf->st_rdev); - Field (v, 8) = - use_64 ? copy_int64(buf->st_size) : Val_int (buf->st_size); - Field (v, 9) = atime; - Field (v, 10) = mtime; - Field (v, 11) = ctime; - End_roots(); - return v; -} - -CAMLprim value unix_stat(value path) -{ - int ret; - struct _stati64 buf; - - ret = _stati64(String_val(path), &buf); - if (ret == -1) uerror("stat", path); - if (buf.st_size > Max_long) { - win32_maperr(ERROR_ARITHMETIC_OVERFLOW); - uerror("stat", path); - } - return stat_aux(0, &buf); -} - -CAMLprim value unix_stat_64(value path) -{ - int ret; - struct _stati64 buf; - ret = _stati64(String_val(path), &buf); - if (ret == -1) uerror("stat", path); - return stat_aux(1, &buf); -} - diff --git a/otherlibs/win32unix/system.c b/otherlibs/win32unix/system.c deleted file mode 100644 index 725817c37a..0000000000 --- a/otherlibs/win32unix/system.c +++ /dev/null @@ -1,41 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> -#include <signals.h> -#include "unixsupport.h" -#include <process.h> -#include <stdio.h> - -CAMLprim value win_system(cmd) - value cmd; -{ - int ret; - value st; - - enter_blocking_section(); - _flushall(); - ret = system(String_val(cmd));; - leave_blocking_section(); - if (ret == -1) uerror("system", Nothing); - st = alloc_small(1, 0); /* Tag 0: Exited */ - Field(st, 0) = Val_int(ret); - return st; -} - - - diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml deleted file mode 100644 index f7a7e9ee7c..0000000000 --- a/otherlibs/win32unix/unix.ml +++ /dev/null @@ -1,797 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy and Pascal Cuoq, 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, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Initialization *) - -external startup: unit -> unit = "win_startup" -external cleanup: unit -> unit = "win_cleanup" - -let _ = startup(); at_exit cleanup - -(* Errors *) - -type 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 *) - | EOVERFLOW - (* All other errors are mapped to EUNKNOWNERR *) - | EUNKNOWNERR of int (* Unknown error *) - -exception Unix_error of error * string * string - -let _ = Callback.register_exception "Unix.Unix_error" - (Unix_error(E2BIG, "", "")) - -external error_message : error -> string = "unix_error_message" - -let handle_unix_error f arg = - try - f arg - with Unix_error(err, fun_name, arg) -> - prerr_string Sys.argv.(0); - prerr_string ": \""; - prerr_string fun_name; - prerr_string "\" failed"; - if String.length arg > 0 then begin - prerr_string " on \""; - prerr_string arg; - prerr_string "\"" - end; - prerr_string ": "; - prerr_endline (error_message err); - exit 2 - -external environment : unit -> string array = "unix_environment" -external getenv: string -> string = "sys_getenv" -external putenv: string -> string -> unit = "unix_putenv" - -type process_status = - WEXITED of int - | WSIGNALED of int - | WSTOPPED of int - -type wait_flag = - WNOHANG - | WUNTRACED - -type file_descr - -external execv : string -> string array -> unit = "unix_execv" -external execve : string -> string array -> string array -> unit = "unix_execve" -external execvp : string -> string array -> unit = "unix_execvp" -external execvpe : string -> string array -> string array -> unit = "unix_execvpe" - -external waitpid : wait_flag list -> int -> int * process_status - = "win_waitpid" -external getpid : unit -> int = "unix_getpid" - -let fork () = invalid_arg "Unix.fork not implemented" -let wait () = invalid_arg "Unix.wait not implemented" -let getppid () = invalid_arg "Unix.getppid not implemented" -let nice prio = invalid_arg "Unix.nice not implemented" - -(* Basic file input/output *) - -external filedescr_of_fd : int -> file_descr = "win_handle_fd" - -let stdin = filedescr_of_fd 0 -let stdout = filedescr_of_fd 1 -let stderr = filedescr_of_fd 2 - -type open_flag = - O_RDONLY - | O_WRONLY - | O_RDWR - | O_NONBLOCK - | O_APPEND - | O_CREAT - | O_TRUNC - | O_EXCL - | O_NOCTTY - | O_DSYNC - | O_SYNC - | O_RSYNC - -type file_perm = int - -external openfile : string -> open_flag list -> file_perm -> file_descr - = "unix_open" -external close : file_descr -> unit = "unix_close" -external unsafe_read : file_descr -> string -> int -> int -> int - = "unix_read" -external unsafe_write : file_descr -> string -> int -> int -> int - = "unix_write" - -let read fd buf ofs len = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.read" - else unsafe_read fd buf ofs len -let write fd buf ofs len = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.write" - else unsafe_write fd buf ofs len - -(* Interfacing with the standard input/output library *) - -external open_read_descriptor : int -> in_channel = "caml_open_descriptor_in" -external open_write_descriptor : int -> out_channel = "caml_open_descriptor_out" -external fd_of_in_channel : in_channel -> int = "channel_descriptor" -external fd_of_out_channel : out_channel -> int = "channel_descriptor" - -external open_handle : file_descr -> int = "win_fd_handle" - -let in_channel_of_descr handle = - open_read_descriptor(open_handle handle) -let out_channel_of_descr handle = - open_write_descriptor(open_handle handle) - -let descr_of_in_channel inchan = - filedescr_of_fd(fd_of_in_channel inchan) -let descr_of_out_channel outchan = - filedescr_of_fd(fd_of_out_channel outchan) - -(* Seeking and truncating *) - -type seek_command = - SEEK_SET - | SEEK_CUR - | SEEK_END - -external lseek : file_descr -> int -> seek_command -> int = "unix_lseek" - -let truncate name len = invalid_arg "Unix.truncate not implemented" -let ftruncate fd len = invalid_arg "Unix.ftruncate not implemented" - -(* File statistics *) - -type file_kind = - S_REG - | S_DIR - | S_CHR - | S_BLK - | S_LNK - | S_FIFO - | S_SOCK - -type stats = - { st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int; - st_atime : float; - st_mtime : float; - st_ctime : float } - -external stat : string -> stats = "unix_stat" -let lstat = stat -let fstat fd = invalid_arg "Unix.fstat not implemented" - -(* Operations on file names *) - -external unlink : string -> unit = "unix_unlink" -external rename : string -> string -> unit = "unix_rename" -external link : string -> string -> unit = "unix_link" - -(* Operations on large files *) - -module LargeFile = - struct - external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64" - let truncate name len = invalid_arg "Unix.LargeFile.truncate not implemented" - let ftruncate name len = invalid_arg "Unix.LargeFile.ftruncate not implemented" - type stats = - { st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int64; - st_atime : float; - st_mtime : float; - st_ctime : float; - } - external stat : string -> stats = "unix_stat_64" - let lstat = stat - let fstat fd = invalid_arg "Unix.LargeFile.fstat not implemented" - end - -(* File permissions and ownership *) - -type access_permission = - R_OK - | W_OK - | X_OK - | F_OK - -external chmod : string -> file_perm -> unit = "unix_chmod" -let fchmod fd perm = invalid_arg "Unix.fchmod not implemented" -let chown file perm = invalid_arg "Unix.chown not implemented" -let fchown fd perm = invalid_arg "Unix.fchown not implemented" -let umask msk = invalid_arg "Unix.umask not implemented" - -external access : string -> access_permission list -> unit = "unix_access" - -(* Operations on file descriptors *) - -external dup : file_descr -> file_descr = "unix_dup" -external dup2 : file_descr -> file_descr -> unit = "unix_dup2" - -external set_nonblock : file_descr -> unit = "unix_set_nonblock" -external clear_nonblock : file_descr -> unit = "unix_clear_nonblock" - -external set_close_on_exec : file_descr -> unit = "win_set_close_on_exec" -external clear_close_on_exec : file_descr -> unit = "win_clear_close_on_exec" - -(* Directories *) - -external mkdir : string -> file_perm -> unit = "unix_mkdir" -external rmdir : string -> unit = "unix_rmdir" -external chdir : string -> unit = "unix_chdir" -external getcwd : unit -> string = "unix_getcwd" -let chroot _ = invalid_arg "Unix.chroot not implemented" - -type dir_entry = - Dir_empty - | Dir_read of string - | Dir_toread - -type dir_handle = - { dirname: string; mutable handle: int; mutable entry_read: dir_entry } - -external findfirst : string -> string * int = "win_findfirst" -external findnext : int -> string= "win_findnext" - -let opendir dirname = - try - let (first_entry, handle) = findfirst (dirname ^ "\\*.*") in - { dirname = dirname; handle = handle; entry_read = Dir_read first_entry } - with End_of_file -> - { dirname = dirname; handle = 0; entry_read = Dir_empty } - -let readdir d = - match d.entry_read with - Dir_empty -> raise End_of_file - | Dir_read name -> d.entry_read <- Dir_toread; name - | Dir_toread -> findnext d.handle - -external win_findclose : int -> unit = "win_findclose" - -let closedir d = - match d.entry_read with - Dir_empty -> () - | _ -> win_findclose d.handle - -let rewinddir d = - closedir d; - try - let (first_entry, handle) = findfirst (d.dirname ^ "\\*.*") in - d.handle <- handle; d.entry_read <- Dir_read first_entry - with End_of_file -> - d.handle <- 0; d.entry_read <- Dir_empty - -(* Pipes *) - -external pipe : unit -> file_descr * file_descr = "unix_pipe" - -let mkfifo name perm = invalid_arg "Unix.mkfifo not implemented" - -(* Symbolic links *) - -let readlink path = invalid_arg "Unix.readlink not implemented" -let symlink path1 path2 = invalid_arg "Unix.symlink not implemented" - -(* Locking *) - -type lock_command = - F_ULOCK - | F_LOCK - | F_TLOCK - | F_TEST - | F_RLOCK - | F_TRLOCK - -external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf" -let kill pid signo = invalid_arg "Unix.kill not implemented" -type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK -let sigprocmask cmd sigs = invalid_arg "Unix.sigprocmask not implemented" -let sigpending () = invalid_arg "Unix.sigpending not implemented" -let sigsuspend sigs = invalid_arg "Unix.sigsuspend not implemented" -let pause () = invalid_arg "Unix.pause not implemented" - -(* Time functions *) - -type process_times = - { tms_utime : float; - tms_stime : float; - tms_cutime : float; - tms_cstime : float } - -type tm = - { tm_sec : int; - tm_min : int; - tm_hour : int; - tm_mday : int; - tm_mon : int; - tm_year : int; - tm_wday : int; - tm_yday : int; - tm_isdst : bool } - -external time : unit -> float = "unix_time" -external gettimeofday : unit -> float = "unix_gettimeofday" -external gmtime : float -> tm = "unix_gmtime" -external localtime : float -> tm = "unix_localtime" -external mktime : tm -> float * tm = "unix_mktime" -let alarm n = invalid_arg "Unix.alarm not implemented" -external sleep : int -> unit = "unix_sleep" -let times () = - { tms_utime = Sys.time(); tms_stime = 0.0; - tms_cutime = 0.0; tms_cstime = 0.0 } -external utimes : string -> float -> float -> unit = "unix_utimes" - -type interval_timer = - ITIMER_REAL - | ITIMER_VIRTUAL - | ITIMER_PROF - -type interval_timer_status = - { it_interval: float; - it_value: float } - -let getitimer it = invalid_arg "Unix.getitimer not implemented" -let setitimer it tm = invalid_arg "Unix.setitimer not implemented" - -(* User id, group id *) - -let getuid () = 1 -let geteuid = getuid -let setuid id = invalid_arg "Unix.setuid not implemented" - -let getgid () = 1 -let getegid = getgid -let setgid id = invalid_arg "Unix.setgid not implemented" - -let getgroups () = [|1|] - -type passwd_entry = - { pw_name : string; - pw_passwd : string; - pw_uid : int; - pw_gid : int; - pw_gecos : string; - pw_dir : string; - pw_shell : string } - -type group_entry = - { gr_name : string; - gr_passwd : string; - gr_gid : int; - gr_mem : string array } - -let getlogin () = try Sys.getenv "USERNAME" with Not_found -> "" -let getpwnam x = raise Not_found -let getgrnam = getpwnam -let getpwuid = getpwnam -let getgrgid = getpwnam - -(* Internet addresses *) - -type inet_addr - -external inet_addr_of_string : string -> inet_addr - = "unix_inet_addr_of_string" -external string_of_inet_addr : inet_addr -> string - = "unix_string_of_inet_addr" - -let inet_addr_any = inet_addr_of_string "0.0.0.0" - -(* Sockets *) - -type socket_domain = - PF_UNIX - | PF_INET - -type socket_type = - SOCK_STREAM - | SOCK_DGRAM - | SOCK_RAW - | SOCK_SEQPACKET - -type sockaddr = - ADDR_UNIX of string - | ADDR_INET of inet_addr * int - -type shutdown_command = - SHUTDOWN_RECEIVE - | SHUTDOWN_SEND - | SHUTDOWN_ALL - -type msg_flag = - MSG_OOB - | MSG_DONTROUTE - | MSG_PEEK - -type socket_bool_option = - SO_DEBUG - | SO_BROADCAST - | SO_REUSEADDR - | SO_KEEPALIVE - | SO_DONTROUTE - | SO_OOBINLINE - | SO_ACCEPTCONN - -type socket_int_option = - SO_SNDBUF - | SO_RCVBUF - | SO_ERROR - | SO_TYPE - | SO_RCVLOWAT - | SO_SNDLOWAT - -type socket_optint_option = SO_LINGER - -type socket_float_option = - SO_RCVTIMEO - | SO_SNDTIMEO - -external socket : socket_domain -> socket_type -> int -> file_descr - = "unix_socket" -let socketpair dom ty proto = invalid_arg "Unix.socketpair not implemented" -external accept : file_descr -> file_descr * sockaddr = "unix_accept" -external bind : file_descr -> sockaddr -> unit = "unix_bind" -external connect : file_descr -> sockaddr -> unit = "unix_connect" -external listen : file_descr -> int -> unit = "unix_listen" -external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" -external getsockname : file_descr -> sockaddr = "unix_getsockname" -external getpeername : file_descr -> sockaddr = "unix_getpeername" - -external unsafe_recv : - file_descr -> string -> int -> int -> msg_flag list -> int - = "unix_recv" -external unsafe_recvfrom : - file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr - = "unix_recvfrom" -external unsafe_send : - file_descr -> string -> int -> int -> msg_flag list -> int - = "unix_send" -external unsafe_sendto : - file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int - = "unix_sendto" "unix_sendto_native" - -let recv fd buf ofs len flags = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.recv" - else unsafe_recv fd buf ofs len flags -let recvfrom fd buf ofs len flags = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.recvfrom" - else unsafe_recvfrom fd buf ofs len flags -let send fd buf ofs len flags = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.send" - else unsafe_send fd buf ofs len flags -let sendto fd buf ofs len flags addr = - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.sendto" - else unsafe_sendto fd buf ofs len flags addr - -external getsockopt : file_descr -> socket_bool_option -> bool - = "unix_getsockopt_bool" -external setsockopt : file_descr -> socket_bool_option -> bool -> unit - = "unix_setsockopt_bool" -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" -external getsockopt_optint : file_descr -> socket_optint_option -> int option - = "unix_getsockopt_optint" -external setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit - = "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" - -(* Host and protocol databases *) - -type host_entry = - { h_name : string; - h_aliases : string array; - h_addrtype : socket_domain; - h_addr_list : inet_addr array } - -type protocol_entry = - { p_name : string; - p_aliases : string array; - p_proto : int } - -type service_entry = - { s_name : string; - s_aliases : string array; - s_port : int; - s_proto : string } - -external gethostname : unit -> string = "unix_gethostname" -external gethostbyname : string -> host_entry = "unix_gethostbyname" -external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr" -external getprotobyname : string -> protocol_entry - = "unix_getprotobyname" -external getprotobynumber : int -> protocol_entry - = "unix_getprotobynumber" - -external getservbyname : string -> string -> service_entry - = "unix_getservbyname" -external getservbyport : int -> string -> service_entry - = "unix_getservbyport" - -(* High-level process management (system, popen) *) - -external win_create_process : string -> string -> string option -> - file_descr -> file_descr -> file_descr -> int - = "win_create_process" "win_create_process_native" - -let create_process prog args fd1 fd2 fd3 = - win_create_process prog (String.concat " " (Array.to_list args)) None - fd1 fd2 fd3 - -let create_process_env prog args env fd1 fd2 fd3 = - win_create_process prog (String.concat " " (Array.to_list args)) - (Some(String.concat "\000" (Array.to_list env) ^ "\000")) - fd1 fd2 fd3 - -external system: string -> process_status = "win_system" - -type popen_process = - Process of in_channel * out_channel - | Process_in of in_channel - | Process_out of out_channel - | Process_full of in_channel * out_channel * in_channel - -let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t) - -let open_proc cmd optenv proc input output error = - let shell = - try Sys.getenv "COMSPEC" - with Not_found -> raise(Unix_error(ENOEXEC, "open_proc", cmd)) in - let pid = - win_create_process shell (shell ^ " /c " ^ cmd) optenv - input output error in - Hashtbl.add popen_processes proc pid - -let open_process_in cmd = - let (in_read, in_write) = pipe() in - set_close_on_exec in_read; - let inchan = in_channel_of_descr in_read in - open_proc cmd None (Process_in inchan) stdin in_write stderr; - close in_write; - inchan - -let open_process_out cmd = - let (out_read, out_write) = pipe() in - set_close_on_exec out_write; - let outchan = out_channel_of_descr out_write in - open_proc cmd None (Process_out outchan) out_read stdout stderr; - close out_read; - outchan - -let open_process cmd = - let (in_read, in_write) = pipe() in - let (out_read, out_write) = pipe() in - set_close_on_exec in_read; - set_close_on_exec out_write; - let inchan = in_channel_of_descr in_read in - let outchan = out_channel_of_descr out_write in - open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr; - close out_read; close in_write; - (inchan, outchan) - -let open_process_full cmd env = - let (in_read, in_write) = pipe() in - let (out_read, out_write) = pipe() in - let (err_read, err_write) = pipe() in - set_close_on_exec in_read; - set_close_on_exec out_write; - set_close_on_exec err_read; - let inchan = in_channel_of_descr in_read in - let outchan = out_channel_of_descr out_write in - let errchan = in_channel_of_descr err_read in - open_proc cmd (Some(String.concat "\000" (Array.to_list env) ^ "\000")) - (Process_full(inchan, outchan, errchan)) - out_read in_write err_write; - close out_read; close in_write; close err_write; - (inchan, outchan, errchan) - -let find_proc_id fun_name proc = - try - let pid = Hashtbl.find popen_processes proc in - Hashtbl.remove popen_processes proc; - pid - with Not_found -> - raise(Unix_error(EBADF, fun_name, "")) - -let close_process_in inchan = - let pid = find_proc_id "close_process_in" (Process_in inchan) in - close_in inchan; - snd(waitpid [] pid) - -let close_process_out outchan = - let pid = find_proc_id "close_process_out" (Process_out outchan) in - close_out outchan; - snd(waitpid [] pid) - -let close_process (inchan, outchan) = - let pid = find_proc_id "close_process" (Process(inchan, outchan)) in - close_in inchan; close_out outchan; - snd(waitpid [] pid) - -let close_process_full (inchan, outchan, errchan) = - let pid = - find_proc_id "close_process_full" - (Process_full(inchan, outchan, errchan)) in - close_in inchan; close_out outchan; close_in errchan; - snd(waitpid [] pid) - -(* Polling *) - -external select : - file_descr list -> file_descr list -> file_descr list -> float -> - file_descr list * file_descr list * file_descr list = "unix_select" - -(* High-level network functions *) - -let open_connection sockaddr = - let domain = - match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in - let sock = - socket domain SOCK_STREAM 0 in - connect sock sockaddr; - (in_channel_of_descr sock, out_channel_of_descr sock) - -let shutdown_connection inchan = - shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND - -let establish_server server_fun sockaddr = - invalid_arg "Unix.establish_server not implmented" - -(* Terminal interface *) - -type terminal_io = { - mutable c_ignbrk: bool; - mutable c_brkint: bool; - mutable c_ignpar: bool; - mutable c_parmrk: bool; - mutable c_inpck: bool; - mutable c_istrip: bool; - mutable c_inlcr: bool; - mutable c_igncr: bool; - mutable c_icrnl: bool; - mutable c_ixon: bool; - mutable c_ixoff: bool; - mutable c_opost: bool; - mutable c_obaud: int; - mutable c_ibaud: int; - mutable c_csize: int; - mutable c_cstopb: int; - mutable c_cread: bool; - mutable c_parenb: bool; - mutable c_parodd: bool; - mutable c_hupcl: bool; - mutable c_clocal: bool; - mutable c_isig: bool; - mutable c_icanon: bool; - mutable c_noflsh: bool; - mutable c_echo: bool; - mutable c_echoe: bool; - mutable c_echok: bool; - mutable c_echonl: bool; - mutable c_vintr: char; - mutable c_vquit: char; - mutable c_verase: char; - mutable c_vkill: char; - mutable c_veof: char; - mutable c_veol: char; - mutable c_vmin: int; - mutable c_vtime: int; - mutable c_vstart: char; - mutable c_vstop: char - } - -type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH - -let tcgetattr fd = invalid_arg "Unix.tcgetattr not implemented" -let tcsetattr fd wh = invalid_arg "Unix.tcsetattr not implemented" -let tcsendbreak fd n = invalid_arg "Unix.tcsendbreak not implemented" -let tcdrain fd = invalid_arg "Unix.tcdrain not implemented" - -type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH -let tcflush fd q = invalid_arg "Unix.tcflush not implemented" -type flow_action = TCOOFF | TCOON | TCIOFF | TCION -let tcflow fd fl = invalid_arg "Unix.tcflow not implemented" -let setsid () = invalid_arg "Unix.setsid not implemented" diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c deleted file mode 100644 index a8558f8164..0000000000 --- a/otherlibs/win32unix/unixsupport.c +++ /dev/null @@ -1,259 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <stddef.h> -#include <mlvalues.h> -#include <callback.h> -#include <alloc.h> -#include <memory.h> -#include <fail.h> -#include <custom.h> -#include "unixsupport.h" -#include "cst2constr.h" -#include <errno.h> - -/* Heap-allocation of Windows file handles */ - -static int win_handle_compare(value v1, value v2) -{ - HANDLE h1 = Handle_val(v1); - HANDLE h2 = Handle_val(v2); - return h1 == h2 ? 0 : h1 < h2 ? -1 : 1; -} - -static long win_handle_hash(value v) -{ - return (long) Handle_val(v); -} - -static struct custom_operations win_handle_ops = { - "_handle", - custom_finalize_default, - win_handle_compare, - win_handle_hash, - custom_serialize_default, - custom_deserialize_default -}; - -value win_alloc_handle(HANDLE h) -{ - value res = alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1); - Handle_val(res) = h; - Descr_kind_val(res) = KIND_HANDLE; - CRT_fd_val(res) = NO_CRT_FD; - return res; -} - -value win_alloc_socket(SOCKET s) -{ - value res = alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1); - Socket_val(res) = s; - Descr_kind_val(res) = KIND_SOCKET; - return res; -} - -value win_alloc_handle_or_socket(HANDLE h) -{ - value res = win_alloc_handle(h); - int opt; - int optlen = sizeof(opt); - if (getsockopt((SOCKET) h, SOL_SOCKET, SO_TYPE, (char *)&opt, &optlen) == 0) - Descr_kind_val(res) = KIND_SOCKET; - return res; -} - -/* Mapping of Windows error codes to POSIX error codes */ - -struct error_entry { unsigned long win_code; int range; int posix_code; }; - -static struct error_entry win_error_table[] = { - { ERROR_INVALID_FUNCTION, 0, EINVAL}, - { ERROR_FILE_NOT_FOUND, 0, ENOENT}, - { ERROR_PATH_NOT_FOUND, 0, ENOENT}, - { ERROR_TOO_MANY_OPEN_FILES, 0, EMFILE}, - { ERROR_ACCESS_DENIED, 0, EACCES}, - { ERROR_INVALID_HANDLE, 0, EBADF}, - { ERROR_ARENA_TRASHED, 0, ENOMEM}, - { ERROR_NOT_ENOUGH_MEMORY, 0, ENOMEM}, - { ERROR_INVALID_BLOCK, 0, ENOMEM}, - { ERROR_BAD_ENVIRONMENT, 0, E2BIG}, - { ERROR_BAD_FORMAT, 0, ENOEXEC}, - { ERROR_INVALID_ACCESS, 0, EINVAL}, - { ERROR_INVALID_DATA, 0, EINVAL}, - { ERROR_INVALID_DRIVE, 0, ENOENT}, - { ERROR_CURRENT_DIRECTORY, 0, EACCES}, - { ERROR_NOT_SAME_DEVICE, 0, EXDEV}, - { ERROR_NO_MORE_FILES, 0, ENOENT}, - { ERROR_LOCK_VIOLATION, 0, EACCES}, - { ERROR_BAD_NETPATH, 0, ENOENT}, - { ERROR_NETWORK_ACCESS_DENIED, 0, EACCES}, - { ERROR_BAD_NET_NAME, 0, ENOENT}, - { ERROR_FILE_EXISTS, 0, EEXIST}, - { ERROR_CANNOT_MAKE, 0, EACCES}, - { ERROR_FAIL_I24, 0, EACCES}, - { ERROR_INVALID_PARAMETER, 0, EINVAL}, - { ERROR_NO_PROC_SLOTS, 0, EAGAIN}, - { ERROR_DRIVE_LOCKED, 0, EACCES}, - { ERROR_BROKEN_PIPE, 0, EPIPE}, - { ERROR_DISK_FULL, 0, ENOSPC}, - { ERROR_INVALID_TARGET_HANDLE, 0, EBADF}, - { ERROR_INVALID_HANDLE, 0, EINVAL}, - { ERROR_WAIT_NO_CHILDREN, 0, ECHILD}, - { ERROR_CHILD_NOT_COMPLETE, 0, ECHILD}, - { ERROR_DIRECT_ACCESS_HANDLE, 0, EBADF}, - { ERROR_NEGATIVE_SEEK, 0, EINVAL}, - { ERROR_SEEK_ON_DEVICE, 0, EACCES}, - { ERROR_DIR_NOT_EMPTY, 0, ENOTEMPTY}, - { ERROR_NOT_LOCKED, 0, EACCES}, - { ERROR_BAD_PATHNAME, 0, ENOENT}, - { ERROR_MAX_THRDS_REACHED, 0, EAGAIN}, - { ERROR_LOCK_FAILED, 0, EACCES}, - { ERROR_ALREADY_EXISTS, 0, EEXIST}, - { ERROR_FILENAME_EXCED_RANGE, 0, ENOENT}, - { ERROR_NESTING_NOT_ALLOWED, 0, EAGAIN}, - { ERROR_NOT_ENOUGH_QUOTA, 0, ENOMEM}, - { ERROR_INVALID_STARTING_CODESEG, - ERROR_INFLOOP_IN_RELOC_CHAIN - ERROR_INVALID_STARTING_CODESEG, - ENOEXEC }, - { ERROR_WRITE_PROTECT, - ERROR_SHARING_BUFFER_EXCEEDED - ERROR_WRITE_PROTECT, - EACCES }, - { WSAEINVAL, 0, EINVAL }, - { WSAEACCES, 0, EACCES }, - { WSAEBADF, 0, EBADF }, - { WSAEFAULT, 0, EFAULT }, - { WSAEINTR, 0, EINTR }, - { WSAEINVAL, 0, EINVAL }, - { WSAEMFILE, 0, EMFILE }, -#ifdef WSANAMETOOLONG - { WSANAMETOOLONG, 0, ENAMETOOLONG }, -#endif -#ifdef WSAENFILE - { WSAENFILE, 0, ENFILE }, -#endif - { WSAENOTEMPTY, 0, ENOTEMPTY }, - { 0, -1, 0 } -}; - -void win32_maperr(unsigned long errcode) -{ - int i; - - for (i = 0; win_error_table[i].range >= 0; i++) { - if (errcode >= win_error_table[i].win_code && - errcode <= win_error_table[i].win_code + win_error_table[i].range) { - errno = win_error_table[i].posix_code; - return; - } - } - /* Not found: save original error code, negated so that we can - recognize it in unix_error_message */ - errno = -errcode; -} - -/* Windows socket errors */ - -#define EWOULDBLOCK -WSAEWOULDBLOCK -#define EINPROGRESS -WSAEINPROGRESS -#define EALREADY -WSAEALREADY -#define ENOTSOCK -WSAENOTSOCK -#define EDESTADDRREQ -WSAEDESTADDRREQ -#define EMSGSIZE -WSAEMSGSIZE -#define EPROTOTYPE -WSAEPROTOTYPE -#define ENOPROTOOPT -WSAENOPROTOOPT -#define EPROTONOSUPPORT -WSAEPROTONOSUPPORT -#define ESOCKTNOSUPPORT -WSAESOCKTNOSUPPORT -#define EOPNOTSUPP -WSAEOPNOTSUPP -#define EPFNOSUPPORT -WSAEPFNOSUPPORT -#define EAFNOSUPPORT -WSAEAFNOSUPPORT -#define EADDRINUSE -WSAEADDRINUSE -#define EADDRNOTAVAIL -WSAEADDRNOTAVAIL -#define ENETDOWN -WSAENETDOWN -#define ENETUNREACH -WSAENETUNREACH -#define ENETRESET -WSAENETRESET -#define ECONNABORTED -WSAECONNABORTED -#define ECONNRESET -WSAECONNRESET -#define ENOBUFS -WSAENOBUFS -#define EISCONN -WSAEISCONN -#define ENOTCONN -WSAENOTCONN -#define ESHUTDOWN -WSAESHUTDOWN -#define ETOOMANYREFS -WSAETOOMANYREFS -#define ETIMEDOUT -WSAETIMEDOUT -#define ECONNREFUSED -WSAECONNREFUSED -#define ELOOP -WSAELOOP -#define EHOSTDOWN -WSAEHOSTDOWN -#define EHOSTUNREACH -WSAEHOSTUNREACH -#define EPROCLIM -WSAEPROCLIM -#define EUSERS -WSAEUSERS -#define EDQUOT -WSAEDQUOT -#define ESTALE -WSAESTALE -#define EREMOTE -WSAEREMOTE - -#define EOVERFLOW -ERROR_ARITHMETIC_OVERFLOW -#define EACCESS EACCES - -int error_table[] = { - E2BIG, EACCESS, EAGAIN, EBADF, EBUSY, ECHILD, EDEADLK, EDOM, - EEXIST, EFAULT, EFBIG, EINTR, EINVAL, EIO, EISDIR, EMFILE, EMLINK, - ENAMETOOLONG, ENFILE, ENODEV, ENOENT, ENOEXEC, ENOLCK, ENOMEM, ENOSPC, - ENOSYS, ENOTDIR, ENOTEMPTY, ENOTTY, ENXIO, EPERM, EPIPE, ERANGE, - EROFS, ESPIPE, ESRCH, EXDEV, EWOULDBLOCK, EINPROGRESS, EALREADY, - ENOTSOCK, EDESTADDRREQ, EMSGSIZE, EPROTOTYPE, ENOPROTOOPT, - EPROTONOSUPPORT, ESOCKTNOSUPPORT, EOPNOTSUPP, EPFNOSUPPORT, - EAFNOSUPPORT, EADDRINUSE, EADDRNOTAVAIL, ENETDOWN, ENETUNREACH, - ENETRESET, ECONNABORTED, ECONNRESET, ENOBUFS, EISCONN, ENOTCONN, - ESHUTDOWN, ETOOMANYREFS, ETIMEDOUT, ECONNREFUSED, EHOSTDOWN, - EHOSTUNREACH, ELOOP, EOVERFLOW /*, EUNKNOWNERR */ -}; - -static value * unix_error_exn = NULL; - -void unix_error(int errcode, char *cmdname, value cmdarg) -{ - value res; - value name = Val_unit, err = Val_unit, arg = Val_unit; - int errconstr; - - Begin_roots3 (name, err, arg); - arg = cmdarg == Nothing ? copy_string("") : cmdarg; - name = copy_string(cmdname); - errconstr = - cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1); - if (errconstr == Val_int(-1)) { - err = alloc_small(1, 0); - Field(err, 0) = Val_int(errcode); - } else { - err = errconstr; - } - if (unix_error_exn == NULL) { - unix_error_exn = caml_named_value("Unix.Unix_error"); - if (unix_error_exn == NULL) - invalid_argument("Exception Unix.Unix_error not initialized, please link unix.cma"); - } - res = alloc_small(4, 0); - Field(res, 0) = *unix_error_exn; - Field(res, 1) = err; - Field(res, 2) = name; - Field(res, 3) = arg; - End_roots(); - mlraise(res); -} - -void uerror(cmdname, cmdarg) - char * cmdname; - value cmdarg; -{ - unix_error(errno, cmdname, cmdarg); -} diff --git a/otherlibs/win32unix/unixsupport.h b/otherlibs/win32unix/unixsupport.h deleted file mode 100644 index 2b1ff71eaf..0000000000 --- a/otherlibs/win32unix/unixsupport.h +++ /dev/null @@ -1,54 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy and Pascal Cuoq, 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#define WIN32_LEAN_AND_MEAN -#include <wtypes.h> -#include <winbase.h> -#include <stdlib.h> -/* Include io.h in current dir, which is a copy of the system's io.h, - not io.h from ../../byterun */ -/*#include "io.h"*/ -#include <direct.h> -#include <process.h> -#include <sys/types.h> -#include <winsock.h> - -struct filedescr { - union { - HANDLE handle; - SOCKET socket; - } fd; - enum { KIND_HANDLE, KIND_SOCKET } kind; - int crt_fd; -}; - -#define Handle_val(v) (((struct filedescr *) Data_custom_val(v))->fd.handle) -#define Socket_val(v) (((struct filedescr *) Data_custom_val(v))->fd.socket) -#define Descr_kind_val(v) (((struct filedescr *) Data_custom_val(v))->kind) -#define CRT_fd_val(v) (((struct filedescr *) Data_custom_val(v))->crt_fd) - -extern value win_alloc_handle_or_socket(HANDLE); -extern value win_alloc_handle(HANDLE); -extern value win_alloc_socket(SOCKET); - -#define NO_CRT_FD (-1) -#define Nothing ((value) 0) - -extern void win32_maperr(unsigned long errcode); -extern void unix_error (int errcode, char * cmdname, value arg); -extern void uerror (char * cmdname, value arg); -extern value unix_freeze_buffer (value); - -#define UNIX_BUFFER_SIZE 16384 diff --git a/otherlibs/win32unix/windir.c b/otherlibs/win32unix/windir.c deleted file mode 100644 index 0a681e76ce..0000000000 --- a/otherlibs/win32unix/windir.c +++ /dev/null @@ -1,80 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Pascal Cuoq and 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <mlvalues.h> -#include <memory.h> -#include <errno.h> -#include <alloc.h> -#include <fail.h> -#include "unixsupport.h" - -CAMLprim value win_findfirst(name) - value name; -{ - HANDLE h; - value v; - WIN32_FIND_DATA fileinfo; - value valname = Val_unit; - value valh = Val_unit; - - Begin_roots2 (valname,valh); - h = FindFirstFile(String_val(name),&fileinfo); - if (h == INVALID_HANDLE_VALUE) { - DWORD err = GetLastError(); - if (err == ERROR_NO_MORE_FILES) - raise_end_of_file(); - else { - win32_maperr(err); - uerror("opendir", Nothing); - } - } - valname = copy_string(fileinfo.cFileName); - valh = win_alloc_handle(h); - v = alloc_small(2, 0); - Field(v,0) = valname; - Field(v,1) = valh; - End_roots(); - return v; -} - -CAMLprim value win_findnext(valh) - value valh; -{ - WIN32_FIND_DATA fileinfo; - BOOL retcode; - - retcode = FindNextFile(Handle_val(valh), &fileinfo); - if (!retcode) { - DWORD err = GetLastError(); - if (err == ERROR_NO_MORE_FILES) - raise_end_of_file(); - else { - win32_maperr(err); - uerror("readdir", Nothing); - } - } - return copy_string(fileinfo.cFileName); -} - -CAMLprim value win_findclose(valh) - value valh; -{ - if (! FindClose(Handle_val(valh))) { - win32_maperr(GetLastError()); - uerror("closedir", Nothing); - } - return Val_unit; -} - diff --git a/otherlibs/win32unix/winwait.c b/otherlibs/win32unix/winwait.c deleted file mode 100644 index db3a62dde5..0000000000 --- a/otherlibs/win32unix/winwait.c +++ /dev/null @@ -1,62 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Pascal Cuoq and 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <windows.h> -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include "unixsupport.h" -#include <sys/types.h> - -static value alloc_process_status(HANDLE pid, int status) -{ - value res, st; - - st = alloc(1, 0); - Field(st, 0) = Val_int(status); - Begin_root (st); - res = alloc_small(2, 0); - Field(res, 0) = Val_long((long) pid); - Field(res, 1) = st; - End_roots(); - return res; -} - -enum { CAML_WNOHANG = 1, CAML_WUNTRACED = 2 }; - -static int wait_flag_table[] = { CAML_WNOHANG, CAML_WUNTRACED }; - -CAMLprim value win_waitpid(value vflags, value vpid_req) -{ - int flags; - DWORD status; - HANDLE pid_req = (HANDLE) Long_val(vpid_req); - - flags = convert_flag_list(vflags, wait_flag_table); - if ((flags & CAML_WNOHANG) == 0) { - if (WaitForSingleObject(pid_req, INFINITE) == WAIT_FAILED) { - win32_maperr(GetLastError()); - uerror("waitpid", Nothing); - } - } - if (! GetExitCodeProcess(pid_req, &status)) { - win32_maperr(GetLastError()); - uerror("waitpid", Nothing); - } - if (status == STILL_ACTIVE) - return alloc_process_status((HANDLE) 0, 0); - else - return alloc_process_status(pid_req, status); -} diff --git a/otherlibs/win32unix/write.c b/otherlibs/win32unix/write.c deleted file mode 100644 index 8571ff6794..0000000000 --- a/otherlibs/win32unix/write.c +++ /dev/null @@ -1,64 +0,0 @@ -/***********************************************************************/ -/* */ -/* 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, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include <errno.h> -#include <string.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> -#include "unixsupport.h" - -CAMLprim value unix_write(value fd, value buf, value vofs, value vlen) -{ - long ofs, len, written; - DWORD numbytes, numwritten; - char iobuf[UNIX_BUFFER_SIZE]; - - Begin_root (buf); - ofs = Long_val(vofs); - len = Long_val(vlen); - written = 0; - while (len > 0) { - numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; - memmove (iobuf, &Byte(buf, ofs), numbytes); - if (Descr_kind_val(fd) == KIND_SOCKET) { - int ret; - SOCKET s = Socket_val(fd); - enter_blocking_section(); - ret = send(s, iobuf, numbytes, 0); - leave_blocking_section(); - if (ret == SOCKET_ERROR) { - win32_maperr(WSAGetLastError()); - uerror("write", Nothing); - } - numwritten = ret; - } else { - BOOL ret; - HANDLE h = Handle_val(fd); - enter_blocking_section(); - ret = WriteFile(h, iobuf, numbytes, &numwritten, NULL); - leave_blocking_section(); - if (! ret) { - win32_maperr(GetLastError()); - uerror("write", Nothing); - } - } - written += numwritten; - ofs += numwritten; - len -= numwritten; - } - End_roots(); - return Val_long(written); -} |
