import labltklabltk

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/labltk@2531 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

155 files changed, 15896 insertions, 0 deletions

diff --git a/otherlibs/labltk/.cvsignore b/otherlibs/labltk/.cvsignore
new file mode 100644
index 0000000000..65fc49b97a
--- /dev/null
+++ b/otherlibs/labltk/.cvsignore
@@ -0,0 +1,5 @@
+labltk
+labltklink
+labltkopt
+Makefile.config
+config.status
diff --git a/otherlibs/labltk/COPYRIGHT.mmm b/otherlibs/labltk/COPYRIGHT.mmm
new file mode 100644
index 0000000000..2f9626cca1
--- /dev/null
+++ b/otherlibs/labltk/COPYRIGHT.mmm
@@ -0,0 +1,56 @@
+LEGAL NOTICE
+
+Software: MMM, version 0.30alpha2 of January 1996, hereinafter
+referred to as "the software".
+
+The software has been designed and produced by Francois Rouaix,
+research worker for the Institut National de Recherche en Informatique et
+en Automatique (INRIA) - Domaine de Voluceau - Rocquencourt - 78153 Le
+Chesnay Cedex - France.
+
+INRIA holds all ownership rights to MMM.
+
+MMM uses various freely available software:
+Caml Special Light 1.13
+	Copyright INRIA.
+Tcl7.4pl3/Tk4.0pl3
+	Copyright The Regents of the University of California
+	and Sun Microsystems, Inc
+BLT-1.8
+	Copyright AT&T Bell Laboratories
+
+Preamble:
+
+The software is currently being developed and INRIA desires
+that it be used by the scientific community so as to test, evaluate
+and develop it.  To this end, INRIA has decided to have a prototype of
+the software distributed by FTP.
+
+a- Extent of the rights granted by the INRIA to the user of the software:
+
+INRIA freely grants the right to use, modify and integrate the
+software in another software, provided that the modifications are for
+personal use only. Public distribution of derivative works is not
+permitted, unless the user obtains the express approval of INRIA.
+
+b- Reproduction of the software:
+
+INRIA grants any user of the software the right to reproduce it so as
+to circulate it in accordance with the same purposes and conditions as
+those defined at point a- above.  Any copy of the software and/or relevant
+documentation must comprise reference to the ownership of INRIA and
+the present file.
+
+The user undertakes not to carry out any paying distribution of the
+software. However, he is authorized to bill any person or body for the
+cost of reproduction of said software. As regards any other type of
+distribution, the user undertakes to apply to obtain the express
+approval of INRIA.
+
+c- Guarantees:
+
+Please note that the software is a product currently being developed.
+INRIA shall not be responsible in any way concerning conformity, and in
+particular shall not be liable should the software not comply with the
+requirements of the user, INRIA not being obliged to repair any
+possible direct or indirect damage.
diff --git a/otherlibs/labltk/INSTALL b/otherlibs/labltk/INSTALL
new file mode 100644
index 0000000000..70369fb7cf
--- /dev/null
+++ b/otherlibs/labltk/INSTALL
@@ -0,0 +1,91 @@
+PREREQUISITES
+
+You must have already installed
+ * Objective Label 2.02 Summer edition
+    see http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/
+
+ * Tcl7.5/Tk4.1 through Tcl/Tk8.2
+    http://www.scriptics.com/ or various mirrors
+
+
+INSTALLATION INSTRUCTIONS
+
+1- Extract the archive labltk41-2.02.tar.gz somewhere (preferably
+directly in the main directory of your Objective Label installation).
+This will create the "labltk41" directory. (Only if you get it
+independently of olabl-2.02-summer)
+
+2- Configure the system. To complete this step, you need to know the
+locations of
+ * the installed Objective Label libraries (e.g. /usr/local/lib/olabl)
+ * where are the header and libraries for Tcl/Tk
+   (e.g. /usr/local/include and /usr/local/lib)
+ * the sources of Objective Label (for LablBrowser)
+
+Edit the file site.config, and set the corresponding variables
+(OLABLLIBDIR and OLABLBINDIR). You should also set a destination
+directory for executables. The rest of the configuration is supposed
+to be automated by the "configure" script; this scripts attempts to
+find the correct information for compiling and linking against Tk. If
+it fails, e.g. because your installation uses exotic paths, then you
+can help configure by setting other variables in site.config:
+CPPFLAGS="-I/path/to/tclinclude -I/path/to/tkinclude"
+LDFLAGS=-L/path/to/tcllib -L/path/to/tklib
+
+If you are compiling for several platforms, you can of course keep several
+site.config files. Don't forget to remove config.cache between compilation 
+runs.
+
+Then run
+$ ./configure --with-config=site.config
+
+This generates the files "Makefile.config" and "labltklink".
+
+If the automatic configuration fails, look at config.log to see what
+happened, check and edit site.config and rerun configure.
+
+If you just can't get configure to work, then look at the files
+Makefile.config.tmpl and labltklink.tmpl, and generate the required files
+Makefile.config and labltklink following the indications.
+
+Other settable variables in site.config are:
+INSTALLDIR: the final location of libraries
+LIBEXT: for japanese version of Tcl/Tk
+TKNAME: for special versions of Tk
+
+3- Build the system. From the "labltk41" directory, do:
+   make all
+   make opt for the native version
+
+4- To be sure everything works well, you can try the examples
+   cd examples; make; ./hello
+
+If the examples program fail with error message
+./helloworld: can't load library 'libtk4.2.so'
+or something similar, this means that you must set the LD_LIBRARY_PATH
+in your shell environment, e.g.
+	$ LD_LIBRARY_PATH=/usr/local/lib
+	$ export LD_LIBRARY_PATH
+or
+	% setenv LD_LIBRARY_PATH /usr/local/lib
+
+5- You will be even surer by compiling LablBrowser:
+   make browser
+   browser/lablbrowser
+
+6- You can now install LablTk41.
+   make install
+
+This will create /usr/local/lib/olabl/labltk41/ (or the equivalent for
+your installation of Objective Labl) and copy there the various
+library files, and copy labltklink (a command to link with Tk and X
+libraries) and labltktop (an Objective Labl toplevel with builtin Tk)
+to INSTALLBINDIR. If lablbrowser was compiled, it will also be
+installed.
+
+Remark about labltktop: since cmi files for Tk are not in OLABLLIBDIR
+but in a subdirectory, "open Tk;;" will fail.
+First type the directive:
+	# #directory"/usr/local/lib/olabl/labltk41";;
+and then
+	# open Tk;;
\ No newline at end of file
diff --git a/otherlibs/labltk/Makefile b/otherlibs/labltk/Makefile
new file mode 100644
index 0000000000..ed8743964e
--- /dev/null
+++ b/otherlibs/labltk/Makefile
@@ -0,0 +1,63 @@
+include Makefile.config
+
+SUBDIRS=compiler support lib jpf example browser
+
+all:    Makefile.config
+	cd support; $(MAKE)
+	cd compiler; $(MAKE)
+	cd lib; $(MAKE) -f Makefile.gen; $(MAKE)
+	cd jpf; $(MAKE)
+
+opt:	Makefile.config
+	cd support; $(MAKE) opt
+	cd lib; $(MAKE) -f Makefile.gen; $(MAKE) opt
+	cd jpf; $(MAKE) opt
+
+Makefile.config:
+	@echo "You must configure first. Read INSTALL."
+	exit 1
+
+lib: Widgets.src
+	compiler/tkcompiler
+	cd lib; $(MAKE)
+
+example: example/all
+
+example/all:
+	cd example; $(MAKE) all
+
+browser: browser/all
+
+browser/all:
+	cd browser; \
+	$(MAKE) LINKER='ocamlc -custom -ccopt -L../support -cclib -llabltk41 $(TKLIBS) $(X11_LIBS)' \
+		LABLTKLIB="-I ../lib -I ../support"
+
+install: 
+	if test -d $(INSTALLBINDIR); then : ; \
+		else mkdir -p $(INSTALLBINDIR); fi
+	cp labltklink labltk $(INSTALLBINDIR)
+	chmod 755 $(INSTALLBINDIR)/labltklink $(INSTALLBINDIR)/labltk
+	if test -d $(INSTALLDIR); then : ; else mkdir -p $(INSTALLDIR); fi
+	cd lib; $(MAKE) install
+	cd support; $(MAKE) install
+	cd compiler; $(MAKE) install
+	cd jpf; $(MAKE) install
+	cd browser; $(MAKE) install
+	if test -f lib/tk41.cmxa; then $(MAKE) installopt; fi
+
+installopt:
+	cp labltkopt $(INSTALLBINDIR)
+	chmod 755 $(INSTALLBINDIR)/labltkopt
+	cd lib; $(MAKE) installopt
+	cd jpf; $(MAKE) installopt
+
+clean : 
+	-rm -f config.cache
+	for d in $(SUBDIRS); do \
+	cd $$d; $(MAKE) clean; cd ..; \
+	done
+
+distclean:  clean
+	-rm -f config.log config.status config.cache
+	-rm -f Makefile.config labltklink labltk labltkopt
diff --git a/otherlibs/labltk/Makefile.config.in b/otherlibs/labltk/Makefile.config.in
new file mode 100644
index 0000000000..af3130c494
--- /dev/null
+++ b/otherlibs/labltk/Makefile.config.in
@@ -0,0 +1,39 @@
+## Where you installed Objective Label
+LIBDIR=@OCAMLLIBDIR@
+
+## Where are the sources (for LablBrowser).
+OCAMLDIR=@OCAMLSRCDIR@
+
+## Where you want to install LablTk41 libraries and binaries
+INSTALLDIR=@INSTALLDIR@
+INSTALLBINDIR=@INSTALLBINDIR@
+
+### What to use to link with X
+X11_LIBS=-cclib "@X_LIBS@ @THE_X_LIBS@"
+
+### What to use to compile and link with Tcl/Tk
+TKINCLUDES=-ccopt "@CPPFLAGS@"
+TKLIBS=-cclib "@LDFLAGS@ @LIBS@"
+
+### Making a library
+RANLIB=@RANLIB@
+
+### Shouldn't need to change anything below
+## Tools from the Objective Label distribution
+EXCRC=$(LIBDIR)/extract_crc
+EXPUNGE=$(LIBDIR)/expunge
+
+LABLC=ocamlc
+LABLCOMP=$(LABLC) -w s -modern -c
+CPP=@CPPPROG@ -P
+LABLYACC=ocamlyacc -v
+LABLLEX=ocamllex
+LABLLIBR=$(LABLC) -a
+LABLDEP=ocamldep
+COMPFLAGS=
+LINKFLAGS=
+
+CAMLOPT=ocamlopt
+CAMLOPTLIBR=$(CAMLOPT) -a
+
+## End of configuration section
diff --git a/otherlibs/labltk/Makefile.config.tmpl b/otherlibs/labltk/Makefile.config.tmpl
new file mode 100644
index 0000000000..ba3b9e8337
--- /dev/null
+++ b/otherlibs/labltk/Makefile.config.tmpl
@@ -0,0 +1,40 @@
+# Generated automatically from Makefile.config.in by configure.
+## Where you installed Objective Label
+LIBDIR=/usr/local/lib/olabl
+
+## Where are the sources (for LablBrowser).
+OLABLDIR=../..
+
+## Where you want to install LablTk41 libraries and binaries
+INSTALLDIR=/usr/local/lib/olabl/labltk41
+INSTALLBINDIR=/usr/local/bin
+
+### What to use to link with X
+X11_LIBS=-ccopt "" -cclib " -lX11"
+
+### What to use to compile and link with Tcl/Tk
+TKINCLUDES=-ccopt "-I/usr/local/include "
+TKLIBS=-ccopt "-L/usr/local/lib" -cclib "-ltk4.2 -ltcl7.6 -lm"
+
+### Making a library
+RANLIB=ranlib
+
+### Shouldn't need to change anything below
+## Tools from the Objective Label distribution
+EXCRC=$(LIBDIR)/extract_crc
+EXPUNGE=$(LIBDIR)/expunge
+
+LABLC=olablc
+LABLCOMP=$(LABLC) -c
+CPP=/usr/bin/cpp -P
+LABLYACC=olablyacc -v
+LABLLEX=olabllex
+LABLLIBR=$(LABLC) -a
+LABLDEP=olabldep
+COMPFLAGS=
+LINKFLAGS=
+
+CAMLOPT=olablopt
+CAMLOPTLIBR=$(CAMLOPT) -a
+
+## End of configuration section
diff --git a/otherlibs/labltk/README b/otherlibs/labltk/README
new file mode 100644
index 0000000000..102b0fd82c
--- /dev/null
+++ b/otherlibs/labltk/README
@@ -0,0 +1,25 @@
+LablTk41 is a library for interfacing Objective Labl with the scripting
+language Tcl/Tk (all versions since 7.5/4.1, but no betas).
+
+In addition to the basic interface with Tcl/Tk, this package contains
+ * the LablBrowser 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
+ 
+
+REQUIREMENTS:
+You must have already installed
+ * Objective Label 2.02 Summer edition
+    http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/
+
+ * Tcl7.5/Tk4.1 through Tcl/Tk8.2
+    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).  We have not attempted to
+compile this package on Windows.
+
+See the INSTALL file for installation instructions.
diff --git a/otherlibs/labltk/Widgets.src b/otherlibs/labltk/Widgets.src
new file mode 100644
index 0000000000..79c92bd729
--- /dev/null
+++ b/otherlibs/labltk/Widgets.src
@@ -0,0 +1,1847 @@
+############## Standard Tk4.0 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
+
+variant type ImageBitmap {
+  Bitmap [string]
+  }
+variant type ImagePhoto {
+  Photo [string]
+  }
+variant type Image {
+  Bitmap [string]
+  Photo [string]
+}
+
+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]
+   ActiveForeground		["-activeforeground"; Color]
+   Anchor			["-anchor"; Anchor]
+   Background			["-background"; Color]
+   Bitmap			["-bitmap"; Bitmap]
+   BorderWidth			["-borderwidth"; Units]
+   Cursor			["-cursor";  Cursor]
+   DisabledForeground		["-disabledforeground"; Color]
+   ExportSelection		["-exportselection"; bool]
+   Font				["-font"; string]
+   Foreground			["-foreground"; Color]
+   Geometry			["-geometry"; string]  # Too variable to encode
+   HighlightBackground          ["-highlightbackground"; Color]
+   HighlightColor               ["-highlightcolor"; Color]
+   HighlightThickness           ["-highlightthickness"; Units]
+   Image 			["-image"; Image]
+# it is old   # images are split, to do additionnal static typing
+#   ImageBitmap (ImageBitmap)    ["-image"; ImageBitmap]
+#   ImagePhoto  (ImagePhoto)	["-image"; ImagePhoto]
+   InsertBackground		["-insertbackground"; Color]
+   InsertBorderWidth		["-insertborderwidth"; Units]
+   InsertOffTime		["-insertofftime"; int]   # Positive only
+   InsertOnTime			["-insertontime"; int]    # Idem
+   InsertWidth			["-insertwidth"; Units]
+   Jump				["-jump"; bool]
+   Justify			["-justify"; Justification]
+   Orient			["-orient"; Orientation]
+   PadX				["-padx"; Units]
+   PadY				["-pady"; Units]
+   Relief			["-relief"; Relief]
+   RepeatDelay			["-repeatdelay"; int]
+   RepeatInterval		["-repeatinterval"; int]
+   SelectBackground		["-selectbackground"; Color]
+   SelectBorderWidth		["-selectborderwidth"; Units]
+   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]
+   # Major incompatibility with Tk3.6 where it was function(int,int,int,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 {
+  function () ring ["bell"; ?displayof:["-displayof"; widget]]
+#  function () ring ["bell"]
+#  function () ring_displayof ["bell"; "-displayof" ; displayof: widget]
+  }
+
+##### 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]
+#  function (ImageBitmap) create ["image"; "create"; "bitmap"; option(bitmapimage) list]
+#  function (ImageBitmap) create_named ["image"; "create"; "bitmap"; name: ImageBitmap; option(bitmapimage) list]
+  function () configure [ImageBitmap; "configure"; option(bitmapimage) list]
+  function (string) configure_get [ImageBitmap; "configure"]
+  # Functions inherited from the "image" TK class
+  function () delete ["image"; "delete"; ImageBitmap]
+  function (int) height ["image"; "height"; ImageBitmap]
+  function (int) width ["image"; "width"; ImageBitmap]
+  }
+
+##### 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
+   option Image
+#   option ImageBitmap
+#   option ImagePhoto
+   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 Height ["-height"; Units]
+   option State ["-state"; State]
+   option Width ["-width"; Units]
+
+   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; Units]
+  ClosestHalo (Closesthalo) ["closest"; Units; Units; Units]
+  ClosestHaloStart (Closesthalostart) ["closest"; Units; Units; Units; TagOrId]
+  Enclosed ["enclosed"; Units;Units;Units;Units]
+  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]
+   PageWidth ["-pagewidth"; Units]
+   PageX ["-pagex"; Units]
+   PageY ["-pagey"; Units]
+   Rotate ["-rotate"; bool]
+   Width
+   X ["-x"; Units]
+   Y ["-y"; Units]
+   }
+
+
+# Arc item configuration
+type ArcStyle {
+   Arc ["arc"]
+   Chord ["chord"]
+   PieSlice ["pieslice"]
+}
+
+subtype option(arc) {
+   Extent ["-extent"; float]
+   # 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 list]]
+   Width
+  }
+
+# Bitmap item configuration
+subtype option(bitmap) {
+   Anchor
+   Background
+   Bitmap
+   Foreground
+   Tags
+}
+
+# Image item configuration
+subtype option(image) {
+   Anchor
+   Image
+#   ImagePhoto
+#   ImageBitmap
+   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; Units; Units]]
+   CapStyle ["-capstyle"; CapStyle]
+   FillColor
+   JoinStyle ["-joinstyle"; JoinStyle]
+   Smooth ["-smooth"; bool]
+   SplineSteps ["-splinesteps"; int]
+   Stipple
+   Tags
+   Width
+   }
+
+# Oval item configuration
+subtype option(oval) {
+   FillColor Outline Stipple Tags Width
+   }
+
+# Polygon item configuration
+subtype option(polygon) {
+   FillColor Outline Smooth SplineSteps
+   Stipple Tags Width
+   }
+
+# Rectangle item configuration
+subtype option(rectangle) {
+   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]
+   }
+
+# 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]
+   option ScrollRegion ["-scrollregion"; [Units;Units;Units;Units]]
+   option Width ["-width"; Units]
+   option XScrollIncrement ["-xscrollincrement"; Units]
+   option YScrollIncrement ["-yscrollincrement"; Units]
+
+
+   function () addtag [widget(canvas); "addtag"; tag: TagOrId; 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"; tags: TagOrId list]
+   external bind "builtin/canvas_bind"
+   function (float) canvasx [widget(canvas); "canvasx"; x:Units; ?spacing:[Units]]
+#   function (float) canvasx [widget(canvas); "canvasx"; x:Units]
+#   function (float) canvasx_grid [widget(canvas); "canvasx"; x:Units; spacing:Units]
+   function (float) canvasy [widget(canvas); "canvasy"; y:Units; ?spacing:[Units]]
+#   function (float) canvasy [widget(canvas); "canvasy"; y:Units]
+#   function (float) canvasy_grid [widget(canvas); "canvasy"; y:Units; spacing:Units]
+   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"; tag: TagOrId]
+   function () coords_set [widget(canvas); "coords"; tag: TagOrId; coords: Units list]
+   # create variations (see below)
+   function () dchars [widget(canvas); "dchars"; tag: TagOrId; first: Index(canvas); last: Index(canvas)]
+   function () delete [widget(canvas); "delete"; tags: TagOrId list]
+   function () dtag [widget(canvas); "dtag"; tag: TagOrId; tagtodelete: TagOrId]     # 2d arg is tag only 
+   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"; tag: TagOrId]
+   function (TagOrId list) gettags [widget(canvas); "gettags"; tag: TagOrId]
+   function () icursor [widget(canvas); "icursor"; tag: TagOrId; index: Index(canvas)]
+   function (int) index [widget(canvas); "index"; tag: TagOrId; index: Index(canvas)]
+   function () insert [widget(canvas); "insert"; tag: TagOrId; before: Index(canvas); text: string]
+   function () lower [widget(canvas); "lower"; tag: TagOrId; ?below: [TagOrId]]
+   # configure variations, see below
+#   function () lower_below [widget(canvas); "lower"; tag: TagOrId; below: TagOrId]
+#   function () lower_bot   [widget(canvas); "lower"; tag: TagOrId]
+   function () move [widget(canvas); "move"; tag: TagOrId; x: Units; y: Units]
+   unsafe function (string) postscript [widget(canvas); "postscript"; option(postscript) list]
+   # We use raise... with Module name
+   function () raise [widget(canvas); "raise"; tag: TagOrId; ?above:[TagOrId]]
+#   function () raise_above [widget(canvas); "raise"; tag: TagOrId; above: TagOrId]
+#   function () raise_top [widget(canvas); "raise"; tag: TagOrId]
+   function () scale [widget(canvas); "scale"; tag: TagOrId; xorigin: Units; yorigin: Units; 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"; tag: TagOrId; index: Index(canvas)]
+   function () select_clear [widget(canvas); "select"; "clear"]
+   function () select_from [widget(canvas); "select"; "from"; tag: TagOrId; index: Index(canvas)]
+   function (TagOrId) select_item [widget(canvas); "select"; "item"]
+   function () select_to  [widget(canvas); "select"; "to"; tag: TagOrId; index: Index(canvas)]
+
+   function (CanvasItem) typeof [widget(canvas); "type"; tag: 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; y1: Units; x2: Units; y2: Units; option(arc) list]
+   function (TagOrId) create_bitmap [widget(canvas); "create"; "bitmap"; x: Units; y: Units; option(bitmap) list]
+   function (TagOrId) create_image [widget(canvas); "create"; "image"; x: Units; y: Units; option(image) list]
+   function (TagOrId) create_line [widget(canvas); "create"; "line"; xys: Units list; option(line) list]
+   function (TagOrId) create_oval [widget(canvas); "create"; "oval"; x1: Units; y1: Units; x2: Units; y2: Units; option(oval) list]
+   function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; xys: Units list; option(polygon) list]
+   function (TagOrId) create_rectangle [widget(canvas); "create"; "rectangle"; x1: Units; y1: Units; x2: Units; y2: Units; option(rectangle) list]
+   function (TagOrId) create_text [widget(canvas); "create"; "text"; x: Units; y: Units; option(canvastext) list]
+   function (TagOrId) create_window [widget(canvas); "create"; "window"; x: Units; y: Units; option(window) list]
+
+   function (string) itemconfigure_get [widget(canvas); "itemconfigure"; tag: TagOrId]
+
+   function () configure_arc [widget(canvas); "itemconfigure"; tag: TagOrId; option(arc) list]
+   function () configure_bitmap [widget(canvas); "itemconfigure"; tag: TagOrId; option(bitmap) list]
+   function () configure_image [widget(canvas); "itemconfigure"; tag: TagOrId; option(image) list]
+   function () configure_line [widget(canvas); "itemconfigure"; tag: TagOrId; option(line) list]
+   function () configure_oval [widget(canvas); "itemconfigure"; tag: TagOrId; option(oval) list]
+   function () configure_polygon [widget(canvas); "itemconfigure"; tag: TagOrId; option(polygon) list]
+   function () configure_rectangle [widget(canvas); "itemconfigure"; tag: TagOrId; option(rectangle) list]
+   function () configure_text [widget(canvas); "itemconfigure"; tag: TagOrId; option(canvastext) list]
+   function () configure_window [widget(canvas); "itemconfigure"; tag: 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
+   option Image
+#   option ImageBitmap
+#   option ImagePhoto
+   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]
+   option SelectImage ["-selectimage"; Image]
+#   option SelectImageBitmap (SelectImageBitmap) ["-selectimage"; ImageBitmap]
+#   option SelectImagePhoto (SelectImagePhoto) ["-selectimage"; ImagePhoto]
+   option State    ["-state"; 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_clear) {
+  DisplayOf ["-displayof"; widget]
+  }
+
+subtype icccm(clipboard_append) {
+  DisplayOf ["-displayof"; widget]
+  ICCCMFormat ["-format"; string]
+  ICCCMType ["-type"; string]
+  }
+
+module Clipboard {
+  function () clear ["clipboard"; "clear"; icccm(clipboard_clear) list]
+  function () append ["clipboard"; "append"; 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
+# }
+
+
+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]
+   option State
+   option TextWidth (Textwidth) ["-width"; int]
+
+   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); end: 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) ; end: Index(entry)]
+   function () selection_to [widget(entry); "selection"; "to"; index: Index(entry)]
+
+   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"]
+  function ()       set ["focus"; widget]
+  unsafe function (widget) displayof ["focus"; "-displayof"; displayof: 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"]
+}
+
+
+##### frame(n)
+type Colormap {
+  NewColormap (New) ["new"]
+  WidgetColormap (Widget) [widget]
+  }
+
+# Visual classes are: directcolor, grayscale, greyscale, pseudocolor,
+#                     staticcolor, staticgray, staticgrey, truecolor
+type Visual {
+  ClassVisual (Class) [[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
+   option Class  ["-class"; string]
+   option Colormap ["-colormap"; Colormap]
+   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"]
+}
+module Grab {
+   function () set ["grab"; widget]
+   function () set_global ["grab"; "-global"; widget]
+   unsafe function (widget list) current ["grab"; "current"; ?widget:[widget]]
+#   unsafe function (widget list) current ["grab"; "current"; widget]
+#   unsafe function (widget list) all_current ["grab"; "current"]
+   function () release ["grab"; "release"; widget]
+   function (GrabStatus) status ["grab"; "status"; widget]
+}
+
+subtype option(rowcolumnconfigure) {
+  Minsize ["-minsize"; Units]
+  Weight  ["-weight"; float]
+}
+
+subtype option(grid) {
+   Column ["-column"; int]
+   ColumnSpan ["-columnspan"; int]
+   In ["-in"; widget]
+   IPadX ["-ipadx"; Units]
+   IPadY ["-ipady"; Units]
+   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; int; int]
+   function () column_configure 
+       ["grid"; "columnconfigure"; widget; x:int;
+	 option(rowcolumnconfigure) list]
+   function () configure ["grid"; "configure"; widget list; option(grid) list]
+   function (string) column_configure_get ["grid"; "columnconfigure"; widget;
+                              x: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:int; y:int]
+   function (bool) propagate_get ["grid"; "propagate"; widget]
+   function () propagate_set ["grid"; "propagate"; widget; to: bool]
+   function () row_configure 
+       ["grid"; "rowconfigure"; widget; y:int; option(rowcolumnconfigure) list]
+   function (string) row_configure_get 
+       ["grid"; "rowconfigure"; widget; y:int]
+   function (int,int) size ["grid"; "size"; widget]
+
+   function (widget list) slaves ["grid"; "slaves"; widget; ?column:["-column"; int]; ?row:["-row"; int]]
+#   function (widget list) all_slaves ["grid"; "slaves"; widget]
+#   function (widget list) row_slaves ["grid"; "slaves"; widget; "-row"; int]
+#   function (widget list) column_slaves ["grid"; "slaves"; widget; "-column"; int]
+   }
+
+
+
+
+
+
+##### image(n)
+##### cf bitmap(n) and photo(n)
+# Some functions on images are not implemented
+# names, types
+
+
+##### 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
+   option Image
+#   option ImageBitmap
+#   option ImagePhoto
+   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 Foreground
+   option Font
+   option HighlightBackground
+   option HighlightColor
+   option HighlightThickness
+   option Relief
+   option SelectBackground
+   option SelectBorderWidth
+   option SelectForeground
+   option SetGrid
+   option TakeFocus
+   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 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 int]") index [widget(listbox); "index"; index: Index(listbox)]
+   function () insert [widget(listbox); "insert"; index: Index(listbox); texts: string list]
+   function (Index(listbox) as "[>`Num 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]]
+#function () lower_window ["lower"; widget]
+#function () lower_window_below ["lower"; widget; below: widget]
+
+
+##### 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
+   Command
+   Font
+   Foreground
+   Image
+#   ImageBitmap
+#   ImagePhoto
+   IndicatorOn
+   Label ["-label"; string]
+   Menu ["-menu"; widget(menu)]
+   OffValue
+   OnValue
+   SelectColor
+   SelectImage
+#   SelectImageBitmap
+#   SelectImagePhoto
+   State
+   UnderlinedChar
+   Value ["-value"; string]
+   Variable
+   }
+
+# Options for cascade entry
+subtype option(menucascade) {
+   ActiveBackground ActiveForeground Accelerator
+   Background Bitmap Command Font Foreground
+#   ImageBitmap ImagePhoto Label Menu State UnderlinedChar
+   Image Label Menu State UnderlinedChar
+   }
+
+# Options for radiobutton entry
+subtype option(menuradio) {
+   ActiveBackground ActiveForeground Accelerator
+   Background Bitmap Command Font Foreground
+#   ImageBitmap ImagePhoto IndicatorOn Label
+   Image IndicatorOn Label
+#   SelectColor SelectImageBitmap SelectImagePhoto
+   SelectColor SelectImage
+   State UnderlinedChar Value Variable
+   }
+
+# Options for checkbutton entry
+subtype option(menucheck) {
+   ActiveBackground ActiveForeground Accelerator
+   Background Bitmap Command Font Foreground
+#   ImageBitmap ImagePhoto IndicatorOn Label
+   Image IndicatorOn Label
+#   OffValue OnValue SelectColor SelectImageBitmap SelectImagePhoto 
+   OffValue OnValue SelectColor SelectImage
+   State UnderlinedChar Variable
+   }
+
+# Options for command entry
+subtype option(menucommand) {
+   ActiveBackground ActiveForeground Accelerator
+   Background Bitmap Command Font Foreground
+#   ImageBitmap ImagePhoto Label State UnderlinedChar
+   Image Label State UnderlinedChar
+   }
+
+# 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]
+
+   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"]
+   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: Index(menu); option(menucascade) list]
+   function () configure_checkbutton [widget(menu); "entryconfigure"; index: Index(menu); option(menucheck) list]
+   function () configure_command [widget(menu); "entryconfigure"; index: Index(menu); option(menucommand) list]
+   function () configure_radiobutton [widget(menu); "entryconfigure"; index: Index(menu); option(menuradio) list]
+   function (string) entryconfigure_get [widget(menu); "entryconfigure"; index: Index(menu)]
+   function (int) index [widget(menu); "index"; 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)]]
+#   function () popup ["tk_popup"; widget(menu); x: int; y: int]
+#   function () popup_entry ["tk_popup"; widget(menu); x: int; y: int; index: Index(menu)]
+   }
+
+
+##### menubutton(n)
+
+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
+   option Image
+#   option ImageBitmap
+#   option ImagePhoto
+   option Justify
+   option PadX
+   option PadY
+   option Relief
+   option TakeFocus
+   option Text
+   option TextVariable
+   option UnderlinedChar
+   option WrapLength
+   # Widget specific options
+   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]
+   }
+
+module Option {
+   unsafe function () add
+	["option"; "add"; string; value: string; ?priority:[OptionPriority]]
+   function () clear ["option"; "clear"]
+   function (string) get ["option"; "get"; widget; name: string; class: string]
+   unsafe function () readfile
+	["option"; "readfile"; name:string; ?priority:[OptionPriority]]
+   }
+
+##### 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 ["-in"; widget]
+   IPadX ["-ipadx"; Units]
+   IPadY ["-ipady"; Units]
+   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 (bool) propagate_get ["pack"; "propagate"; widget]
+    function () propagate_set ["pack"; "propagate"; widget; to: 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) {
+  Data
+  Format ["-format"; string]
+  File
+  Gamma ["-gamma"; float]
+  Height
+  Palette ["-palette"; PaletteType]
+  Width
+  }
+
+subtype photo(copy) {
+  ImgFrom ["-from"; int; int; int; int]
+  ImgTo   ["-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 ["-to"; int; int]
+  }
+
+subtype photo(write) {
+  ImgFormat ImgFrom
+  }
+
+module Imagephoto {
+  function (ImagePhoto) create ["image"; "create"; "photo"; option(photoimage) list]
+  function () blank [ImagePhoto; "blank"]
+  function () configure [ImagePhoto; "configure"; option(photoimage) list]
+  function (string) configure_get [ImagePhoto; "configure"]
+  function () copy [ImagePhoto; "copy"; to: ImagePhoto; photo(copy) list]
+  function (int, int, int) get [ImagePhoto; "get"; x: int; y: int]
+# can't express nested lists ?
+#  function () put [ImagePhoto; "put"; [[Color list] list]; photo(put) list]
+  function () read [ImagePhoto; "read"; name: string; photo(read) list]
+  function () redither [ImagePhoto; "redither"]
+  function () write [ImagePhoto; "write"; photo(write) list]
+  # Functions inherited from the "image" TK class
+  function () delete ["image"; "delete"; ImagePhoto]
+  function (int) height ["image"; "height"; ImagePhoto]
+  function (int) width ["image"; "width"; ImagePhoto]
+  }
+
+
+##### 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
+   option Image
+#   option ImageBitmap
+#   option ImagePhoto
+   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
+   option SelectImage
+#   option SelectImageBitmap
+#   option SelectImagePhoto
+   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]]
+#function () raise_window ["raise"; widget]
+#function () raise_window_above ["raise"; widget; above: widget]
+
+
+##### scale(n)
+## shared with scrollbars
+subtype WidgetElement(scale) {
+  Slider ["slider"]
+  Trough1 ["trough1"]
+  Trough2 ["trough2"]
+  Beyond [""]
+  }
+
+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 ["-from"; float]
+   option Label ["-label"; string]
+   option Length ["-length"; Units]
+   option Resolution ["-resolution"; float]
+   option ShowValue ["-showvalue"; bool]
+   option SliderLength ["-sliderlength"; Units]
+   option State
+   option TickInterval ["-tickinterval"; float]
+   option To ["-to"; float]
+   option Variable
+   option Width
+
+   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(scale)) identify [widget(scale); x: int; y: int]
+   function () set [widget(scale); "set"; to: float]
+   }
+
+
+##### scrollbar(n)
+subtype WidgetElement(scrollbar) {
+  Arrow1 ["arrow1"]
+  Trough1
+  Trough2
+  Slider
+  Arrow2 ["arrow2"]
+  Beyond
+  }
+
+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]
+   option Width
+
+   function () activate [widget(scrollbar); "activate"; element: WidgetElement(scrollbar)]
+   function (WidgetElement(scrollbar)) 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(scrollbar)) identify [widget(scrollbar); "identify"; x: int; y: 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
+  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"
+   }
+
+
+##### text(n)
+
+type TextIndex external
+type TextTag external
+type TextMark external
+
+
+type TabType {
+  TabLeft [Units; "left"]
+  TabRight [Units; "right"]
+  TabCenter [Units; "center"]
+  TabNumeric [Units; "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]
+  Image
+  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]
+  }
+
+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]
+   option Spacing2 ["-spacing2"; Units]
+   option Spacing3 ["-spacing3"; Units]
+   option State
+   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; comparison: Comparison; index: TextIndex]
+   function () configure [widget(text); "configure"; option(text) list]
+   function (string) configure_get [widget(text); "configure"]
+   function () debug [widget(text); "debug"; switch: bool]
+   function () delete [widget(text); "delete"; start: TextIndex; end: TextIndex]
+   function () delete_char [widget(text); "delete"; index: TextIndex]
+   function (int, int, int, int, int) dlineinfo [ widget(text); "dlineinfo"; index: TextIndex]
+   function (string) get [widget(text); "get"; start: TextIndex; end: 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"; option(embeddedi) list]
+   function (string list) image_names [widget(text); "image"; "names"]
+   function (Index(text) as "[>`Linechar int * int]") index [widget(text); "index"; index: TextIndex]
+   function () insert [widget(text); "insert"; index: TextIndex; text: string; ?tags: [TextTag list]]
+   # 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 () 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]
+   function (Index(text) as "[>`Linechar int * int]") search [widget(text); "search"; switches: TextSearch list; "--"; pattern: string; start: TextIndex; ?end: [TextIndex]]
+   function () see [widget(text); "see"; index: TextIndex]
+   # Tags
+   function () tag_add [widget(text); "tag"; "add"; tag: TextTag; start: TextIndex; end: TextIndex]
+   function () tag_add_char [widget(text); "tag"; "add"; tag: TextTag; at: 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]]
+#   function () tag_lower_below [widget(text); "tag";  "lower"; tag: TextTag; below: TextTag]
+#   function () tag_lower_bot [widget(text); "tag"; "lower"; tag: TextTag]
+   function (TextTag list) tag_names [widget(text); "tag"; "names"; ?index: [TextIndex]]
+#   function (TextTag list) tag_allnames [widget(text); "tag"; "names"]
+#   function (TextTag list) tag_indexnames [widget(text); "tag"; "names"; index: TextIndex]
+   function (Index(text) as "[>`Linechar int * int]", Index(text) as "[>`Linechar int * int]") tag_nextrange [widget(text); "tag"; "nextrange"; tag: TextTag; start: TextIndex; ?end: [TextIndex]]
+   function () tag_raise [widget(text); "tag"; "raise"; tag: TextTag; ?above: [TextTag]]
+#   function () tag_raise_above [widget(text); "tag"; "raise"; tag: TextTag; above: TextTag]
+#   function () tag_raise_top [widget(text); "tag"; "raise"; tag: TextTag ]
+   function (Index(text) as "[>`Linechar int * int]" list) tag_ranges [widget(text); "tag"; "ranges"; tag: TextTag]
+   function () tag_remove [widget(text); "tag"; "remove"; tag: TextTag; start: TextIndex; end: TextIndex]
+   function () tag_remove_char [widget(text); "tag"; "remove"; tag: TextTag; at: 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]
+   LMargin2 ["-lmargin2"; Units]
+   Offset ["-offset"; Units]
+   OverStrike ["-overstrike"; bool]
+   Relief
+   RMargin ["-rmargin"; Units]
+   Spacing1
+   Spacing2
+   Spacing3
+   Tabs 
+   Underline ["-underline"; bool]
+   Wrap ["-wrap"; WrapMode]
+   }
+
+
+##### tk(n)
+function () appname_set ["tk"; "appname"; string]
+function (string) appname_get ["tk"; "appname"]
+
+##### 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
+   option Class
+   option Colormap
+   option Height
+   option Screen ["-screen"; string]
+   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"; string]
+   unsafe function (AtomId) atom_displayof ["winfo"; "atom"; "-displayof"; displayof: widget; string]
+   unsafe function (string) atomname ["winfo"; "atomname"; ?displayof:["-displayof"; widget]; AtomId]
+#   unsafe function (string) atomname ["winfo"; "atomname"; AtomId]
+#   unsafe function (string) atomname_displayof ["winfo"; "atomname"; "-displayof"; displayof: widget; AtomId]
+   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]
+#   unsafe function (widget) containing ["winfo"; "containing"; x: int; y: int]
+   # addition for applets
+   external contained "builtin/winfo_contained"
+#   unsafe function (widget) containing_displayof ["winfo"; "containing"; "-displayof"; displayof: widget; x: int; y: int]
+   function (int) depth ["winfo"; "depth"; widget]
+   function (bool) exists ["winfo"; "exists"; widget]
+   function (float) fpixels ["winfo"; "fpixels"; widget; distance: 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_displayof ["winfo"; "interps"; ?displayof:["-displayof"; widget]]
+#   unsafe function (string list) interps ["winfo"; "interps"]
+#   unsafe function (string list) interps_displayof ["winfo"; "interps"; "-displayof"; displayof:widget]
+   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]
+#   unsafe function (widget) pathname ["winfo"; "pathname"; string]
+#   unsafe function (widget) pathname_displayof ["winfo"; "pathname"; "-displayof"; displayof: widget; string]
+   function (int) pixels ["winfo"; "pixels"; widget; distance: 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]
+   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) screenmmdepth ["winfo"; "screenmmdepth"; widget]
+   function (int) screenmmheight ["winfo"; "screenmmheight"; 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]
+   # not so
+   function (string) visualsavailable ["winfo"; "visualsavailable"; widget]
+   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 {
+   FromUser ["user"]
+   FromProgram ["program"]
+}
+
+module Wm {
+### Aspect
+   function () aspect_set ["wm"; "aspect"; widget; minnum:int; mindenom:int; maxnum:int; maxdenom:int]
+   # aspect: problem with empty return
+   function (int,int,int,int) aspect_get ["wm"; "aspect"; widget]
+### WM_CLIENT_MACHINE
+   function () client_set ["wm"; "client"; widget; name: string]
+   function (string) client_get ["wm"; "client"; widget]
+### WM_COLORMAP_WINDOWS
+   function () colormapwindows_set 
+        ["wm"; "colormapwindows"; widget; [widgets: widget list]]
+   unsafe function (widget list) colormapwindows_get
+	["wm"; "colormapwindows"; widget]
+### WM_COMMAND
+   function () command_clear ["wm"; "command"; widget; ""]
+   function () command_set ["wm"; "command"; widget; [commands: string list]]
+   function (string list) command_get ["wm"; "command"; widget]
+
+   function () deiconify ["wm"; "deiconify"; widget]
+
+### Focus model
+   function () focusmodel_set ["wm"; "focusmodel"; widget; model: FocusModel]
+   function (FocusModel) focusmodel_get ["wm"; "focusmodel"; widget]
+
+   function (string) frame ["wm"; "frame"; widget]
+
+### Geometry
+   function () geometry_set ["wm"; "geometry"; widget; geometry: string]
+   function (string) geometry_get ["wm"; "geometry"; widget]
+
+### Grid
+   function () grid_clear ["wm"; "grid"; widget; ""; ""; ""; ""]
+   function () grid_set ["wm"; "grid"; widget; basewidth: int; baseheight: int; widthinc: int; heightinc: int]
+   function (int,int,int,int) grid_get ["wm"; "grid"; widget]
+
+### Groups
+   function () group_clear ["wm"; "group"; widget; ""]
+   function () group_set ["wm"; "group"; widget; leader: widget]
+   unsafe function (widget) group_get ["wm"; "group"; widget]
+### Icon bitmap
+   function () iconbitmap_clear ["wm"; "iconbitmap"; widget; ""]
+   function () iconbitmap_set ["wm"; "iconbitmap"; widget; bitmap: Bitmap]
+   function (Bitmap) iconbitmap_get ["wm"; "iconbitmap"; widget]
+
+   function () iconify ["wm"; "iconify"; widget]
+
+### Icon mask
+   function () iconmask_clear ["wm"; "iconmask"; widget; ""]
+   function () iconmask_set ["wm"; "iconmask"; widget; bitmap: Bitmap]
+   function (Bitmap) iconmask_get ["wm"; "iconmask"; widget]
+
+### Icon name
+   function () iconname_set ["wm"; "iconname"; widget; name: string]
+   function (string) iconname_get ["wm"; "iconname"; widget]
+### Icon position
+   function () iconposition_clear ["wm"; "iconposition"; widget; ""; ""]
+   function () iconposition_set ["wm"; "iconposition"; widget; x: int; y: int]
+   function (int,int) iconposition_get ["wm"; "iconposition"; widget]
+### Icon window
+   function () iconwindow_clear ["wm"; "iconwindow"; widget; ""]
+   function () iconwindow_set ["wm"; "iconwindow"; widget; icon: widget]
+   unsafe function (widget) iconwindow_get ["wm"; "iconwindow"; widget]
+
+### Sizes
+   function () maxsize_set ["wm"; "maxsize"; widget; width: int; height: int]
+   function (int,int) maxsize_get ["wm"; "maxsize"; widget]
+   function () minsize_set ["wm"; "minsize"; widget; width: int; height: int]
+   function (int,int) minsize_get ["wm"; "minsize"; widget]
+### Override
+   function () overrideredirect_set ["wm"; "overrideredirect"; widget; to: bool]
+   function (bool) overrideredirect_get ["wm"; "overrideredirect"; widget]
+### Position
+   function () positionfrom_clear ["wm"; "positionfrom"; widget; ""]
+   function () positionfrom_set ["wm"; "positionfrom"; widget; who: WmFrom]
+   function (WmFrom) positionfrom_get ["wm"; "positionfrom"; widget]
+### Protocols
+   function () protocol_set ["wm"; "protocol"; widget; name: string; command: function()]
+   function () protocol_clear ["wm"; "protocol"; widget; name: string; ""]
+   function (string list) protocols ["wm"; "protocol"; widget]
+### 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; ""]
+   function () sizefrom_set ["wm"; "sizefrom"; widget; who: WmFrom]
+   function (WmFrom) sizefrom_get ["wm"; "sizefrom"; widget]
+
+   function (string) state ["wm"; "state"; widget]
+
+### Title
+   function (string) title_get ["wm"; "title"; widget]
+   function () title_set ["wm"; "title"; widget; title: string]
+### Transient
+   function () transient_clear ["wm"; "transient"; widget; ""]
+   function () transient_set ["wm"; "transient"; widget; master: widget(toplevel)]
+   unsafe function (widget(toplevel)) transient_get ["wm"; "transient"; widget]
+
+   function () withdraw ["wm"; "withdraw"; widget]
+
+}
diff --git a/otherlibs/labltk/browser/.cvsignore b/otherlibs/labltk/browser/.cvsignore
new file mode 100644
index 0000000000..c5fa6cd386
--- /dev/null
+++ b/otherlibs/labltk/browser/.cvsignore
@@ -0,0 +1 @@
+lablbrowser
diff --git a/otherlibs/labltk/browser/.depend b/otherlibs/labltk/browser/.depend
new file mode 100644
index 0000000000..de782f073a
--- /dev/null
+++ b/otherlibs/labltk/browser/.depend
@@ -0,0 +1,66 @@
+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 \
+    list2.cmo 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 \
+    list2.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_config.cmi 
+jg_config.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_button.cmo jg_text.cmi jg_tk.cmo \
+    jg_toplevel.cmo jg_message.cmi 
+jg_message.cmx: jg_bind.cmx jg_button.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_message.cmi jg_text.cmi jg_tk.cmo lexical.cmi \
+    searchid.cmi searchpos.cmi 
+searchpos.cmx: jg_bind.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: fileselect.cmi jg_menu.cmo jg_text.cmi jg_tk.cmo jg_toplevel.cmo \
+    lexical.cmi list2.cmo shell.cmi 
+shell.cmx: fileselect.cmx jg_menu.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: list2.cmo useunix.cmi 
+useunix.cmx: list2.cmx useunix.cmi 
+viewer.cmo: jg_bind.cmi jg_box.cmo jg_button.cmo jg_entry.cmo jg_menu.cmo \
+    jg_message.cmi jg_multibox.cmi jg_tk.cmo jg_toplevel.cmo list2.cmo \
+    mytypes.cmi searchid.cmi searchpos.cmi setpath.cmi shell.cmi useunix.cmi \
+    viewer.cmi 
+viewer.cmx: jg_bind.cmx jg_box.cmx jg_button.cmx jg_entry.cmx jg_menu.cmx \
+    jg_message.cmx jg_multibox.cmx jg_tk.cmx jg_toplevel.cmx list2.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
new file mode 100644
index 0000000000..94b11d80ce
--- /dev/null
+++ b/otherlibs/labltk/browser/Makefile
@@ -0,0 +1,46 @@
+include ../Makefile.config
+
+LINKER=labltklink
+LABLTKLIB=-I $(INSTALLDIR)
+INCLUDES=$(LABLTKLIB) $(OLABLINCLUDES)
+OLABLINCLUDES=-I $(OCAMLDIR)/parsing -I $(OCAMLDIR)/utils -I $(OCAMLDIR)/typing
+
+OBJ =	list2.cmo	useunix.cmo	setpath.cmo	lexical.cmo	\
+	fileselect.cmo	searchid.cmo	searchpos.cmo	shell.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:
+	$(LABLCOMP) $(INCLUDES) $<
+
+.mli.cmi:
+	$(LABLCOMP) $(INCLUDES) $<
+
+all: lablbrowser
+
+lablbrowser: jglib.cma $(OBJ)
+	$(LINKER) -o lablbrowser $(LABLTKLIB) toplevellib.cma \
+		unix.cma str.cma tk41.cma jglib.cma $(OBJ) \
+		-cclib -lstr -cclib -lunix $(SYSLIBS)
+
+jglib.cma: $(JG)
+	$(LABLCOMP) -a -o jglib.cma $(JG) 
+
+install:
+	if test -f lablbrowser; then : ; cp lablbrowser $(INSTALLBINDIR); fi
+
+clean:
+	rm -f *.cm? lablbrowser *~ *.orig
+
+depend:
+	$(LABLDEP) *.ml *.mli > .depend
+
+include	.depend
diff --git a/otherlibs/labltk/browser/README b/otherlibs/labltk/browser/README
new file mode 100644
index 0000000000..ca28b5132d
--- /dev/null
+++ b/otherlibs/labltk/browser/README
@@ -0,0 +1,155 @@
+
+		   Installing and Using LablBrowser
+
+
+INSTALLATION
+   If you installed it with LablTk, nothing to do.
+   Otherwise, the source is in labltk41/browser.
+   After installing LablTk, simply do "make" and "make install".
+   The name of the command is `lablbrowser'.
+
+USE
+   LablBrowser 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 O'Labl
+   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 OLABLDIR. You may also extend the
+   initial load path (only standard library by default) by using the
+   -I command line option.
+
+a) Viewer
+   It displays the list of modules in the load path. Click on one to
+   start your trip.
+
+   The entry line at the bottom 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
+   during your trip (every click creates one...) By double-clicking on
+   it you will quit the browser.
+
+   File - Open and File - Editor give access to the editor.
+
+   File - Shell opens an O'Labl shell.
+
+   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.
+
+b) Module walking
+   Each module is displayed in its own window.
+
+   At the top, a scrollable list of the defined identifiers. If you
+   click on one, this will either create a new window (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.
+   * Show all displays the signature of the whole module.
+   * 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.
+				   
+c) 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.
+
+d) 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 LablBrowser 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 lablbrowser 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>
\ No newline at end of file
diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml
new file mode 100644
index 0000000000..c5c662f01e
--- /dev/null
+++ b/otherlibs/labltk/browser/editor.ml
@@ -0,0 +1,543 @@
+(* $Id$ *)
+
+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 () =
+  let tl = Jg_toplevel.titled "Compiler" in
+  Wm.transient_set tl master:Widget.default_toplevel;
+  let mk_chkbutton :text :ref =
+    let variable = Textvariable.create on:tl () in
+    if !ref then Textvariable.set variable to:"1";
+    Checkbutton.create parent:tl :text :variable (),
+    (fun () -> ref := Textvariable.get variable = "1")
+  in
+  let chkbuttons, setflags = List.split
+      (List.map fun:(fun (text, ref) -> mk_chkbutton :text :ref)
+      	["No pervasives", Clflags.nopervasives;
+	 "No warnings", Typecheck.nowarnings;
+	 "Classic", Clflags.classic;
+	 "Lex on load", lex_on_load;
+	 "Type on load", type_on_load])
+  in
+  let buttons = Frame.create parent:tl () in
+  let ok = Button.create parent:buttons text:"Ok" padx:(`Pix 20) () command:
+      begin fun () ->
+      	List.iter fun:(fun f -> f ()) setflags;
+	destroy tl
+      end
+  and cancel = Jg_button.create_destroyer tl parent:buttons text:"Cancel"
+  in
+  pack chkbuttons side:`Top anchor:`W;
+  pack [ok;cancel] side:`Left fill:`X expand:true;
+  pack [buttons] side:`Bottom fill:`X
+
+let rec exclude elt:txt = function
+    [] -> []
+  | x :: l -> if txt.number = x.number then l else x :: exclude elt:txt l
+
+let goto_line tw =
+  let tl = Jg_toplevel.titled "Go to" in
+  Wm.transient_set tl master:Widget.default_toplevel;
+  Jg_bind.escape_destroy tl;
+  let ef = Frame.create parent:tl () in
+  let fl = Frame.create parent:ef ()
+  and fi = Frame.create parent:ef () in
+  let ll = Label.create parent:fl text:"Line number:" ()
+  and il = Entry.create parent:fi width:10 ()
+  and lc = Label.create parent:fl text:"Col number:" ()
+  and ic = Entry.create parent: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 parent:tl () in
+  let ok = Button.create parent: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] fun:
+  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 = Sort.list shells order:(fun (x,_) (y,_) -> x <= y) 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 parent:tl text:"Send to:" ()
+  and box = Listbox.create parent:tl ()
+  and frame = Frame.create parent:tl () in
+  Jg_bind.enter_focus box;
+  let cancel = Jg_button.create_destroyer tl parent:frame text:"Cancel"
+  and ok = Button.create parent:frame text:"Ok" () command:
+      begin fun () ->
+	try
+	  let name = Listbox.get box index:`Active in
+	  txt.shell <- Some (name, List.assoc key:name shells);
+	  destroy tl
+	with Not_found -> txt.shell <- None; destroy tl
+      end
+  in
+  Listbox.insert box index:`End texts:(List.map fun:fst shells);
+  Listbox.configure box height:(List.length shells);
+  bind box events:[[],`KeyPressDetail"Return"]
+    action:(`Setbreakable([], fun _ -> Button.invoke ok; break ()));
+  bind box events:[[`Double],`ButtonPressDetail 1]
+    action:(`Setbreakable([`MouseX;`MouseY], 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
+
+let send_region 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
+	sh#send (Text.get txt.tw start:(i1,[]) end:(i2,[]));
+	sh#send";;\n"
+      with _ -> ()
+
+let search_pos_window txt :x :y =
+  if txt.structure = [] & 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 in:text + c in
+  try if txt.structure <> [] then
+    try Searchpos.search_pos_structure txt.structure :pos
+    with Searchpos.Found_str (kind, env) ->
+      Searchpos.view_type kind :env
+  else
+    try Searchpos.search_pos_signature
+ 	txt.psignature :pos env:!Searchid.start_env;
+      ()
+    with Searchpos.Found_sig (kind, lid, env) ->
+      Searchpos.view_decl lid :kind :env
+  with Not_found -> ()
+
+let search_pos_menu txt :x :y =
+  if txt.structure = [] & 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 in:text + c in
+  try if txt.structure <> [] then
+    try Searchpos.search_pos_structure txt.structure :pos
+    with Searchpos.Found_str (kind, env) ->
+      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
+  else
+    try Searchpos.search_pos_signature
+ 	txt.psignature :pos env:!Searchid.start_env;
+      ()
+    with Searchpos.Found_sig (kind, lid, env) ->
+      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
+  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]) end:(ins,[]) in
+    Str.string_match reg line pos:0;
+    if Str.match_end () < c then
+      Text.insert tw index:(ins,[]) text:"\t"
+    else let indent =
+      if l <= 1 then 2 else
+      let previous =
+	Text.get tw start:(ins,[`Line(-1);`Linestart])
+	  end:(ins,[`Line(-1);`Lineend]) in
+      Str.string_match reg previous pos:0;
+      let previous = Str.matched_string previous in
+      let width = string_width line
+      and 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 len: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 parent: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 parent:top ()
+  val vwindow = Textvariable.create on:top ()
+  val mutable window_counter = 0
+
+  method reset_window_menu =
+    Menu.delete window_menu#menu first:(`Num 0) last:`End;
+    List.iter
+      (Sort.list windows order:
+	 (fun w1 w2 -> Filename.basename w1.name < Filename.basename w2.name))
+      fun:
+      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 elt:txt windows;
+    self#reset_window_menu;
+    current_tw <- txt.tw;
+    Checkbutton.configure label text:(Filename.basename txt.name)
+      variable:txt.modified;
+    Textvariable.set vwindow to: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 parent: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 = []; signature = []; psignature = [] }
+    in
+    let control c = Char.chr (Char.code c - 96) in
+    bind tw events:[[`Alt], `KeyPress] action:(`Set ([], fun _ -> ()));
+    bind tw events:[[], `KeyPress]
+      action:(`Set ([`Char], fun ev ->
+	if ev.ev_Char <> "" &
+	  (ev.ev_Char.[0] >= ' ' or
+	   List.mem elt:ev.ev_Char.[0]
+	     (List.map fun:control ['d'; 'h'; 'i'; 'k'; 'o'; 't'; 'w'; 'y']))
+	then Textvariable.set txt.modified to:"modified"));
+    bind tw events:[[],`KeyPressDetail"Tab"]
+      action:(`Setbreakable ([], fun _ ->
+	indent_line tw;
+	Textvariable.set txt.modified to:"modified";
+	break ()));
+    bind tw events:[[`Control],`KeyPressDetail"k"]
+      action:(`Set ([], fun _ ->
+	let text =
+	  Text.get tw start:(`Mark"insert",[]) end:(`Mark"insert",[`Lineend])
+	in Str.string_match (Str.regexp "[ \t]*") text pos:0;
+	if Str.match_end () <> String.length text then begin
+	  Clipboard.clear ();
+	  Clipboard.append data:text ()
+	end));
+    bind tw events:[[], `KeyRelease]
+      action:(`Set ([`Char], fun ev ->
+	if ev.ev_Char <> "" then
+	  Lexical.tag tw start:(`Mark"insert", [`Linestart])
+	    end:(`Mark"insert", [`Lineend])));
+    bind tw events:[[], `Motion] action:(`Set ([], fun _ -> Focus.set tw));
+    bind tw events:[[], `ButtonPressDetail 2]
+      action:(`Set ([], fun _ ->
+	Textvariable.set txt.modified to:"modified";
+	Lexical.tag txt.tw start:(`Mark"insert", [`Linestart])
+	  end:(`Mark"insert", [`Lineend])));
+    bind tw events:[[`Double], `ButtonPressDetail 1]
+      action:(`Set ([`MouseX;`MouseY], fun ev ->
+	search_pos_window txt x:ev.ev_MouseX y:ev.ev_MouseY));
+    bind tw events:[[], `ButtonPressDetail 3]
+      action:(`Set ([`MouseX;`MouseY], 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 end:tend;
+    List.iter error_messages
+      fun:(fun tl -> try destroy tl with Protocol.TkError _ -> ());
+    error_messages <- []
+
+  method typecheck () =
+    self#clear_errors ();
+    error_messages <- Typecheck.f (List.hd windows)
+
+  method lex () =
+    Text.tag_remove current_tw tag:"error" start:tstart end:tend;
+    Lexical.tag current_tw
+
+  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
+	  Sys.rename old:name new:(name ^ "~")
+	else begin match
+	  Jg_message.ask master:top title:"Save"
+	    ("File `" ^ name ^ "' exists. Overwrite it?")
+	with `yes -> () | `no | `cancel -> raise Exit
+	end;
+      let file = open_out name in
+      let text = Text.get txt.tw start:tstart end:(tposend 1) in
+      output_string text to:file;
+      close_out file;
+      Checkbutton.configure label text:(Filename.basename name);
+      Checkbutton.deselect label;
+      txt.name <- name
+    with
+      Sys_error _ | 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 pred:(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 buffer = String.create len:4096 in
+      Text.delete tw start:tstart end:tend;
+      while
+	len := input file :buffer pos:0 len:4096;
+	!len > 0
+      do
+	Jg_text.output tw :buffer pos:0 len:!len
+      done;
+      close_in file;
+      Text.mark_set tw mark:"insert" :index;
+      Text.see tw :index;
+      if Filename.check_suffix name suff:".ml" or
+	Filename.check_suffix name suff:".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 elt: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 () =
+    try List.iter windows
+	fun:(fun txt ->
+	  if Textvariable.get txt.modified = "modified" then
+	    match Jg_message.ask master:top title:"Quit"
+		("`" ^ Filename.basename txt.name ^ "' modified. Save it?")
+	    with `yes -> self#save_text txt
+	    | `no -> ()
+	    | `cancel -> raise Exit);
+      bind top events:[[],`Destroy] action:`Remove;
+      destroy top; break ()
+    with Exit -> break ()
+
+  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);
+	Text.yview_index current_tw
+	  index:(`Linechar(1,0),[`Char pos; `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], "x", (fun () -> send_region (List.hd windows));
+	[`Alt], "l", self#lex;
+	[`Alt], "t", self#typecheck ]
+      fun:begin fun (modi,key,act) ->
+	bind top events:[modi, `KeyPressDetail key]
+	  action:(`Setbreakable ([], fun _ -> act (); break ()))
+      end;
+
+    bind top events:[[],`Destroy]
+      action:(`Setbreakable
+		([`Widget], fun ev ->
+		  if Widget.name ev.ev_Widget = Widget.name top
+		  then self#quit ()));
+
+    (* 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;
+    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_region (List.hd windows));
+    edit_menu#add_command "Select shell..."
+      command:(fun () -> select_shell (List.hd windows));
+
+    (* Compiler menu *)
+    compiler_menu#add_command "Preferences..."
+      command:compiler_preferences;
+    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
+      end;
+
+    (* Modules *)
+    module_menu#add_command "Path editor..."
+      command:(fun () -> Setpath.f 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 fun:(fun m -> coe m#button)
+	    [file_menu; edit_menu; compiler_menu; module_menu; window_menu]
+	  @ [coe label])
+      side:`Left ipadx:(`Pix 5) anchor:`W;
+    pack [menus] before:(List.hd windows).frame side:`Top fill:`X
+end
+
+(* The main function starts here ! *)
+
+let already_open : editor option ref = ref None
+
+let editor ?:file ?:pos{= 0} () =
+
+  if match !already_open with None -> false
+  | Some ed ->
+      try ed#reopen :file :pos; true
+      with Protocol.TkError _ -> already_open := None; false
+  then () else
+    let top = Jg_toplevel.titled "Editor" in
+    let menus = Frame.create parent:top name:"menubar" () in
+    let ed = new editor :top :menus in
+    already_open := Some 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 ()
diff --git a/otherlibs/labltk/browser/editor.mli b/otherlibs/labltk/browser/editor.mli
new file mode 100644
index 0000000000..d186e48749
--- /dev/null
+++ b/otherlibs/labltk/browser/editor.mli
@@ -0,0 +1,6 @@
+(* $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
new file mode 100644
index 0000000000..e0d0e7c330
--- /dev/null
+++ b/otherlibs/labltk/browser/fileselect.ml
@@ -0,0 +1,282 @@
+(* $Id$ *)
+
+(* file selection box *)
+
+open Useunix
+open Str
+open Filename
+
+open Tk
+
+(**** Memoized rexgexp *)
+
+let regexp = (new Jg_memo.c fun:Str.regexp)#get
+
+(************************************************************ Path name *)
+
+let parse_filter src = 
+  (* replace // by / *)
+  let s = global_replace (regexp "/+") with:"/" src in
+  (* replace /./ by / *)
+  let s = global_replace (regexp "/\./") with:"/" s in
+  (* replace hoge/../ by "" *)
+  let s = global_replace
+     (regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\./") with:"" s in
+  (* replace hoge/..$ by *)
+  let s = global_replace
+     (regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\.$") with:"" s in
+  (* replace ^/../../ by / *)
+  let s = global_replace (regexp "^\(/\.\.\)+/") with:"/" s in
+  if string_match (regexp "^\([^\*?[]*/\)\(.*\)") s pos:0 then 
+    let dirs = matched_group 1 s
+    and ptrn = matched_group 2 s
+    in
+      dirs, ptrn
+  else "", s
+
+let fixpoint fun:f v =
+  let v1 = ref v and v2 = ref (f v) in
+  while !v1 <> !v2 do v1 := !v2; v2 := f !v2 done;
+  !v1
+
+let unix_regexp s =
+  let s = Str.global_replace (regexp "[$^.+]") with:"\\\\\\0" s in
+  let s = Str.global_replace (regexp "\\*") with:".*" s in
+  let s = Str.global_replace (regexp "\\?") with:".?" s in
+  let s =
+    fixpoint s fun:(fun s ->
+      Str.global_replace (regexp "\\({.*\\),\\(.*}\\)") s
+	with:"\\1\\|\\2") in
+  let s =
+    Str.global_replace (regexp "{\\(.*\\)}") with:"\\(\\1\\)" s in
+  Str.regexp s
+
+let exact_match s :regexp =
+  Str.string_match regexp s pos: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 pred:(exact_match :regexp)
+
+(*
+let ls :dir :pattern =
+  subshell cmd:("cd " ^ dir ^ ";/bin/ls -ad " ^ pattern ^" 2>/dev/null")
+*)
+ 
+(********************************************* 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 dir 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 to:deffilter;
+
+  let frm = Frame.create parent:tl borderwidth:(`Pix 1) relief:`Raised () in
+    let df = Frame.create parent:frm () in
+      let dfl = Frame.create parent:df () in
+        let dfll = Label.create parent:dfl text:"Directories" () in
+	let dflf, directory_listbox, directory_scrollbar =
+	    Jg_box.create_with_scrollbar parent:dfl () in
+      let dfr = Frame.create parent:df () in
+        let dfrl = Label.create parent:dfr text:"Files" () in
+	let dfrf, filter_listbox, filter_scrollbar =
+	    Jg_box.create_with_scrollbar parent:dfr () in
+  let cfrm = Frame.create parent:tl borderwidth:(`Pix 1) relief:`Raised () in
+
+  let configure :filter =
+    let filter =
+      if string_match  (regexp "^/.*") filter pos:0
+      then filter
+      else !current_dir ^ "/" ^ 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 acc:[] fun:
+      begin fun :acc dir ->
+      	let files = ls :dir :pattern in
+	Sort.merge order:(<) files
+      	  (List.fold_left files :acc
+      	   fun:(fun :acc name -> List2.exclude elt:name acc))
+      end
+      else
+	List.fold_left directories acc:(ls :dir :pattern)
+	  fun:(fun :acc dir -> List2.exclude elt:dir acc)
+    in
+      Textvariable.set filter_var to:filter;
+      Textvariable.set selection_var to:(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 acc:[] fun:
+      	begin fun name :acc ->
+      	  if name <> "" & name.[0] = '/' then name :: acc else
+      	  try search_in_path :name :: acc with Not_found -> acc
+      	end
+      else
+        List.map l fun:
+      	begin fun x ->
+      	  if x <> "" & x.[0] = '/' then x
+          else !current_dir ^ "/" ^ x
+	end
+    in
+    if sync then 
+      begin
+        selected_files := l;
+      	Textvariable.set sync_var to:"1"
+      end
+    else proc l 
+  in
+  
+  (* entries *)
+  let fl = Label.create parent:frm text:"Filter" () in
+  let sl = Label.create parent:frm text:"Selection" () in
+  let filter_entry = Jg_entry.create parent:frm textvariable:filter_var ()
+      command:(fun filter -> configure :filter) in
+  let selection_entry = Jg_entry.create parent:frm textvariable:selection_var
+      command:(fun file -> activate [file]) () in
+
+  (* and buttons *)
+  let set_path = Button.create parent: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]
+        action:(`Extend ([], fun _ -> Grab.set tl))
+    end in
+  let toggle_in_path = Checkbutton.create parent: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 parent:cfrm text:"Ok" () command:
+    begin fun () -> 
+      let files = 
+      	List.map (Listbox.curselection filter_listbox) fun:
+	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 parent:cfrm text:"Filter" ()
+      command:(fun () -> configure filter:(Textvariable.get filter_var))
+  and ccb = Button.create parent:cfrm text:"Cancel" ()
+      command:(fun () -> activate []) in
+
+  (* binding *)
+  bind tl events:[[], `KeyPressDetail "Escape"]
+    action:(`Set ([], 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]
+    action:(`Set ([`MouseY], 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 to:(search_in_path :name)
+	with Not_found -> ()
+      else Textvariable.set selection_var to:(!current_dir ^ "/" ^ name)));
+
+  Jg_box.add_completion directory_listbox action:
+    begin fun index ->
+      let filter =
+      	!current_dir ^ "/" ^
+       	(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
new file mode 100644
index 0000000000..789cd17e2c
--- /dev/null
+++ b/otherlibs/labltk/browser/fileselect.mli
@@ -0,0 +1,22 @@
+(* $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 *)
diff --git a/otherlibs/labltk/browser/jg_bind.ml b/otherlibs/labltk/browser/jg_bind.ml
new file mode 100644
index 0000000000..9d30f57934
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_bind.ml
@@ -0,0 +1,15 @@
+(* $Id$ *)
+
+open Tk
+
+let enter_focus w = 
+  bind w events:[[], `Enter] action:(`Set ([], 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:(`Set ([], fun _ -> destroy tl))
+
+let return_invoke w :button =
+  bind w events:[[], `KeyPressDetail "Return"]
+      	 action:(`Set ([], fun _ -> Button.invoke button))
diff --git a/otherlibs/labltk/browser/jg_bind.mli b/otherlibs/labltk/browser/jg_bind.mli
new file mode 100644
index 0000000000..3889f20fdc
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_bind.mli
@@ -0,0 +1,7 @@
+(* $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
new file mode 100644
index 0000000000..f71bd0e7f9
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_box.ml
@@ -0,0 +1,57 @@
+(* $Id$ *)
+
+open Tk
+
+let add_scrollbar lb  =
+  let sb =
+    Scrollbar.create parent:(Winfo.parent lb) command:(Listbox.yview lb) () in
+  Listbox.configure lb yscrollcommand:(Scrollbar.set sb); sb
+
+let create_with_scrollbar :parent ?:selectmode () =
+  let frame = Frame.create :parent () in
+  let lb = Listbox.create parent: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 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] 
+    action:(`Set([`Char], 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))));
+
+  begin match action with 
+    Some action ->
+      bind lb events:[[], `KeyPressDetail "Return"]
+      	action:(`Set ([], fun _ -> action `Active));
+      bind lb events:[[`Double], `ButtonPressDetail 1]
+      	action:(`Setbreakable ([`MouseY], fun ev ->
+	  action (Listbox.nearest lb y:ev.ev_MouseY); break ()))
+  | 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
new file mode 100644
index 0000000000..db56374aa7
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_button.ml
@@ -0,0 +1,11 @@
+(* $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
new file mode 100644
index 0000000000..8836af09f8
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_completion.ml
@@ -0,0 +1,39 @@
+(* $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 pos:current) prefix ?:nocase
+    do
+      current <- current + 1
+    done;
+    current
+  method current = current
+  method get_current = List.nth texts pos: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
new file mode 100644
index 0000000000..427e744556
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_completion.mli
@@ -0,0 +1,9 @@
+(* $Id$ *)
+
+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
new file mode 100644
index 0000000000..330efa7e5c
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_config.ml
@@ -0,0 +1,18 @@
+(* $Id$ *)
+
+let init () =
+  let font =
+    let font =
+      Option.get Widget.default_toplevel name:"variableFont" class:"Font" in
+    if font = "" then "variable" else font
+  in
+  List.iter ["Button"; "Label"; "Menu"; "Menubutton"; "Radiobutton"]
+    fun:(fun cl -> Option.add ("*" ^ cl ^ ".font") value:font);
+  Option.add "*Button.padY" value:"0" priority:`StartupFile;
+  Option.add "*Text.highlightThickness" value:"0" priority:`StartupFile;
+  Option.add "*interface.background" value:"gray85" priority:`StartupFile;
+  let foreground =
+    Option.get Widget.default_toplevel
+      name:"disabledForeground" class:"Foreground" in
+  if foreground = "" then
+    Option.add "*disabledForeground" value:"black"
diff --git a/otherlibs/labltk/browser/jg_config.mli b/otherlibs/labltk/browser/jg_config.mli
new file mode 100644
index 0000000000..1830351087
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_config.mli
@@ -0,0 +1,3 @@
+(* $Id$ *)
+
+val init: unit -> unit
diff --git a/otherlibs/labltk/browser/jg_entry.ml b/otherlibs/labltk/browser/jg_entry.ml
new file mode 100644
index 0000000000..d9109d83af
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_entry.ml
@@ -0,0 +1,13 @@
+(* $Id$ *)
+
+open Tk
+
+let create :parent ?:command ?:width ?:textvariable () =
+  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:(`Set ([], fun _ -> command (Entry.get ew)))
+  | None -> ()
+  end;
+  ew
diff --git a/otherlibs/labltk/browser/jg_memo.ml b/otherlibs/labltk/browser/jg_memo.ml
new file mode 100644
index 0000000000..43a5eb15b4
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_memo.ml
@@ -0,0 +1,17 @@
+(* $Id$ *)
+
+class ['a,'b] c fun:(f : 'a -> 'b) = object
+  val hash = Hashtbl.create 7
+  method get key =
+    try Hashtbl.find hash :key
+    with Not_found ->
+      let data = f key in
+      Hashtbl.add hash :key :data;
+      data
+  method clear = Hashtbl.clear hash
+  method reget key =
+    Hashtbl.remove :key hash;
+    let data = f key in
+    Hashtbl.add hash :key :data;
+    data
+end
diff --git a/otherlibs/labltk/browser/jg_memo.mli b/otherlibs/labltk/browser/jg_memo.mli
new file mode 100644
index 0000000000..8d08111b1e
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_memo.mli
@@ -0,0 +1,8 @@
+(* $Id$ *)
+
+class ['a, 'b] c : fun:('a -> 'b) -> object
+  val hash : ('a, 'b) Hashtbl.t
+  method clear : unit
+  method get : 'a -> 'b
+  method reget : 'a -> 'b
+end
diff --git a/otherlibs/labltk/browser/jg_menu.ml b/otherlibs/labltk/browser/jg_menu.ml
new file mode 100644
index 0000000000..21295f3d6e
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_menu.ml
@@ -0,0 +1,28 @@
+(* $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 parent: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
new file mode 100644
index 0000000000..9385f37d00
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_message.ml
@@ -0,0 +1,82 @@
+(* $Id$ *)
+
+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 ?:width{=60} ?:maxheight{=10} ?:minheight{=0} () =
+  let tl, frame =
+    match on with
+      Some frame -> coe frame, frame
+    | None ->
+ 	let tl = Jg_toplevel.titled title in
+  	Jg_bind.escape_destroy tl;
+	let frame = Frame.create parent:tl () in
+	pack [frame] side:`Top fill:`Both expand:true;
+	coe tl, frame
+  in
+  let tw = Text.create parent:frame :width wrap:`Word  () in
+  pack [tw] side:`Left fill:`Both expand:true;
+  Format.print_flush ();
+  Format.set_margin (width - 2);
+  let fof,fff = Format.get_formatter_output_functions () in
+  Format.set_formatter_output_functions
+    out:(Jg_text.output tw) flush:(fun () -> ());
+  tl, tw,
+  begin fun () ->
+    Format.print_flush ();
+    Format.set_formatter_output_functions out:fof flush: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 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 parent:tl :text padx:(`Pix 20) pady:(`Pix 10)
+      	   width:(`Pix 250) justify:`Left aspect:400 anchor:`W ()
+  and fw = Frame.create parent:tl ()
+  and sync = Textvariable.create on:tl ()
+  and r = ref (`cancel : [`yes|`no|`cancel]) in
+  let accept = Button.create parent:fw text:"Yes" ()
+      command:(fun () -> r := `yes; destroy tl) 
+  and refuse = Button.create parent:fw text:"No" ()
+      command:(fun () -> r := `no; destroy tl)
+  and cancel = Jg_button.create_destroyer tl parent:fw text:"Cancel"
+  in
+  bind tl events:[[],`Destroy]
+    action:(`Extend([],fun _ -> Textvariable.set sync to:"1"));
+  pack [accept; refuse; cancel] 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
diff --git a/otherlibs/labltk/browser/jg_message.mli b/otherlibs/labltk/browser/jg_message.mli
new file mode 100644
index 0000000000..8862702c61
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_message.mli
@@ -0,0 +1,13 @@
+(* $Id$ *)
+
+val formatted :
+  title:string ->
+  ?on:Widget.frame Widget.widget ->
+  ?width:int ->
+  ?maxheight:int ->
+  ?minheight:int ->
+  unit -> Widget.any Widget.widget * Widget.text Widget.widget * (unit -> unit)
+
+val ask :
+    title:string -> ?master:Widget.toplevel Widget.widget ->
+    string -> [`cancel|`no|`yes]
diff --git a/otherlibs/labltk/browser/jg_multibox.ml b/otherlibs/labltk/browser/jg_multibox.ml
new file mode 100644
index 0000000000..161e21534c
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_multibox.ml
@@ -0,0 +1,169 @@
+(* $Id$ *)
+
+let rec gen_list fun:f :len =
+  if len = 0 then [] else f () :: gen_list fun: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 fun:(fun a l -> a::l)
+  
+
+open Tk
+
+class c :parent :cols :texts ?:maxheight ?:width () = 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 fun:
+      begin fun () ->
+ 	Listbox.create :parent :height ?:width
+	  highlightthickness:(`Pix 0)
+	  borderwidth:(`Pix 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 pos:(current mod cols)
+    and index = `Num (current / cols) in
+    List.iter boxes fun:
+      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 fun:(Listbox.yview scroll:(`Moveto first))
+  method init =
+    let textl = split len:cols texts in
+    List.iter2 boxes textl fun:
+      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) ]
+      fun: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 fun:
+      begin fun box ->
+	let b = !i in
+	bind box :events
+	  action:(`Setbreakable ([`MouseX;`MouseY], 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 fun:
+      begin fun box ->
+	let b = !i in
+	bind box :events
+	  action:(`Setbreakable ([`Char], 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 parent:(box#parent) ()
+      command:(fun :scroll -> List.iter boxes fun:(Listbox.yview :scroll)) in
+  List.iter boxes
+    fun:(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
new file mode 100644
index 0000000000..fbd1ab13a4
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_multibox.mli
@@ -0,0 +1,23 @@
+(* $Id$ *)
+
+class c :
+  parent:'a Widget.widget -> cols:int ->
+  texts:string list -> ?maxheight:int -> ?width:int -> unit ->
+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.modifier list * Tk.xEvent) list ->
+    action:(Tk.eventInfo -> index:int -> unit) -> unit
+  method bind_kbd :
+    events:(Tk.modifier list * Tk.xEvent) 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
new file mode 100644
index 0000000000..2477e9acc4
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_text.ml
@@ -0,0 +1,88 @@
+(* $Id$ *)
+
+open Tk
+open Jg_tk
+
+let get_all tw = Text.get tw start:tstart end:(tposend 1)
+
+let tag_and_see tw :tag :start end:e =
+  Text.tag_remove tw start:(tpos 0) end:tend :tag;
+  Text.tag_add tw :start end:e :tag;
+  try
+    Text.see tw index:(`Tagfirst tag, []);
+    Text.mark_set tw mark:"insert" index:(`Tagfirst tag, [])
+  with Protocol.TkError _ -> ()
+
+let output tw :buffer :pos :len =
+  Text.insert tw index:tend text:(String.sub buffer :pos :len)
+
+let add_scrollbar tw =
+  let sb = Scrollbar.create parent:(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 parent: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:Widget.default_toplevel;
+  let fi = Frame.create parent:tl ()
+  and fd = Frame.create parent:tl ()
+  and fm = Frame.create parent:tl ()
+  and buttons = Frame.create parent:tl ()
+  and direction = Textvariable.create on:tl ()
+  and mode = Textvariable.create on:tl ()
+  and count = Textvariable.create on:tl ()
+  in
+  let label = Label.create parent:fi text:"Pattern:" ()
+  and text = Entry.create parent:fi width:20 ()
+  and back = Radiobutton.create parent:fd variable:direction
+      	       text:"Backwards" value:"backward" ()
+  and forw = Radiobutton.create parent:fd variable:direction
+               text:"Forwards" value:"forward" ()
+  and exact = Radiobutton.create parent:fm variable:mode
+                text:"Exact" value:"exact" ()
+  and nocase = Radiobutton.create parent:fm variable:mode
+                 text:"No case" value:"nocase" ()
+  and regexp =  Radiobutton.create parent:fm variable:mode
+                 text:"Regexp" value:"regexp" ()
+  in
+  let search = Button.create parent: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
+      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,[])
+      	end:(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 to:"forward";
+  Textvariable.set mode to:"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
new file mode 100644
index 0000000000..8b3880eef7
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_text.mli
@@ -0,0 +1,14 @@
+(* $Id$ *)
+
+open Widget
+
+val get_all : text widget -> string
+val tag_and_see :
+  text widget ->
+  tag:Tk.textTag -> start:Tk.textIndex -> end:Tk.textIndex -> unit
+val output : text widget -> buffer:string -> pos:int -> len:int -> unit
+val add_scrollbar : text widget -> scrollbar widget
+val create_with_scrollbar :
+  parent:'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
new file mode 100644
index 0000000000..da5f4930cf
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_tk.ml
@@ -0,0 +1,8 @@
+(* $Id$ *)
+
+open Tk
+
+let tpos x : textIndex = `Linechar (1,0), [`Char x]
+and tposend x : textIndex = `End, [`Char (-x)]
+let tstart : textIndex = `Linechar (1,0), []
+and tend : textIndex = `End, []
diff --git a/otherlibs/labltk/browser/jg_toplevel.ml b/otherlibs/labltk/browser/jg_toplevel.ml
new file mode 100644
index 0000000000..c36a215ef1
--- /dev/null
+++ b/otherlibs/labltk/browser/jg_toplevel.ml
@@ -0,0 +1,10 @@
+(* $Id$ *)
+
+open Tk
+
+let titled ?:iconname title  =
+  let iconname = match iconname with None -> title | Some s -> s in 
+  let tl = Toplevel.create parent:Widget.default_toplevel () in
+  Wm.title_set tl :title;
+  Wm.iconname_set tl name:iconname;
+  tl
diff --git a/otherlibs/labltk/browser/lexical.ml b/otherlibs/labltk/browser/lexical.ml
new file mode 100644
index 0000000000..e98096c2e6
--- /dev/null
+++ b/otherlibs/labltk/browser/lexical.ml
@@ -0,0 +1,111 @@
+(* $Id$ *)
+
+open Tk
+open Jg_tk
+open Parser
+
+let tags =
+  ["control"; "define"; "structure"; "char";
+   "infix"; "label"; "uident"]
+and colors =
+    ["blue"; "forestgreen"; "purple"; "gray40";
+     "indianred4"; "brown"; "midnightblue"]
+
+let init_tags tw =
+  List.iter2 tags colors fun:
+  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} ?end:pend{=tend} tw =
+  let tpos c = (Text.index tw index:start, [`Char c]) in
+  let text = Text.get tw :start end:pend in
+  let buffer = Lexing.from_string text in
+  List.iter tags
+    fun:(fun tag -> Text.tag_remove tw :start end:pend :tag);
+  try
+    while true do
+    let tag =
+      match Lexer.token buffer 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
+      | PARSER
+      | PRIVATE
+      | REC
+      | TYPE
+      | VAL
+      | VIRTUAL
+      	  -> "define"
+      | BEGIN
+      | END
+      | INCLUDE
+      |	OBJECT
+      | OPEN
+      | SIG
+      | STRUCT
+          -> "structure"
+      | CHAR _
+      | STRING _
+      	  -> "char"
+      | BACKQUOTE
+      | INFIXOP1 _
+      | INFIXOP2 _
+      | INFIXOP3 _
+      | INFIXOP4 _
+      | PREFIXOP _
+      |	QUESTION3
+      | SHARP
+      	  -> "infix"
+      | LABEL _
+      | QUESTION
+      	  -> "label"
+      | UIDENT _ -> "uident"
+      | EOF -> raise End_of_file
+      | _ -> ""
+    in
+    if tag <> "" then
+    Text.tag_add tw :tag
+        start:(tpos (Lexing.lexeme_start buffer))
+	end:(tpos (Lexing.lexeme_end buffer))
+    done
+  with
+    End_of_file -> ()
+  | Lexer.Error (err, s, e) -> ()
diff --git a/otherlibs/labltk/browser/lexical.mli b/otherlibs/labltk/browser/lexical.mli
new file mode 100644
index 0000000000..d9711f5fc1
--- /dev/null
+++ b/otherlibs/labltk/browser/lexical.mli
@@ -0,0 +1,6 @@
+(* $Id$ *)
+
+open Widget
+
+val init_tags : text widget -> unit
+val tag : ?start:Tk.textIndex -> ?end:Tk.textIndex -> text widget -> unit
diff --git a/otherlibs/labltk/browser/list2.ml b/otherlibs/labltk/browser/list2.ml
new file mode 100644
index 0000000000..6ab8b78631
--- /dev/null
+++ b/otherlibs/labltk/browser/list2.ml
@@ -0,0 +1,7 @@
+(* $Id$ *)
+
+let exclude elt:x l = List.filter l pred:((<>) x)
+
+let rec flat_map fun:f = function
+    [] -> []
+  | x :: l -> f x @ flat_map fun:f l
diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml
new file mode 100644
index 0000000000..681342cff5
--- /dev/null
+++ b/otherlibs/labltk/browser/main.ml
@@ -0,0 +1,34 @@
+(* $Id$ *)
+
+open Tk
+
+let _ =
+  let path = ref [] in
+  Arg.parse
+    keywords:[ "-I", Arg.String (fun s -> path := s :: !path),
+	       "<dir>  Add <dir> to the list of include directories" ]
+    others:(fun name -> raise(Arg.Bad("don't know what to do with " ^ name)))
+    errmsg:"lablbrowser :";
+  Config.load_path := List.rev !path @ [Config.standard_library];
+  begin
+    try Searchid.start_env := Env.open_pers_signature "Pervasives" Env.initial
+    with Env.Error _ -> ()
+  end;
+  
+  Searchpos.view_defined_ref := Viewer.view_defined;
+  Searchpos.editor_ref.contents <- Editor.f;
+
+  let top = openTkClass "LablBrowser" in
+  Jg_config.init ();
+
+  bind top events:[[], `Destroy] action:(`Set ([], fun _ -> exit 0));
+  at_exit Shell.kill_all;
+  
+
+  Viewer.f on:top ();
+
+  while true do
+    try
+      Printexc.print mainLoop ()
+    with Protocol.TkError _ -> ()
+  done
diff --git a/otherlibs/labltk/browser/mytypes.mli b/otherlibs/labltk/browser/mytypes.mli
new file mode 100644
index 0000000000..582295c393
--- /dev/null
+++ b/otherlibs/labltk/browser/mytypes.mli
@@ -0,0 +1,14 @@
+(* $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 signature: Types.signature;
+    mutable psignature: Parsetree.signature;
+    number: string }
diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml
new file mode 100644
index 0000000000..a43085752a
--- /dev/null
+++ b/otherlibs/labltk/browser/searchid.ml
@@ -0,0 +1,497 @@
+(* $Id$ *)
+
+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 acc:(l,[]) fun:
+    begin fun acc:(l, perms) a ->
+      let l = List.tl l in
+      l @ [a],
+      List.map (permutations l) fun:(fun l -> a :: l) @ perms
+    end
+  in perms
+
+let rec choose n in:l =
+  let len = List.length l in
+  if n = len then [l] else
+  if n = 1 then List.map l fun:(fun x -> [x]) else
+  if n = 0 then [[]] else
+  if n > len then [] else
+  match l with [] -> [] 
+  | a :: l ->
+    List.map (choose (n-1) in:l) fun:(fun l -> a :: l)
+    @ choose n in:l
+
+let rec arr p in:n =
+  if p = 0 then 1 else n * arr (p-1) in:(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 pred:
+      	   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 pred:(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) pred:
+      begin fun l1 ->
+      	List.for_all2 l1 l2 pred:
+	begin fun (p1,t1) (p2,t2) ->
+	  (p1 = "" or p1 = p2) & equal t1 t2 :prefix
+	end
+      end
+  | Ttuple l1, Ttuple l2 ->
+      List.length l1 = List.length l2 &
+      List.for_all2 l1 l2 pred:(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 pred:(equal :prefix)
+  | _ -> false
+
+let is_opt s = s <> "" & s.[0] = '?'
+let get_options = List.filter pred: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 pred:
+      	   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 pred:(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 in:len2 < 100 then l2 else
+      	  let ll1 = get_options (fst (List.split l1)) in
+      	  List.filter l2
+          pred:(fun (l,_) -> not (is_opt l) or List.mem elt:l ll1)
+      in
+      len1 <= len2 &
+      List.exists (List2.flat_map fun:permutations (choose len1 in:l2)) pred:
+      begin fun l2 ->
+	List.for_all2 l1 l2 pred:
+      	begin fun (p1,t1) (p2,t2) ->
+	  (p1 = "" or 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 fun:permutations (choose len1 in:l2)) pred:
+      begin fun l2 ->
+      	List.for_all2 l1 l2 pred:(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 pred:(included :prefix)
+  | _ -> false
+
+let mklid = function
+    [] -> raise (Invalid_argument "Searchid.mklid")
+  | x :: l ->
+      List.fold_left l acc:(Lident x) fun:(fun :acc x -> Ldot (acc, x))
+
+let mkpath = function
+    [] -> raise (Invalid_argument "Searchid.mklid")
+  | x :: l ->
+      List.fold_left l acc:(Pident (Ident.create x))
+      fun:(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 in: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 fun:
+  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 or
+          begin match td.type_kind with
+	    Type_abstract -> false
+	  | Type_variant l ->
+      	    List.exists l pred:(fun (_, l) -> List.exists l pred:matches)
+	  | Type_record l ->
+	    List.exists l pred:(fun (_, _, t) -> matches t)
+	  end
+	  then [lid_of_id id, Ptype] else []
+      | Tsig_exception (id, l) ->
+      	  if List.exists l pred:matches
+      	  then [lid_of_id id, Pconstructor]
+	  else []
+      | Tsig_module (id, Tmty_signature sign) ->
+      	  search_type_in_signature t in: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
+          or (match cl.cty_new with None -> false | Some ty -> matches ty)
+	  (* or List.exists (get_fields :prefix :sign self)
+	      pred:(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
+	  (* or List.exists (get_fields :prefix :sign self)
+	      pred:(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())); newty(Tarrow("",newvar(),t))]
+  in List2.flat_map !module_list fun:
+    begin fun modname ->
+    let mlid = Lident modname in
+    try match lookup_module mlid initial with
+      _, Tmty_signature sign ->
+      	List2.flat_map tl
+      	  fun:(search_type_in_signature in: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 acc:initial fun:
+      	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,_) -> raise (Error (l.loc_start - 8, l.loc_end - 8))
+      | Typetexp.Error (l,_) -> raise (Error (l.loc_start - 8, l.loc_end - 8))
+    in match sign with
+        [Tsig_value (_, vd)] ->
+	  search_all_types vd.val_type :mode
+      | _ -> []
+  with
+    Syntaxerr.Error(Syntaxerr.Unclosed(l,_,_,_)) ->
+      raise (Error (l.loc_start - 8, l.loc_end - 8))
+  | Syntaxerr.Error(Syntaxerr.Other l) ->
+      raise (Error (l.loc_start - 8, l.loc_end - 8))
+  | Lexer.Error (_, s, e) ->  raise (Error (s - 8, e - 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) 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'
+                  or 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 fun:
+    begin fun modname -> Lident modname,
+    try match lookup_module (Lident modname) initial with
+      _, Tmty_signature sign ->
+      	List2.flat_map sign fun:
+	  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
+	    or List.exists
+		(get_fields prefix:[modname] :sign (self_type cl.cty_type))
+	        pred:(fun (name,_,_) -> check_match :pattern (explode name))
+	    -> [i, Pclass]
+	  | Tsig_cltype (i, cl) when check i
+	    or List.exists
+		(get_fields prefix:[modname] :sign (self_type cl.clty_type))
+	        pred:(fun (name,_,_) -> check_match :pattern (explode name))
+	    -> [i, Pcltype]
+	  | _ -> []
+	  end
+    | _ -> []
+    with Env.Error _ -> []
+    end
+  in
+  List2.flat_map l fun:
+    begin fun (m, l) ->
+      List.map l fun:(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] = '?' or 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_var s -> [s]
+  | Ppat_alias (pat,s) -> s :: bound_variables pat
+  | Ppat_tuple l -> List2.flat_map l fun: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 fun:(fun (_,pat) -> bound_variables pat)
+  | Ppat_array l ->
+      List2.flat_map l fun: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 acc:[] str fun:
+	    begin fun :acc item ->
+	      match item.pstr_desc with
+		Pstr_module (s, mexp) when s = modu ->
+		  loc := mexp.pmod_loc.loc_start;
+		  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) fun:
+    begin fun item ->
+      if match item.pstr_desc with
+      	Pstr_value (_, l) when kind = Pvalue ->
+	  List.iter l fun:
+	    begin fun (pat,_) ->
+	      if List.mem elt:name (bound_variables pat)
+	      then loc := pat.ppat_loc.loc_start
+	    end;
+	  false
+      |	Pstr_primitive (s, _) when kind = Pvalue -> name = s
+      |	Pstr_type l when kind = Ptype ->
+	  List.iter l fun:
+	    begin fun (s, td) ->
+	      if s = name then loc := td.ptype_loc.loc_start
+	    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 or kind = Ptype or kind = Pcltype ->
+	  List.iter l fun:
+	    begin fun c ->
+	      if c.pci_name = name then loc := c.pci_loc.loc_start
+	    end;
+	  false
+      |	Pstr_class_type l when kind = Pcltype or kind = Ptype ->
+	  List.iter l fun:
+	    begin fun c ->
+	      if c.pci_name = name then loc := c.pci_loc.loc_start
+	    end;
+	  false
+      |	_ -> false
+      then loc := item.pstr_loc.loc_start
+    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 acc:[] sign fun:
+	    begin fun :acc item ->
+	      match item.psig_desc with
+		Psig_module (s, mtyp) when s = modu ->
+		  loc := mtyp.pmty_loc.loc_start;
+		  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) fun:
+    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 fun:
+	    begin fun (s, td) ->
+	      if s = name then loc := td.ptype_loc.loc_start
+	    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 or kind = Ptype or kind = Pcltype ->
+	  List.iter l fun:
+	    begin fun c ->
+	      if c.pci_name = name then loc := c.pci_loc.loc_start
+	    end;
+	  false
+      |	Psig_class_type l when kind = Ptype or kind = Pcltype ->
+	  List.iter l fun:
+	    begin fun c ->
+	      if c.pci_name = name then loc := c.pci_loc.loc_start
+	    end;
+	  false
+      |	_ -> false
+      then loc := item.psig_loc.loc_start
+    end;
+  !loc
diff --git a/otherlibs/labltk/browser/searchid.mli b/otherlibs/labltk/browser/searchid.mli
new file mode 100644
index 0000000000..0d7458e700
--- /dev/null
+++ b/otherlibs/labltk/browser/searchid.mli
@@ -0,0 +1,31 @@
+(* $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
new file mode 100644
index 0000000000..9883ea50c2
--- /dev/null
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -0,0 +1,760 @@
+(* $Id$ *)
+
+open Tk
+open Jg_tk
+open Parsetree
+open Types
+open Typedtree
+open Location
+open Longident
+open Path
+open Env
+open Searchid
+
+(* auxiliary functions *)
+
+let lines_to_chars n in:s =
+  let l = String.length s in
+  let rec ltc n :pos =
+    if n = 1 or 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 =
+  pos >= loc.loc_start & pos < loc.loc_end
+
+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 standard (diposable) buffer class *)
+
+class buffer :len = object
+  val mutable buffer = String.create :len
+  val mutable length = len
+  val mutable current = 0
+  method out buffer:b :pos :len =
+    while len + current > length do
+      let newbuf = String.create len:(length * 2) in
+      String.blit buffer pos:0 len:current to:newbuf to_pos:0;
+      buffer <- newbuf;
+      length <- 2 * length
+    done;
+    String.blit b :pos to:buffer to_pos:current :len;
+    current <- current + len
+  method get = String.sub buffer pos:0 len:current
+end
+
+(* Search in a signature *)
+
+type skind = [`Type|`Class|`Module|`Modtype]
+
+exception Found_sig of skind * Longident.t * Env.t
+
+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
+	fun:(fun (_,_,tl) -> List.iter tl fun:(search_pos_type :pos :env))
+  | Ptyp_arrow (_, t1, t2) ->
+      search_pos_type t1 :pos :env;
+      search_pos_type t2 :pos :env
+  | Ptyp_tuple tl ->
+      List.iter tl fun:(search_pos_type :pos :env)
+  | Ptyp_constr (lid, tl) ->
+      List.iter tl fun:(search_pos_type :pos :env);
+      raise (Found_sig (`Type, lid, env))
+  | Ptyp_object fl ->
+      List.iter fl fun:
+      	begin function
+	| {pfield_desc = Pfield (_, ty)} -> search_pos_type ty :pos :env
+	| _ -> ()
+	end
+  | Ptyp_class (lid, tl, _) ->
+      List.iter tl fun:(search_pos_type :pos :env);
+      raise (Found_sig (`Type, lid, env))
+  | Ptyp_alias (t, _) -> search_pos_type :pos :env t);
+  raise Not_found
+  end
+
+let rec search_pos_class_type cl :pos :env =
+  if in_loc cl.pcty_loc :pos then begin
+    begin match cl.pcty_desc with
+      Pcty_constr (lid, _) ->
+	raise (Found_sig (`Class, lid, env))
+    | Pcty_signature (_, cfl) ->
+	List.iter cfl fun:
+	  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;
+    raise Not_found
+  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;
+    begin match td.ptype_kind with
+      Ptype_abstract -> ()
+    | Ptype_variant dl ->
+      	List.iter dl
+	  fun:(fun (_, tl) -> List.iter tl fun:(search_pos_type :pos :env))
+    | Ptype_record dl ->
+      	List.iter dl fun:(fun (_, _, t) -> search_pos_type t :pos :env)
+    end;
+    raise Not_found
+  end
+  
+let rec search_pos_signature l :pos :env =
+  List.fold_left l acc:env fun:
+  begin fun acc: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
+      begin match pt.psig_desc with
+      	Psig_value (_, desc) -> search_pos_type desc.pval_type :pos :env
+      | Psig_type l ->
+    	  List.iter l fun:(fun (_,desc) -> search_pos_type_decl :pos desc :env)
+      | Psig_exception (_, l) ->
+      	  List.iter l fun:(search_pos_type :pos :env);
+       	  raise (Found_sig (`Type, Lident "exn", env))
+      | Psig_module (_, t) -> 
+          search_pos_module t :pos :env
+      | Psig_modtype (_, Pmodtype_manifest t) ->
+          search_pos_module t :pos :env
+      | Psig_modtype _ -> ()
+      | Psig_class l ->
+      	  List.iter l
+	    fun:(fun ci -> search_pos_class_type ci.pci_expr :pos :env)
+      | Psig_class_type l ->
+      	  List.iter l
+	    fun:(fun ci -> search_pos_class_type ci.pci_expr :pos :env)
+      (* The last cases should not happen in generated interfaces *) 
+      | Psig_open lid -> raise (Found_sig (`Module, lid, env))
+      | Psig_include t -> search_pos_module t :pos :env
+      end;
+      raise Not_found
+    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 -> raise (Found_sig (`Modtype, lid, env))
+    | Pmty_signature sg -> let _ = search_pos_signature sg :pos :env in ()
+    | 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 fun:
+	  begin function
+              _, Pwith_type t -> search_pos_type_decl t :pos :env 
+	    | _ -> ()
+	  end
+    end;
+    raise Not_found
+  end
+
+(* the module display machinery *)
+
+type module_widgets =
+    { mw_frame: Widget.frame Widget.widget;
+      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 filter_modules () =
+  Hashtbl.iter shown_modules fun:
+    begin fun :key :data ->
+      if not (Winfo.exists data.mw_frame) then
+	Hashtbl.remove :key shown_modules
+    end
+let add_shown_module path :widgets =
+  Hashtbl.add shown_modules key:path data:widgets
+and find_shown_module path =
+  filter_modules ();
+  Hashtbl.find shown_modules key: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 suff:".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} 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 with
+      None -> raise Not_found
+    | Some path ->
+	let widgets =
+	  try find_shown_module path
+	  with Not_found ->
+	    view_module path :env;
+	    find_shown_module path
+	in
+	Button.configure widgets.mw_detach
+	  command:(fun () -> view_signature sign :title :env);
+	pack [widgets.mw_detach] side:`Left;
+	Pack.forget [widgets.mw_edit; widgets.mw_intf];
+	List.iter2 [widgets.mw_edit; widgets.mw_intf] [".ml"; ".mli"] fun:
+	  begin fun button ext ->
+	    try
+	      let id = head_id path in
+	      let file =
+		Misc.find_in_path !Config.load_path
+		  (String.uncapitalize (Ident.name id) ^ ext) in
+	      Button.configure button
+		command:(fun () -> edit_source :file :path :sign);
+	      pack [button] side:`Left
+	    with Not_found -> ()
+	  end;
+	let top = Winfo.toplevel widgets.mw_frame in
+  	if not (Winfo.ismapped top) then Wm.deiconify top;
+	Focus.set top;
+	List.iter fun:destroy (Winfo.children widgets.mw_frame);
+	Jg_message.formatted :title on:widgets.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 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)
+	  end:(tpos l.loc_end) tag:"error"; []
+      | Lexer.Error (_, s, e) ->
+      	 Jg_text.tag_and_see tw start:(tpos s) end:(tpos e) tag:"error"; []
+  in
+  Jg_bind.enter_focus tw;
+  bind tw events:[[`Control], `KeyPressDetail"s"]
+    action:(`Set ([], fun _ -> Jg_text.search_string tw));
+  bind tw events:[[`Double], `ButtonPressDetail 1]
+    action:(`Setbreakable ([`MouseX;`MouseY], fun ev ->
+      let `Linechar (l, c) =
+ 	Text.index tw index:(`Atxy(ev.ev_MouseX,ev.ev_MouseY), []) in
+      try try
+	search_pos_signature pt pos:(lines_to_chars l in:text + c) :env;
+      	break ()
+      with Found_sig (kind, lid, env) -> view_decl lid :kind :env
+      with Not_found | Env.Error _ -> ()));
+  bind tw events:[[], `ButtonPressDetail 3]
+    action:(`Setbreakable ([`MouseX;`MouseY], 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 try
+	search_pos_signature pt pos:(lines_to_chars l in:text + c) :env;
+      	break ()
+      with Found_sig (kind, lid, env) ->
+	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 or kind = `Modtype then begin
+    let buf = new buffer len:60 in
+    let (fo,ff) = Format.get_formatter_output_functions ()
+    and margin = Format.get_margin () in
+    Format.set_formatter_output_functions out:buf#out flush:(fun () -> ());
+    Format.set_margin 60;
+    Format.open_hbox ();
+    if kind = `Type then
+      Printtyp.type_declaration
+	(ident_of_path path default:"t")
+	(find_type path env)
+    else
+      Printtyp.modtype_declaration
+	(ident_of_path path default:"S")
+	(find_modtype path env);
+    Format.close_box (); Format.print_flush ();
+    Format.set_formatter_output_functions out:fo flush:ff;
+    Format.set_margin margin;
+    let l = Str.split sep:(Str.regexp "\n") buf#get in
+    let font =
+      let font =
+	Option.get Widget.default_toplevel name:"font" class:"Font" in
+      if font = "" then "7x14" else font
+    in
+    (* Menu.add_separator menu; *)
+    List.iter l
+      fun:(fun label -> Menu.add_command menu :label :font state:`Disabled)
+  end;
+  menu
+
+(* search and view in a structure *)
+
+type fkind =
+    [ `Exp [`Expr|`Pat|`Const|`Val Path.t|`Var Path.t|`New Path.t]
+	* Types.type_expr
+    | `Class Path.t * Types.class_type
+    | `Module Path.t * Types.module_type ]
+exception Found_str of fkind * Env.t
+
+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 len:60 in
+      let (fo,ff) = Format.get_formatter_output_functions ()
+      and margin = Format.get_margin () in
+      Format.set_formatter_output_functions out:buf#out	flush:(fun () -> ());
+      Format.set_margin 60;
+      Format.open_hbox ();
+      Printtyp.reset ();
+      Printtyp.mark_loops ty;
+      Printtyp.type_expr ty;
+      Format.close_box (); Format.print_flush ();
+      Format.set_formatter_output_functions out:fo flush:ff;
+      Format.set_margin margin;
+      let l = Str.split sep:(Str.regexp "\n") buf#get in
+      let font =
+	let font =
+	  Option.get Widget.default_toplevel name:"font" class:"Font" in
+	if font = "" then "7x14" else font
+      in
+      (* Menu.add_separator menu; *)
+      List.iter l fun:
+	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 rec search_pos_structure :pos str =
+  List.iter str fun:
+  begin function
+    Tstr_eval exp -> search_pos_expr exp :pos
+  | Tstr_value (rec_flag, l) ->
+      List.iter l fun:
+      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_module (_, m) -> search_pos_module_expr m :pos
+  | Tstr_modtype _ -> ()
+  | Tstr_open _ -> ()
+  | Tstr_class l ->
+      List.iter l fun:(fun (id, _, _, cl) -> search_pos_class_expr cl :pos)
+  | Tstr_cltype _ -> ()
+  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 ->
+	raise (Found_str (`Class (path, cl.cl_type), !start_env))
+    | Tclass_structure cls ->
+	List.iter cls.cl_field fun:
+	  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 fun:
+		  begin fun (pat, exp) ->
+		    search_pos_pat pat :pos env:exp.exp_env;
+		    search_pos_expr exp :pos
+		  end;
+		List.iter iel fun:(fun (_,exp) -> search_pos_expr exp :pos)
+	    | Cf_init exp -> search_pos_expr exp :pos
+	  end
+    | Tclass_fun (pat, iel, cl, _) ->
+	search_pos_pat pat :pos env:pat.pat_env;
+	List.iter iel fun:(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 fun:(Misc.may (search_pos_expr :pos))
+    | Tclass_let (_, pel, iel, cl) ->
+	List.iter pel fun:
+	  begin fun (pat, exp) ->
+	    search_pos_pat pat :pos env:exp.exp_env;
+	    search_pos_expr exp :pos
+	  end;
+	List.iter iel fun:(fun (_,exp) -> search_pos_expr exp :pos);
+	search_pos_class_expr cl :pos
+    | Tclass_constraint (cl, _, _, _) ->
+	search_pos_class_expr cl :pos
+    end;
+    raise (Found_str
+	     (`Class (Pident (Ident.create "c"), cl.cl_type), !start_env))
+  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, _) ->
+      raise (Found_str (`Exp(`Val path, exp.exp_type), exp.exp_env))
+  | Texp_constant v ->
+      raise (Found_str (`Exp(`Const, exp.exp_type), exp.exp_env))
+  | Texp_let (_, expl, exp) ->
+      List.iter expl fun:
+      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 fun:
+      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 fun:(Misc.may (search_pos_expr :pos));
+      search_pos_expr exp :pos
+  | Texp_match (exp, l, _) ->
+      search_pos_expr exp :pos;
+      List.iter l fun:
+      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 fun:
+      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 fun:(search_pos_expr :pos)
+  | Texp_construct (_, l) -> List.iter l fun:(search_pos_expr :pos)
+  | Texp_variant (_, None) -> ()
+  | Texp_variant (_, Some exp) -> search_pos_expr exp :pos
+  | Texp_record (l, opt) ->
+      List.iter l fun:(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 fun:(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] fun:(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, _) ->
+      raise (Found_str (`Exp(`New path, exp.exp_type), exp.exp_env))
+  | Texp_instvar (_,path) ->
+      raise (Found_str (`Exp(`Var path, exp.exp_type), exp.exp_env))
+  | Texp_setinstvar (_, path, exp) ->
+      search_pos_expr exp :pos;
+      raise (Found_str (`Exp(`Var path, exp.exp_type), exp.exp_env))
+  | Texp_override (_, l) ->
+      List.iter l fun:(fun (_, exp) -> search_pos_expr exp :pos)
+  | Texp_letmodule (id, modexp, exp) ->
+      search_pos_module_expr modexp :pos;
+      search_pos_expr exp :pos
+  end;
+  raise (Found_str (`Exp(`Expr, exp.exp_type), exp.exp_env))
+  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 ->
+      raise (Found_str (`Exp(`Val (Pident id), pat.pat_type), env))
+  | Tpat_alias (pat, _) -> search_pos_pat pat :pos :env
+  | Tpat_constant _ ->
+      raise (Found_str (`Exp(`Const, pat.pat_type), env))
+  | Tpat_tuple l ->
+      List.iter l fun:(search_pos_pat :pos :env)
+  | Tpat_construct (_, l) ->
+      List.iter l fun:(search_pos_pat :pos :env)
+  | Tpat_variant (_, None, _) -> ()
+  | Tpat_variant (_, Some pat, _) -> search_pos_pat pat :pos :env
+  | Tpat_record l ->
+      List.iter l fun:(fun (_, pat) -> search_pos_pat pat :pos :env)
+  | Tpat_array l ->
+      List.iter l fun:(search_pos_pat :pos :env)
+  | Tpat_or (a, b) ->
+      search_pos_pat a :pos :env; search_pos_pat b :pos :env
+  end;
+  raise (Found_str (`Exp(`Pat, pat.pat_type), env))
+  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 ->
+	raise
+	  (Found_str (`Module (path, m.mod_type), m.mod_env))
+    | 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;
+    raise (Found_str (`Module (Pident (Ident.create "M"), m.mod_type),
+		      m.mod_env))
+  end
diff --git a/otherlibs/labltk/browser/searchpos.mli b/otherlibs/labltk/browser/searchpos.mli
new file mode 100644
index 0000000000..eeae7f32c6
--- /dev/null
+++ b/otherlibs/labltk/browser/searchpos.mli
@@ -0,0 +1,57 @@
+(* $Id$ *)
+
+open Widget
+
+val top_widgets : any widget list ref
+
+type module_widgets =
+    { mw_frame: frame widget;
+      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 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 -> 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]
+exception Found_sig of skind * Longident.t * Env.t
+val search_pos_signature :
+  Parsetree.signature -> pos:int -> env:Env.t -> Env.t
+      (* raises Found_sig to return its result, or Not_found *)
+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 [`Expr|`Pat|`Const|`Val Path.t|`Var Path.t|`New Path.t]
+	* Types.type_expr
+    | `Class Path.t * Types.class_type
+    | `Module Path.t * Types.module_type ]
+exception Found_str of fkind * Env.t
+val search_pos_structure :
+  pos:int -> Typedtree.structure_item list -> unit
+      (* raises Found_str to return its result *)
+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 -> in:string -> int
+
diff --git a/otherlibs/labltk/browser/setpath.ml b/otherlibs/labltk/browser/setpath.ml
new file mode 100644
index 0000000000..99c045d97a
--- /dev/null
+++ b/otherlibs/labltk/browser/setpath.ml
@@ -0,0 +1,149 @@
+(* $Id$ *)
+
+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 pred:
+      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 to: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 fun:
+      begin function
+	  "." -> base 
+	| ".." -> Filename.dirname base
+	| x -> base ^ "/" ^ x
+      end
+  in
+  set_load_path
+    (dirs @ List.fold_left dirs acc:(get_load_path ())
+      	      fun:(fun :acc x -> List2.exclude elt:x acc))
+
+let remove_path box :dirs =
+  set_load_path
+    (List.fold_left dirs acc:(get_load_path ())
+       fun:(fun :acc x -> List2.exclude elt: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 parent:tl text:"Path" ()
+  and dir_name =
+      Entry.create parent:tl textvariable:var_dir ()
+  and browse = Frame.create parent:tl () in
+  let dirs = Frame.create parent:browse ()
+  and path = Frame.create parent:browse () in
+  let dirframe, dirbox, dirsb = Jg_box.create_with_scrollbar parent:dirs ()
+  and pathframe, pathbox, pathsb = Jg_box.create_with_scrollbar parent: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:(`Set([], 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));
+
+  let bind_space_toggle lb =
+    bind lb events:[[], `KeyPressDetail "space"]
+    action:(`Extend ([], fun _ -> ()))
+  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)
+      	      fun:(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)
+      	      fun:(fun x -> Listbox.get pathbox index:x))
+  in
+  bind dirbox events:[[], `KeyPressDetail "Insert"]
+    action:(`Set ([], add_paths));
+  bind pathbox events:[[], `KeyPressDetail "Delete"]
+    action:(`Set ([], remove_paths));
+  
+  let dirlab = Label.create parent:dirs text:"Directories" ()
+  and pathlab = Label.create parent:path text:"Load path" ()
+  and addbutton =
+    Button.create parent:dirs text:"Add to path" command:add_paths ()
+  and pathbuttons = Frame.create parent:path () in
+  let removebutton =
+    Button.create parent: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:(`Pix 10);
+  pack [addbutton] side:`Bottom fill:`X;
+  pack [dirframe] fill:`Y expand:true;
+  pack [pathlab] side:`Top anchor:`W padx:(`Pix 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:(`Pix 10);
+  pack [dir_name] side:`Top anchor:`W fill:`X;
+  pack [browse] side:`Bottom expand:true fill:`Both;
+  tl
diff --git a/otherlibs/labltk/browser/setpath.mli b/otherlibs/labltk/browser/setpath.mli
new file mode 100644
index 0000000000..9801f83e7e
--- /dev/null
+++ b/otherlibs/labltk/browser/setpath.mli
@@ -0,0 +1,10 @@
+(* $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 f : dir:string -> toplevel widget
+    (* edit the load path *)  
diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml
new file mode 100644
index 0000000000..5af22d1b45
--- /dev/null
+++ b/otherlibs/labltk/browser/shell.ml
@@ -0,0 +1,237 @@
+(* $Id$ *)
+
+open Tk
+open Jg_tk
+
+(* 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 pos:count history 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 pos:((l + count - 1) mod l)
+end
+
+(* The shell class. Now encapsulated *)
+
+let protect f x = try f x with _ -> ()
+
+class shell :textw :prog :args :env =
+  let (in2,out1) = Unix.pipe ()
+  and (in1,out2) = Unix.pipe ()
+  and (err1,err2) = Unix.pipe () in
+object (self)
+  val pid = Unix.create_process_env :prog :args :env in:in2 out:out2 err:err2
+  val out = Unix.out_channel_of_descr out1
+  val h = new history ()
+  val mutable alive = true
+  val mutable reading = false
+  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;
+      List.iter fun:(protect Unix.close) [in1; err1; in2; out2; err2];
+      try
+	Fileevent.remove_fileinput fd:in1;
+	Fileevent.remove_fileinput fd:err1;
+	Unix.kill :pid signal:Sys.sigkill;
+	Unix.waitpid flags:[] pid; ()
+      with _ -> ()
+    end
+  method interrupt =
+    if alive then try
+      reading <- false;
+      Unix.kill :pid signal:Sys.sigint
+    with Unix.Unix_error _ -> ()
+  method send s =
+    if alive then try
+      output_string s to:out;
+      flush out
+    with Sys_error _ -> ()
+  method private read :fd :len =
+    try
+      let buffer = String.create :len in
+      let len = Unix.read fd :buffer pos:0 :len in
+      self#insert (String.sub buffer pos:0 :len);
+      Text.mark_set textw mark:"input" index:(`Mark"insert",[`Char(-1)])
+    with Unix.Unix_error _ -> ()
+  method history (dir : [`next|`previous]) =
+    if not h#empty then begin
+      if reading then begin
+	Text.delete textw start:(`Mark"input",[`Char 1])
+	  end:(`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]}
+      ?end:endx{= `Mark"insert",[`Lineend]} () =
+    Lexical.tag textw :start end:endx
+  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]);
+    self#lex start:(`Mark"input",[`Linestart]) ();
+    let s =
+      (* input is one character before real input *)
+      Text.get textw start:(`Mark"input",[`Char 1])
+	end:(`Mark"insert",[]) in
+    h#add s;
+    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
+      fun:(fun (events,fields,f) ->
+	bind textw :events action:(`Set(fields,f)));
+    begin try
+      List.iter [in1;err1] fun:
+	begin fun fd ->
+	  Fileevent.add_fileinput :fd
+	    callback:(fun () -> self#read :fd len:1024)
+	end
+    with _ -> ()
+    end
+end
+
+(* Specific use of shell, for LablBrowser *)
+
+let shells : (string * shell) list ref = ref []
+
+(* Called before exiting *)
+let kill_all () =
+  List.iter !shells fun:(fun (_,sh) -> if sh#alive then sh#kill);
+  shells := []
+
+let get_all () =
+  let all = List.filter !shells pred:(fun (_,sh) -> sh#alive) in
+  shells := all;
+  all
+
+let may_exec prog =
+  try
+    let stats = Unix.stat prog in
+    stats.Unix.st_perm land 1 <> 0 or
+    stats.Unix.st_perm land 8 <> 0
+      & List.mem elt:stats.Unix.st_gid (Array.to_list (Unix.getgroups ())) or
+    stats.Unix.st_perm land 64 <> 0 & stats.Unix.st_uid = Unix.getuid ()
+  with Unix.Unix_error _ -> false
+
+let f :prog :title =
+  let progargs =
+    List.filter pred:((<>) "") (Str.split sep:(Str.regexp " ") prog) in
+  if progargs = [] then () else
+  let prog = List.hd progargs in
+  let path = try Sys.getenv "PATH" with Not_found -> "/bin:/usr/bin" in
+  let exec_path = Str.split sep:(Str.regexp":") path in
+  let exists =
+    if not (Filename.is_implicit prog) then may_exec prog else
+    List.exists exec_path
+      pred:(fun dir -> may_exec (Filename.concat dir prog)) in
+  if not exists then () else
+  let tl = Jg_toplevel.titled title in
+  let menus = Frame.create parent: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:(`Pix 5) anchor:`W;
+  let frame, tw, sb = Jg_text.create_with_scrollbar parent: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 reg = Str.regexp "TERM=" in
+  let env = Array.map (Unix.environment ()) fun:
+      begin fun s ->
+ 	if Str.string_match reg s pos:0 then "TERM=dumb" else s
+      end in
+  let load_path =
+    List2.flat_map !Config.load_path fun:(fun dir -> ["-I"; dir]) in
+  let args = Array.of_list (progargs @ load_path) in
+  let sh = new shell textw:tw :prog :env :args in
+  let current_dir = ref (Unix.getcwd ()) in
+  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 = List.hd l in
+	  current_dir := Filename.dirname name;
+	  if Filename.check_suffix name suff:".ml"
+	  then
+	    let cmd = "#use \"" ^ 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 = List.hd l in
+	  current_dir := Filename.dirname name;
+	  if Filename.check_suffix name suff:".cmo" or
+	    Filename.check_suffix name suff:".cma"
+	  then
+	    let cmd = "#load \"" ^ 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)
+	fun:(fun dir -> sh#send ("#directory \"" ^ 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);
+  shells := (title, sh) :: !shells
diff --git a/otherlibs/labltk/browser/shell.mli b/otherlibs/labltk/browser/shell.mli
new file mode 100644
index 0000000000..adea445514
--- /dev/null
+++ b/otherlibs/labltk/browser/shell.mli
@@ -0,0 +1,20 @@
+(* $Id$ *)
+
+(* toplevel shell *)
+
+class shell :
+  textw:Widget.text Widget.widget -> prog:string ->
+  args:string array -> env:string array ->
+  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 f : prog:string -> title:string -> unit
diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml
new file mode 100644
index 0000000000..8c1e29debd
--- /dev/null
+++ b/otherlibs/labltk/browser/typecheck.ml
@@ -0,0 +1,98 @@
+(* $Id$ *)
+
+open Tk
+open Parsetree
+open Location
+open Jg_tk
+open Mytypes
+
+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" () in
+  Text.tag_remove txt.tw tag:"error" start:tstart end:tend;
+  begin
+  txt.structure <- [];
+  txt.signature <- [];
+  txt.psignature <- [];
+  try
+
+    if Filename.check_suffix txt.name suff:".mli" then
+    let psign = Parse.interface (Lexing.from_string text) in
+    txt.psignature <- psign;
+    txt.signature <- Typemod.transl_signature !env psign
+
+    else (* others are interpreted as .ml *)
+
+    let psl = Parse.use_file (Lexing.from_string text) in
+    List.iter psl fun:
+    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
+
+  with
+    Lexer.Error _ | Syntaxerr.Error _
+  | Typecore.Error _ | Typemod.Error _
+  | Typeclass.Error _ | Typedecl.Error _
+  | Typetexp.Error _ | Includemod.Error _
+  | Env.Error _ | Ctype.Tags _ as exn ->
+      let et, ew, end_message = Jg_message.formatted title:"Error !" () in
+      error_messages := et :: !error_messages;
+      let s, e = match exn with
+     	Lexer.Error (err, s, e) ->
+	  Lexer.report_error err; s,e
+      | Syntaxerr.Error err ->
+	  Syntaxerr.report_error err;
+ 	  let l =
+	    match err with
+	      Syntaxerr.Unclosed(l,_,_,_) -> l
+	    | Syntaxerr.Other l -> l
+	  in l.loc_start, l.loc_end
+      | Typecore.Error (l,err) ->
+	  Typecore.report_error err; l.loc_start, l.loc_end
+      | Typeclass.Error (l,err) ->
+	  Typeclass.report_error err; l.loc_start, l.loc_end
+      | Typedecl.Error (l, err) ->
+	  Typedecl.report_error err; l.loc_start, l.loc_end
+      | Typemod.Error (l,err) ->
+	  Typemod.report_error err; l.loc_start, l.loc_end
+      | Typetexp.Error (l,err) ->
+	  Typetexp.report_error err; l.loc_start, l.loc_end
+      | Includemod.Error errl ->
+	  Includemod.report_error errl; 0, 0
+      | Env.Error err ->
+	  Env.report_error err; 0, 0
+      | Ctype.Tags(l, l') ->
+	  Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value." l l'; 0, 0
+      |	_ -> assert false
+      in
+      end_message ();
+      if s < e then
+   	Jg_text.tag_and_see txt.tw start:(tpos s) end:(tpos e) tag:"error"
+  end;
+  end_message ();
+  if !nowarnings or 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:[[`Double], `ButtonPressDetail 1]
+      action:(`Set ([], fun _ ->
+	let s =
+	  Text.get ew start:(`Mark "insert", [`Wordstart])
+      	              end:(`Mark "insert", [`Wordend]) in
+	try
+	  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 Failure "int_of_string" -> ()))
+  end;
+  !error_messages
diff --git a/otherlibs/labltk/browser/typecheck.mli b/otherlibs/labltk/browser/typecheck.mli
new file mode 100644
index 0000000000..fd9970495c
--- /dev/null
+++ b/otherlibs/labltk/browser/typecheck.mli
@@ -0,0 +1,9 @@
+(* $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
new file mode 100644
index 0000000000..33dd20f2bc
--- /dev/null
+++ b/otherlibs/labltk/browser/useunix.ml
@@ -0,0 +1,36 @@
+(* $Id$ *)
+
+open Unix
+
+let get_files_in_directory dir =
+  try
+  let dirh = opendir dir in
+  let rec get_them () =
+    try
+      let x = readdir dirh in
+      x :: get_them ()
+    with
+      _ -> closedir dirh; [] 
+  in
+    Sort.list order:(<) (get_them ())
+  with Unix_error _ -> []
+
+let is_directory name =
+  try
+    (stat name).st_kind = S_DIR
+  with _ -> false
+
+let get_directories_in_files :path =
+  List.filter pred:(fun x -> is_directory  (path ^ "/" ^ x))
+
+(************************************************** Subshell call *)
+let subshell :cmd =
+  let rc = open_process_in cmd in
+  let rec it () =
+    try 
+      let x = input_line rc in x :: it ()
+    with _ -> []
+  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
new file mode 100644
index 0000000000..23699155ab
--- /dev/null
+++ b/otherlibs/labltk/browser/useunix.mli
@@ -0,0 +1,8 @@
+(* $Id$ *)
+
+(* Unix utilities *)
+
+val get_files_in_directory : string -> string list
+val is_directory : string -> bool
+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
new file mode 100644
index 0000000000..bc9d7228b1
--- /dev/null
+++ b/otherlibs/labltk/browser/viewer.ml
@@ -0,0 +1,323 @@
+(* $Id$ *)
+
+open Tk
+open Jg_tk
+open Mytypes
+open Longident
+open Types
+open Typedtree
+open Env
+open Searchpos
+open Searchid
+
+let list_modules :path =
+  List.fold_left path acc:[] fun:
+  begin fun :acc dir ->
+    let l = 
+      List.filter (Useunix.get_files_in_directory dir)
+        pred:(fun x -> Filename.check_suffix x suff:".cmi") in
+    let l = List.map l fun:
+    begin fun x ->
+      String.capitalize (Filename.chop_suffix x suff:".cmi")
+    end in
+    List.fold_left l :acc
+     fun:(fun :acc elt -> if List.mem acc :elt then acc else elt :: acc)
+  end
+
+let reset_modules box =
+  Listbox.delete box first:(`Num 0) last:`End;
+  module_list := Sort.list order:(<) (list_modules path:!Config.load_path);
+  Listbox.insert box index:`End texts:!module_list;
+  Jg_box.recenter box index:(`Num 0)
+
+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
+
+let choose_symbol :title :env ?:signature ?:path l =
+  if match path with
+    None -> false
+  | Some path ->
+      try find_shown_module path; true with Not_found -> false
+  then () else
+  let tl = Jg_toplevel.titled title in
+  Jg_bind.escape_destroy tl;
+  top_widgets := coe tl :: !top_widgets;
+  let buttons = Frame.create parent:tl () in
+  let all = Button.create parent:buttons text:"Show all" padx:(`Pix 20) ()
+  and ok = Jg_button.create_destroyer tl parent:buttons
+  and detach = Button.create parent:buttons text:"Detach" ()
+  and edit = Button.create parent:buttons text:"Impl" ()
+  and intf = Button.create parent:buttons text:"Intf" () in
+  let l = Sort.list l order:
+      (fun (li1, _) (li2,_) ->
+	string_of_longident li1 < string_of_longident li2)
+  in
+  let nl = List.map l fun:
+    begin fun (li, k) ->
+      string_of_longident li ^ " (" ^ string_of_kind k ^ ")"
+    end in
+  let fb = Frame.create parent:tl () in
+  let box =
+    new Jg_multibox.c parent: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 (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 parent:tl () in
+      pack [frame] side:`Bottom fill:`X;
+      add_shown_module path
+	widgets:{ mw_frame = frame; mw_detach = detach;
+		  mw_edit = edit; mw_intf = intf }
+  end
+
+let search_which = ref "itself"
+
+let search_symbol () =
+  if !module_list = [] then
+  module_list := Sort.list order:(<) (list_modules path:!Config.load_path);
+  let tl = Jg_toplevel.titled "Search symbol" in
+  Jg_bind.escape_destroy tl;
+  let ew = Entry.create parent:tl width:30 () in
+  let choice = Frame.create parent:tl ()
+  and which = Textvariable.create on:tl () in
+  let itself = Radiobutton.create parent:choice text:"Itself"
+        variable:which value:"itself" ()
+  and extype = Radiobutton.create parent:choice text:"Exact type"
+        variable:which value:"exact" ()
+  and iotype = Radiobutton.create parent:choice text:"Included type"
+      	variable:which value:"iotype" ()
+  and buttons = Frame.create parent:tl () in
+  let search = Button.create parent:buttons text:"Search" () command:
+    begin fun () ->
+      search_which := Textvariable.get which;
+      let text = Entry.get ew in
+      try if text = "" then () else      
+        let l = match !search_which with
+                "itself" -> search_string_symbol text
+      	      | "iotype" -> search_string_type text mode:`included
+	      | "exact" -> search_string_type text mode:`exact
+        in
+        if l <> [] then
+        choose_symbol title:"Choose symbol" env:!start_env l
+      with Searchid.Error (s,e) ->
+      	Entry.selection_clear ew;
+	Entry.selection_range ew start:(`Num s) end:(`Num e);
+	Entry.xview_index ew index:(`Num s)
+    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 to:!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
+
+let view_defined modlid :env =
+  try match lookup_module modlid env with
+    path, Tmty_signature sign ->
+    let ident_of_decl = 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
+    in
+    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 decl :: idents)
+    in
+    let l = iter_sign sign [] in
+    choose_symbol l title:(string_of_path path) signature:sign
+       env:(open_signature path sign env) :path
+  | _ -> ()
+  with Not_found -> ()
+  | Env.Error err ->
+      let tl, tw, finish = Jg_message.formatted title:"Error!" () in
+      Env.report_error err;
+      finish ()
+
+let close_all_views () =
+    List.iter !top_widgets
+      fun:(fun tl -> try destroy tl with Protocol.TkError _ -> ());
+    top_widgets := []
+
+
+let shell_counter = ref 1
+let default_shell = ref "ocaml"
+
+let start_shell () =
+  let tl = Jg_toplevel.titled "Start New Shell" in
+  Wm.transient_set tl master:Widget.default_toplevel;
+  let input = Frame.create parent:tl ()
+  and buttons = Frame.create parent:tl () in
+  let ok = Button.create parent:buttons text:"Ok" ()
+  and cancel = Jg_button.create_destroyer tl parent:buttons text:"Cancel"
+  and labels = Frame.create parent:input ()
+  and entries = Frame.create parent:input () in
+  let l1 = Label.create parent:labels text:"Command:" ()
+  and l2 = Label.create parent:labels text:"Title:" ()
+  and e1 =
+    Jg_entry.create parent:entries command:(fun _ -> Button.invoke ok) ()
+  and e2 =
+    Jg_entry.create parent:entries command:(fun _ -> Button.invoke ok) ()
+  and names = List.map fun:fst (Shell.get_all ()) in
+  Entry.insert e1 index:`End text:!default_shell;
+  while List.mem names elt:("Shell #" ^ string_of_int !shell_counter) do
+    incr shell_counter
+  done;
+  Entry.insert e2 index:`End text:("Shell #" ^ string_of_int !shell_counter);
+  Button.configure ok command:(fun () ->
+      if not (List.mem names elt:(Entry.get e2)) 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
+
+let f ?:dir{= Unix.getcwd()} ?:on () =
+  let tl = match on with
+    None ->
+      let tl = Jg_toplevel.titled "Module viewer" in
+      Jg_bind.escape_destroy tl; coe tl
+  | Some top ->
+      Wm.title_set top title:"LablBrowser";
+      Wm.iconname_set top name:"LablBrowser";
+      let tl = Frame.create parent:top () in
+      pack [tl] expand:true fill:`Both;
+      coe tl
+  in
+  let menus = Frame.create parent: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 parent: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 parent:tl () in
+  let buttons = Frame.create parent:tl () in
+  let search = Button.create parent:buttons text:"Search" pady:(`Pix 1) ()
+    command:
+    begin fun () ->
+      let s = Entry.get ew in
+      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;
+      let l =
+ 	if !is_type then try
+	  search_string_type mode:`included s
+	with Searchid.Error (start,stop) ->
+	  Entry.icursor ew index:(`Num start); []
+ 	else if !is_long then
+	  search_string_symbol s
+ 	else
+	  search_pattern_symbol s in
+      match l with [] -> ()
+      |	[lid,kind] when !is_long -> view_symbol lid :kind env:!start_env
+      |	_ -> choose_symbol title:"Choose symbol" env:!start_env l
+    end
+  and close =
+    Button.create parent:buttons text:"Close all" pady:(`Pix 1) ()
+                  command:close_all_views
+  in
+  (* bindings *)
+  Jg_bind.enter_focus ew;
+  Jg_bind.return_invoke ew button:search;
+  bind close events:[[`Double], `ButtonPressDetail 1]
+    action:(`Set ([], 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:start_shell;
+  filemenu#add_command "Quit" command:(fun () -> destroy tl);
+
+  (* modules menu *)
+  modmenu#add_command "Path editor..." command:(fun () -> Setpath.f :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:(`Pix 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
diff --git a/otherlibs/labltk/browser/viewer.mli b/otherlibs/labltk/browser/viewer.mli
new file mode 100644
index 0000000000..798afeb089
--- /dev/null
+++ b/otherlibs/labltk/browser/viewer.mli
@@ -0,0 +1,15 @@
+(* $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 view_defined : Longident.t -> env:Env.t -> unit
+      	(* displays a signature, found in environment *)
+
+val close_all_views : unit -> unit
diff --git a/otherlibs/labltk/builtin/builtin_GetBitmap.ml b/otherlibs/labltk/builtin/builtin_GetBitmap.ml
new file mode 100644
index 0000000000..31b807e681
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_GetBitmap.ml
@@ -0,0 +1,8 @@
+(* Tk_GetBitmap emulation *)
+(* type *)
+type bitmap = [
+    `File string                 (* path of file *)
+  | `Predefined string           (* bitmap  name *)
+]
+(* /type *)
+
diff --git a/otherlibs/labltk/builtin/builtin_GetCursor.ml b/otherlibs/labltk/builtin/builtin_GetCursor.ml
new file mode 100644
index 0000000000..7e04015921
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_GetCursor.ml
@@ -0,0 +1,24 @@
+(* Color *)
+(* type *)
+type color = [
+    `Color 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 *)
+
+(* Tk_GetCursor emulation *)
+(* type *)
+type cursor = [
+    `Xcursor string
+  | `Xcursorfg string * color
+  | `Xcursorfgbg string * color * color
+  | `Cursorfilefg string * color
+  | `Cursormaskfile string * string * color * color
+]
+(* /type *)
+
diff --git a/otherlibs/labltk/builtin/builtin_GetPixel.ml b/otherlibs/labltk/builtin/builtin_GetPixel.ml
new file mode 100644
index 0000000000..f760dce75b
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_GetPixel.ml
@@ -0,0 +1,11 @@
+(* Tk_GetPixels emulation *)
+(* type *)
+type units = [
+    `Pix int
+  | `Cm float
+  | `In float
+  | `Mm float
+  | `Pt float
+]
+(* /type *)
+
diff --git a/otherlibs/labltk/builtin/builtin_ScrollValue.ml b/otherlibs/labltk/builtin/builtin_ScrollValue.ml
new file mode 100644
index 0000000000..54ef881877
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_ScrollValue.ml
@@ -0,0 +1,8 @@
+(* type *)
+type scrollValue = [
+    `Page(int)		(* tk option: scroll <int> page *)
+  | `Unit(int)		(* tk option: scroll <int> unit *)
+  | `Moveto(float)	(* tk option: moveto <float> *)
+]
+(* /type *)
+
diff --git a/otherlibs/labltk/builtin/builtin_bind.ml b/otherlibs/labltk/builtin/builtin_bind.ml
new file mode 100644
index 0000000000..41ebfe8468
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_bind.ml
@@ -0,0 +1,236 @@
+open Widget
+
+(* Events and bindings *)
+(* Builtin types *)
+(* type *)
+type xEvent = [
+    `ButtonPress (* also Button, but we omit it *)
+  | `ButtonPressDetail (int)
+  | `ButtonRelease
+  | `ButtonReleaseDetail (int)
+  | `Circulate
+  | `ColorMap
+  | `Configure
+  | `Destroy
+  | `Enter
+  | `Expose
+  | `FocusIn
+  | `FocusOut
+  | `Gravity
+  | `KeyPress (* also Key, but we omit it *)
+  | `KeyPressDetail (string)      (* /usr/include/X11/keysymdef.h *)
+  | `KeyRelease
+  | `KeyReleaseDetail (string)
+  | `Leave
+  | `Map
+  | `Motion
+  | `Property
+  | `Reparent
+  | `Unmap
+  | `Visibility 
+]
+(* /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 =
+  {
+  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 = 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 =
+  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 fun:(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
+        `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
+
+
+(* type *)
+type bindAction = [
+   `Set ( eventField list *  (eventInfo -> unit))
+  | `Setbreakable ( eventField list *  (eventInfo -> unit) )
+  | `Remove
+  | `Extend ( eventField list *  (eventInfo -> unit))
+]
+(* /type *)
+
+
diff --git a/otherlibs/labltk/builtin/builtin_bindtags.ml b/otherlibs/labltk/builtin/builtin_bindtags.ml
new file mode 100644
index 0000000000..6461df43c0
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_bindtags.ml
@@ -0,0 +1,7 @@
+(* type *)
+type bindings = [
+    `Tag(string)		(* tk option: <string> *)
+  | `Widget(any widget)		(* tk option: <widget> *)
+]
+(* /type *)
+
diff --git a/otherlibs/labltk/builtin/builtin_index.ml b/otherlibs/labltk/builtin/builtin_index.ml
new file mode 100644
index 0000000000..917ac410a3
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_index.ml
@@ -0,0 +1,56 @@
+(* Various indexes
+    canvas
+    entry
+    listbox
+*)
+
+type canvas_index = [
+    `Num(int)		
+  | `End		        
+  | `Insert		
+  | `Selfirst		
+  | `Sellast		
+  | `Atxy(int * int)         
+]
+
+type entry_index = [
+    `Num(int)		
+  | `End
+  | `Insert		
+  | `Selfirst		
+  | `Sellast		
+  | `At(int)
+  | `Anchor
+]
+
+type listbox_index = [
+    `Num(int)		
+  | `Active
+  | `Anchor
+  | `End
+  | `Atxy(int * int)
+]
+
+type menu_index = [
+    `Num(int)		
+  | `Active
+  | `End
+  | `Last			
+  | `None		
+  | `At(int)
+  | `Pattern(string)
+]
+
+type text_index = [
+    `Linechar(int * int)   
+  | `Atxy(int * int)
+  | `End
+  | `Mark(string)
+  | `Tagfirst(string)
+  | `Taglast(string)
+  | `Window(any widget)
+  | `Image(string) 
+]
+
+type linechar_index = int * int
+type num_index = int
diff --git a/otherlibs/labltk/builtin/builtin_palette.ml b/otherlibs/labltk/builtin/builtin_palette.ml
new file mode 100644
index 0000000000..1bf3054901
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_palette.ml
@@ -0,0 +1,7 @@
+(* type *)
+type paletteType = [
+    `Gray (int)
+  | `Rgb (int * int * int)
+]
+(* /type *)
+
diff --git a/otherlibs/labltk/builtin/builtin_text.ml b/otherlibs/labltk/builtin/builtin_text.ml
new file mode 100644
index 0000000000..1b6d6facdc
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtin_text.ml
@@ -0,0 +1,24 @@
+(* Not a string as such, more like a symbol *)
+
+(* type *)
+type textMark = string
+(* /type *)
+
+(* type *)
+type textTag = string
+(* /type *)
+
+(* type *)
+type textModifier = [
+    `Char(int)		(* tk keyword: +/- Xchars *)
+  | `Line(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 *)
diff --git a/otherlibs/labltk/builtin/builtina_empty.ml b/otherlibs/labltk/builtin/builtina_empty.ml
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtina_empty.ml
diff --git a/otherlibs/labltk/builtin/builtinf_bind.ml b/otherlibs/labltk/builtin/builtinf_bind.ml
new file mode 100644
index 0000000000..5a3dd19a26
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtinf_bind.ml
@@ -0,0 +1,83 @@
+(*
+FUNCTION
+ val bind: 
+    any widget -> (modifier list * xEvent) list -> bindAction -> unit
+/FUNCTION
+*)
+let bind widget events:eventsequence action:(action : bindAction) =
+  tkEval [| TkToken "bind";
+      	    TkToken (Widget.name widget);
+	    cCAMLtoTKeventSequence eventsequence;
+  begin match action with
+     `Remove -> TkToken ""
+  |  `Set (what, f) ->
+      let cbId = register_callback widget callback: (wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+  |  `Setbreakable (what, f) ->
+      let cbId = register_callback widget callback: (wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
+                 " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0"
+                )
+  |  `Extend (what, f) ->
+      let cbId = register_callback widget callback: (wrapeventInfo f what) in
+        TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+      
+  end
+  |];
+  ()
+
+(* 
+FUNCTION
+(* unsafe *)
+ val class_bind : 
+    string -> (modifier list * xEvent) list -> bindAction -> unit 
+(* /unsafe *)
+/FUNCTION
+ class arg is not constrained
+*)
+let class_bind clas events:eventsequence action:(action : bindAction) =
+  tkEval [| TkToken "bind";
+      	    TkToken clas;
+	    cCAMLtoTKeventSequence eventsequence;
+  begin match action with
+     `Remove -> TkToken ""
+  |  `Set (what, f) ->
+      let cbId = register_callback Widget.dummy 
+      	                           callback: (wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+  |  `Setbreakable (what, f) ->
+      let cbId = register_callback Widget.dummy 
+      	                           callback: (wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
+                 " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0"
+                )
+  |  `Extend (what, f) ->
+      let cbId = register_callback Widget.dummy 
+                                   callback: (wrapeventInfo f what) in
+        TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+      
+  end
+ |];
+  ()
+
+(* 
+FUNCTION
+(* unsafe *)
+ val tag_bind : 
+    string -> (modifier list * xEvent) list -> bindAction -> unit 
+(* /unsafe *)
+/FUNCTION
+ tag name arg is not constrained 
+*)
+
+let tag_bind = class_bind
+
+
+(*
+FUNCTION
+  val break : unit -> unit
+/FUNCTION
+*)
+let break = function () ->
+  tkEval [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |];
+  ()
diff --git a/otherlibs/labltk/builtin/builtini_GetBitmap.ml b/otherlibs/labltk/builtin/builtini_GetBitmap.ml
new file mode 100644
index 0000000000..d18111127d
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_GetBitmap.ml
@@ -0,0 +1,10 @@
+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
+
+
diff --git a/otherlibs/labltk/builtin/builtini_GetCursor.ml b/otherlibs/labltk/builtin/builtini_GetCursor.ml
new file mode 100644
index 0000000000..8c63876cbe
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_GetCursor.ml
@@ -0,0 +1,24 @@
+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])
+
+
diff --git a/otherlibs/labltk/builtin/builtini_GetPixel.ml b/otherlibs/labltk/builtin/builtini_GetPixel.ml
new file mode 100644
index 0000000000..e47048aec1
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_GetPixel.ml
@@ -0,0 +1,18 @@
+let cCAMLtoTKunits : units -> tkArgs = function
+    `Pix (foo) -> TkToken (string_of_int foo)
+  | `Mm (foo)  -> TkToken(string_of_float foo^"m")
+  | `In (foo)  -> TkToken(string_of_float foo^"i")
+  | `Pt (foo) -> TkToken(string_of_float foo^"p")
+  | `Cm (foo) -> TkToken(string_of_float foo^"c")
+  
+
+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)
+
diff --git a/otherlibs/labltk/builtin/builtini_ScrollValue.ml b/otherlibs/labltk/builtin/builtini_ScrollValue.ml
new file mode 100644
index 0000000000..8327ab6f7d
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_ScrollValue.ml
@@ -0,0 +1,17 @@
+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 (string_of_float 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")
diff --git a/otherlibs/labltk/builtin/builtini_bind.ml b/otherlibs/labltk/builtin/builtini_bind.ml
new file mode 100644
index 0000000000..8dbde204be
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_bind.ml
@@ -0,0 +1,58 @@
+let cCAMLtoTKxEvent : xEvent -> string = function
+    `ButtonPress -> "ButtonPress"
+  | `ButtonPressDetail n -> "ButtonPress-"^string_of_int n
+  | `ButtonRelease -> "ButtonRelease"
+  | `ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n
+  | `Circulate -> "Circulate"
+  | `ColorMap -> "ColorMap"
+  | `Configure -> "Configure"
+  | `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" 
+
+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-"
+
+
+(* type event = modifier list * xEvent *)
+let cCAMLtoTKevent : (modifier list * xEvent) -> string = 
+ function (ml, xe) ->
+  "<" ^ (catenate_sep " " (List.map fun:cCAMLtoTKmodifier ml))  
+      ^ (cCAMLtoTKxEvent xe) ^ ">"
+  
+(* type eventSequence == (modifier list * xEvent) list *)
+let cCAMLtoTKeventSequence : (modifier list * xEvent) list -> tkArgs = 
+ function l ->
+  TkToken(catenate_sep "" (List.map fun:cCAMLtoTKevent l))
+
+
diff --git a/otherlibs/labltk/builtin/builtini_bindtags.ml b/otherlibs/labltk/builtin/builtini_bindtags.ml
new file mode 100644
index 0000000000..7bbfe5963c
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_bindtags.ml
@@ -0,0 +1,9 @@
+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
diff --git a/otherlibs/labltk/builtin/builtini_index.ml b/otherlibs/labltk/builtin/builtini_index.ml
new file mode 100644
index 0000000000..b0a88b269a
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_index.ml
@@ -0,0 +1,70 @@
+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 *)
+(* .menu index returns none if arg is none, but blast it *)
+
+let cTKtoCAMLindex s =
+  try
+   let p = String.index elt:'.' 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 ->
+      try `Num (int_of_string s)
+      with _ -> raise (Invalid_argument ("TKtoCAMLindex: "^s))
+
+let cTKtoCAMLtext_index s = 
+  try
+   let p = String.index elt:'.' 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))
+
+(*
+let cTKtoCAMLlinechar_index s =
+  try
+   let p = char_index '.' in:s in
+      (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 ("TKtoCAMLlinechar_index: "^s))
+
+let cTKtoCAMLnum_index s =
+  try int_of_string s
+  with _ -> raise (Invalid_argument ("TKtoCAMLnum_index: "^s))
+*)
diff --git a/otherlibs/labltk/builtin/builtini_palette.ml b/otherlibs/labltk/builtin/builtini_palette.ml
new file mode 100644
index 0000000000..8d07d96472
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_palette.ml
@@ -0,0 +1,6 @@
+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)
+
diff --git a/otherlibs/labltk/builtin/builtini_text.ml b/otherlibs/labltk/builtin/builtini_text.ml
new file mode 100644
index 0000000000..1c7e2d7c09
--- /dev/null
+++ b/otherlibs/labltk/builtin/builtini_text.ml
@@ -0,0 +1,37 @@
+let cCAMLtoTKtextMark  x =  TkToken x
+let cTKtoCAMLtextMark x = x
+
+let cCAMLtoTKtextTag  x =  TkToken x
+let cTKtoCAMLtextTag x = x
+
+(* TextModifiers are never returned by Tk *)
+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"
+
+(*
+let ppTextIndex = function
+   `None -> ""
+ | `Index (base, ml) -> 
+     let (TkToken ppbase) = cCAMLtoTKtext_index base in 
+       catenate_sep "" (ppbase :: List.map fun:ppTextModifier ml)
+*)
+
+let ppTextIndex = function
+  (base, ml) -> 
+     let (TkToken ppbase) = cCAMLtoTKtext_index base in 
+       catenate_sep "" (ppbase :: List.map fun:ppTextModifier ml)
+
+let cCAMLtoTKtextIndex : textIndex -> tkArgs = function i -> 
+  TkToken (ppTextIndex i)
+
diff --git a/otherlibs/labltk/builtin/canvas_bind.ml b/otherlibs/labltk/builtin/canvas_bind.ml
new file mode 100644
index 0000000000..2a8923333a
--- /dev/null
+++ b/otherlibs/labltk/builtin/canvas_bind.ml
@@ -0,0 +1,21 @@
+let bind widget :tag events:eventsequence :action =
+  tkEval [| cCAMLtoTKwidget widget;
+      	    TkToken "bind";
+      	    cCAMLtoTKtagOrId tag;
+       	    cCAMLtoTKeventSequence eventsequence;
+  begin match action with
+     `Remove -> TkToken ""
+  |  `Set (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+  |  `Setbreakable (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
+                " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0"
+                )
+  |  `Extend (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+
+  end |];
+  ()
diff --git a/otherlibs/labltk/builtin/canvas_bind.mli b/otherlibs/labltk/builtin/canvas_bind.mli
new file mode 100644
index 0000000000..55c3ec3644
--- /dev/null
+++ b/otherlibs/labltk/builtin/canvas_bind.mli
@@ -0,0 +1,2 @@
+val bind : canvas widget -> tag: tagOrId -> 
+           events: (modifier list * xEvent) list -> action: bindAction -> unit 
diff --git a/otherlibs/labltk/builtin/dialog.ml b/otherlibs/labltk/builtin/dialog.ml
new file mode 100644
index 0000000000..cfde292af5
--- /dev/null
+++ b/otherlibs/labltk/builtin/dialog.ml
@@ -0,0 +1,12 @@
+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 fun:(fun x -> TkToken x) buttons)|]
+   in
+    int_of_string res
diff --git a/otherlibs/labltk/builtin/dialog.mli b/otherlibs/labltk/builtin/dialog.mli
new file mode 100644
index 0000000000..d0f6398c38
--- /dev/null
+++ b/otherlibs/labltk/builtin/dialog.mli
@@ -0,0 +1,8 @@
+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 *)
diff --git a/otherlibs/labltk/builtin/optionmenu.ml b/otherlibs/labltk/builtin/optionmenu.ml
new file mode 100644
index 0000000000..d3b471859a
--- /dev/null
+++ b/otherlibs/labltk/builtin/optionmenu.ml
@@ -0,0 +1,16 @@
+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 fun:(fun x -> TkToken x) values)|] in
+   if res <> Widget.name mw then
+     raise (TkError "internal error in Optionmenu.create")
+   else
+     w,mw
diff --git a/otherlibs/labltk/builtin/optionmenu.mli b/otherlibs/labltk/builtin/optionmenu.mli
new file mode 100644
index 0000000000..39707e9ff1
--- /dev/null
+++ b/otherlibs/labltk/builtin/optionmenu.mli
@@ -0,0 +1,7 @@
+(* Support for tk_optionMenu *)
+val create: parent:'a widget -> variable:textVariable ->
+            ?name: string -> string list -> menubutton widget * menu widget
+      	      (* [create 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 *)
diff --git a/otherlibs/labltk/builtin/selection_handle_set.ml b/otherlibs/labltk/builtin/selection_handle_set.ml
new file mode 100644
index 0000000000..2cdd0abe75
--- /dev/null
+++ b/otherlibs/labltk/builtin/selection_handle_set.ml
@@ -0,0 +1,15 @@
+(* The function *must* use tkreturn *)
+let handle_set command: cmd =
+selection_handle_icccm_optionals (fun opts w ->
+tkEval [|TkToken"selection";
+	 TkToken"handle";
+	 TkTokenList 
+      	   (List.map opts fun:(cCAMLtoTKselection_handle_icccm w));
+	 cCAMLtoTKwidget w;
+	 let id = register_callback w callback:(function args ->
+	   let a1 = int_of_string (List.hd args) in
+	   let a2 = int_of_string (List.nth args pos:1) in
+	   tkreturn (cmd pos:a1 len:a2)) in TkToken ("camlcb "^id)
+       |];
+  ())
+
diff --git a/otherlibs/labltk/builtin/selection_handle_set.mli b/otherlibs/labltk/builtin/selection_handle_set.mli
new file mode 100644
index 0000000000..d1d9963999
--- /dev/null
+++ b/otherlibs/labltk/builtin/selection_handle_set.mli
@@ -0,0 +1,4 @@
+val handle_set :
+    command: (pos:int -> len:int -> string) -> 
+    ?format: string -> ?selection:string -> ?type: string -> 'a widget -> unit
+(* tk invocation: selection handle <icccm list> <widget> <command> *)
diff --git a/otherlibs/labltk/builtin/selection_own_set.ml b/otherlibs/labltk/builtin/selection_own_set.ml
new file mode 100644
index 0000000000..feffcdf96b
--- /dev/null
+++ b/otherlibs/labltk/builtin/selection_own_set.ml
@@ -0,0 +1,13 @@
+(* builtin to handle callback association to widget *)
+let own_set ?:command =
+selection_ownset_icccm_optionals ?:command (fun opts w ->
+tkEval [|TkToken"selection";
+	 TkToken"own";
+	 TkTokenList 
+      	   (List.map 
+      	     fun:(function x -> 
+      	       cCAMLtoTKselection_ownset_icccm w x)
+      	     opts);
+	cCAMLtoTKwidget w|];
+())
+
diff --git a/otherlibs/labltk/builtin/selection_own_set.mli b/otherlibs/labltk/builtin/selection_own_set.mli
new file mode 100644
index 0000000000..d054509035
--- /dev/null
+++ b/otherlibs/labltk/builtin/selection_own_set.mli
@@ -0,0 +1,3 @@
+val own_set :
+    ?command:(unit->unit) -> ?selection:string -> 'a widget -> unit 
+(* tk invocation: selection own <icccm list> <widget> *)
diff --git a/otherlibs/labltk/builtin/text_tag_bind.ml b/otherlibs/labltk/builtin/text_tag_bind.ml
new file mode 100644
index 0000000000..79b2e6cb3f
--- /dev/null
+++ b/otherlibs/labltk/builtin/text_tag_bind.ml
@@ -0,0 +1,22 @@
+let tag_bind widget :tag events:eventsequence :action =
+  tkEval [| cCAMLtoTKwidget widget;
+            TkToken "tag";
+            TkToken "bind";
+            cCAMLtoTKtextTag tag;
+      	    cCAMLtoTKeventSequence eventsequence;
+  begin match action with
+     `Remove -> TkToken ""
+  |  `Set (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+  |  `Setbreakable (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
+                 " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0"
+                )
+  |  `Extend (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+  end
+  |];
+  ()
diff --git a/otherlibs/labltk/builtin/text_tag_bind.mli b/otherlibs/labltk/builtin/text_tag_bind.mli
new file mode 100644
index 0000000000..c78a35e62d
--- /dev/null
+++ b/otherlibs/labltk/builtin/text_tag_bind.mli
@@ -0,0 +1,2 @@
+val tag_bind: text widget -> tag:textTag ->
+      events:(modifier list * xEvent) list -> action: bindAction -> unit 
diff --git a/otherlibs/labltk/builtin/winfo_contained.ml b/otherlibs/labltk/builtin/winfo_contained.ml
new file mode 100644
index 0000000000..76df1025fc
--- /dev/null
+++ b/otherlibs/labltk/builtin/winfo_contained.ml
@@ -0,0 +1,2 @@
+let contained :x :y w =
+  forget_type w = containing :x :y ()
diff --git a/otherlibs/labltk/builtin/winfo_contained.mli b/otherlibs/labltk/builtin/winfo_contained.mli
new file mode 100644
index 0000000000..0baf36ebdf
--- /dev/null
+++ b/otherlibs/labltk/builtin/winfo_contained.mli
@@ -0,0 +1,2 @@
+val contained : x:int -> y:int -> 'a widget -> bool
+(* [contained x y w] returns true if (x,y) is in w *)
diff --git a/otherlibs/labltk/compiler/.cvsignore b/otherlibs/labltk/compiler/.cvsignore
new file mode 100644
index 0000000000..178a0fab7c
--- /dev/null
+++ b/otherlibs/labltk/compiler/.cvsignore
@@ -0,0 +1,5 @@
+lexer.ml
+parser.output
+parser.ml
+parser.mli
+tkcompiler
diff --git a/otherlibs/labltk/compiler/.depend b/otherlibs/labltk/compiler/.depend
new file mode 100644
index 0000000000..16916fe66e
--- /dev/null
+++ b/otherlibs/labltk/compiler/.depend
@@ -0,0 +1,14 @@
+compile.cmo: tables.cmo 
+compile.cmx: tables.cmx 
+intf.cmo: compile.cmo tables.cmo 
+intf.cmx: compile.cmx tables.cmx 
+lexer.cmo: parser.cmi 
+lexer.cmx: parser.cmx 
+maincompile.cmo: compile.cmo intf.cmo lexer.cmo parser.cmi tables.cmo \
+    tsort.cmo 
+maincompile.cmx: compile.cmx intf.cmx lexer.cmx parser.cmx tables.cmx \
+    tsort.cmx 
+parser.cmo: tables.cmo parser.cmi 
+parser.cmx: tables.cmx parser.cmi 
+tables.cmo: tsort.cmo 
+tables.cmx: tsort.cmx 
diff --git a/otherlibs/labltk/compiler/Makefile b/otherlibs/labltk/compiler/Makefile
new file mode 100644
index 0000000000..7d826a1613
--- /dev/null
+++ b/otherlibs/labltk/compiler/Makefile
@@ -0,0 +1,36 @@
+include ../Makefile.config
+
+OBJS=tsort.cmo tables.cmo lexer.cmo parser.cmo  compile.cmo intf.cmo \
+     maincompile.cmo
+
+tkcompiler : $(OBJS)
+	$(LABLC) $(LINKFLAGS) -o tkcompiler $(OBJS)
+
+lexer.ml: lexer.mll
+	$(LABLLEX) lexer.mll
+
+parser.ml parser.mli: parser.mly
+	$(LABLYACC) -v parser.mly
+
+clean : 
+	rm -f *.cm*  parser.ml parser.mli lexer.ml tkcompiler parser.output
+
+scratch :
+	rm -f *.cm*  parser.ml parser.mli lexer.ml tkcompiler
+
+install: 
+	cp tkcompiler $(INSTALLDIR)
+
+.SUFFIXES :
+.SUFFIXES : .mli .ml .cmi .cmo .mlp
+
+.mli.cmi:
+	$(LABLCOMP) $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(LABLCOMP) $(COMPFLAGS) $<
+
+depend: parser.ml parser.mli lexer.ml
+	$(LABLDEP) *.mli *.ml > .depend
+
+include .depend
diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml
new file mode 100644
index 0000000000..dbc777da19
--- /dev/null
+++ b/otherlibs/labltk/compiler/compile.ml
@@ -0,0 +1,803 @@
+(* $Id$ *)
+
+open Tables
+
+(* CONFIGURE *)
+(* if you set it true, ImagePhoto and ImageBitmap will annoy you... *)
+let safetype = false 
+
+let lowercase s =
+  let r = String.create len:(String.length s) in
+  String.blit s pos:0 to:r to_pos:0 len:(String.length s);
+  for i = 0 to String.length s - 1 
+  do
+    let c = s.[i] in
+    if c >= 'A' & c <= 'Z' then r.[i] <- Char.chr(Char.code c + 32)
+  done;
+  r
+
+let labeloff :at l = match l with
+  "",t -> t
+| l ,t -> raise (Failure ("labeloff : " ^ l ^ " at " ^ at))
+
+let labelstring l = match l with
+  "" -> ""
+| _ -> l ^ ":" 
+
+let labelprint :w l = w (labelstring l)
+
+let small s =
+  let sout = ref "" in
+  for i=0 to String.length s - 1 do
+    let c =
+      if s.[i] >= 'A' && s.[i] <= 'Z' then 
+      	Char.chr(Char.code(s.[i]) - (Char.code 'A' - Char.code 'a'))
+      else s.[i]
+    in
+      sout := !sout ^ (String.make len:1 c)
+  done;
+  !sout
+
+let small_ident s =
+  let idents = ["to"; "raise"; "in"; "class"; "new"]
+  in
+  let s = small s in
+  if List.mem elt:s idents then (String.make len:1 s.[0])^s
+  else s
+
+let gettklabel fc = 
+  match fc.template with
+    ListArg( StringArg s :: _ ) ->
+      if (try s.[0] = '-' with _ -> false) then
+  	String.sub s pos:1 len:(String.length s - 1)
+      else
+  	if s = "" then small fc.ml_name else small s
+  | _ -> raise (Failure "gettklabel")
+
+let count elt:x l =
+  let count = ref 0 in
+  List.iter fun:(fun y -> if x = y then incr count) l;
+  !count
+
+let catenate_sep :sep =
+  function 
+    [] -> ""
+  | x::l -> List.fold_left fun:(fun :acc s' -> acc ^ sep ^ s') acc:x l
+
+(* Extract all types from a template *)
+let rec types_of_template = function
+    StringArg _ -> []
+  | TypeArg (l,t) -> [l,t]
+  | ListArg l -> List.flatten (List.map fun:types_of_template l)
+  | OptionalArgs (l,tl,_) -> 
+      begin
+      match List.flatten (List.map fun: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 return then
+      sub^"_"^sup^" list"
+    else 
+     begin
+       try 
+      	let typdef = Hashtbl.find types_table key:sup in
+        let fcl = List.assoc key:sub typdef.subtypes in
+        let tklabels = List.map fun:gettklabel fcl in
+	let l = List.map fcl fun:
+          begin fun fc ->
+	    "?" ^ begin let p = gettklabel fc in
+      	       	  if count elt:p tklabels > 1 then small fc.ml_name else p
+      	          end
+            ^ ":" ^ 
+      	    let l = types_of_template fc.template in
+      	    match l with
+	      [] -> "unit"
+            | [lt] -> ppMLtype (labeloff lt at:"ppMLtype")
+      	    | l ->
+                "(" ^ catenate_sep sep:"*" 
+                  (List.map l
+                     fun:(fun lt -> ppMLtype (labeloff lt at:"ppMLtype")))
+                ^ ")"
+          end in
+	catenate_sep sep:"   ->\n" l
+      with
+        Not_found -> Printf.eprintf "ppMLtype %s/%s\n" sup sub; exit (-1)
+     end
+  | List ty -> (ppMLtype ty) ^ " list"
+  | Product tyl -> catenate_sep sep:" * " (List.map fun:ppMLtype tyl)
+  | Record tyl -> 
+      catenate_sep sep:" * "
+	(List.map tyl fun:(fun (l,t) -> labelstring l ^ ppMLtype t))
+  | Subtype ("widget", sub) -> sub ^ " widget"
+  | UserDefined "widget" -> 
+      if any then "any widget" else 
+      	let c = String.make len:1 (Char.chr(Char.code 'a' + !counter)) 
+      	in 
+      	  incr counter;
+      	  "'" ^ c ^ " widget"
+  | UserDefined s -> 
+      (* a bit dirty hack for ImageBitmap and ImagePhoto *)
+     begin
+      try
+	let typdef = Hashtbl.find types_table key:s in
+	if typdef.variant then
+	  if return then try
+	    "[>" ^
+  	    catenate_sep sep:"|" 
+  	      (List.map typdef.constructors fun:
+  		begin
+  		  fun c ->
+  		    "`" ^ c.var_name ^ 
+  		    (match types_of_template c.template with
+  		       [] -> ""
+  		     | l ->  " " ^ ppMLtype (Product (List.map l
+			      fun:(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') -> s'^"_"^s
+  | Function (Product tyl) -> 
+      	raise (Failure "Function (Product tyl) ? ppMLtype")
+  | Function (Record tyl) -> 
+      	"(" ^ catenate_sep sep:" -> " 
+      	  (List.map tyl fun:(fun (l,t) -> labelstring l ^ ppMLtype t))
+      	^ " -> unit)"
+  | Function ty ->
+      	"(" ^ (ppMLtype ty) ^ " -> unit)"
+  | As (_, s) -> s
+  in
+    ppMLtype
+
+(* Produce a documentation version of a template *)
+let rec ppTemplate = function
+    StringArg s -> s
+  | TypeArg (l,t) -> "<" ^ ppMLtype t ^ ">"
+  | ListArg l -> "{" ^ catenate_sep sep:" " (List.map fun:ppTemplate l) ^ "}"
+  | OptionalArgs (l,tl,d) ->
+      "?" ^ l ^ "{" ^ catenate_sep sep:" " (List.map fun:ppTemplate tl)
+      ^ "}[<" ^ catenate_sep sep:" " (List.map fun:ppTemplate d) ^ ">]"
+
+let doc_of_template = function
+    ListArg l -> catenate_sep sep:" " (List.map fun: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
+                fun:(labeloff at:"write_constructor"))))
+   end;
+   w "\t\t(* 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 fun:
+	begin fun x ->
+	  w "\n\t| ";
+	  write_constructor :w x
+        end
+
+(* Write an ML variant *)
+let write_variant :w {ml_name = mlconstr; var_name = varname; template = t} =
+  w "`";
+  w varname;
+  begin match types_of_template t with
+    [] -> ()
+  | l ->    
+      w " ";
+      w (ppMLtype any:true def:true
+	   (Product (List.map l fun:(labeloff at:"write_variant"))))
+   end;
+   w "\t\t(* tk option: "; w (doc_of_template t); w " *)"
+
+let write_variants :w = function
+    [] -> fatal_error "empty variants"
+  | x::l ->
+      write_variant :w x;
+      List.iter l fun:
+      	begin fun x ->
+      	  w "\n  | ";
+      	  write_variant :w x
+        end
+
+(* Definition of a type *)	    
+let write_type intf:w impl:w' name def:typdef =
+(*  if typdef.subtypes = [] then (* If there is no subtypes *) 
+    begin
+    (* The type itself *)
+    (* Put markers for extraction *)
+    w "(* type *)\n";
+    w ("type "^name^" =\n\t");
+    write_constructors :w (sort_components typdef.constructors);
+    w "\n(* /type *)\n\n"
+    end
+  else
+*)
+    begin
+      if typdef.subtypes = [] then
+        begin
+          w "(* Variant type *)\n";
+          w ("type "^name^" = [\n    ");
+          write_variants :w (sort_components typdef.constructors);
+          w "\n]\n\n"
+        end
+      else
+        begin
+          (* Dynamic Subtyping *)
+          (* All the subtypes *)
+          List.iter typdef.subtypes fun:
+  	    begin fun (s,l) ->
+  	      w ("type "^s^"_"^name^" = [\n\t");
+  	      write_variants w:w (sort_components l);
+  	      w ("]\n\n")
+            end
+  	end
+    end
+
+(************************************************************)
+(* Converters                                               *)
+(************************************************************)
+
+let rec converterTKtoCAML argname as:ty =
+  match ty with
+   Int -> "int_of_string " ^ argname
+ | Float -> "float_of_string " ^ argname
+ | Bool -> "(match " ^ argname ^" with
+       	     \"1\" -> true
+           | \"0\" -> false
+           | s -> Pervasives.raise (Invalid_argument (\"cTKtoCAMLbool\" ^ s)))"
+ | Char -> "String.get "^argname ^" 0"
+ | String -> argname
+ | UserDefined s -> "cTKtoCAML"^s^" "^argname
+ | Subtype ("widget",s') ->
+     "(Obj.magic (cTKtoCAMLwidget "^argname^") : "^s'^" widget)"
+ | Subtype (s,s') -> "cTKtoCAML"^s'^"_"^s^" "^argname
+ | List ty ->
+    begin match type_parser_arity ty with
+      OneToken -> 
+      	 "(List.map (function x -> " ^ (converterTKtoCAML "x) " as:ty)
+         ^ argname ^ ")"
+    | MultipleToken ->
+      	 "iterate_converter (function x -> " ^
+              (converterTKtoCAML "x) " as:ty) ^ argname ^ ")"
+    end
+ | As (ty, _) -> converterTKtoCAML argname as:ty
+ | t -> (prerr_endline ("ERROR with "^argname^" "^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 fname of:ty =
+  match ty with
+    Unit -> "(function _ -> "^fname^" ())"
+  | As (ty, _) -> wrapper_code fname of:ty
+  | ty ->
+      "(function args ->\n\t\t" ^ 
+      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 fun:
+	    begin fun v (l,ty) ->
+	      match type_parser_arity ty with
+		OneToken ->
+		  "let ("^v^",args) = " ^
+                  converterTKtoCAML "(List.hd args)"  as:ty  ^
+                  ", List.tl args in\n\t\t"
+	      | MultipleToken ->
+		  "let ("^v^",args) = " ^
+		  converterTKtoCAML "args"  as:ty ^
+                  " in\n\t\t"
+	    end in
+          catenate_sep sep:"" readarg ^ fname ^ " " ^
+          catenate_sep sep:" " 
+      	    (List.map2 fun:(fun v (l,_) -> labelstring l^v) vnames tyl)
+
+	(* all other types are read in one operation *)
+	| List ty ->
+	    fname ^ "(" ^ converterTKtoCAML "args" as:ty ^ ")"
+	| String ->
+	    fname ^ "(" ^ converterTKtoCAML "(List.hd args)" as:ty ^ ")"
+	| ty ->
+	  begin match type_parser_arity ty with
+	    OneToken -> 
+      	      fname ^ "(" ^ converterTKtoCAML "(List.hd args)" as:ty ^ ")"
+	  | MultipleToken ->
+	      "let (v,_) = " ^ converterTKtoCAML "args" as:ty ^
+	      " in\n\t\t" ^ fname ^ " 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 pred:
+    begin fun c ->
+      match c.template with
+	ListArg [StringArg s] ->
+	  pp.zeroary <- (s,"`" ^ c.var_name):: 
+            pp.zeroary; true
+      | ListArg [TypeArg(_,Int)] | ListArg[TypeArg(_,Float)] -> 
+      	  if pp.intpar <> [] then false
+	  else (pp.intpar <- ["`" ^ c.var_name]; true)
+      | ListArg [TypeArg(_,String)] ->
+	  if pp.stringpar <> [] then false
+	  else (pp.stringpar <- ["`" ^ c.var_name]; true)
+      | _ -> false
+    end
+  then ParserPieces pp
+  else NoParser
+
+
+(* We can generate parsers only for simple types *)
+(* we should avoid multiple walks *)
+let 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 ("\tmatch n with\n");
+  	let first = ref true in
+  	List.iter pp.zeroary fun:
+  	  begin fun (tk,ml) -> 
+  	    if not !first then w "\t| " else w "\t";
+  	    first := false;
+  	    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
+  	if not !first then w "\t| " else w "\t";
+  	w final;
+  	w "\n\n"
+  in
+    begin
+      write :name consts:typdef.constructors;
+      List.iter typdef.subtypes fun: begin
+      	fun (subname,consts) -> write name:(subname^"_"^name) :consts
+      end
+    end
+
+(******************************)
+(* 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 as:ty =
+ match ty with
+    Int -> "TkToken (string_of_int " ^ argname ^ ")"
+ |  Float -> "TkToken (string_of_float " ^ argname ^ ")"
+ |  Bool -> "if "^argname^" then TkToken \"1\" else TkToken \"0\""
+ |  Char -> "TkToken (Char.escaped " ^ argname ^ ")"
+ |  String -> "TkToken " ^ argname
+ |  As (ty, _) -> converterCAMLtoTK :context_widget argname as:ty
+ |  UserDefined s -> 
+       let name = "cCAMLtoTK"^s^" " in
+       let args = argname in
+(*
+       let args = 
+       	   if is_subtyped s then  (* unconstraint subtype *)
+	     s^"_any_table "^args
+	   else args in
+*)
+       let args = 
+       	   if requires_widget_context s then
+ 	     context_widget^" "^args
+           else args in
+       name^args
+ |  Subtype ("widget",s') ->
+       let name = "cCAMLtoTKwidget" in
+       let args = "("^argname^" : "^s'^" widget)" in
+(*
+       let args = 
+       	   if requires_widget_context s then
+	     context_widget^" "^args
+           else args in
+*)
+       name^args
+ |  Subtype (s,s') ->
+       let name = "cCAMLtoTK"^s'^"_"^s^" " in
+       let args = if safetype then "("^argname^" : "^s'^"_"^s^")" else argname
+       in
+(*
+       let args = s^"_"^s'^"_table "^argname in
+*)
+       let args = 
+       	   if requires_widget_context s then
+	     context_widget^" "^args
+           else args in
+       name^args
+ | Function _ -> fatal_error "unexpected function type in converterCAMLtoTK"
+ | Unit       -> fatal_error "unexpected unit type in converterCAMLtoTK"
+ | Product _  -> fatal_error "unexpected product type in converterCAMLtoTK"
+ | Record _  -> fatal_error "unexpected product type in converterCAMLtoTK"
+ | List ty -> fatal_error "unexpected list 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)) ->
+      let typdef = Hashtbl.find key:sup types_table in
+      let classdef = List.assoc key:sub typdef.subtypes in
+      let lbl = gettklabel (List.hd classdef) in
+      catch_opts := (sub^"_"^sup, lbl);
+      newvar := newvar2;
+      "TkTokenList (List.map fun:(function x -> "
+      ^ converterCAMLtoTK :context_widget "x" as:ty ^ ") opts)" 
+  | TypeArg (l,List ty) ->
+      "TkTokenList (List.map fun:(function x -> "
+      ^ converterCAMLtoTK :context_widget "x" as:ty
+      ^ ") " ^ !newvar l ^ ")"
+  | TypeArg (l,Function tyarg) ->
+     "let id = register_callback " ^context_widget
+     ^ " callback: "^ wrapper_code (!newvar l) of:tyarg
+     ^ " in TkToken (\"camlcb \"^id)"
+  | TypeArg (l,ty) -> converterCAMLtoTK :context_widget (!newvar l) as:ty
+  | ListArg l ->
+      "TkQuote (TkTokenList ["
+      ^ catenate_sep sep:";\n\t" (List.map fun:coderec l) ^ "])" 
+  | OptionalArgs (l,tl,d) -> 
+      let nv = !newvar ("?"^l) in
+      optionvar := Some nv; (* Store *)
+      let argstr = catenate_sep sep:"; " (List.map fun:coderec tl) in 
+      let defstr = catenate_sep sep:"; " (List.map fun: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 ->
+	"[|" ^ catenate_sep sep:";\n\t" (List.map fun:coderec l) ^ "|]"
+    | _ -> "[|" ^ coderec template ^ "|]"
+    else
+    match template with
+      ListArg [x] -> coderec x
+    | ListArg l ->
+	"TkTokenList ["
+	^ catenate_sep sep:";\n\t" (List.map fun: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 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 (catenate_sep sep:", " (List.map fun:(labeloff at:"write_clause") l));
+      w ")";
+      warrow()
+  end;
+  w code
+
+
+(* The full converter *)	 
+let write_CAMLtoTK :w def:typdef ?safetype:st{=true} name =
+  let write_one name constrs =
+    w ("let cCAMLtoTK"^name);
+    let context_widget = 
+      if typdef.requires_widget_context then begin
+	w " w"; "w"
+        end
+      else
+	"dummy" in
+    if safetype && st then
+      w (" : " ^ name ^ " -> tkArgs ");
+    w(" = function\n\t");
+    write_clause :w :context_widget (List.hd constrs);
+    List.iter (List.tl constrs)
+      fun:(fun c -> w "\n\t| "; write_clause :w :context_widget c);
+    w "\n\n\n"
+  in
+    if typdef.subtypes == [] then
+      write_one name typdef.constructors
+    else
+      List.iter typdef.subtypes fun:begin
+	fun (subname,constrs) -> 
+	  write_one (subname^"_"^name) constrs
+      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 ->
+      w ("\tList.map fun: "^ converterTKtoCAML "(splitlist res)" as: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 "\tlet l = splitlist res in\n";
+      w ("\t  if List.length l <> " ^ string_of_int (List.length tyl) ^ "\n");
+      w ("\t  then Pervasives.raise (TkError (\"unexpected result: \" ^ res))");
+      w ("\t  else ");
+      List.iter2 rnames tyl fun:
+	begin fun r (l,ty) ->
+	  if l <> "" then raise (Failure "lables in return type!!!"); 
+	  w ("\tlet " ^ r ^ ", l = ");
+	  begin match type_parser_arity ty with
+	    OneToken ->
+	      w (converterTKtoCAML "(List.hd l)" as:ty); w (", List.tl l")
+	  | MultipleToken ->
+	      w (converterTKtoCAML "l" as:ty)
+	  end;
+	  w (" in\n")
+	end;
+      w (catenate_sep sep:"," rnames)
+  | String ->
+      w (converterTKtoCAML "res" as:String)
+  | As (ty, _) -> write_result_parsing :w ty
+  | ty ->
+      match type_parser_arity ty with
+	OneToken -> w (converterTKtoCAML "res" as:ty)
+      | MultipleToken -> w (converterTKtoCAML "(splitlist res)" as:ty)
+
+let 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
+  List.iter (lv@ov) fun:(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 List.iter uv fun:(fun x -> w " "; w x);
+    w " ->\n"
+  end else begin
+    List.iter uv fun:(fun x -> w " "; w x);
+    if (ov <> [] || lv = []) && uv = [] then w " ()";
+    w " =\n"
+  end;
+  begin match def.result with
+    Unit | As (Unit, _) ->  
+      w "tkEval ";  w code; w ";()";
+  | ty -> 
+      w "let res = tkEval "; w code ; w " in \n";
+      write_result_parsing :w ty;
+  end;
+  if co <> "" then w ")";
+  w "\n\n"
+
+let write_create :w clas =
+  (w  "let create :parent ?:name =\n" : unit);
+  w ("  "^ clas ^ "_options_optionals (fun options () ->\n");
+  w ("     let w = new_atom \"" ^ clas ^ "\" :parent ?:name in\n");
+  w  "     tkEval [|";
+  w ("TkToken \"" ^ clas ^ "\";\n");
+  w ("              TkToken (Widget.name w);\n");
+  w ("              TkTokenList (List.map fun:(cCAMLtoTK" ^ clas ^ "_options dummy) options) |];\n");
+  w ("      w)\n\n\n")
+
+(* builtin-code: the file (without suffix) is in .template... *)
+(* not efficient, but hell *)
+let write_external :w def =
+  match def.template with
+    StringArg fname ->
+      let ic = open_in_bin (fname ^ ".ml") in
+      	begin try
+	 while true do
+	   w (input_line ic);
+	   w "\n"
+	 done
+        with
+	 End_of_file -> close_in ic
+        end
+  | _ -> raise (Compiler_Error "invalid external definition")
+
+let write_catch_optionals :w clas def:typdef =
+  if typdef.subtypes = [] then 
+    (* begin Printf.eprintf "No subtypes\n";() end *) ()
+  else 
+    (* Printf.eprintf "Type constructors of %s\n" clas; *)
+  List.iter typdef.subtypes fun:
+  begin fun (subclass, classdefs) ->
+(*
+      Printf.eprintf "Subclass %s" subclass;
+      List.iter (fun fc -> 
+  	Printf.eprintf "  %s\n" fc.ml_name) classdefs;
+*)
+    w  ("let " ^ subclass ^"_"^ clas ^ "_optionals f = fun\n");
+    let tklabels = List.map fun:gettklabel classdefs in
+    let l = 
+      List.map classdefs fun:
+      begin fun fc ->
+	List.length (types_of_template fc.template),
+	types_of_template fc.template,
+	(* used as names of variants *)
+	fc.var_name,
+	begin let p = gettklabel fc in
+	  if count elt:p tklabels > 1 then small fc.ml_name else p
+	end,
+	small_ident fc.ml_name (* used as labels *)
+      end in
+    let p = 
+      List.map l fun:
+      begin fun (_,_,_,s,si) ->
+      	if s = si then "  ?:" ^ s 
+      	else "  ?" ^ s ^ ":" ^ si
+      end in
+    let v =
+      List.map l fun:
+      begin fun (i,t,c,s,si) -> 
+      	let vars =
+	  if i = 0 then "()" else
+      	  if i = 1 then "x" 
+	  else 
+      	  let s = ref [] in
+      	  for i=1 to i do
+      	    s := !s @ ["x" ^ string_of_int i]
+	  done;
+	  "(" ^ catenate_sep sep:"," !s ^ ")"
+	in
+	let apvars = 
+	  if i = 0 then "" 
+	  (* VERY VERY QUICK HACK FOR 'a widget -> any widget *)
+	  else if i = 1 && vars = "x" && t = ["",UserDefined "widget"] then
+	  "(forget_type x)"
+	  else vars
+	in  
+	"(maycons (fun " ^ vars ^ " -> " ^ "`" ^ c ^ " " ^ apvars ^ ") " ^ si
+      end in
+    w (catenate_sep sep:"\n" p);
+    w " ->\n";
+    w "    f ";
+    w (catenate_sep sep:"\n      " v);
+    w "\n       []";
+    w (String.make len:(List.length v) ')');
+    w "\n\n"
+  end
diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml
new file mode 100644
index 0000000000..6ecb84ae27
--- /dev/null
+++ b/otherlibs/labltk/compiler/intf.ml
@@ -0,0 +1,83 @@
+(* $Id$ *)
+
+(* Write .mli for widgets *)
+
+open Tables
+open Compile
+
+let write_create_p :w wname =
+  w "val create :\n  parent:'a widget ->\n  ?name:string ->\n";
+  begin
+    try 
+      let option = Hashtbl.find types_table key:"options" in
+      let classdefs = List.assoc key:wname option.subtypes in
+      let tklabels = List.map fun:gettklabel classdefs in
+      let l = List.map classdefs fun:
+      	begin fun fc ->
+     	  begin let p = gettklabel fc in
+      	    if count elt:p tklabels > 1 then small fc.ml_name else p
+      	  end, fc.template
+	end in
+      w (catenate_sep sep:" ->\n" 
+      	 (List.map l fun:
+	  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 fun:(labeloff at:"write_create_p") l)))
+	  end))
+    with Not_found -> fatal_error "in write_create_p"
+  end;
+  w (" ->\n  unit -> "^wname^" widget\n");
+  w "             (* [create p options ?name] creates a new widget with\n";
+  w "                parent p and new patch component name.\n";
+  w "                Options are restricted to the widget class subset,\n";
+  w "                and checked dynamically. *)\n"
+
+(* Unsafe: write special comment *)
+let 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
+  List.iter (ls @ os @ us)
+    fun:(fun (l,t) -> labelprint :w l; w (ppMLtype t :counter); w " -> ");
+  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\n"
+  else w "\n(* /unsafe *)\n\n"
+
+let write_external_type :w def =
+  match def.template with
+    StringArg fname ->
+      let ic = open_in_bin (fname ^ ".mli") in
+      if not def.safe then w "(* unsafe *)\n";
+      begin try
+	while true do
+	  w (input_line ic);
+	  w "\n"
+	done
+      with End_of_file -> 
+      	close_in ic;
+	if def.safe then w "\n\n"
+	else w "\n(* /unsafe *)\n\n"
+      end
+  | _ -> raise (Compiler_Error "invalid external definition")
diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll
new file mode 100644
index 0000000000..065edd3a4f
--- /dev/null
+++ b/otherlibs/labltk/compiler/lexer.mll
@@ -0,0 +1,141 @@
+(* $Id$ *)
+
+{
+open Lexing
+open Parser
+
+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
+  fun:(fun (str,tok) -> Hashtbl.add keyword_table key:str data: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 len: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 len:(String.length (!string_buff) * 2) in
+      String.blit (!string_buff) pos:0 to:new_buff to_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 pos:i) - 48) +
+               10 * (Char.code(Lexing.lexeme_char lexbuf pos:(i+1)) - 48) +
+                    (Char.code(Lexing.lexeme_char lexbuf pos:(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 key: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}
+  | "#" { comment 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 pos: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 pos:0);
+        string lexbuf }
+  | _
+      { store_string_char(Lexing.lexeme_char lexbuf pos:0);
+        string lexbuf }
+
+and comment = parse
+   '\010' { incr current_line }
+ | eof  { () }
+ | _ { comment lexbuf }
+
diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml
new file mode 100644
index 0000000000..aa9412933e
--- /dev/null
+++ b/otherlibs/labltk/compiler/maincompile.ml
@@ -0,0 +1,229 @@
+(* $Id$ *)
+
+open Tables
+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 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 ": "
+
+
+let parse_file filename =
+  let ic = open_in_bin filename in
+  try
+    let lexbuf = Lexing.from_channel ic in
+      while true do
+       Parser.entry Lexer.main lexbuf
+      done
+  with
+    Parsing.Parse_error ->
+      close_in ic;
+      prerr_error_header();
+      prerr_string "Syntax error \n";
+      exit 1
+  | Lexer.Lexical_error s ->
+      close_in ic;
+      prerr_error_header();
+      prerr_string "Lexical error (";
+      prerr_string s;
+      prerr_string ")\n";
+      exit 1
+  | Duplicate_Definition (s,s') ->
+      close_in ic;
+      prerr_error_header();
+      prerr_string s; prerr_string " "; prerr_string s';
+      prerr_string " is defined twice.\n";
+      exit 1
+  | Compiler_Error s ->
+      close_in ic;
+      prerr_error_header();
+      prerr_string "Internal error: "; prerr_string s; prerr_string "\n";
+      prerr_string "Please report bug\n";
+      exit 1
+  | End_of_file ->
+      close_in ic
+
+(* hack to provoke production of cCAMLtoTKoptions_constrs *)
+let option_hack oc =
+  try
+   let typdef = Hashtbl.find types_table key:"options" in
+   let hack =
+   { parser_arity = OneToken;
+     constructors = 
+      List.map typdef.constructors fun:
+      begin fun c -> 
+      { component = Constructor;
+        ml_name = 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;
+     subtypes = [];
+     requires_widget_context = false; 
+     variant = false }
+   in
+   write_CAMLtoTK w:(output_string to:oc) "options_constrs" def:hack safetype: false
+  with Not_found -> ()
+
+let compile () = 
+verbose_endline "Creating tkgen.ml ...";
+  let oc = open_out_bin "lib/tkgen.ml" in
+  let oc' = open_out_bin "lib/tkigen.ml" in
+  let oc'' = open_out_bin "lib/tkfgen.ml" in
+  let sorted_types = Tsort.sort types_order in
+verbose_endline "  writing types ...";
+  List.iter sorted_types fun:
+  begin fun typname ->
+verbose_string ("    "^typname^" ");
+  try
+    let typdef = Hashtbl.find types_table key:typname in
+verbose_string "type ";
+    write_type intf:(output_string to:oc)
+               impl:(output_string to:oc')
+               typname def:typdef;
+verbose_string "C2T ";
+    write_CAMLtoTK w:(output_string to:oc') typname def:typdef;
+verbose_string "T2C ";
+    if List.mem elt:typname !types_returned then
+    write_TKtoCAML w:(output_string to:oc') typname def:typdef;
+verbose_string "CO ";
+    write_catch_optionals w:(output_string to:oc') typname def:typdef;
+verbose_endline "."
+  with Not_found -> 
+    if not (List.mem_assoc key:typname !types_external) then
+    begin
+      verbose_string "Type ";
+      verbose_string typname;
+      verbose_string " is undeclared external or undefined\n"
+    end
+    else verbose_endline "."
+  end;
+  option_hack oc';
+verbose_endline "  writing functions ...";
+  List.iter fun:(write_function w:(output_string to: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 "lib/tkgen.mli" in
+  List.iter (sort_components !function_table)
+    fun:(write_function_type w:(output_string to:oc));
+  close_out oc;
+verbose_endline "Creating other ml, mli ...";
+  Hashtbl.iter module_table fun:
+  begin fun key:wname data:wdef ->
+verbose_endline ("  "^wname);
+    let modname = wname in
+    let oc = open_out_bin ("lib/" ^ modname ^ ".ml") 
+    and oc' = open_out_bin ("lib/" ^ modname ^ ".mli") in 
+    begin match wdef.module_type with
+      Widget -> output_string to:oc' ("(* The "^wname^" widget *)\n")
+    | Family -> output_string to:oc' ("(* The "^wname^" commands  *)\n")
+    end;
+    output_string to:oc "open Protocol\n";
+    List.iter fun:(fun s -> output_string s to:oc; output_string s to:oc')
+    [ "open Tk\n";
+      "open Tkintf\n";
+      "open Widget\n";
+      "open Textvariable\n"
+    ];
+    begin match wdef.module_type with
+      Widget ->
+	write_create w:(output_string to:oc) wname;
+	write_create_p w:(output_string to:oc') wname
+    | Family -> ()
+    end;
+    List.iter fun:(write_function w:(output_string to:oc)) 
+	  (sort_components wdef.commands);
+    List.iter fun:(write_function_type w:(output_string to:oc'))
+      	  (sort_components wdef.commands);
+    List.iter fun:(write_external w:(output_string to:oc)) 
+      	   (sort_components wdef.externals);
+    List.iter fun:(write_external_type w:(output_string to:oc'))
+      	   (sort_components wdef.externals);
+    close_out oc;
+    close_out oc'
+  end;
+  (* write the module list for the Makefile *)
+  (* and hack to death until it works *)
+  let oc = open_out_bin "lib/modules" in
+    output_string to:oc "WIDGETOBJS=";
+    Hashtbl.iter module_table
+    fun:(fun key:name data:_ ->
+	 output_string to:oc name;
+	 output_string to:oc ".cmo ");
+    output_string to:oc "\n";
+    Hashtbl.iter module_table
+    fun:(fun key:name data:_ ->
+	 output_string to:oc name;
+	 output_string to:oc ".ml ");
+    output_string to:oc ": tkgen.ml\n\n";
+    Hashtbl.iter module_table fun:
+      begin fun key:name data:_ ->
+	output_string to:oc name;
+	output_string to:oc ".cmo : ";
+	output_string to:oc name;
+	output_string to:oc ".ml\n";
+	output_string to:oc name;
+	output_string to:oc ".cmi : ";
+	output_string to:oc name;
+	output_string to:oc ".mli\n"
+      end;
+    close_out oc
+
+let main () =
+  Arg.parse
+    keywords:[ "-verbose",  Arg.Unit (fun () -> flag_verbose := true),
+	       "Make output verbose" ]
+    others:(fun filename -> input_name := filename)
+    errmsg:"Usage: tkcompiler <source file>" ;
+  try
+verbose_string "Parsing... ";
+    parse_file !input_name;
+verbose_string "Compiling... ";
+    compile ();
+verbose_string "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
new file mode 100644
index 0000000000..4920c5c62f
--- /dev/null
+++ b/otherlibs/labltk/compiler/parser.mly
@@ -0,0 +1,312 @@
+/* $Id$ */
+
+%{
+
+open Tables
+
+let lowercase s =
+  let r = String.create len:(String.length s) in
+  String.blit s pos:0 to:r to_pos:0 len:(String.length s);
+  let c = s.[0] in
+  if c >= 'A' & c <= 'Z' then r.[0] <- Char.chr(Char.code c + 32);
+  r
+
+%}
+
+/* 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 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 { lowercase $1 }
+ | WIDGET { "widget" }
+;
+
+/* Atomic types */
+Type0 :
+    TYINT
+      { Int }
+  | TYFLOAT
+      { Float }
+  | TYBOOL
+      { Bool }
+  | TYCHAR
+      { Char }
+  | TYSTRING
+      { String }
+  | TypeName
+      { UserDefined $1 }
+;
+
+/* with subtypes */
+Type1 : 
+    Type0
+      { $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) }
+;
+
+/* with list constructors */
+Type2 :
+    Type1
+     { $1 }
+  | Type1 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 (lowercase $2) $4 }
+| EOF
+    { raise End_of_file }
+;
diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml
new file mode 100644
index 0000000000..4a606014d4
--- /dev/null
+++ b/otherlibs/labltk/compiler/tables.ml
@@ -0,0 +1,414 @@
+(* $Id$ *)
+
+(* 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; (* may be no longer useful *)
+  var_name : string;
+  template : template;
+  result   : mltype;
+  safe : bool
+  }
+
+let sort_components =
+  Sort.list order:(fun c1 c2 ->  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 key:typname data:typdef;
+    typdef
+
+
+(* Assume that types not yet defined are not subtyped *)
+(* Widget is builtin and implicitly subtyped *)
+let is_subtyped s =
+  s = "widget" or
+  try  
+    let typdef = Hashtbl.find types_table key:s in
+      typdef.subtypes <> []
+  with
+    Not_found -> false
+
+let requires_widget_context s = 
+  try  
+    (Hashtbl.find types_table key:s).requires_widget_context
+  with
+    Not_found -> false
+
+let declared_type_parser_arity s = 
+  try  
+    (Hashtbl.find types_table key:s).parser_arity
+  with
+    Not_found -> 
+      try List.assoc key: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 fun:enter_argtype tyl
+  | Record tyl -> List.iter tyl fun:(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 fun:enter_template_types l
+   | OptionalArgs (_,tl,_) -> List.iter fun: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 fun:(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 fun:(add_template_dependancies s) l
+   | OptionalArgs (_,tl,_) -> List.iter fun:(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 pred:has_callback l
+   | OptionalArgs (_,tl,_) -> List.exists pred:has_callback tl
+
+(*** Returned types ***)
+let really_add ty = 
+  if List.mem elt: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 fun:add_return_type tyl
+  | Record tyl -> List.iter tyl fun:(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 =
+  try
+      Hashtbl.find types_table key:typname;
+      raise (Duplicate_Definition ("type", typname))
+  with Not_found ->
+    let typdef = new_type typname arity in
+    if variant then typdef.variant <- true;  
+    List.iter constructors fun:
+      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 or
+                  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 key:typ
+    with Not_found -> new_type typ arity
+  in
+    if List.mem_assoc key:subtyp typdef.subtypes
+    then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp))
+    else begin
+      let real_constructors = 
+      	List.map constructors fun:
+	  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 or
+      	       	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 , Sort.list real_constructors
+	              order:(fun c1 c2 -> 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 key:"options"
+    with 
+      Not_found -> raise (Invalid_implicit_constructor optname)
+  in find_constructor optname optiontyp.constructors
+  
+(* Sort components by type *)
+let rec add_sort acc: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 acc:rest obj)
+
+let separate_components =  List.fold_left fun:add_sort acc:[]
+
+let enter_widget name components =
+  try 
+    Hashtbl.find module_table key:name;
+    raise (Duplicate_Definition ("widget/module", name))
+  with Not_found ->
+  let sorted_components = separate_components components in
+  List.iter sorted_components fun:
+    begin function 
+      Constructor, l ->
+	enter_subtype "options" MultipleToken 
+      	  name (List.map fun:(fun c -> Full c) l)
+    | Command, l -> 
+	List.iter fun:enter_component_types l
+    | External, _ -> ()
+    end;
+  let commands = 
+      try List.assoc key:Command sorted_components
+      with Not_found -> [] 
+  and externals = 
+      try List.assoc key:External sorted_components
+      with Not_found -> []
+  in
+  Hashtbl.add module_table key:name 
+    data:{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 = 
+  try 
+    Hashtbl.find module_table key:name;
+    raise (Duplicate_Definition ("widget/module", name))
+  with Not_found ->
+  let sorted_components = separate_components components in
+  List.iter sorted_components fun:
+    begin function 
+      Constructor, l -> fatal_error "unexpected Constructor"
+    | Command, l -> List.iter fun:enter_component_types l
+    | External, _ -> ()
+    end;
+  let commands = 
+      try List.assoc key:Command sorted_components
+      with Not_found -> [] 
+  and externals = 
+      try List.assoc key:External sorted_components
+      with Not_found -> []
+  in
+    Hashtbl.add module_table key:name 
+      data:{module_type = Family; commands = commands; externals = externals}
+
diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml
new file mode 100644
index 0000000000..b820289245
--- /dev/null
+++ b/otherlibs/labltk/compiler/tsort.ml
@@ -0,0 +1,72 @@
+(* $Id$ *)
+
+(* 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 =
+  find_entry order e;
+  ()
+
+let sort order =
+    let q = Queue.create () 
+    and result = ref [] in
+    List.iter !order
+      fun:(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 fun:
+	    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
+           fun:(fun node -> if node.pred_count <> 0
+			      then raise Cyclic)
+    end;
+    !result
+			 
+    
diff --git a/otherlibs/labltk/configure b/otherlibs/labltk/configure
new file mode 100755
index 0000000000..fe8e18ef15
--- /dev/null
+++ b/otherlibs/labltk/configure
@@ -0,0 +1,2482 @@
+#! /bin/sh
+
+# Guess values for system-dependent variables and create Makefiles.
+# Generated automatically using autoconf version 2.13 
+# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
+#
+# This configure script is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
+
+# Defaults:
+ac_help=
+ac_default_prefix=/usr/local
+# Any additions from configure.in:
+ac_help="$ac_help
+    --with-config=Site specific locations of various software. Check the INSTALL instructions"
+ac_help="$ac_help
+  --with-x                use the X Window System"
+
+# Initialize some variables set by options.
+# The variables have the same names as the options, with
+# dashes changed to underlines.
+build=NONE
+cache_file=./config.cache
+exec_prefix=NONE
+host=NONE
+no_create=
+nonopt=NONE
+no_recursion=
+prefix=NONE
+program_prefix=NONE
+program_suffix=NONE
+program_transform_name=s,x,x,
+silent=
+site=
+srcdir=
+target=NONE
+verbose=
+x_includes=NONE
+x_libraries=NONE
+bindir='${exec_prefix}/bin'
+sbindir='${exec_prefix}/sbin'
+libexecdir='${exec_prefix}/libexec'
+datadir='${prefix}/share'
+sysconfdir='${prefix}/etc'
+sharedstatedir='${prefix}/com'
+localstatedir='${prefix}/var'
+libdir='${exec_prefix}/lib'
+includedir='${prefix}/include'
+oldincludedir='/usr/include'
+infodir='${prefix}/info'
+mandir='${prefix}/man'
+
+# Initialize some other variables.
+subdirs=
+MFLAGS= MAKEFLAGS=
+SHELL=${CONFIG_SHELL-/bin/sh}
+# Maximum number of lines to put in a shell here document.
+ac_max_here_lines=12
+
+ac_prev=
+for ac_option
+do
+
+  # If the previous option needs an argument, assign it.
+  if test -n "$ac_prev"; then
+    eval "$ac_prev=\$ac_option"
+    ac_prev=
+    continue
+  fi
+
+  case "$ac_option" in
+  -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;;
+  *) ac_optarg= ;;
+  esac
+
+  # Accept the important Cygnus configure options, so we can diagnose typos.
+
+  case "$ac_option" in
+
+  -bindir | --bindir | --bindi | --bind | --bin | --bi)
+    ac_prev=bindir ;;
+  -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
+    bindir="$ac_optarg" ;;
+
+  -build | --build | --buil | --bui | --bu)
+    ac_prev=build ;;
+  -build=* | --build=* | --buil=* | --bui=* | --bu=*)
+    build="$ac_optarg" ;;
+
+  -cache-file | --cache-file | --cache-fil | --cache-fi \
+  | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
+    ac_prev=cache_file ;;
+  -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
+  | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
+    cache_file="$ac_optarg" ;;
+
+  -datadir | --datadir | --datadi | --datad | --data | --dat | --da)
+    ac_prev=datadir ;;
+  -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \
+  | --da=*)
+    datadir="$ac_optarg" ;;
+
+  -disable-* | --disable-*)
+    ac_feature=`echo $ac_option|sed -e 's/-*disable-//'`
+    # Reject names that are not valid shell variable names.
+    if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then
+      { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
+    fi
+    ac_feature=`echo $ac_feature| sed 's/-/_/g'`
+    eval "enable_${ac_feature}=no" ;;
+
+  -enable-* | --enable-*)
+    ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'`
+    # Reject names that are not valid shell variable names.
+    if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then
+      { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
+    fi
+    ac_feature=`echo $ac_feature| sed 's/-/_/g'`
+    case "$ac_option" in
+      *=*) ;;
+      *) ac_optarg=yes ;;
+    esac
+    eval "enable_${ac_feature}='$ac_optarg'" ;;
+
+  -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
+  | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
+  | --exec | --exe | --ex)
+    ac_prev=exec_prefix ;;
+  -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
+  | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
+  | --exec=* | --exe=* | --ex=*)
+    exec_prefix="$ac_optarg" ;;
+
+  -gas | --gas | --ga | --g)
+    # Obsolete; use --with-gas.
+    with_gas=yes ;;
+
+  -help | --help | --hel | --he)
+    # Omit some internal or obsolete options to make the list less imposing.
+    # This message is too long to be a string in the A/UX 3.1 sh.
+    cat << EOF
+Usage: configure [options] [host]
+Options: [defaults in brackets after descriptions]
+Configuration:
+  --cache-file=FILE       cache test results in FILE
+  --help                  print this message
+  --no-create             do not create output files
+  --quiet, --silent       do not print \`checking...' messages
+  --version               print the version of autoconf that created configure
+Directory and file names:
+  --prefix=PREFIX         install architecture-independent files in PREFIX
+                          [$ac_default_prefix]
+  --exec-prefix=EPREFIX   install architecture-dependent files in EPREFIX
+                          [same as prefix]
+  --bindir=DIR            user executables in DIR [EPREFIX/bin]
+  --sbindir=DIR           system admin executables in DIR [EPREFIX/sbin]
+  --libexecdir=DIR        program executables in DIR [EPREFIX/libexec]
+  --datadir=DIR           read-only architecture-independent data in DIR
+                          [PREFIX/share]
+  --sysconfdir=DIR        read-only single-machine data in DIR [PREFIX/etc]
+  --sharedstatedir=DIR    modifiable architecture-independent data in DIR
+                          [PREFIX/com]
+  --localstatedir=DIR     modifiable single-machine data in DIR [PREFIX/var]
+  --libdir=DIR            object code libraries in DIR [EPREFIX/lib]
+  --includedir=DIR        C header files in DIR [PREFIX/include]
+  --oldincludedir=DIR     C header files for non-gcc in DIR [/usr/include]
+  --infodir=DIR           info documentation in DIR [PREFIX/info]
+  --mandir=DIR            man documentation in DIR [PREFIX/man]
+  --srcdir=DIR            find the sources in DIR [configure dir or ..]
+  --program-prefix=PREFIX prepend PREFIX to installed program names
+  --program-suffix=SUFFIX append SUFFIX to installed program names
+  --program-transform-name=PROGRAM
+                          run sed PROGRAM on installed program names
+EOF
+    cat << EOF
+Host type:
+  --build=BUILD           configure for building on BUILD [BUILD=HOST]
+  --host=HOST             configure for HOST [guessed]
+  --target=TARGET         configure for TARGET [TARGET=HOST]
+Features and packages:
+  --disable-FEATURE       do not include FEATURE (same as --enable-FEATURE=no)
+  --enable-FEATURE[=ARG]  include FEATURE [ARG=yes]
+  --with-PACKAGE[=ARG]    use PACKAGE [ARG=yes]
+  --without-PACKAGE       do not use PACKAGE (same as --with-PACKAGE=no)
+  --x-includes=DIR        X include files are in DIR
+  --x-libraries=DIR       X library files are in DIR
+EOF
+    if test -n "$ac_help"; then
+      echo "--enable and --with options recognized:$ac_help"
+    fi
+    exit 0 ;;
+
+  -host | --host | --hos | --ho)
+    ac_prev=host ;;
+  -host=* | --host=* | --hos=* | --ho=*)
+    host="$ac_optarg" ;;
+
+  -includedir | --includedir | --includedi | --included | --include \
+  | --includ | --inclu | --incl | --inc)
+    ac_prev=includedir ;;
+  -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
+  | --includ=* | --inclu=* | --incl=* | --inc=*)
+    includedir="$ac_optarg" ;;
+
+  -infodir | --infodir | --infodi | --infod | --info | --inf)
+    ac_prev=infodir ;;
+  -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
+    infodir="$ac_optarg" ;;
+
+  -libdir | --libdir | --libdi | --libd)
+    ac_prev=libdir ;;
+  -libdir=* | --libdir=* | --libdi=* | --libd=*)
+    libdir="$ac_optarg" ;;
+
+  -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
+  | --libexe | --libex | --libe)
+    ac_prev=libexecdir ;;
+  -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
+  | --libexe=* | --libex=* | --libe=*)
+    libexecdir="$ac_optarg" ;;
+
+  -localstatedir | --localstatedir | --localstatedi | --localstated \
+  | --localstate | --localstat | --localsta | --localst \
+  | --locals | --local | --loca | --loc | --lo)
+    ac_prev=localstatedir ;;
+  -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
+  | --localstate=* | --localstat=* | --localsta=* | --localst=* \
+  | --locals=* | --local=* | --loca=* | --loc=* | --lo=*)
+    localstatedir="$ac_optarg" ;;
+
+  -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
+    ac_prev=mandir ;;
+  -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
+    mandir="$ac_optarg" ;;
+
+  -nfp | --nfp | --nf)
+    # Obsolete; use --without-fp.
+    with_fp=no ;;
+
+  -no-create | --no-create | --no-creat | --no-crea | --no-cre \
+  | --no-cr | --no-c)
+    no_create=yes ;;
+
+  -no-recursion | --no-recursion | --no-recursio | --no-recursi \
+  | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
+    no_recursion=yes ;;
+
+  -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
+  | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
+  | --oldin | --oldi | --old | --ol | --o)
+    ac_prev=oldincludedir ;;
+  -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
+  | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
+  | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
+    oldincludedir="$ac_optarg" ;;
+
+  -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
+    ac_prev=prefix ;;
+  -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
+    prefix="$ac_optarg" ;;
+
+  -program-prefix | --program-prefix | --program-prefi | --program-pref \
+  | --program-pre | --program-pr | --program-p)
+    ac_prev=program_prefix ;;
+  -program-prefix=* | --program-prefix=* | --program-prefi=* \
+  | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
+    program_prefix="$ac_optarg" ;;
+
+  -program-suffix | --program-suffix | --program-suffi | --program-suff \
+  | --program-suf | --program-su | --program-s)
+    ac_prev=program_suffix ;;
+  -program-suffix=* | --program-suffix=* | --program-suffi=* \
+  | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
+    program_suffix="$ac_optarg" ;;
+
+  -program-transform-name | --program-transform-name \
+  | --program-transform-nam | --program-transform-na \
+  | --program-transform-n | --program-transform- \
+  | --program-transform | --program-transfor \
+  | --program-transfo | --program-transf \
+  | --program-trans | --program-tran \
+  | --progr-tra | --program-tr | --program-t)
+    ac_prev=program_transform_name ;;
+  -program-transform-name=* | --program-transform-name=* \
+  | --program-transform-nam=* | --program-transform-na=* \
+  | --program-transform-n=* | --program-transform-=* \
+  | --program-transform=* | --program-transfor=* \
+  | --program-transfo=* | --program-transf=* \
+  | --program-trans=* | --program-tran=* \
+  | --progr-tra=* | --program-tr=* | --program-t=*)
+    program_transform_name="$ac_optarg" ;;
+
+  -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+  | -silent | --silent | --silen | --sile | --sil)
+    silent=yes ;;
+
+  -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
+    ac_prev=sbindir ;;
+  -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
+  | --sbi=* | --sb=*)
+    sbindir="$ac_optarg" ;;
+
+  -sharedstatedir | --sharedstatedir | --sharedstatedi \
+  | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
+  | --sharedst | --shareds | --shared | --share | --shar \
+  | --sha | --sh)
+    ac_prev=sharedstatedir ;;
+  -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
+  | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
+  | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
+  | --sha=* | --sh=*)
+    sharedstatedir="$ac_optarg" ;;
+
+  -site | --site | --sit)
+    ac_prev=site ;;
+  -site=* | --site=* | --sit=*)
+    site="$ac_optarg" ;;
+
+  -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
+    ac_prev=srcdir ;;
+  -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
+    srcdir="$ac_optarg" ;;
+
+  -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
+  | --syscon | --sysco | --sysc | --sys | --sy)
+    ac_prev=sysconfdir ;;
+  -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
+  | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
+    sysconfdir="$ac_optarg" ;;
+
+  -target | --target | --targe | --targ | --tar | --ta | --t)
+    ac_prev=target ;;
+  -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
+    target="$ac_optarg" ;;
+
+  -v | -verbose | --verbose | --verbos | --verbo | --verb)
+    verbose=yes ;;
+
+  -version | --version | --versio | --versi | --vers)
+    echo "configure generated by autoconf version 2.13"
+    exit 0 ;;
+
+  -with-* | --with-*)
+    ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'`
+    # Reject names that are not valid shell variable names.
+    if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then
+      { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
+    fi
+    ac_package=`echo $ac_package| sed 's/-/_/g'`
+    case "$ac_option" in
+      *=*) ;;
+      *) ac_optarg=yes ;;
+    esac
+    eval "with_${ac_package}='$ac_optarg'" ;;
+
+  -without-* | --without-*)
+    ac_package=`echo $ac_option|sed -e 's/-*without-//'`
+    # Reject names that are not valid shell variable names.
+    if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then
+      { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
+    fi
+    ac_package=`echo $ac_package| sed 's/-/_/g'`
+    eval "with_${ac_package}=no" ;;
+
+  --x)
+    # Obsolete; use --with-x.
+    with_x=yes ;;
+
+  -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
+  | --x-incl | --x-inc | --x-in | --x-i)
+    ac_prev=x_includes ;;
+  -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
+  | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
+    x_includes="$ac_optarg" ;;
+
+  -x-libraries | --x-libraries | --x-librarie | --x-librari \
+  | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
+    ac_prev=x_libraries ;;
+  -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
+  | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
+    x_libraries="$ac_optarg" ;;
+
+  -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; }
+    ;;
+
+  *)
+    if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then
+      echo "configure: warning: $ac_option: invalid host type" 1>&2
+    fi
+    if test "x$nonopt" != xNONE; then
+      { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; }
+    fi
+    nonopt="$ac_option"
+    ;;
+
+  esac
+done
+
+if test -n "$ac_prev"; then
+  { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; }
+fi
+
+trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
+
+# File descriptor usage:
+# 0 standard input
+# 1 file creation
+# 2 errors and warnings
+# 3 some systems may open it to /dev/tty
+# 4 used on the Kubota Titan
+# 6 checking for... messages and results
+# 5 compiler messages saved in config.log
+if test "$silent" = yes; then
+  exec 6>/dev/null
+else
+  exec 6>&1
+fi
+exec 5>./config.log
+
+echo "\
+This file contains any messages produced by compilers while
+running configure, to aid debugging if configure makes a mistake.
+" 1>&5
+
+# Strip out --no-create and --no-recursion so they do not pile up.
+# Also quote any args containing shell metacharacters.
+ac_configure_args=
+for ac_arg
+do
+  case "$ac_arg" in
+  -no-create | --no-create | --no-creat | --no-crea | --no-cre \
+  | --no-cr | --no-c) ;;
+  -no-recursion | --no-recursion | --no-recursio | --no-recursi \
+  | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;;
+  *" "*|*"	"*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*)
+  ac_configure_args="$ac_configure_args '$ac_arg'" ;;
+  *) ac_configure_args="$ac_configure_args $ac_arg" ;;
+  esac
+done
+
+# NLS nuisances.
+# Only set these to C if already set.  These must not be set unconditionally
+# because not all systems understand e.g. LANG=C (notably SCO).
+# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'!
+# Non-C LC_CTYPE values break the ctype check.
+if test "${LANG+set}"   = set; then LANG=C;   export LANG;   fi
+if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
+if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi
+if test "${LC_CTYPE+set}"    = set; then LC_CTYPE=C;    export LC_CTYPE;    fi
+
+# confdefs.h avoids OS command line length limits that DEFS can exceed.
+rm -rf conftest* confdefs.h
+# AIX cpp loses on an empty file, so make sure it contains at least a newline.
+echo > confdefs.h
+
+# A filename unique to this package, relative to the directory that
+# configure is in, which we can look for to find out if srcdir is correct.
+ac_unique_file=Widgets.src
+
+# Find the source files, if location was not specified.
+if test -z "$srcdir"; then
+  ac_srcdir_defaulted=yes
+  # Try the directory containing this script, then its parent.
+  ac_prog=$0
+  ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'`
+  test "x$ac_confdir" = "x$ac_prog" && ac_confdir=.
+  srcdir=$ac_confdir
+  if test ! -r $srcdir/$ac_unique_file; then
+    srcdir=..
+  fi
+else
+  ac_srcdir_defaulted=no
+fi
+if test ! -r $srcdir/$ac_unique_file; then
+  if test "$ac_srcdir_defaulted" = yes; then
+    { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; }
+  else
+    { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; }
+  fi
+fi
+srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'`
+
+# Prefer explicitly selected file to automatically selected ones.
+if test -z "$CONFIG_SITE"; then
+  if test "x$prefix" != xNONE; then
+    CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site"
+  else
+    CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
+  fi
+fi
+for ac_site_file in $CONFIG_SITE; do
+  if test -r "$ac_site_file"; then
+    echo "loading site script $ac_site_file"
+    . "$ac_site_file"
+  fi
+done
+
+if test -r "$cache_file"; then
+  echo "loading cache $cache_file"
+  . $cache_file
+else
+  echo "creating cache $cache_file"
+  > $cache_file
+fi
+
+ac_ext=c
+# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
+ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
+cross_compiling=$ac_cv_prog_cc_cross
+
+ac_exeext=
+ac_objext=o
+if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
+  # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu.
+  if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then
+    ac_n= ac_c='
+' ac_t='	'
+  else
+    ac_n=-n ac_c= ac_t=
+  fi
+else
+  ac_n= ac_c='\c' ac_t=
+fi
+
+
+
+# Extract the first word of "gcc", so it can be a program name with args.
+set dummy gcc; ac_word=$2
+echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
+echo "configure:533: checking for $ac_word" >&5
+if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  if test -n "$CC"; then
+  ac_cv_prog_CC="$CC" # Let the user override the test.
+else
+  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
+  ac_dummy="$PATH"
+  for ac_dir in $ac_dummy; do
+    test -z "$ac_dir" && ac_dir=.
+    if test -f $ac_dir/$ac_word; then
+      ac_cv_prog_CC="gcc"
+      break
+    fi
+  done
+  IFS="$ac_save_ifs"
+fi
+fi
+CC="$ac_cv_prog_CC"
+if test -n "$CC"; then
+  echo "$ac_t""$CC" 1>&6
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+if test -z "$CC"; then
+  # Extract the first word of "cc", so it can be a program name with args.
+set dummy cc; ac_word=$2
+echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
+echo "configure:563: checking for $ac_word" >&5
+if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  if test -n "$CC"; then
+  ac_cv_prog_CC="$CC" # Let the user override the test.
+else
+  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
+  ac_prog_rejected=no
+  ac_dummy="$PATH"
+  for ac_dir in $ac_dummy; do
+    test -z "$ac_dir" && ac_dir=.
+    if test -f $ac_dir/$ac_word; then
+      if test "$ac_dir/$ac_word" = "/usr/ucb/cc"; then
+        ac_prog_rejected=yes
+	continue
+      fi
+      ac_cv_prog_CC="cc"
+      break
+    fi
+  done
+  IFS="$ac_save_ifs"
+if test $ac_prog_rejected = yes; then
+  # We found a bogon in the path, so make sure we never use it.
+  set dummy $ac_cv_prog_CC
+  shift
+  if test $# -gt 0; then
+    # We chose a different compiler from the bogus one.
+    # However, it has the same basename, so the bogon will be chosen
+    # first if we set CC to just the basename; use the full file name.
+    shift
+    set dummy "$ac_dir/$ac_word" "$@"
+    shift
+    ac_cv_prog_CC="$@"
+  fi
+fi
+fi
+fi
+CC="$ac_cv_prog_CC"
+if test -n "$CC"; then
+  echo "$ac_t""$CC" 1>&6
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+  if test -z "$CC"; then
+    case "`uname -s`" in
+    *win32* | *WIN32*)
+      # Extract the first word of "cl", so it can be a program name with args.
+set dummy cl; ac_word=$2
+echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
+echo "configure:614: checking for $ac_word" >&5
+if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  if test -n "$CC"; then
+  ac_cv_prog_CC="$CC" # Let the user override the test.
+else
+  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
+  ac_dummy="$PATH"
+  for ac_dir in $ac_dummy; do
+    test -z "$ac_dir" && ac_dir=.
+    if test -f $ac_dir/$ac_word; then
+      ac_cv_prog_CC="cl"
+      break
+    fi
+  done
+  IFS="$ac_save_ifs"
+fi
+fi
+CC="$ac_cv_prog_CC"
+if test -n "$CC"; then
+  echo "$ac_t""$CC" 1>&6
+else
+  echo "$ac_t""no" 1>&6
+fi
+ ;;
+    esac
+  fi
+  test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; }
+fi
+
+echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
+echo "configure:646: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
+
+ac_ext=c
+# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
+ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
+cross_compiling=$ac_cv_prog_cc_cross
+
+cat > conftest.$ac_ext << EOF
+
+#line 657 "configure"
+#include "confdefs.h"
+
+main(){return(0);}
+EOF
+if { (eval echo configure:662: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  ac_cv_prog_cc_works=yes
+  # If we can't run a trivial program, we are probably using a cross compiler.
+  if (./conftest; exit) 2>/dev/null; then
+    ac_cv_prog_cc_cross=no
+  else
+    ac_cv_prog_cc_cross=yes
+  fi
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  ac_cv_prog_cc_works=no
+fi
+rm -fr conftest*
+ac_ext=c
+# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
+ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
+cross_compiling=$ac_cv_prog_cc_cross
+
+echo "$ac_t""$ac_cv_prog_cc_works" 1>&6
+if test $ac_cv_prog_cc_works = no; then
+  { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
+fi
+echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
+echo "configure:688: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
+echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
+cross_compiling=$ac_cv_prog_cc_cross
+
+echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
+echo "configure:693: checking whether we are using GNU C" >&5
+if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.c <<EOF
+#ifdef __GNUC__
+  yes;
+#endif
+EOF
+if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:702: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
+  ac_cv_prog_gcc=yes
+else
+  ac_cv_prog_gcc=no
+fi
+fi
+
+echo "$ac_t""$ac_cv_prog_gcc" 1>&6
+
+if test $ac_cv_prog_gcc = yes; then
+  GCC=yes
+else
+  GCC=
+fi
+
+ac_test_CFLAGS="${CFLAGS+set}"
+ac_save_CFLAGS="$CFLAGS"
+CFLAGS=
+echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
+echo "configure:721: checking whether ${CC-cc} accepts -g" >&5
+if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  echo 'void f(){}' > conftest.c
+if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then
+  ac_cv_prog_cc_g=yes
+else
+  ac_cv_prog_cc_g=no
+fi
+rm -f conftest*
+
+fi
+
+echo "$ac_t""$ac_cv_prog_cc_g" 1>&6
+if test "$ac_test_CFLAGS" = set; then
+  CFLAGS="$ac_save_CFLAGS"
+elif test $ac_cv_prog_cc_g = yes; then
+  if test "$GCC" = yes; then
+    CFLAGS="-g -O2"
+  else
+    CFLAGS="-g"
+  fi
+else
+  if test "$GCC" = yes; then
+    CFLAGS="-O2"
+  else
+    CFLAGS=
+  fi
+fi
+
+echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
+echo "configure:753: checking how to run the C preprocessor" >&5
+# On Suns, sometimes $CPP names a directory.
+if test -n "$CPP" && test -d "$CPP"; then
+  CPP=
+fi
+if test -z "$CPP"; then
+if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+    # This must be in double quotes, not single quotes, because CPP may get
+  # substituted into the Makefile and "${CC-cc}" will confuse make.
+  CPP="${CC-cc} -E"
+  # On the NeXT, cc -E runs the code through the compiler's parser,
+  # not just through cpp.
+  cat > conftest.$ac_ext <<EOF
+#line 768 "configure"
+#include "confdefs.h"
+#include <assert.h>
+Syntax Error
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:774: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
+if test -z "$ac_err"; then
+  :
+else
+  echo "$ac_err" >&5
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  CPP="${CC-cc} -E -traditional-cpp"
+  cat > conftest.$ac_ext <<EOF
+#line 785 "configure"
+#include "confdefs.h"
+#include <assert.h>
+Syntax Error
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:791: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
+if test -z "$ac_err"; then
+  :
+else
+  echo "$ac_err" >&5
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  CPP="${CC-cc} -nologo -E"
+  cat > conftest.$ac_ext <<EOF
+#line 802 "configure"
+#include "confdefs.h"
+#include <assert.h>
+Syntax Error
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:808: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
+if test -z "$ac_err"; then
+  :
+else
+  echo "$ac_err" >&5
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  CPP=/lib/cpp
+fi
+rm -f conftest*
+fi
+rm -f conftest*
+fi
+rm -f conftest*
+  ac_cv_prog_CPP="$CPP"
+fi
+  CPP="$ac_cv_prog_CPP"
+else
+  ac_cv_prog_CPP="$CPP"
+fi
+echo "$ac_t""$CPP" 1>&6
+
+for ac_hdr in unistd.h limits.h
+do
+ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
+echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
+echo "configure:836: checking for $ac_hdr" >&5
+if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 841 "configure"
+#include "confdefs.h"
+#include <$ac_hdr>
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:846: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
+if test -z "$ac_err"; then
+  rm -rf conftest*
+  eval "ac_cv_header_$ac_safe=yes"
+else
+  echo "$ac_err" >&5
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_header_$ac_safe=no"
+fi
+rm -f conftest*
+fi
+if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_hdr 1
+EOF
+ 
+else
+  echo "$ac_t""no" 1>&6
+fi
+done
+
+
+LIBEXT=
+TKNAME=tk
+
+# Check whether --with-config or --without-config was given.
+if test "${with_config+set}" = set; then
+  withval="$with_config"
+  if test -f $withval; then
+     SITECFG=`dirname $withval`/`basename $withval`
+     . $SITECFG
+   else
+    { echo "configure: error: $withval does not exist" 1>&2; exit 1; }
+   fi
+else
+  { echo "configure: error: You must provide a file giving the location of various software using the option --with-config=file. Check the INSTALL instructions" 1>&2; exit 1; }
+fi
+
+
+if test -z "$OCAMLLIBDIR"; then
+  { echo "configure: error: "OCAMLLIBDIR is still undefined. Edit $SITECFG"" 1>&2; exit 1; }
+fi
+
+if test -z "$INSTALLDIR"; then
+  { echo "configure: error: "INSTALLDIR is still undefined. Edit $SITECFG"" 1>&2; exit 1; }
+fi
+
+if test -z "$INSTALLBINDIR"; then
+  { echo "configure: error: "INSTALLBINDIR is still undefined. Edit $SITECFG"" 1>&2; exit 1; }
+fi
+
+# If we find X, set shell vars x_includes and x_libraries to the
+# paths, otherwise set no_x=yes.
+# Uses ac_ vars as temps to allow command line to override cache and checks.
+# --without-x overrides everything else, but does not touch the cache.
+echo $ac_n "checking for X""... $ac_c" 1>&6
+echo "configure:907: checking for X" >&5
+
+# Check whether --with-x or --without-x was given.
+if test "${with_x+set}" = set; then
+  withval="$with_x"
+  :
+fi
+
+# $have_x is `yes', `no', `disabled', or empty when we do not yet know.
+if test "x$with_x" = xno; then
+  # The user explicitly disabled X.
+  have_x=disabled
+else
+  if test "x$x_includes" != xNONE && test "x$x_libraries" != xNONE; then
+    # Both variables are already set.
+    have_x=yes
+  else
+if eval "test \"`echo '$''{'ac_cv_have_x'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  # One or both of the vars are not set, and there is no cached value.
+ac_x_includes=NO ac_x_libraries=NO
+rm -fr conftestdir
+if mkdir conftestdir; then
+  cd conftestdir
+  # Make sure to not put "make" in the Imakefile rules, since we grep it out.
+  cat > Imakefile <<'EOF'
+acfindx:
+	@echo 'ac_im_incroot="${INCROOT}"; ac_im_usrlibdir="${USRLIBDIR}"; ac_im_libdir="${LIBDIR}"'
+EOF
+  if (xmkmf) >/dev/null 2>/dev/null && test -f Makefile; then
+    # GNU make sometimes prints "make[1]: Entering...", which would confuse us.
+    eval `${MAKE-make} acfindx 2>/dev/null | grep -v make`
+    # Open Windows xmkmf reportedly sets LIBDIR instead of USRLIBDIR.
+    for ac_extension in a so sl; do
+      if test ! -f $ac_im_usrlibdir/libX11.$ac_extension &&
+        test -f $ac_im_libdir/libX11.$ac_extension; then
+        ac_im_usrlibdir=$ac_im_libdir; break
+      fi
+    done
+    # Screen out bogus values from the imake configuration.  They are
+    # bogus both because they are the default anyway, and because
+    # using them would break gcc on systems where it needs fixed includes.
+    case "$ac_im_incroot" in
+	/usr/include) ;;
+	*) test -f "$ac_im_incroot/X11/Xos.h" && ac_x_includes="$ac_im_incroot" ;;
+    esac
+    case "$ac_im_usrlibdir" in
+	/usr/lib | /lib) ;;
+	*) test -d "$ac_im_usrlibdir" && ac_x_libraries="$ac_im_usrlibdir" ;;
+    esac
+  fi
+  cd ..
+  rm -fr conftestdir
+fi
+
+if test "$ac_x_includes" = NO; then
+  # Guess where to find include files, by looking for this one X11 .h file.
+  test -z "$x_direct_test_include" && x_direct_test_include=X11/Intrinsic.h
+
+  # First, try using that file with no special directory specified.
+cat > conftest.$ac_ext <<EOF
+#line 969 "configure"
+#include "confdefs.h"
+#include <$x_direct_test_include>
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:974: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
+if test -z "$ac_err"; then
+  rm -rf conftest*
+  # We can compile using X headers with no special include directory.
+ac_x_includes=
+else
+  echo "$ac_err" >&5
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  # Look for the header file in a standard set of common directories.
+# Check X11 before X11Rn because it is often a symlink to the current release.
+  for ac_dir in               \
+    /usr/X11/include          \
+    /usr/X11R6/include        \
+    /usr/X11R5/include        \
+    /usr/X11R4/include        \
+                              \
+    /usr/include/X11          \
+    /usr/include/X11R6        \
+    /usr/include/X11R5        \
+    /usr/include/X11R4        \
+                              \
+    /usr/local/X11/include    \
+    /usr/local/X11R6/include  \
+    /usr/local/X11R5/include  \
+    /usr/local/X11R4/include  \
+                              \
+    /usr/local/include/X11    \
+    /usr/local/include/X11R6  \
+    /usr/local/include/X11R5  \
+    /usr/local/include/X11R4  \
+                              \
+    /usr/X386/include         \
+    /usr/x386/include         \
+    /usr/XFree86/include/X11  \
+                              \
+    /usr/include              \
+    /usr/local/include        \
+    /usr/unsupported/include  \
+    /usr/athena/include       \
+    /usr/local/x11r5/include  \
+    /usr/lpp/Xamples/include  \
+                              \
+    /usr/openwin/include      \
+    /usr/openwin/share/include \
+    ; \
+  do
+    if test -r "$ac_dir/$x_direct_test_include"; then
+      ac_x_includes=$ac_dir
+      break
+    fi
+  done
+fi
+rm -f conftest*
+fi # $ac_x_includes = NO
+
+if test "$ac_x_libraries" = NO; then
+  # Check for the libraries.
+
+  test -z "$x_direct_test_library" && x_direct_test_library=Xt
+  test -z "$x_direct_test_function" && x_direct_test_function=XtMalloc
+
+  # See if we find them without any special options.
+  # Don't add to $LIBS permanently.
+  ac_save_LIBS="$LIBS"
+  LIBS="-l$x_direct_test_library $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 1043 "configure"
+#include "confdefs.h"
+
+int main() {
+${x_direct_test_function}()
+; return 0; }
+EOF
+if { (eval echo configure:1050: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  LIBS="$ac_save_LIBS"
+# We can link X programs with no special library path.
+ac_x_libraries=
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  LIBS="$ac_save_LIBS"
+# First see if replacing the include by lib works.
+# Check X11 before X11Rn because it is often a symlink to the current release.
+for ac_dir in `echo "$ac_x_includes" | sed s/include/lib/` \
+    /usr/X11/lib          \
+    /usr/X11R6/lib        \
+    /usr/X11R5/lib        \
+    /usr/X11R4/lib        \
+                          \
+    /usr/lib/X11          \
+    /usr/lib/X11R6        \
+    /usr/lib/X11R5        \
+    /usr/lib/X11R4        \
+                          \
+    /usr/local/X11/lib    \
+    /usr/local/X11R6/lib  \
+    /usr/local/X11R5/lib  \
+    /usr/local/X11R4/lib  \
+                          \
+    /usr/local/lib/X11    \
+    /usr/local/lib/X11R6  \
+    /usr/local/lib/X11R5  \
+    /usr/local/lib/X11R4  \
+                          \
+    /usr/X386/lib         \
+    /usr/x386/lib         \
+    /usr/XFree86/lib/X11  \
+                          \
+    /usr/lib              \
+    /usr/local/lib        \
+    /usr/unsupported/lib  \
+    /usr/athena/lib       \
+    /usr/local/x11r5/lib  \
+    /usr/lpp/Xamples/lib  \
+    /lib/usr/lib/X11	  \
+                          \
+    /usr/openwin/lib      \
+    /usr/openwin/share/lib \
+    ; \
+do
+  for ac_extension in a so sl; do
+    if test -r $ac_dir/lib${x_direct_test_library}.$ac_extension; then
+      ac_x_libraries=$ac_dir
+      break 2
+    fi
+  done
+done
+fi
+rm -f conftest*
+fi # $ac_x_libraries = NO
+
+if test "$ac_x_includes" = NO || test "$ac_x_libraries" = NO; then
+  # Didn't find X anywhere.  Cache the known absence of X.
+  ac_cv_have_x="have_x=no"
+else
+  # Record where we found X for the cache.
+  ac_cv_have_x="have_x=yes \
+	        ac_x_includes=$ac_x_includes ac_x_libraries=$ac_x_libraries"
+fi
+fi
+  fi
+  eval "$ac_cv_have_x"
+fi # $with_x != no
+
+if test "$have_x" != yes; then
+  echo "$ac_t""$have_x" 1>&6
+  no_x=yes
+else
+  # If each of the values was on the command line, it overrides each guess.
+  test "x$x_includes" = xNONE && x_includes=$ac_x_includes
+  test "x$x_libraries" = xNONE && x_libraries=$ac_x_libraries
+  # Update the cache value to reflect the command line values.
+  ac_cv_have_x="have_x=yes \
+		ac_x_includes=$x_includes ac_x_libraries=$x_libraries"
+  echo "$ac_t""libraries $x_libraries, headers $x_includes" 1>&6
+fi
+
+if test "$no_x" = yes; then
+  # Not all programs may use this symbol, but it does not hurt to define it.
+  cat >> confdefs.h <<\EOF
+#define X_DISPLAY_MISSING 1
+EOF
+
+  X_CFLAGS= X_PRE_LIBS= X_LIBS= X_EXTRA_LIBS=
+else
+  if test -n "$x_includes"; then
+    X_CFLAGS="$X_CFLAGS -I$x_includes"
+  fi
+
+  # It would also be nice to do this for all -L options, not just this one.
+  if test -n "$x_libraries"; then
+    X_LIBS="$X_LIBS -L$x_libraries"
+    # For Solaris; some versions of Sun CC require a space after -R and
+    # others require no space.  Words are not sufficient . . . .
+    case "`(uname -sr) 2>/dev/null`" in
+    "SunOS 5"*)
+      echo $ac_n "checking whether -R must be followed by a space""... $ac_c" 1>&6
+echo "configure:1156: checking whether -R must be followed by a space" >&5
+      ac_xsave_LIBS="$LIBS"; LIBS="$LIBS -R$x_libraries"
+      cat > conftest.$ac_ext <<EOF
+#line 1159 "configure"
+#include "confdefs.h"
+
+int main() {
+
+; return 0; }
+EOF
+if { (eval echo configure:1166: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  ac_R_nospace=yes
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  ac_R_nospace=no
+fi
+rm -f conftest*
+      if test $ac_R_nospace = yes; then
+	echo "$ac_t""no" 1>&6
+	X_LIBS="$X_LIBS -R$x_libraries"
+      else
+	LIBS="$ac_xsave_LIBS -R $x_libraries"
+	cat > conftest.$ac_ext <<EOF
+#line 1182 "configure"
+#include "confdefs.h"
+
+int main() {
+
+; return 0; }
+EOF
+if { (eval echo configure:1189: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  ac_R_space=yes
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  ac_R_space=no
+fi
+rm -f conftest*
+	if test $ac_R_space = yes; then
+	  echo "$ac_t""yes" 1>&6
+	  X_LIBS="$X_LIBS -R $x_libraries"
+	else
+	  echo "$ac_t""neither works" 1>&6
+	fi
+      fi
+      LIBS="$ac_xsave_LIBS"
+    esac
+  fi
+
+  # Check for system-dependent libraries X programs must link with.
+  # Do this before checking for the system-independent R6 libraries
+  # (-lICE), since we may need -lsocket or whatever for X linking.
+
+  if test "$ISC" = yes; then
+    X_EXTRA_LIBS="$X_EXTRA_LIBS -lnsl_s -linet"
+  else
+    # Martyn.Johnson@cl.cam.ac.uk says this is needed for Ultrix, if the X
+    # libraries were built with DECnet support.  And karl@cs.umb.edu says
+    # the Alpha needs dnet_stub (dnet does not exist).
+    echo $ac_n "checking for dnet_ntoa in -ldnet""... $ac_c" 1>&6
+echo "configure:1221: checking for dnet_ntoa in -ldnet" >&5
+ac_lib_var=`echo dnet'_'dnet_ntoa | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-ldnet  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 1229 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char dnet_ntoa();
+
+int main() {
+dnet_ntoa()
+; return 0; }
+EOF
+if { (eval echo configure:1240: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  X_EXTRA_LIBS="$X_EXTRA_LIBS -ldnet"
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+    if test $ac_cv_lib_dnet_dnet_ntoa = no; then
+      echo $ac_n "checking for dnet_ntoa in -ldnet_stub""... $ac_c" 1>&6
+echo "configure:1262: checking for dnet_ntoa in -ldnet_stub" >&5
+ac_lib_var=`echo dnet_stub'_'dnet_ntoa | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-ldnet_stub  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 1270 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char dnet_ntoa();
+
+int main() {
+dnet_ntoa()
+; return 0; }
+EOF
+if { (eval echo configure:1281: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  X_EXTRA_LIBS="$X_EXTRA_LIBS -ldnet_stub"
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+    fi
+
+    # msh@cis.ufl.edu says -lnsl (and -lsocket) are needed for his 386/AT,
+    # to get the SysV transport functions.
+    # chad@anasazi.com says the Pyramis MIS-ES running DC/OSx (SVR4)
+    # needs -lnsl.
+    # The nsl library prevents programs from opening the X display
+    # on Irix 5.2, according to dickey@clark.net.
+    echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6
+echo "configure:1310: checking for gethostbyname" >&5
+if eval "test \"`echo '$''{'ac_cv_func_gethostbyname'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 1315 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+    which can conflict with char gethostbyname(); below.  */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char gethostbyname();
+
+int main() {
+
+/* The GNU C library defines this for functions which it implements
+    to always fail with ENOSYS.  Some functions are actually named
+    something starting with __ and the normal name is an alias.  */
+#if defined (__stub_gethostbyname) || defined (__stub___gethostbyname)
+choke me
+#else
+gethostbyname();
+#endif
+
+; return 0; }
+EOF
+if { (eval echo configure:1338: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_func_gethostbyname=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_func_gethostbyname=no"
+fi
+rm -f conftest*
+fi
+
+if eval "test \"`echo '$ac_cv_func_'gethostbyname`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  :
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+    if test $ac_cv_func_gethostbyname = no; then
+      echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6
+echo "configure:1359: checking for gethostbyname in -lnsl" >&5
+ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-lnsl  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 1367 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char gethostbyname();
+
+int main() {
+gethostbyname()
+; return 0; }
+EOF
+if { (eval echo configure:1378: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  X_EXTRA_LIBS="$X_EXTRA_LIBS -lnsl"
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+    fi
+
+    # lieder@skyler.mavd.honeywell.com says without -lsocket,
+    # socket/setsockopt and other routines are undefined under SCO ODT
+    # 2.0.  But -lsocket is broken on IRIX 5.2 (and is not necessary
+    # on later versions), says simon@lia.di.epfl.ch: it contains
+    # gethostby* variants that don't use the nameserver (or something).
+    # -lsocket must be given before -lnsl if both are needed.
+    # We assume that if connect needs -lnsl, so does gethostbyname.
+    echo $ac_n "checking for connect""... $ac_c" 1>&6
+echo "configure:1408: checking for connect" >&5
+if eval "test \"`echo '$''{'ac_cv_func_connect'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 1413 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+    which can conflict with char connect(); below.  */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char connect();
+
+int main() {
+
+/* The GNU C library defines this for functions which it implements
+    to always fail with ENOSYS.  Some functions are actually named
+    something starting with __ and the normal name is an alias.  */
+#if defined (__stub_connect) || defined (__stub___connect)
+choke me
+#else
+connect();
+#endif
+
+; return 0; }
+EOF
+if { (eval echo configure:1436: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_func_connect=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_func_connect=no"
+fi
+rm -f conftest*
+fi
+
+if eval "test \"`echo '$ac_cv_func_'connect`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  :
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+    if test $ac_cv_func_connect = no; then
+      echo $ac_n "checking for connect in -lsocket""... $ac_c" 1>&6
+echo "configure:1457: checking for connect in -lsocket" >&5
+ac_lib_var=`echo socket'_'connect | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-lsocket $X_EXTRA_LIBS $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 1465 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char connect();
+
+int main() {
+connect()
+; return 0; }
+EOF
+if { (eval echo configure:1476: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  X_EXTRA_LIBS="-lsocket $X_EXTRA_LIBS"
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+    fi
+
+    # gomez@mi.uni-erlangen.de says -lposix is necessary on A/UX.
+    echo $ac_n "checking for remove""... $ac_c" 1>&6
+echo "configure:1500: checking for remove" >&5
+if eval "test \"`echo '$''{'ac_cv_func_remove'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 1505 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+    which can conflict with char remove(); below.  */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char remove();
+
+int main() {
+
+/* The GNU C library defines this for functions which it implements
+    to always fail with ENOSYS.  Some functions are actually named
+    something starting with __ and the normal name is an alias.  */
+#if defined (__stub_remove) || defined (__stub___remove)
+choke me
+#else
+remove();
+#endif
+
+; return 0; }
+EOF
+if { (eval echo configure:1528: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_func_remove=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_func_remove=no"
+fi
+rm -f conftest*
+fi
+
+if eval "test \"`echo '$ac_cv_func_'remove`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  :
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+    if test $ac_cv_func_remove = no; then
+      echo $ac_n "checking for remove in -lposix""... $ac_c" 1>&6
+echo "configure:1549: checking for remove in -lposix" >&5
+ac_lib_var=`echo posix'_'remove | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-lposix  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 1557 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char remove();
+
+int main() {
+remove()
+; return 0; }
+EOF
+if { (eval echo configure:1568: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  X_EXTRA_LIBS="$X_EXTRA_LIBS -lposix"
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+    fi
+
+    # BSDI BSD/OS 2.1 needs -lipc for XOpenDisplay.
+    echo $ac_n "checking for shmat""... $ac_c" 1>&6
+echo "configure:1592: checking for shmat" >&5
+if eval "test \"`echo '$''{'ac_cv_func_shmat'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 1597 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+    which can conflict with char shmat(); below.  */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char shmat();
+
+int main() {
+
+/* The GNU C library defines this for functions which it implements
+    to always fail with ENOSYS.  Some functions are actually named
+    something starting with __ and the normal name is an alias.  */
+#if defined (__stub_shmat) || defined (__stub___shmat)
+choke me
+#else
+shmat();
+#endif
+
+; return 0; }
+EOF
+if { (eval echo configure:1620: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_func_shmat=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_func_shmat=no"
+fi
+rm -f conftest*
+fi
+
+if eval "test \"`echo '$ac_cv_func_'shmat`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  :
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+    if test $ac_cv_func_shmat = no; then
+      echo $ac_n "checking for shmat in -lipc""... $ac_c" 1>&6
+echo "configure:1641: checking for shmat in -lipc" >&5
+ac_lib_var=`echo ipc'_'shmat | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-lipc  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 1649 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char shmat();
+
+int main() {
+shmat()
+; return 0; }
+EOF
+if { (eval echo configure:1660: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  X_EXTRA_LIBS="$X_EXTRA_LIBS -lipc"
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+    fi
+  fi
+
+  # Check for libraries that X11R6 Xt/Xaw programs need.
+  ac_save_LDFLAGS="$LDFLAGS"
+  test -n "$x_libraries" && LDFLAGS="$LDFLAGS -L$x_libraries"
+  # SM needs ICE to (dynamically) link under SunOS 4.x (so we have to
+  # check for ICE first), but we must link in the order -lSM -lICE or
+  # we get undefined symbols.  So assume we have SM if we have ICE.
+  # These have to be linked with before -lX11, unlike the other
+  # libraries we check for below, so use a different variable.
+  #  --interran@uluru.Stanford.EDU, kb@cs.umb.edu.
+  echo $ac_n "checking for IceConnectionNumber in -lICE""... $ac_c" 1>&6
+echo "configure:1693: checking for IceConnectionNumber in -lICE" >&5
+ac_lib_var=`echo ICE'_'IceConnectionNumber | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-lICE $X_EXTRA_LIBS $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 1701 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char IceConnectionNumber();
+
+int main() {
+IceConnectionNumber()
+; return 0; }
+EOF
+if { (eval echo configure:1712: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  X_PRE_LIBS="$X_PRE_LIBS -lSM -lICE"
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+  LDFLAGS="$ac_save_LDFLAGS"
+
+fi
+
+WITH_X="$X_LIBS $X_PRE_LIBS -lX11 $X_EXTRA_LIBS"
+CPPFLAGS="$CPPFLAGS $X_CFLAGS"
+
+# Extract the first word of "ranlib", so it can be a program name with args.
+set dummy ranlib; ac_word=$2
+echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
+echo "configure:1742: checking for $ac_word" >&5
+if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  if test -n "$RANLIB"; then
+  ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
+else
+  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
+  ac_dummy="$PATH"
+  for ac_dir in $ac_dummy; do
+    test -z "$ac_dir" && ac_dir=.
+    if test -f $ac_dir/$ac_word; then
+      ac_cv_prog_RANLIB="ranlib"
+      break
+    fi
+  done
+  IFS="$ac_save_ifs"
+  test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":"
+fi
+fi
+RANLIB="$ac_cv_prog_RANLIB"
+if test -n "$RANLIB"; then
+  echo "$ac_t""$RANLIB" 1>&6
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+
+# Extract the first word of "cpp", so it can be a program name with args.
+set dummy cpp; ac_word=$2
+echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
+echo "configure:1773: checking for $ac_word" >&5
+if eval "test \"`echo '$''{'ac_cv_path_CPPPROG'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  case "$CPPPROG" in
+  /*)
+  ac_cv_path_CPPPROG="$CPPPROG" # Let the user override the test with a path.
+  ;;
+  ?:/*)			 
+  ac_cv_path_CPPPROG="$CPPPROG" # Let the user override the test with a dos path.
+  ;;
+  *)
+  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
+  ac_dummy="$PATH"
+  for ac_dir in $ac_dummy; do 
+    test -z "$ac_dir" && ac_dir=.
+    if test -f $ac_dir/$ac_word; then
+      ac_cv_path_CPPPROG="$ac_dir/$ac_word"
+      break
+    fi
+  done
+  IFS="$ac_save_ifs"
+  test -z "$ac_cv_path_CPPPROG" && ac_cv_path_CPPPROG="/lib/cpp"
+  ;;
+esac
+fi
+CPPPROG="$ac_cv_path_CPPPROG"
+if test -n "$CPPPROG"; then
+  echo "$ac_t""$CPPPROG" 1>&6
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+
+
+LIBS="-lm"
+
+### We probably need more
+echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6
+echo "configure:1812: checking for dlopen in -ldl" >&5
+ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-ldl  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 1820 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char dlopen();
+
+int main() {
+dlopen()
+; return 0; }
+EOF
+if { (eval echo configure:1831: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  LIBS="-ldl $LIBS"
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+
+### Check for Tcl7.5(7.6,8.0) and Tk4.1(4.2)
+echo "checking Tcl and Tk includes and libraries" 1>&6
+echo "configure:1854: checking Tcl and Tk includes and libraries" >&5
+
+for ac_hdr in tcl.h
+do
+ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
+echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
+echo "configure:1860: checking for $ac_hdr" >&5
+if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 1865 "configure"
+#include "confdefs.h"
+#include <$ac_hdr>
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:1870: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
+if test -z "$ac_err"; then
+  rm -rf conftest*
+  eval "ac_cv_header_$ac_safe=yes"
+else
+  echo "$ac_err" >&5
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_header_$ac_safe=no"
+fi
+rm -f conftest*
+fi
+if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_hdr 1
+EOF
+ 
+else
+  echo "$ac_t""no" 1>&6
+{ echo "configure: error: Can't find tcl.h. Check the CPPFLAGS variable in $SITECFG" 1>&2; exit 1; }
+fi
+done
+
+
+for ac_hdr in tk.h
+do
+ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
+echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
+echo "configure:1902: checking for $ac_hdr" >&5
+if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 1907 "configure"
+#include "confdefs.h"
+#include <$ac_hdr>
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:1912: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
+if test -z "$ac_err"; then
+  rm -rf conftest*
+  eval "ac_cv_header_$ac_safe=yes"
+else
+  echo "$ac_err" >&5
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_header_$ac_safe=no"
+fi
+rm -f conftest*
+fi
+if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_hdr 1
+EOF
+ 
+else
+  echo "$ac_t""no" 1>&6
+{ echo "configure: error: Can't find tk.h. Check the CPPFLAGS variable in $SITECFG" 1>&2; exit 1; }
+fi
+done
+
+
+echo $ac_n "checking Tcl version""... $ac_c" 1>&6
+echo "configure:1941: checking Tcl version" >&5
+### Check Tcl version
+tclver=no
+cat > conftest.$ac_ext <<EOF
+#line 1945 "configure"
+#include "confdefs.h"
+#include <tcl.h>
+VERSION=TCL_VERSION
+EOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+  egrep "^VERSION=.*7\.5" >/dev/null 2>&1; then
+  rm -rf conftest*
+  tclver=7.5
+fi
+rm -f conftest*
+
+if test $tclver = no; then
+cat > conftest.$ac_ext <<EOF
+#line 1959 "configure"
+#include "confdefs.h"
+#include <tcl.h>
+VERSION=TCL_VERSION
+EOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+  egrep "^VERSION=.*7\.6" >/dev/null 2>&1; then
+  rm -rf conftest*
+  tclver=7.6
+fi
+rm -f conftest*
+
+fi
+if test $tclver = no; then
+cat > conftest.$ac_ext <<EOF
+#line 1974 "configure"
+#include "confdefs.h"
+#include <tcl.h>
+VERSION=TCL_VERSION
+EOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+  egrep "^VERSION=.*8\.0" >/dev/null 2>&1; then
+  rm -rf conftest*
+  tclver=8.0
+fi
+rm -f conftest*
+
+fi
+if test $tclver = no; then
+cat > conftest.$ac_ext <<EOF
+#line 1989 "configure"
+#include "confdefs.h"
+#include <tcl.h>
+VERSION=TCL_VERSION
+EOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+  egrep "^VERSION=.*8\.1" >/dev/null 2>&1; then
+  rm -rf conftest*
+  tclver=8.1
+fi
+rm -f conftest*
+
+fi
+if test $tclver = no; then
+cat > conftest.$ac_ext <<EOF
+#line 2004 "configure"
+#include "confdefs.h"
+#include <tcl.h>
+VERSION=TCL_VERSION
+EOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+  egrep "^VERSION=.*8\.2" >/dev/null 2>&1; then
+  rm -rf conftest*
+  tclver=8.2
+fi
+rm -f conftest*
+
+fi
+echo "$ac_t""$tclver" 1>&6
+
+case $tclver in
+7.5) tclmaj=7 tclmin=5 tkmaj=4 tkmin=1 ;;
+7.6) tclmaj=7 tclmin=6 tkmaj=4 tkmin=2 ;;
+8.0) tclmaj=8 tclmin=0 tkmaj=8 tkmin=0 ;;
+8.1) tclmaj=8 tclmin=1 tkmaj=8 tkmin=1 ;;
+8.2) tclmaj=8 tclmin=2 tkmaj=8 tkmin=2 ;;
+esac
+
+if test x$tkmaj = x8; then
+  CPPFLAGS="-DTK80 $CPPFLAGS"
+fi
+
+tcllib="tcl$tclmaj$tclmin$LIBEXT"
+tcllibd="tcl$tclmaj.$tclmin$LIBEXT"
+
+echo $ac_n "checking for Tcl_DoOneEvent in -l$tcllibd""... $ac_c" 1>&6
+echo "configure:2035: checking for Tcl_DoOneEvent in -l$tcllibd" >&5
+ac_lib_var=`echo $tcllibd'_'Tcl_DoOneEvent | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-l$tcllibd $X_EXTRA_LIBS $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 2043 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char Tcl_DoOneEvent();
+
+int main() {
+Tcl_DoOneEvent()
+; return 0; }
+EOF
+if { (eval echo configure:2054: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  LIBS="-l$tcllibd $LIBS" tkver=$tkmaj.$tkmin
+else
+  echo "$ac_t""no" 1>&6
+echo $ac_n "checking for Tcl_DoOneEvent in -l$tcllib""... $ac_c" 1>&6
+echo "configure:2073: checking for Tcl_DoOneEvent in -l$tcllib" >&5
+ac_lib_var=`echo $tcllib'_'Tcl_DoOneEvent | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-l$tcllib $X_EXTRA_LIBS $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 2081 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char Tcl_DoOneEvent();
+
+int main() {
+Tcl_DoOneEvent()
+; return 0; }
+EOF
+if { (eval echo configure:2092: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  LIBS="-l$tcllib $LIBS" tkver=$tkmaj$tkmin
+else
+  echo "$ac_t""no" 1>&6
+echo $ac_n "checking for Tcl_DoOneEvent in -ltcl$LIBEXT""... $ac_c" 1>&6
+echo "configure:2111: checking for Tcl_DoOneEvent in -ltcl$LIBEXT" >&5
+ac_lib_var=`echo tcl$LIBEXT'_'Tcl_DoOneEvent | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-ltcl$LIBEXT $X_EXTRA_LIBS $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 2119 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char Tcl_DoOneEvent();
+
+int main() {
+Tcl_DoOneEvent()
+; return 0; }
+EOF
+if { (eval echo configure:2130: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  LIBS="-ltcl$LIBEXT $LIBS"
+else
+  echo "$ac_t""no" 1>&6
+{ echo "configure: error: Can't find a tcl library.
+Check config.log to see what happened" 1>&2; exit 1; }
+fi
+
+fi
+
+fi
+
+
+tklib="${TKNAME}${tkver}${LIBEXT}"
+
+echo $ac_n "checking for Tk_SetGrid in -l$tklib""... $ac_c" 1>&6
+echo "configure:2160: checking for Tk_SetGrid in -l$tklib" >&5
+ac_lib_var=`echo $tklib'_'Tk_SetGrid | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-l$tklib $WITH_X -lm $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 2168 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char Tk_SetGrid();
+
+int main() {
+Tk_SetGrid()
+; return 0; }
+EOF
+if { (eval echo configure:2179: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  LIBS="-l$tklib $LIBS"
+else
+  echo "$ac_t""no" 1>&6
+{ echo "configure: error: Can't find a tk library.
+Check config.log to see what happened" 1>&2; exit 1; }
+fi
+
+
+
+
+
+
+
+
+
+
+
+THE_X_LIBS="$X_PRE_LIBS -lX11 $X_EXTRA_LIBS"
+
+
+
+
+
+
+
+trap '' 1 2 15
+cat > confcache <<\EOF
+# This file is a shell script that caches the results of configure
+# tests run on this system so they can be shared between configure
+# scripts and configure runs.  It is not useful on other systems.
+# If it contains results you don't want to keep, you may remove or edit it.
+#
+# By default, configure uses ./config.cache as the cache file,
+# creating it if it does not exist already.  You can give configure
+# the --cache-file=FILE option to use a different cache file; that is
+# what configure does when it calls configure scripts in
+# subdirectories, so they share the cache.
+# Giving --cache-file=/dev/null disables caching, for debugging configure.
+# config.status only pays attention to the cache file if you give it the
+# --recheck option to rerun configure.
+#
+EOF
+# The following way of writing the cache mishandles newlines in values,
+# but we know of no workaround that is simple, portable, and efficient.
+# So, don't put newlines in cache variables' values.
+# Ultrix sh set writes to stderr and can't be redirected directly,
+# and sets the high bit in the cache file unless we assign to the vars.
+(set) 2>&1 |
+  case `(ac_space=' '; set | grep ac_space) 2>&1` in
+  *ac_space=\ *)
+    # `set' does not quote correctly, so add quotes (double-quote substitution
+    # turns \\\\ into \\, and sed turns \\ into \).
+    sed -n \
+      -e "s/'/'\\\\''/g" \
+      -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p"
+    ;;
+  *)
+    # `set' quotes correctly as required by POSIX, so do not add quotes.
+    sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p'
+    ;;
+  esac >> confcache
+if cmp -s $cache_file confcache; then
+  :
+else
+  if test -w $cache_file; then
+    echo "updating cache $cache_file"
+    cat confcache > $cache_file
+  else
+    echo "not updating unwritable cache $cache_file"
+  fi
+fi
+rm -f confcache
+
+trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
+
+test "x$prefix" = xNONE && prefix=$ac_default_prefix
+# Let make expand exec_prefix.
+test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
+
+# Any assignment to VPATH causes Sun make to only execute
+# the first set of double-colon rules, so remove it if not needed.
+# If there is a colon in the path, we need to keep it.
+if test "x$srcdir" = x.; then
+  ac_vpsub='/^[ 	]*VPATH[ 	]*=[^:]*$/d'
+fi
+
+trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15
+
+# Transform confdefs.h into DEFS.
+# Protect against shell expansion while executing Makefile rules.
+# Protect against Makefile macro expansion.
+cat > conftest.defs <<\EOF
+s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g
+s%[ 	`~#$^&*(){}\\|;'"<>?]%\\&%g
+s%\[%\\&%g
+s%\]%\\&%g
+s%\$%$$%g
+EOF
+DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '`
+rm -f conftest.defs
+
+
+# Without the "./", some shells look in PATH for config.status.
+: ${CONFIG_STATUS=./config.status}
+
+echo creating $CONFIG_STATUS
+rm -f $CONFIG_STATUS
+cat > $CONFIG_STATUS <<EOF
+#! /bin/sh
+# Generated automatically by configure.
+# Run this file to recreate the current configuration.
+# This directory was configured as follows,
+# on host `(hostname || uname -n) 2>/dev/null | sed 1q`:
+#
+# $0 $ac_configure_args
+#
+# Compiler output produced by configure, useful for debugging
+# configure, is in ./config.log if it exists.
+
+ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]"
+for ac_option
+do
+  case "\$ac_option" in
+  -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
+    echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion"
+    exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;;
+  -version | --version | --versio | --versi | --vers | --ver | --ve | --v)
+    echo "$CONFIG_STATUS generated by autoconf version 2.13"
+    exit 0 ;;
+  -help | --help | --hel | --he | --h)
+    echo "\$ac_cs_usage"; exit 0 ;;
+  *) echo "\$ac_cs_usage"; exit 1 ;;
+  esac
+done
+
+ac_given_srcdir=$srcdir
+
+trap 'rm -fr `echo "Makefile.config labltk labltklink labltkopt" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
+EOF
+cat >> $CONFIG_STATUS <<EOF
+
+# Protect against being on the right side of a sed subst in config.status.
+sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g;
+ s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF
+$ac_vpsub
+$extrasub
+s%@SHELL@%$SHELL%g
+s%@CFLAGS@%$CFLAGS%g
+s%@CPPFLAGS@%$CPPFLAGS%g
+s%@CXXFLAGS@%$CXXFLAGS%g
+s%@FFLAGS@%$FFLAGS%g
+s%@DEFS@%$DEFS%g
+s%@LDFLAGS@%$LDFLAGS%g
+s%@LIBS@%$LIBS%g
+s%@exec_prefix@%$exec_prefix%g
+s%@prefix@%$prefix%g
+s%@program_transform_name@%$program_transform_name%g
+s%@bindir@%$bindir%g
+s%@sbindir@%$sbindir%g
+s%@libexecdir@%$libexecdir%g
+s%@datadir@%$datadir%g
+s%@sysconfdir@%$sysconfdir%g
+s%@sharedstatedir@%$sharedstatedir%g
+s%@localstatedir@%$localstatedir%g
+s%@libdir@%$libdir%g
+s%@includedir@%$includedir%g
+s%@oldincludedir@%$oldincludedir%g
+s%@infodir@%$infodir%g
+s%@mandir@%$mandir%g
+s%@CC@%$CC%g
+s%@CPP@%$CPP%g
+s%@X_CFLAGS@%$X_CFLAGS%g
+s%@X_PRE_LIBS@%$X_PRE_LIBS%g
+s%@X_LIBS@%$X_LIBS%g
+s%@X_EXTRA_LIBS@%$X_EXTRA_LIBS%g
+s%@RANLIB@%$RANLIB%g
+s%@CPPPROG@%$CPPPROG%g
+s%@OCAMLLIBDIR@%$OCAMLLIBDIR%g
+s%@INSTALLDIR@%$INSTALLDIR%g
+s%@INSTALLBINDIR@%$INSTALLBINDIR%g
+s%@WITH_X@%$WITH_X%g
+s%@THE_X_LIBS@%$THE_X_LIBS%g
+s%@OCAMLSRCDIR@%$OCAMLSRCDIR%g
+
+CEOF
+EOF
+
+cat >> $CONFIG_STATUS <<\EOF
+
+# Split the substitutions into bite-sized pieces for seds with
+# small command number limits, like on Digital OSF/1 and HP-UX.
+ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script.
+ac_file=1 # Number of current file.
+ac_beg=1 # First line for current file.
+ac_end=$ac_max_sed_cmds # Line after last line for current file.
+ac_more_lines=:
+ac_sed_cmds=""
+while $ac_more_lines; do
+  if test $ac_beg -gt 1; then
+    sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file
+  else
+    sed "${ac_end}q" conftest.subs > conftest.s$ac_file
+  fi
+  if test ! -s conftest.s$ac_file; then
+    ac_more_lines=false
+    rm -f conftest.s$ac_file
+  else
+    if test -z "$ac_sed_cmds"; then
+      ac_sed_cmds="sed -f conftest.s$ac_file"
+    else
+      ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file"
+    fi
+    ac_file=`expr $ac_file + 1`
+    ac_beg=$ac_end
+    ac_end=`expr $ac_end + $ac_max_sed_cmds`
+  fi
+done
+if test -z "$ac_sed_cmds"; then
+  ac_sed_cmds=cat
+fi
+EOF
+
+cat >> $CONFIG_STATUS <<EOF
+
+CONFIG_FILES=\${CONFIG_FILES-"Makefile.config labltk labltklink labltkopt"}
+EOF
+cat >> $CONFIG_STATUS <<\EOF
+for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
+  # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
+  case "$ac_file" in
+  *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'`
+       ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
+  *) ac_file_in="${ac_file}.in" ;;
+  esac
+
+  # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories.
+
+  # Remove last slash and all that follows it.  Not all systems have dirname.
+  ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
+  if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then
+    # The file is in a subdirectory.
+    test ! -d "$ac_dir" && mkdir "$ac_dir"
+    ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`"
+    # A "../" for each directory in $ac_dir_suffix.
+    ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'`
+  else
+    ac_dir_suffix= ac_dots=
+  fi
+
+  case "$ac_given_srcdir" in
+  .)  srcdir=.
+      if test -z "$ac_dots"; then top_srcdir=.
+      else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;;
+  /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;;
+  *) # Relative path.
+    srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix"
+    top_srcdir="$ac_dots$ac_given_srcdir" ;;
+  esac
+
+
+  echo creating "$ac_file"
+  rm -f "$ac_file"
+  configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure."
+  case "$ac_file" in
+  *Makefile*) ac_comsub="1i\\
+# $configure_input" ;;
+  *) ac_comsub= ;;
+  esac
+
+  ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"`
+  sed -e "$ac_comsub
+s%@configure_input@%$configure_input%g
+s%@srcdir@%$srcdir%g
+s%@top_srcdir@%$top_srcdir%g
+" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file
+fi; done
+rm -f conftest.s*
+
+EOF
+cat >> $CONFIG_STATUS <<EOF
+
+EOF
+cat >> $CONFIG_STATUS <<\EOF
+
+exit 0
+EOF
+chmod +x $CONFIG_STATUS
+rm -fr confdefs* $ac_clean_files
+test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1
+
diff --git a/otherlibs/labltk/configure.in b/otherlibs/labltk/configure.in
new file mode 100644
index 0000000000..05097b94aa
--- /dev/null
+++ b/otherlibs/labltk/configure.in
@@ -0,0 +1,167 @@
+dnl     This file is an input file used by the GNU "autoconf" program to
+dnl     generate the file "configure", which in turn produces the files
+dnl     "Makefile.config" and "labltklink".
+dnl	If you don't have autoconf installed, simply use the "configure"
+dnl	script.
+dnl     Usage: 
+dnl	  $ autoconf configure.in > configure
+dnl	  edit site.config
+dnl       $ ./configure -with-config=site.config
+dnl     NOTE: autoconf 2.4 CHOKES on this. Use a newer version (e.g 2.7).
+
+dnl This is the file that must exist in srcdir
+AC_INIT(Widgets.src)
+
+dnl Rather use gcc
+AC_PROG_CC
+AC_HAVE_HEADERS(unistd.h limits.h)
+
+dnl Defaults for variables, overriden in site.config
+LIBEXT=
+TKNAME=tk
+
+dnl We need locations in the first place
+AC_ARG_WITH(config,
+   [    --with-config=Site specific locations of various software. Check the INSTALL instructions],
+   if test -f $withval; then
+     SITECFG=`dirname $withval`/`basename $withval`
+     . $SITECFG
+   else
+    AC_MSG_ERROR($withval does not exist)
+   fi,
+   AC_MSG_ERROR(
+You must provide a file giving the location of various software using the option --with-config=file. Check the INSTALL instructions))
+
+if test -z "$OCAMLLIBDIR"; then
+  AC_MSG_ERROR("OCAMLLIBDIR is still undefined. Edit $SITECFG")
+fi
+
+if test -z "$INSTALLDIR"; then
+  AC_MSG_ERROR("INSTALLDIR is still undefined. Edit $SITECFG")
+fi
+
+if test -z "$INSTALLBINDIR"; then
+  AC_MSG_ERROR("INSTALLBINDIR is still undefined. Edit $SITECFG")
+fi
+
+dnl builtin rule for X
+AC_PATH_XTRA
+WITH_X="$X_LIBS $X_PRE_LIBS -lX11 $X_EXTRA_LIBS"
+CPPFLAGS="$CPPFLAGS $X_CFLAGS"
+
+dnl builtin rule for ranlib
+AC_PROG_RANLIB
+
+dnl where is cpp
+AC_PATH_PROG(CPPPROG, cpp, /lib/cpp, $PATH)
+
+dnl As soon as we use this, we must have install-sh available. Damn.
+dnl AC_CANONICAL_HOST
+
+LIBS="-lm"
+
+### We probably need more
+AC_CHECK_LIB(dl, dlopen, LIBS="-ldl $LIBS")
+
+### Check for Tcl7.5(7.6,8.0) and Tk4.1(4.2)
+AC_CHECKING(Tcl and Tk includes and libraries)
+
+AC_CHECK_HEADERS(tcl.h,,
+  AC_MSG_ERROR(Can't find tcl.h. Check the CPPFLAGS variable in $SITECFG))
+
+AC_CHECK_HEADERS(tk.h,,
+  AC_MSG_ERROR(Can't find tk.h. Check the CPPFLAGS variable in $SITECFG))
+
+AC_MSG_CHECKING(Tcl version)
+### Check Tcl version
+tclver=no
+AC_EGREP_CPP(^VERSION=.*7\.5, [#include <tcl.h>
+VERSION=TCL_VERSION], tclver=7.5)
+if test $tclver = no; then
+AC_EGREP_CPP(^VERSION=.*7\.6, [#include <tcl.h>
+VERSION=TCL_VERSION], tclver=7.6)
+fi
+if test $tclver = no; then
+AC_EGREP_CPP(^VERSION=.*8\.0, [#include <tcl.h>
+VERSION=TCL_VERSION], tclver=8.0)
+fi
+if test $tclver = no; then
+AC_EGREP_CPP(^VERSION=.*8\.1, [#include <tcl.h>
+VERSION=TCL_VERSION], tclver=8.1)
+fi
+if test $tclver = no; then
+AC_EGREP_CPP(^VERSION=.*8\.2, [#include <tcl.h>
+VERSION=TCL_VERSION], tclver=8.2)
+fi
+AC_MSG_RESULT($tclver)
+
+case $tclver in
+7.5) tclmaj=7 tclmin=5 tkmaj=4 tkmin=1 ;;
+7.6) tclmaj=7 tclmin=6 tkmaj=4 tkmin=2 ;;
+8.0) tclmaj=8 tclmin=0 tkmaj=8 tkmin=0 ;;
+8.1) tclmaj=8 tclmin=1 tkmaj=8 tkmin=1 ;;
+8.2) tclmaj=8 tclmin=2 tkmaj=8 tkmin=2 ;;
+esac
+
+if test x$tkmaj = x8; then
+  CPPFLAGS="-DTK80 $CPPFLAGS"
+fi
+
+tcllib="tcl$tclmaj$tclmin$LIBEXT"
+tcllibd="tcl$tclmaj.$tclmin$LIBEXT"
+
+dnl We use Tcl_DoOneEvent to be sure to get version >= 7.5
+AC_CHECK_LIB($tcllibd, Tcl_DoOneEvent,
+             LIBS="-l$tcllibd $LIBS" tkver=$tkmaj.$tkmin,
+ AC_CHECK_LIB($tcllib, Tcl_DoOneEvent,
+	      LIBS="-l$tcllib $LIBS" tkver=$tkmaj$tkmin,
+  AC_CHECK_LIB(tcl$LIBEXT, Tcl_DoOneEvent, LIBS="-ltcl$LIBEXT $LIBS",
+    AC_MSG_ERROR(Can't find a tcl library.
+Check config.log to see what happened, and try setting LDFLAGS in $SITECFG),
+   $X_EXTRA_LIBS),
+  $X_EXTRA_LIBS),
+ $X_EXTRA_LIBS)
+
+tklib="${TKNAME}${tkver}${LIBEXT}"
+
+dnl We use Tk_SetGrid to be sure to get version >= 4.1
+AC_CHECK_LIB($tklib, Tk_SetGrid, LIBS="-l$tklib $LIBS",
+  AC_MSG_ERROR(Can't find a tk library.
+Check config.log to see what happened, and try setting LDFLAGS in $SITECFG),
+  $WITH_X -lm)
+
+dnl This is the file that we produce
+dnl These are the variables that are substituted in Makefile.config.in to
+dnl produce Makefile.config
+
+dnl The OCAML library
+AC_SUBST(OCAMLLIBDIR)
+
+dnl Install dir
+AC_SUBST(INSTALLDIR)
+AC_SUBST(INSTALLBINDIR)
+
+dnl Info collected about X
+dnl The includes and options
+dnl AC_SUBST(X_CFLAGS)
+
+dnl The libraries
+dnl special trick to substitute -L and -l ...
+dnl All options (for cc compilation)
+AC_SUBST(WITH_X)
+dnl X link options
+AC_SUBST(X_LIBS)
+THE_X_LIBS="$X_PRE_LIBS -lX11 $X_EXTRA_LIBS"
+AC_SUBST(THE_X_LIBS)
+
+dnl Tcl/Tk
+dnl CPPFLAGS, LIBS and LDFLAGS are substituted by default
+
+dnl Info collected about ranlib
+AC_SUBST(RANLIB)
+AC_SUBST(CPPPROG)
+dnl LIBS is subsituted by default
+AC_SUBST(OCAMLSRCDIR)
+
+dnl Files to generate
+AC_OUTPUT(Makefile.config labltk labltklink labltkopt)
diff --git a/otherlibs/labltk/example/Lambda2.back.gif b/otherlibs/labltk/example/Lambda2.back.gif
new file mode 100644
index 0000000000..7cb3d2c139
--- /dev/null
+++ b/otherlibs/labltk/example/Lambda2.back.gif
diff --git a/otherlibs/labltk/example/Makefile b/otherlibs/labltk/example/Makefile
new file mode 100644
index 0000000000..c30d2aa385
--- /dev/null
+++ b/otherlibs/labltk/example/Makefile
@@ -0,0 +1,46 @@
+include ../Makefile.config
+
+COMPFLAGS=-I ../lib -I ../support 
+
+TKLINKOPT= -ccopt -L../support -cclib -llabltk41 $(TKLIBS) $(X11_LIBS)
+
+all: hello demo eyes calc clock tetris
+
+opt: hello.opt demo.opt eyes.opt calc.opt tetris.opt
+
+hello: hello.cmo
+	$(LABLC) -custom $(COMPFLAGS) -o hello tk41.cma hello.cmo $(TKLINKOPT)
+
+demo: demo.cmo
+	$(LABLC) -custom $(COMPFLAGS) -o demo tk41.cma demo.cmo $(TKLINKOPT)
+
+eyes: eyes.cmo
+	$(LABLC) -custom $(COMPFLAGS) -o eyes tk41.cma eyes.cmo $(TKLINKOPT)
+
+calc: calc.cmo
+	$(LABLC) -custom $(COMPFLAGS) -o calc tk41.cma calc.cmo $(TKLINKOPT)
+
+clock: clock.cmo
+	$(LABLC) -custom $(COMPFLAGS) -o clock tk41.cma unix.cma clock.cmo \
+	      $(TKLINKOPT) -cclib -lunix
+
+tetris: tetris.cmo
+	$(LABLC) -custom $(COMPFLAGS) -o tetris tk41.cma tetris.cmo $(TKLINKOPT)
+
+clean:
+	rm -f hello demo eyes calc clock tetris *.opt *.o *.cm*
+
+.SUFFIXES :
+.SUFFIXES : .mli .ml .cmi .cmx .cmo .opt
+
+.mli.cmi:
+	$(LABLCOMP) $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(LABLCOMP) $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $(COMPFLAGS) $<
+
+.cmx.opt:
+	labltkopt $(COMPFLAGS) -o $@ $<
diff --git a/otherlibs/labltk/example/README b/otherlibs/labltk/example/README
new file mode 100644
index 0000000000..71bbaca796
--- /dev/null
+++ b/otherlibs/labltk/example/README
@@ -0,0 +1,18 @@
+$Id$
+
+Some examples for LablTk. They must be compiled with the -modern
+option, except for hello.ml and calc.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
+
+tetris.ml	You NEED a game also. Edit it to set a background
+
diff --git a/otherlibs/labltk/example/calc.ml b/otherlibs/labltk/example/calc.ml
new file mode 100644
index 0000000000..a330a9ecb3
--- /dev/null
+++ b/otherlibs/labltk/example/calc.ml
@@ -0,0 +1,112 @@
+(* $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 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 to:(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 to:""; displaying <- false);
+	calc#insert s
+    | '.' ->
+	if displaying then
+	  (calc#set to:"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 key:c ops)
+	| Some f ->
+	    x <- f x (calc#get_float);
+	    op <- Some (List.assoc key:c ops);
+	    calc#set to:(string_of_float x)
+	end
+    | '='|'\n'|'\r' ->
+	displaying <- true;
+	begin match op with
+	  None -> ()
+	| Some f ->
+	    x <- f x (calc#get_float);
+	    op <- None;
+	    calc#set to:(string_of_float 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 :parent anchor:`E relief:`Sunken padx:(`Pix 10) ()
+  val frame = Frame.create :parent ()
+
+  initializer
+    let buttons =
+      Array.map fun:
+	(List.map fun:
+	   (fun text ->
+	     Button.create parent:frame :text
+	       command:(fun () -> calc#command text) ()))
+	m
+    in
+    Label.configure textvariable:variable label;
+    calc#set to:"0";
+    bind parent events:[[],`KeyPress]
+      action:(`Set([`Char],fun ev -> calc#command ev.ev_Char));
+    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/example/clock.ml b/otherlibs/labltk/example/clock.ml
new file mode 100644
index 0000000000..0aa0ab74d7
--- /dev/null
+++ b/otherlibs/labltk/example/clock.ml
@@ -0,0 +1,115 @@
+(* $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 :parent width:(`Pix 100) height:(`Pix 100) ()
+  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 = `Pix (truncate (float width *. (x0 +. 1.) /. 2.))
+  method y y0 = `Pix (truncate (float height *. (y0 +. 1.) /. 2.))
+
+  initializer
+    (* Create the oval border *)
+    Canvas.create_oval canvas tags:[`Tag "cadran"]
+      x1:(`Pix 1) y1:(`Pix 1)
+      x2:(`Pix (width - 2)) y2:(`Pix (height - 2))
+      width:(`Pix 3) outline:(`Yellow) fill:`White;
+    (* Draw the figures *)
+    self#draw_figures;
+    (* Create the arrows with dummy position *)
+    Canvas.create_line canvas tags:[`Tag "hours"] fill:`Red
+      xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.];
+    Canvas.create_line canvas tags:[`Tag "minutes"] fill:`Blue
+      xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.];
+    Canvas.create_line canvas tags:[`Tag "seconds"] fill:`Black
+      xys:[self#x 0.; self#y 0.; self#x 0.; self#y 0.];
+    (* 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:(`Set ([], fun _ ->
+	width <- Winfo.width canvas;
+	height <- Winfo.height canvas;
+	self#redraw));
+    (* Change direction with right button *)
+    bind canvas events:[[],`ButtonPressDetail 3]
+      action:(`Set ([], fun _ -> rflag <- -rflag; self#redraw));
+    (* Pack, expanding in both directions *)
+    pack [canvas] fill:`Both expand:true
+
+  (* Redraw everything *)
+  method redraw =
+    Canvas.coords_set canvas tag:(`Tag "cadran")
+      coords:[ `Pix 1; `Pix 1;
+	       `Pix (width - 2); `Pix (height - 2) ];
+    self#draw_figures;
+    self#draw_arrows (Unix.localtime (Unix.time ()))
+
+  (* Delete and redraw the figures *)
+  method draw_figures =
+    Canvas.delete canvas tags:[`Tag "figures"];
+    for i = 1 to 12 do
+      let angle = float (rflag * i - 3) *. pi /. 6. in
+      Canvas.create_text canvas tags:[`Tag "figures"]
+	text:(string_of_int i) font:"variable"
+	x:(self#x (0.8 *. cos angle))
+	y:(self#y (0.8 *. sin angle))
+	anchor:`Center
+    done
+
+  (* Resize and reposition the arrows *)
+  method draw_arrows tm =
+    Canvas.configure_line canvas tag:(`Tag "hours")
+      width:(`Pix (min width height / 40));
+    let hangle =
+      float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180)
+	*. pi /. 360. in
+    Canvas.coords_set canvas tag:(`Tag "hours")
+      coords:[ self#x 0.; self#y 0.;
+	       self#x (cos hangle /. 2.); self#y (sin hangle /. 2.) ];
+    Canvas.configure_line canvas tag:(`Tag "minutes")
+      width:(`Pix (min width height / 50));
+    let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in
+    Canvas.coords_set canvas tag:(`Tag "minutes")
+      coords:[ 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:(`Tag "seconds")
+      coords:[ 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/example/demo.ml b/otherlibs/labltk/example/demo.ml
new file mode 100644
index 0000000000..897d4b9e48
--- /dev/null
+++ b/otherlibs/labltk/example/demo.ml
@@ -0,0 +1,150 @@
+(* Some CamlTk4 Demonstration by JPF *)
+
+(* First, open these modules for convenience *)
+open Tk
+
+(* Dummy let *)
+let _ =
+
+(* Initialize Tk *)
+let top = openTk () in 
+(* Title setting *)
+Wm.title_set top title:"LablTk demo";
+
+(* Base frame *)
+let base = Frame.create parent:top () in
+pack [base];
+
+(* Menu bar *)
+let bar =
+  Frame.create parent: base borderwidth: (`Pix 2) relief: `Raised  () in 
+pack [bar] fill: `X;
+
+  (* Menu and Menubutton *)
+  let meb = Menubutton.create parent: bar text: "Menu" () in
+  let men = Menu.create parent: meb () in
+  Menu.add_command men label: "Quit" command: (fun () -> closeTk (); exit 0);
+  Menubutton.configure meb menu: men; 
+  
+  (* Frames *)
+  let base2 = Frame.create parent:base () in
+  let left = Frame.create parent:base2 () in
+  let right = Frame.create parent:base2 () in
+  pack [base2];
+  pack [left; right] side: `Left;
+  
+    (* Widgets on left and right *)
+    
+    (* Button *)
+    let but = Button.create parent: left text: "Welcome to LablTk" () in
+    
+    (* Canvas *)
+    let can = Canvas.create parent: left width: (`Pix 100) 
+      height: (`Pix 100) borderwidth: (`Pix 1) relief: `Sunken ()
+    in
+    Canvas.create_oval can x1:(`Pix 10) y1:(`Pix 10) 
+                           x2:(`Pix 90) y2:(`Pix 90)
+      	                   fill:`Red; 
+
+    (* Check button *)
+    let che = Checkbutton.create parent: left text: "Check" () in
+    
+    (* Entry *)
+    let ent = Entry.create parent: left width: 10 () in 
+    
+    (* Label *)
+    let lab = Label.create parent: left text: "Welcome to LablTk" () in
+    
+    (* Listbox *)
+    let lis = Listbox.create parent: left () in
+    Listbox.insert lis index: `End texts: ["This"; "is"; "Listbox"];
+    
+    (* Message *)
+    let mes = Message.create parent: left ()
+      text: "Hello this is a message widget with very long text, but ..." in
+    
+    (* Radio buttons *)
+    let tv = Textvariable.create () in
+    Textvariable.set tv to: "One";
+    let radf = Frame.create parent: right () in
+    let rads = List.map fun:(fun t ->
+      Radiobutton.create parent: radf text: t value: t variable: tv ())
+  	["One"; "Two"; "Three"] in
+    
+    (* Scale *)
+    let sca = Scale.create parent:right label: "Scale" length: (`Pix 100) 
+      showvalue: true () in
+    
+    (* Text and scrollbar *)
+    let texf = Frame.create parent:right () in 
+    
+      (* Text *)
+      let tex = Text.create parent:texf width: 20 height: 8 () in
+      Text.insert tex text: "This is a text widget." index: (`End,[])
+      	 tags: [];
+      
+      (* Scrollbar *)
+      let scr = Scrollbar.create parent:texf () in
+      
+      (* Text and Scrollbar widget link *)
+      let scroll_link sb tx =
+      	Text.configure tx yscrollcommand: (Scrollbar.set sb);
+      	Scrollbar.configure sb command: (Text.yview tx) in
+      scroll_link scr tex;
+      
+      pack [scr] side: `Right fill: `Y;
+      pack [tex] side: `Left fill: `Both expand: true;
+       
+    (* Pack them *)
+    pack [meb] side: `Left;
+    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 parent:top () in
+  Wm.title_set top2 title:"LablTk demo control";
+  let defcol = `Color "#dfdfdf" in
+  let selcol = `Color "#ffdfdf" in
+  let buttons = 
+    List.map fun:(fun (w, t, c, a) ->
+        let b = Button.create parent:top2 text:t command:c () in
+        bind b events: [[], `Enter] 
+               action:(`Set ([], fun _ -> a selcol));
+        bind b events: [[], `Leave] 
+               action:(`Set ([], fun _ -> a defcol));
+        b)
+      [coe bar, "Frame", (fun () -> ()),
+       (fun background -> Frame.configure bar :background);
+       coe meb, "Menubutton", (fun () -> ()),
+       (fun background -> Menubutton.configure meb :background);
+       coe but, "Button", (fun () -> ()),
+       (fun background -> Button.configure but :background);
+       coe can, "Canvas", (fun () -> ()),
+       (fun background -> Canvas.configure can :background);
+       coe che, "CheckButton", (fun () -> ()),
+       (fun background -> Checkbutton.configure che :background);
+       coe ent, "Entry", (fun () -> ()),
+       (fun background -> Entry.configure ent :background);
+       coe lab, "Label", (fun () -> ()),
+       (fun background -> Label.configure lab :background);
+       coe lis, "Listbox", (fun () -> ()),
+       (fun background -> Listbox.configure lis :background);
+       coe mes, "Message", (fun () -> ()),
+       (fun background -> Message.configure mes :background);
+       coe radf, "Radiobox", (fun () -> ()),
+       (fun background ->
+      	 List.iter rads fun:(fun b -> Radiobutton.configure b :background));
+       coe sca, "Scale", (fun () -> ()),
+       (fun background -> Scale.configure sca :background);
+       coe tex, "Text", (fun () -> ()),
+       (fun background -> Text.configure tex :background);
+       coe scr, "Scrollbar", (fun () -> ()),
+       (fun background -> Scrollbar.configure scr :background)
+      ]
+  in
+    pack buttons fill: `X;
+
+(* Main Loop *)
+Printexc.print mainLoop () 
+
diff --git a/otherlibs/labltk/example/eyes.ml b/otherlibs/labltk/example/eyes.ml
new file mode 100644
index 0000000000..1f281d66c1
--- /dev/null
+++ b/otherlibs/labltk/example/eyes.ml
@@ -0,0 +1,43 @@
+open Tk
+
+let _ =
+ let top = openTk () in
+ let fw = Frame.create parent: top () in
+   pack [fw];
+   let c = Canvas.create parent: fw width: (`Pix 200) height: (`Pix 200) () in
+   let create_eye cx cy wx wy ewx ewy bnd =
+     let o2 = Canvas.create_oval c 
+       x1:(`Pix (cx - wx)) y1:(`Pix (cy - wy)) 
+       x2:(`Pix (cx + wx)) y2:(`Pix (cy + wy)) 
+         outline: (`Color "black") width: (`Pix 7) 
+      	 fill: (`Color "white") 
+     and o = Canvas.create_oval c 
+       x1:(`Pix (cx - ewx)) y1:(`Pix (cy - ewy)) 
+       x2:(`Pix (cx + ewx)) y2:(`Pix (cy + ewy)) 
+      	   fill: (`Color "black") in
+     let curx = ref cx
+     and cury = ref cy in
+       bind c events:[[], `Motion]
+         action: (`Extend ([`MouseX; `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 tag: o 
+	     x: (`Pix (nx - !curx)) y: (`Pix (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/example/hello.ml b/otherlibs/labltk/example/hello.ml
new file mode 100644
index 0000000000..5e890aadaf
--- /dev/null
+++ b/otherlibs/labltk/example/hello.ml
@@ -0,0 +1,20 @@
+(* 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 parent: top text: "Hello, LablTk!" ()
+
+(* 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/example/hello.tcl b/otherlibs/labltk/example/hello.tcl
new file mode 100755
index 0000000000..9e9985c155
--- /dev/null
+++ b/otherlibs/labltk/example/hello.tcl
@@ -0,0 +1,5 @@
+#!/usr/local/bin/wish4.0
+
+button .hello -text "Hello, TclTk!"
+
+pack .hello
diff --git a/otherlibs/labltk/example/tetris.ml b/otherlibs/labltk/example/tetris.ml
new file mode 100644
index 0000000000..bfc60db076
--- /dev/null
+++ b/otherlibs/labltk/example/tetris.ml
@@ -0,0 +1,691 @@
+(* tetris.ml : a Tetris game for LablTk *)
+(* written by Jun P. Furuse             *)
+
+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 fun: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 tag: t1
+	x:(`Pix (- block_size * (x + 1) -10 - cell_border * 2))
+	y:(`Pix (- block_size * (y + 1) -10 - cell_border * 2));
+      Canvas.move canvas tag: t2
+	x:(`Pix (- block_size * (x + 1) -10 - cell_border * 2))
+	y:(`Pix (- block_size * (y + 1) -10 - cell_border * 2));
+      Canvas.move canvas tag: t3
+	x:(`Pix (- block_size * (x + 1) -10 - cell_border * 2))
+	y:(`Pix (- block_size * (y + 1) -10 - cell_border * 2))
+    end else begin
+      Canvas.configure_rectangle canvas tag: t2
+	fill: colors.(col - 1)
+	outline: colors.(col - 1);
+      Canvas.configure_rectangle canvas tag: t1
+	fill: `Black
+	outline: `Black;
+      Canvas.configure_rectangle canvas tag: t3
+	fill: (`Color "light gray")
+	outline: (`Color "light gray");
+      if color = 0 & col <> 0 then begin
+	Canvas.move canvas tag: t1
+      	  x: (`Pix (block_size * (x+1)+10+ cell_border*2))
+          y: (`Pix (block_size * (y+1)+10+ cell_border*2));
+	Canvas.move canvas tag: t2
+          x: (`Pix (block_size * (x+1)+10+ cell_border*2))
+          y: (`Pix (block_size * (y+1)+10+ cell_border*2));
+	Canvas.move canvas tag: t3
+          x: (`Pix (block_size * (x+1)+10+ cell_border*2))
+          y: (`Pix (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 parent: fw borderwidth: (`Pix 2) () in
+  let c = Canvas.create parent: f width: (`Pix (block_size * 10))
+			          height: (`Pix (block_size * 20))
+				  borderwidth: (`Pix cell_border)
+				  relief: `Sunken
+				  background: `Black ()
+  and r = Frame.create parent:f ()
+  and r' = Frame.create parent:f () in
+
+  let nl = Label.create parent:r text: "Next"  font: "variable" () in
+  let nc = Canvas.create parent:r width: (`Pix (block_size * 4))
+                                  height: (`Pix (block_size * 4))
+				  borderwidth: (`Pix cell_border)
+				  relief: `Sunken
+                                  background: `Black () in
+  let scl = Label.create parent: r text: "Score" font: "variable" () in
+  let sc = Label.create parent:r textvariable: scorev font: "variable" () in
+  let lnl = Label.create parent:r text: "Lines" font: "variable" () in
+  let ln = Label.create parent: r textvariable: linev font: "variable" () in
+  let levl = Label.create parent: r text: "Level" font: "variable" () in
+  let lev = Label.create parent: r textvariable: levv font: "variable" () in 
+  let newg = Button.create parent: 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 fun:
+      (Array.map fun:
+	 begin fun (x,y) ->
+	   let t1 =
+	     Canvas.create_rectangle c 
+      	       x1:(`Pix (-block_size - 8)) y1:(`Pix (-block_size - 8))
+               x2:(`Pix (-9))              y2:(`Pix (-9))
+	   and t2 =
+	     Canvas.create_rectangle c 
+      	       x1:(`Pix (-block_size - 10)) y1:(`Pix (-block_size - 10))
+               x2:(`Pix (-11))              y2:(`Pix (-11))
+	   and t3 =
+	     Canvas.create_rectangle c
+      	       x1:(`Pix (-block_size - 12)) y1:(`Pix (-block_size - 12))
+               x2:(`Pix (-13))              y2:(`Pix (-13))
+	   in
+	   Canvas.raise c tag: t1;
+	   Canvas.raise c tag: t2;
+	   Canvas.lower c tag: 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 fun:
+      (Array.map fun:
+	 begin fun (x,y) ->
+	   let t1 =
+	     Canvas.create_rectangle nc 
+      	       x1:(`Pix (-block_size - 8)) y1:(`Pix (-block_size - 8))
+               x2:(`Pix (-9))              y2:(`Pix (-9))
+	   and t2 =
+	     Canvas.create_rectangle nc 
+      	       x1:(`Pix (-block_size - 10)) y1:(`Pix (-block_size - 10))
+               x2:(`Pix (-11))              y2:(`Pix (-11))
+	   and t3 =
+	     Canvas.create_rectangle nc 
+      	       x1:(`Pix (-block_size - 12)) y1:(`Pix (-block_size - 12))
+               x2:(`Pix (-13))              y2:(`Pix (-13))
+	   in
+	   Canvas.raise nc tag: t1;
+	   Canvas.raise nc tag: t2;
+	   Canvas.lower nc tag: 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:milli do:f =
+  timer_ref := Some (Timer.add ms: milli callback: 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 parent:top ()
+  and fw = Frame.create parent: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 fun:(List.map fun:decode_block) blocks in
+  let field = Array.create len: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 pos: 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 pos: 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 pos: 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 pos: !next)) 
+      x: 0 y: 0 
+     
+  and erase_next () =
+    draw_block next_field color: 0 
+      block: (List.hd (List.nth blocks pos: !next)) 
+      x: 0 y: 0 
+  in
+
+  let set_nextblock () =
+    current := 
+       { pattern= (List.nth blocks pos: !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 pos: 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: (`Pix (block_size * 5 + block_size / 2)) 
+      	y: (`Pix (block_size * 10 + block_size / 2))
+        anchor: `Center in
+    Canvas.lower canvas tag: i;
+    let img = Imagephoto.create () in
+    fun file ->
+      try 
+	Imagephoto.configure img file: file;
+	Canvas.configure_image canvas tag: 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 to: (string_of_int !line);
+    Textvariable.set scorev to: (string_of_int !score); 
+
+    if !line /10 <> pline /10 then 
+       (* undate 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 pos: n in
+        image_load file;
+	incr level; 
+        Textvariable.set levv to: (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 do: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 do:
+	  begin fun () ->
+            let l = clear !current in
+            if l > 0 then
+              do_after ms:stop_a_bit do:
+		begin fun () ->
+		  fall_lines ();
+		  add_score l;
+		  do_after ms:stop_a_bit do:newblock
+		end
+            else
+              newblock ()
+	  end
+      end
+    else
+      begin
+        erase_falling_block !current;
+        draw_falling_block m;
+        current := m;
+	do_after ms:!time do:loop
+      end
+  in
+
+  let bind_game w =
+    bind w events:[[],`KeyPress] action:(`Set ([`KeySymString],
+       fun e -> 
+   	 begin 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  
+   	 | _ -> ()	    
+   	 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 do:loop
+  in
+    (* As an applet, it was required... *)
+    (* List.iter fun: bind_game widgets; *)
+  bind_game top; 
+  Button.configure button command: game_init;
+  game_init ()
+
+let _ = Printexc.print mainLoop ()
diff --git a/otherlibs/labltk/jpf/Makefile b/otherlibs/labltk/jpf/Makefile
new file mode 100644
index 0000000000..0e31823054
--- /dev/null
+++ b/otherlibs/labltk/jpf/Makefile
@@ -0,0 +1,75 @@
+include ../Makefile.config
+
+COMPFLAGS=-I ../lib -I ../support
+
+OBJS= fileselect.cmo balloon.cmo
+
+OBJSX = $(OBJS:.cmo=.cmx)
+
+TKLINKOPT=$(STATIC) \
+	  -ccopt -L../support -cclib -llabltk41 \
+	  $(TKLIBS) $(X11_LIBS)
+
+all: libjpf.cma
+
+opt: libjpf.cmxa
+
+test: balloontest
+
+testopt: balloontest.opt
+
+libjpf.cma: $(OBJS)
+	$(LABLLIBR) -o libjpf.cma $(OBJS)
+
+libjpf.cmxa: $(OBJSX)
+	$(CAMLOPTLIBR) -o libjpf.cmxa $(OBJSX)
+
+install: libjpf.cma
+	cp *.cmi *.mli libjpf.cma $(INSTALLDIR)
+
+installopt: libjpf.cmxa
+	cp libjpf.cmxa libjpf.a $(INSTALLDIR)
+
+clean:
+	rm -f *.cm* *.o *.a *~ *test
+
+### Tests
+
+balloontest: balloontest.cmo 
+	$(LABLC) -o balloontest -I ../support -I ../lib \
+	        -custom tk41.cma libjpf.cma balloontest.cmo $(TKLINKOPT)
+
+balloontest.opt: balloontest.cmx
+	$(CAMLOPT) -o balloontest.opt -I ../support -I ../lib \
+	        tk41.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:
+	$(LABLCOMP) $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(LABLCOMP) $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $(COMPFLAGS) $<
+
+depend: 
+	mv Makefile Makefile.bak
+	(sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \
+	 $(LABLDEP) *.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/balloon.ml b/otherlibs/labltk/jpf/balloon.ml
new file mode 100644
index 0000000000..52f00c8395
--- /dev/null
+++ b/otherlibs/labltk/jpf/balloon.ml
@@ -0,0 +1,100 @@
+(* $Id$ *)
+
+(* easy balloon help facility *)
+
+open Tk
+open Widget
+open Protocol
+
+(* 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.tkEval [| 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... *)
+	  geometry: ("+"^(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 fun: (fun x ->
+    bind w events: x action: (`Extend ([], (fun _ -> 
+(*      begin
+	match x with
+	  [[],Leave] -> prerr_endline " LEAVE reset "
+	| _ -> prerr_endline " Other reset "
+      end; 
+*)
+      reset ()))))
+      [[[], `Leave]; [[], `ButtonPress]; [[], `ButtonRelease]; [[], `Destroy];
+       [[], `KeyPress]; [[], `KeyRelease]];
+  List.iter fun: (fun x ->
+    bind w events:x action: (`Extend ([`RootX; `RootY], (fun ev -> 
+(*
+      begin
+	match x with
+	  [[],Enter] -> prerr_endline " Enter set "
+	| [[],Motion] -> prerr_endline " Motion set "
+	| _ -> prerr_endline " ??? set "
+      end;
+*)
+      reset (); set ev))))
+      [[[], `Enter]; [[], `Motion]]
+
+let init () =
+  let t = Hashtbl.create 101 in
+  Protocol.add_destroy_hook (fun w ->
+    Hashtbl.remove t key:w);
+  topw := Toplevel.create parent:default_toplevel ();
+  Wm.overrideredirect_set !topw to: true;
+  Wm.withdraw !topw;
+  popupw := Message.create parent:!topw name: "balloon" ()
+	      background: (`Color "yellow") aspect: 300;
+  pack [!popupw];
+  class_bind "all" 
+    events: [[], `Enter] action: (`Extend ([`Widget], (function w ->
+    try Hashtbl.find t key: w.ev_Widget with
+      Not_found -> begin
+	Hashtbl.add t key:w.ev_Widget data: ();
+	let x = Option.get w.ev_Widget name: "balloon" class: "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
new file mode 100644
index 0000000000..32d2365d6d
--- /dev/null
+++ b/otherlibs/labltk/jpf/balloon.mli
@@ -0,0 +1,6 @@
+(* 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
new file mode 100644
index 0000000000..c3403ac178
--- /dev/null
+++ b/otherlibs/labltk/jpf/balloontest.ml
@@ -0,0 +1,14 @@
+open Tk
+open Widget
+open Balloon
+open Protocol
+
+let _ =
+let t = openTk () in
+Balloon.init ();
+let b = Button.create parent: 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
new file mode 100644
index 0000000000..2720d3b551
--- /dev/null
+++ b/otherlibs/labltk/jpf/fileselect.ml
@@ -0,0 +1,355 @@
+(* $Id$ *)
+
+(* file selection box *)
+
+open Unix
+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: (`Set ([], fun _ -> Focus.set w));;
+
+let myentry_create p :variable =
+  let w = Entry.create parent: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 w 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 () = 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 flags:[] 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 "/+") with:"/" src in
+  (* replace /./ by / *)
+  let s = global_replace (regexp "/\./") with:"/" s in
+  (* replace ????/../ by "" *)
+  let s = global_replace 
+    (regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\./") 
+      with:""  s in
+  (* replace ????/..$ by "" *)
+  let s = global_replace 
+    (regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\.$") 
+      with:"" s in
+  (* replace ^/../../ by / *)
+  let s = global_replace (regexp "^\(/\.\.\)+/") with:"/" s in
+  if string_match dirget s pos: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 () =
+   try 
+    let x = readdir dirh in  (* no let cause Out of memory *)
+      x::(get_them ())
+   with
+      End_of_file -> closedir dirh; [] 
+  in
+    Sort.list order:(<) (get_them ())
+      
+let rec get_directories_in_files path = function
+    [] -> []
+  | x::xs -> 
+      if try (stat (path ^ x)).st_kind = S_DIR with _ -> false then
+      	x::(get_directories_in_files path xs)
+      else get_directories_in_files path xs
+
+let remove_directories dirname = 
+  let rec remove = function
+    [] -> []
+  | x :: xs ->
+    if try (stat (dirname ^ x)).st_kind = S_DIR with _ -> true then 
+      remove xs
+    else  
+      x :: (remove xs)
+  in remove
+
+(************************* 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] 
+      action: (`Set([`Char; `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 events:[[], `KeyPressDetail "Return"] action:(`Set([], 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 parent: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 parent:tl borderwidth: (`Pix 1) relief: `Raised () in
+    let frm = Frame.create parent:frm' borderwidth: (`Pix 8) () in
+    let fl = Label.create parent: frm text: "Filter" () in
+    let df = Frame.create parent:frm () in
+      let dfl = Frame.create parent:df () in
+        let dfll = Label.create parent:dfl text: "Directories" () in
+	let dflf = Frame.create parent:dfl () in
+          let directory_listbox = Listbox.create parent:dflf relief: `Sunken ()
+          and directory_scrollbar = Scrollbar.create parent:dflf () in
+            scroll_link directory_scrollbar directory_listbox; 
+      let dfr = Frame.create parent:df () in
+        let dfrl = Label.create parent:dfr text: "Files" () in
+	let dfrf = Frame.create parent:dfr () in
+	  let filter_listbox = Listbox.create parent:dfrf relief: `Sunken () in
+	  let filter_scrollbar = Scrollbar.create parent:dfrf () in
+	    scroll_link filter_scrollbar filter_listbox;
+    let sl = Label.create parent: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 parent:tl borderwidth: (`Pix 1) relief: `Raised () in
+    let cfrm = Frame.create parent:cfrm' borderwidth: (`Pix 8) () in
+    let dumf = Frame.create parent:cfrm () in
+    let dumf2 = Frame.create parent:cfrm () in
+
+  let configure filter =
+    (* OLDER let curdir = getcwd () in *)
+(* Printf.eprintf "CURDIR %s\n" curdir; *)
+    let filter =
+      if string_match  (regexp "^/.*") filter pos: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 to:filter;
+  	Textvariable.set selection_var to:(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 to:"1"
+      end
+    else 
+      begin
+	proc l; 
+	break ()
+      end 
+  in
+  
+  (* and buttons *)
+    let okb = Button.create parent:cfrm text: "OK" () command:
+      begin fun () -> 
+      	let files = 
+      	  List.map (Listbox.curselection filter_listbox) 
+	    fun:(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 parent:cfrm text: "Filter" ()
+      command: (fun () -> configure (Textvariable.get filter_var)) in
+    let ccb = Button.create parent:cfrm text: "Cancel" ()
+      command: (fun () -> activate [] ()) in
+
+  (* binding *)
+  bind selection_entry events:[[], `KeyPressDetail "Return"] 
+    action:(`Setbreakable ([], fun _ -> 
+      activate [Textvariable.get selection_var] () )); 
+  bind filter_entry events:[[], `KeyPressDetail "Return"] action:(`Set ([], 
+    fun _ -> configure (Textvariable.get filter_var) ));
+  
+  let action _ = 
+      let files = 
+      	List.map (Listbox.curselection filter_listbox)
+	  fun:(fun x -> !current_dir ^ (Listbox.get filter_listbox index:x)) 
+      in
+      	activate files () 
+  in
+  bind filter_listbox events:[[`Double], `ButtonPressDetail 1] 
+			      action:(`Setbreakable ([], 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:[[`Double], `ButtonPressDetail 1]
+				 action:(`Setbreakable ([], 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: (`Pix 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
new file mode 100644
index 0000000000..6f7f15b9d1
--- /dev/null
+++ b/otherlibs/labltk/jpf/fileselect.mli
@@ -0,0 +1,18 @@
+open Support
+
+(* fileselect.mli *)
+
+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/labl.gif b/otherlibs/labltk/labl.gif
new file mode 100644
index 0000000000..78e98dd4af
--- /dev/null
+++ b/otherlibs/labltk/labl.gif
diff --git a/otherlibs/labltk/labltk.in b/otherlibs/labltk/labltk.in
new file mode 100644
index 0000000000..cc0d1b15cd
--- /dev/null
+++ b/otherlibs/labltk/labltk.in
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+exec @INSTALLDIR@/labltktop -I @INSTALLDIR@ $*
diff --git a/otherlibs/labltk/labltklink.in b/otherlibs/labltk/labltklink.in
new file mode 100644
index 0000000000..e4f87210cf
--- /dev/null
+++ b/otherlibs/labltk/labltklink.in
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+# links with the tcl, tk and X11 libraries
+
+exec ocamlc -custom -I @INSTALLDIR@ tk41.cma $* \
+    -cclib "-L@INSTALLDIR@ -llabltk41" \
+    -cclib "@LDFLAGS@ @LIBS@" \
+    -cclib "@X_LIBS@ @THE_X_LIBS@"
diff --git a/otherlibs/labltk/labltklink.tmpl b/otherlibs/labltk/labltklink.tmpl
new file mode 100644
index 0000000000..d54f6a2232
--- /dev/null
+++ b/otherlibs/labltk/labltklink.tmpl
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+# links with the tcl, tk and X11 libraries
+
+exec olablc -custom -I /usr/local/lib/olabl/labltk41 tk41.cma $* \
+    -ccopt -L/usr/local/lib/olabl/labltk41 -cclib -llabltk41 \
+    -ccopt "-L/usr/local/lib" -cclib "-ltk4.2jp -ltcl7.6jp" \
+    -ccopt "" -cclib " -lX11"
diff --git a/otherlibs/labltk/labltkopt.in b/otherlibs/labltk/labltkopt.in
new file mode 100644
index 0000000000..d17e6e43d3
--- /dev/null
+++ b/otherlibs/labltk/labltkopt.in
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+# links with the tcl, tk and X11 libraries
+
+exec ocamlopt -I @INSTALLDIR@ tk41.cmxa $* \
+    -cclib "-L@INSTALLDIR@ -llabltk41" \
+    -cclib "@LDFLAGS@ @LIBS@" \
+    -cclib "@X_LIBS@ @THE_X_LIBS@"
diff --git a/otherlibs/labltk/lib/.cvsignore b/otherlibs/labltk/lib/.cvsignore
new file mode 100644
index 0000000000..c555693118
--- /dev/null
+++ b/otherlibs/labltk/lib/.cvsignore
@@ -0,0 +1,3 @@
+*.ml *.mli labltktop
+modules
+.depend
diff --git a/otherlibs/labltk/lib/Makefile b/otherlibs/labltk/lib/Makefile
new file mode 100644
index 0000000000..0931fee20c
--- /dev/null
+++ b/otherlibs/labltk/lib/Makefile
@@ -0,0 +1,65 @@
+include ../Makefile.config
+
+COMPFLAGS= -I ../support
+
+TKLINKOPT=$(STATIC) \
+          -ccopt -L../support -cclib -llabltk41 \
+	  $(TKLIBS) $(X11_LIBS)
+
+
+SUPPORT=../support/support.cmo ../support/widget.cmo ../support/protocol.cmo \
+        ../support/textvariable.cmo ../support/timer.cmo \
+        ../support/fileevent.cmo
+
+SUPPORTX = $(SUPPORT:.cmo=.cmx)
+
+all : tk41.cma labltktop
+
+opt : tk41.cmxa
+
+include ./modules
+WIDGETOBJSX = $(WIDGETOBJS:.cmo=.cmx)
+
+tk41.cma : $(SUPPORT) $(WIDGETOBJS) tk.cmo 
+	$(LABLLIBR) -o tk41.cma $(SUPPORT) tk.cmo $(WIDGETOBJS)
+
+tk41.cmxa : $(SUPPORTX) $(WIDGETOBJSX) tk.cmx
+	$(CAMLOPTLIBR) -o tk41.cmxa $(SUPPORTX) tk.cmx $(WIDGETOBJSX)
+
+## Until olabltktop is fixed (next release), we in-line it
+## (otherwise our trick with -ccopt is broken)
+
+labltktop : $(WIDGETOBJS) $(SUPPORT)
+	$(LABLC) -custom -linkall -o labltktop -I ../support $(TKLINKOPT) \
+	       toplevellib.cma tk41.cma topmain.cmo
+
+# All .{ml,mli} files are generated in this directory
+clean : 
+	rm -f *.cm* *.ml *.mli *.o *.a labltktop
+
+install: tk41.cma labltktop
+	cp *.cmi tk41.cma labltktop $(INSTALLDIR)
+	chmod 644 $(INSTALLDIR)/*.cmi
+	chmod 644 $(INSTALLDIR)/tk41.cma
+	chmod 755 $(INSTALLDIR)/labltktop
+
+
+installopt: tk41.cmxa
+	if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
+	cp tk41.cmxa tk41.a $(INSTALLDIR)
+	chmod 644 $(INSTALLDIR)/tk41.cmxa
+	chmod 644 $(INSTALLDIR)/tk41.a
+
+.SUFFIXES :
+.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp
+
+.mli.cmi:
+	$(LABLCOMP) $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(LABLCOMP) $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $(COMPFLAGS) $<
+
+include .depend
diff --git a/otherlibs/labltk/lib/Makefile.gen b/otherlibs/labltk/lib/Makefile.gen
new file mode 100644
index 0000000000..4f41c54cf1
--- /dev/null
+++ b/otherlibs/labltk/lib/Makefile.gen
@@ -0,0 +1,35 @@
+include ../Makefile.config
+
+all: tk.ml .depend
+
+tkgen.ml: ../Widgets.src ../compiler/tkcompiler
+	cd ..; compiler/tkcompiler
+
+# dependencies are broken: wouldn't work with gmake 3.77
+
+tk.ml .depend: tkgen.ml ../support/report.ml #../builtin/builtin_*.ml
+	(echo 'open Widget'; \
+         echo 'open Protocol'; \
+         echo 'open Support'; \
+	 echo 'open Textvariable'; \
+	 cat ../support/may.ml; \
+	 cat ../support/coerce.ml; \
+	 cat ../support/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
+	$(LABLDEP) *.mli *.ml > .depend
diff --git a/otherlibs/labltk/site.config b/otherlibs/labltk/site.config
new file mode 100644
index 0000000000..66312c70ef
--- /dev/null
+++ b/otherlibs/labltk/site.config
@@ -0,0 +1,28 @@
+## Location of Objective Caml Libraries
+OCAMLLIBDIR=/usr/local/lib/ocaml
+
+## Location of Objective Caml sources (only needed for the browser)
+## relative to the lablbrowser directory
+OCAMLSRCDIR=../..
+
+## Compilation and link flags for Tcl/Tk applications
+## Preprocessor flags to find tcl.h and tk.h
+CPPFLAGS=-I/usr/local/include
+## ld flags to add path to libtcl*.* and libtk*.*
+## You can also add here nonstandard X libraries
+LDFLAGS="-L/usr/local/lib"
+
+## If you're building the japanised version of MMM, you must use the
+## japanised versions of Tcl and Tk. The libraries are usually installed
+## as libtclXXjp.a and libtkXXjp.a. Uncomment the following line if you
+## want "configure" to find the correct libraries
+# LIBEXT=jp
+
+## If you are using a fancy version of Tk, like TkStep,
+## set this to the base name of this version (no digits).
+# TKNAME=tkstep
+
+## Library and executables installation directories
+## These MUST be absolute paths.
+INSTALLDIR=$OCAMLLIBDIR/labltk41
+INSTALLBINDIR=/usr/local/bin
diff --git a/otherlibs/labltk/support/.depend b/otherlibs/labltk/support/.depend
new file mode 100644
index 0000000000..8a6335ac30
--- /dev/null
+++ b/otherlibs/labltk/support/.depend
@@ -0,0 +1,16 @@
+protocol.cmi: widget.cmi 
+textvariable.cmi: protocol.cmi widget.cmi 
+coerce.cmo: widget.cmi 
+coerce.cmx: widget.cmx 
+fileevent.cmo: protocol.cmi fileevent.cmi 
+fileevent.cmx: protocol.cmx fileevent.cmi 
+protocol.cmo: widget.cmi protocol.cmi 
+protocol.cmx: widget.cmx protocol.cmi 
+support.cmo: support.cmi 
+support.cmx: support.cmi 
+textvariable.cmo: protocol.cmi widget.cmi textvariable.cmi 
+textvariable.cmx: protocol.cmx widget.cmx textvariable.cmi 
+timer.cmo: protocol.cmi timer.cmi 
+timer.cmx: protocol.cmx timer.cmi 
+widget.cmo: widget.cmi 
+widget.cmx: widget.cmi 
diff --git a/otherlibs/labltk/support/Makefile b/otherlibs/labltk/support/Makefile
new file mode 100644
index 0000000000..23a7f46948
--- /dev/null
+++ b/otherlibs/labltk/support/Makefile
@@ -0,0 +1,56 @@
+include ../Makefile.config
+
+all: support.cmo widget.cmo protocol.cmo \
+     textvariable.cmo timer.cmo fileevent.cmo \
+     liblabltk41.a
+
+opt: support.cmx widget.cmx protocol.cmx \
+     textvariable.cmx timer.cmx fileevent.cmx \
+     liblabltk41.a
+
+COBJS=cltkCaml.o cltkEval.o cltkEvent.o cltkFile.o cltkMain.o \
+      cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o
+
+#CCFLAGS=-ccopt -g $(TKINCLUDES)
+CCFLAGS=$(TKINCLUDES)
+
+liblabltk41.a : $(COBJS)
+	rm -f liblabltk41.a
+	ar rc liblabltk41.a $(COBJS)
+	$(RANLIB) liblabltk41.a
+
+PUB=fileevent.cmi fileevent.mli \
+    protocol.cmi protocol.mli \
+    textvariable.cmi textvariable.mli \
+    timer.cmi timer.mli \
+    widget.cmi widget.mli
+
+install: liblabltk41.a $(PUB)
+	if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
+	cp $(PUB) $(INSTALLDIR)
+	cp liblabltk41.a $(INSTALLDIR)
+	cd $(INSTALLDIR); chmod 644 $(PUB) liblabltk41.a
+	$(RANLIB) $(INSTALLDIR)/liblabltk41.a
+
+clean : 
+	rm -f *.cm* *.o *.a
+
+.SUFFIXES :
+.SUFFIXES : .mli .ml .cmi .cmo .cmx .mlp .c .o
+
+.mli.cmi:
+	$(LABLCOMP) $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(LABLCOMP) $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $(COMPFLAGS) $<
+
+.c.o:
+	$(LABLCOMP) $(CCFLAGS) $<
+
+depend:
+	$(LABLDEP) *.mli *.ml > .depend
+
+include .depend
diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h
new file mode 100644
index 0000000000..176ad8a8be
--- /dev/null
+++ b/otherlibs/labltk/support/camltk.h
@@ -0,0 +1,25 @@
+/* cltkEval.c */
+extern Tcl_Interp *cltclinterp; /* The Tcl interpretor */
+
+/* copy a Caml string to the C heap. Must be deallocated with stat_free */
+char *string_to_c();
+
+/* cltkCaml.c */
+/* pointers to Caml values */
+extern value *tkerror_exn;
+extern value *handler_code;
+int CamlCBCmd();
+void tk_error();
+
+/* cltkMain.c */
+extern int signal_events;
+void invoke_pending_caml_signals();
+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/cltkCaml.c b/otherlibs/labltk/support/cltkCaml.c
new file mode 100644
index 0000000000..bb87ba5bdd
--- /dev/null
+++ b/otherlibs/labltk/support/cltkCaml.c
@@ -0,0 +1,70 @@
+#include <tcl.h>
+#include <tk.h>
+#include <caml/mlvalues.h>
+#include <caml/callback.h>
+#include "camltk.h"
+
+value * tkerror_exn = NULL;
+value * handler_code = NULL;
+
+/* The Tcl command for evaluating callback in Caml */
+int CamlCBCmd(clientdata, interp, argc, argv)
+     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
+ */
+value camltk_return (v) /* ML */
+     value v;
+{
+  CheckInit();
+
+  Tcl_SetResult(cltclinterp, String_val(v), TCL_VOLATILE);
+  return Val_unit;
+}
+
+/* Note: raise_with_string WILL copy the error message */
+void tk_error(errmsg)
+     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
+ */
+
+value camltk_init(v) /* ML */
+     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
new file mode 100644
index 0000000000..06449faf79
--- /dev/null
+++ b/otherlibs/labltk/support/cltkDMain.c
@@ -0,0 +1,229 @@
+#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 */
+static Tk_Window 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
new file mode 100644
index 0000000000..ac0d3e15c1
--- /dev/null
+++ b/otherlibs/labltk/support/cltkEval.c
@@ -0,0 +1,222 @@
+#include <stdlib.h>
+
+#include <tcl.h>
+#include <tk.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/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(argc, argv)
+     int argc;
+     char ** argv;
+{
+  value res;
+  int i;
+  value oldres = Val_unit, str = Val_unit;
+
+  Begin_roots2 (oldres, str);
+    res = Val_int(0); /* [] */
+    for (i = argc-1; i >= 0; i--) {
+      oldres = res;
+      str = copy_string(argv[i]);
+      res = alloc(2, 0);
+      Field(res, 0) = str;
+      Field(res, 1) = oldres;
+    }
+  End_roots();
+  return res;
+}
+
+/*
+ * Calling Tcl from Caml
+ *   this version works on an arbitrary Tcl command
+ */
+value camltk_tcl_eval(str) /* ML */
+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 = string_to_c(str);
+  code = Tcl_Eval(cltclinterp, cmd);
+  stat_free(cmd);
+
+  switch (code) {
+  case TCL_OK:
+    return copy_string(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(v)
+value v;
+{
+  switch (Tag_val(v)) {
+  case 0:			/* TkToken */
+    return 1;
+  case 1:			/* TkTokenList */
+    { int n;
+      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;
+  }
+}
+
+/* 
+ * Memory of allocated Tcl lists.
+ * We should not need more than MAX_LIST
+ */
+#define MAX_LIST 256
+static char *tcllists[MAX_LIST];
+
+static int startfree = 0;
+/* If size is lower, do not allocate */
+static char *quotedargv[16];
+
+/* 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 (argv, where, v) 
+char ** argv;
+int where;
+value v;
+{
+  switch (Tag_val(v)) {
+  case 0:
+    argv[where] = String_val(Field(v,0));
+    return (where + 1);
+  case 1:
+    { value l;
+      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;
+      int size = argv_size(Field(v,0));
+      if (size < 16)
+	tmpargv = &quotedargv[0];
+      else
+	tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
+      fill_args(tmpargv,0,Field(v,0));
+      tmpargv[size] = NULL;
+      argv[where] = Tcl_Merge(size,tmpargv);
+      tcllists[startfree++] = argv[where]; /* so we can free it later */
+      if (size >= 16) 
+	stat_free((char *)tmpargv);
+      return (where + 1);
+    }
+  }
+}
+
+/* v is an array of TkArg */
+value camltk_tcl_direct_eval(v) /* ML */
+value v; 
+{
+  int i;
+  int size;			/* size of argv */
+  char **argv;
+  int result;
+  Tcl_CmdInfo info;
+  int wherewasi,whereami;       /* positions in tcllists array */
+
+  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 *));
+
+  wherewasi = startfree; /* should be zero except when nested calls */
+  Assert(startfree < MAX_LIST);
+
+  /* Copy */
+  {
+    int where;
+    for(i=0, where=0;i<Wosize_val(v);i++)
+      where = fill_args(argv,where,Field(v,i));
+    argv[size] = NULL;
+    argv[size + 1] = NULL;
+  }
+
+  Begin_roots_block ((value *) argv, size + 2);
+
+  whereami = startfree;
+
+    /* Eval */
+    Tcl_ResetResult(cltclinterp);
+    if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */
+      result = (*info.proc)(info.clientData,cltclinterp,size,argv);
+    } 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);
+      }
+    }
+  End_roots ();
+
+  /* Free the various things we allocated */
+  stat_free((char *)argv);
+  for (i=wherewasi; i<whereami; i++)
+    free(tcllists[i]);
+  startfree = wherewasi;
+  
+  switch (result) {
+  case TCL_OK:
+    return copy_string (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
new file mode 100644
index 0000000000..92221b9632
--- /dev/null
+++ b/otherlibs/labltk/support/cltkEvent.c
@@ -0,0 +1,38 @@
+#include <tcl.h>
+#include <tk.h>
+#include <caml/mlvalues.h>
+#include "camltk.h"
+
+value camltk_tk_mainloop() /* ML */
+{
+  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
+};
+
+value camltk_dooneevent(flags) /* ML */
+     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
new file mode 100644
index 0000000000..a890aba11a
--- /dev/null
+++ b/otherlibs/labltk/support/cltkFile.c
@@ -0,0 +1,111 @@
+#ifdef _WIN32
+#include <wtypes.h>
+#include <winbase.h>
+#include <winsock.h>
+#endif
+#include <tcl.h>
+#include <tk.h>
+#include <caml/mlvalues.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
+
+/* Unix system */
+
+#if TCL_MAJOR_VERSION >= 8
+#define tcl_filehandle(fd) Int_val(fd)
+#define Tcl_File int
+#define Tcl_FreeFile(fd)
+#else
+static Tcl_File tcl_filehandle(value fd)
+{
+  return Tcl_GetFile((ClientData)Long_val(fd), TCL_UNIX_FD);
+}
+#endif
+
+#else
+
+/* Windows */
+
+#define Handle_val(v) (*((HANDLE *)(v)))
+
+static Tcl_File tcl_filehandle(value fd)
+{
+  HANDLE h = Handle_val(fd);
+  int type;
+  int optval, optsize;
+
+  optsize = sizeof(optval);
+  if (getsockopt((SOCKET) h, SOL_SOCKET, SO_TYPE, &optval, &optsize) == 0)
+    type = TCL_WIN_SOCKET;
+  else
+    switch (GetFileType(h)) {
+    case FILE_TYPE_CHAR:
+      type = TCL_WIN_CONSOLE;
+    case FILE_TYPE_PIPE:
+      type = TCL_WIN_PIPE;
+    case FILE_TYPE_DISK:
+    default:                    /* use WIN_FILE for unknown handles */
+      type = TCL_WIN_FILE;
+    }
+  return Tcl_GetFile(h, type);
+}
+
+#endif
+
+value camltk_add_file_input(fd, cbid)    /* ML */
+     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.
+ */
+value camltk_rem_file_input(fd) /* ML */
+     value fd;
+{
+  Tcl_File fh = tcl_filehandle(fd);
+  Tcl_DeleteFileHandler(fh);
+  Tcl_FreeFile(fh);
+  return Val_unit;
+}
+
+value camltk_add_file_output(fd, cbid)    /* ML */
+     value fd;
+     value cbid;
+{
+  CheckInit();
+  Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_WRITABLE, 
+		       FileProc, (ClientData) (Long_val(cbid)));
+  return Val_unit;
+}
+
+value camltk_rem_file_output(fd) /* ML */
+     value fd;
+{
+  Tcl_File fh = tcl_filehandle(fd);
+  Tcl_DeleteFileHandler(fh);
+  Tcl_FreeFile(fh);
+  return Val_unit;
+}
+
diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c
new file mode 100644
index 0000000000..372372a1de
--- /dev/null
+++ b/otherlibs/labltk/support/cltkMain.c
@@ -0,0 +1,117 @@
+#include <string.h>
+#include <tcl.h>
+#include <tk.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/callback.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 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 */
+value camltk_opentk(display, name) /* ML */
+     value display,name;
+{
+  if (!cltk_slave_mode) {
+    /* Create an interpreter, dies if error */
+#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1
+    Tcl_FindExecutable(String_val(name));
+#endif
+    cltclinterp = Tcl_CreateInterp();
+
+    if (Tcl_Init(cltclinterp) != TCL_OK)
+      tk_error(cltclinterp->result);
+    Tcl_SetVar(cltclinterp, "argv0", String_val (name), TCL_GLOBAL_ONLY);
+    { /* Sets display if needed */
+      char *args;
+      char *tkargv[2];
+      if (string_length(display) > 0) {
+	Tcl_SetVar(cltclinterp, "argc", "2", TCL_GLOBAL_ONLY);
+	tkargv[0] = "-display";
+	tkargv[1] = String_val(display);
+	args = Tcl_Merge(2, tkargv);
+	Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY);
+	free(args);
+      }
+    }
+    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);
+    }
+  }
+
+  return Val_unit;
+}
+
diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c
new file mode 100644
index 0000000000..22db83e46a
--- /dev/null
+++ b/otherlibs/labltk/support/cltkMisc.c
@@ -0,0 +1,42 @@
+#include <tcl.h>
+#include <tk.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include "camltk.h"
+
+/* Parsing results */
+value camltk_splitlist (v) /* ML */
+     value v;
+{
+  int argc;
+  char **argv;
+  int result;
+
+  CheckInit();
+
+  /* argv is allocated by Tcl, to be freed by us */
+  result = Tcl_SplitList(cltclinterp,String_val(v),&argc,&argv);
+  switch(result) {
+  case TCL_OK:
+   { value res = copy_string_list(argc,argv);
+     free((char *)argv);	/* only one large block was allocated */
+     return res;
+   }
+  case TCL_ERROR:
+  default:
+    tk_error(cltclinterp->result);
+  }
+}
+
+/* Copy a Caml string to the C heap. Should deallocate with stat_free */
+char *string_to_c(s)
+     value s;
+{
+  int l = string_length(s);
+  char *res = stat_alloc(l + 1);
+  bcopy(String_val(s),res,l);
+  res[l] = '\0';
+  return res;
+}
+
+
diff --git a/otherlibs/labltk/support/cltkTimer.c b/otherlibs/labltk/support/cltkTimer.c
new file mode 100644
index 0000000000..2b8ec0e1bd
--- /dev/null
+++ b/otherlibs/labltk/support/cltkTimer.c
@@ -0,0 +1,30 @@
+#include <tcl.h>
+#include <tk.h>
+#include <caml/mlvalues.h>
+#include "camltk.h"
+
+
+/* Basically the same thing as FileProc */
+void TimerProc (clientdata)
+     ClientData clientdata;
+{
+  callback2(*handler_code,Val_long(clientdata),Val_int(0));
+}
+
+value camltk_add_timer(milli, cbid) /* ML */
+     value milli;
+     value cbid;
+{
+  CheckInit();
+  /* look at tkEvent.c , Tk_Token is an int */ 
+  return (value)Tcl_CreateTimerHandler(Int_val(milli), TimerProc, 
+				       (ClientData) (Long_val(cbid)));
+}
+
+value camltk_rem_timer(token) /* ML */
+     value token;
+{
+  Tcl_DeleteTimerHandler((Tcl_TimerToken) token);
+  return Val_unit;
+}
+
diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c
new file mode 100644
index 0000000000..9d0f083511
--- /dev/null
+++ b/otherlibs/labltk/support/cltkVar.c
@@ -0,0 +1,109 @@
+/* Alternative to tkwait variable */
+#include <string.h>
+#include <tcl.h>
+#include <tk.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include "camltk.h"
+
+value camltk_getvar(var) /* ML */
+     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(copy_string(s));
+}
+
+value camltk_setvar(var,contents) /* ML */
+     value var;
+     value contents;
+{
+  char *s;
+  char *stable_var = NULL;
+  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);
+  s = Tcl_SetVar(cltclinterp,stable_var, String_val(contents),
+		   TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
+  stat_free(stable_var);
+
+  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 */
+value camltk_trace_var(var,cbid) /* ML */
+     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;
+}
+
+value camltk_untrace_var(var,cbid) /* ML */
+     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
new file mode 100644
index 0000000000..7645dd9317
--- /dev/null
+++ b/otherlibs/labltk/support/cltkWait.c
@@ -0,0 +1,89 @@
+#include <tcl.h>
+#include <tk.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.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 */
+value camltk_wait_vis(win,cbid) /* ML */
+     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, eventPtr)
+    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 */
+value camltk_wait_des(win,cbid) /* ML */
+     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/coerce.ml b/otherlibs/labltk/support/coerce.ml
new file mode 100644
index 0000000000..1562fbec18
--- /dev/null
+++ b/otherlibs/labltk/support/coerce.ml
@@ -0,0 +1,2 @@
+(* for no Support open *)
+let coe = Widget.coe
diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml
new file mode 100644
index 0000000000..ffebc909b1
--- /dev/null
+++ b/otherlibs/labltk/support/fileevent.ml
@@ -0,0 +1,64 @@
+(* $Id$ *)
+
+open Unix
+open Protocol
+
+external add_file_input : file_descr -> cbid -> unit
+        =  "camltk_add_file_input"
+external rem_file_input : file_descr -> unit
+        =  "camltk_rem_file_input"
+external add_file_output : file_descr -> cbid -> unit
+        =  "camltk_add_file_output"
+external rem_file_output : file_descr -> 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 key:id data:(fun _ -> f());
+  Hashtbl.add fd_table key:(fd, 'r') data:id;
+  if !Protocol.debug then begin
+    Protocol.prerr_cbid id; prerr_endline " for fileinput"
+  end;
+  add_file_input fd id
+
+let remove_fileinput :fd =
+  try
+    let id = Hashtbl.find fd_table key:(fd, 'r') in
+    clear_callback id;
+    Hashtbl.remove fd_table key:(fd, 'r');
+    if !Protocol.debug then begin
+      prerr_string "clear "; 
+      Protocol.prerr_cbid id;
+      prerr_endline " for fileinput"
+    end;
+    rem_file_input fd
+  with
+    Not_found -> ()
+
+let add_fileoutput :fd callback:f =
+  let id = new_function_id () in
+  Hashtbl.add callback_naming_table key:id data:(fun _ -> f());
+  Hashtbl.add fd_table key:(fd, 'w') data:id;
+  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 key:(fd, 'w') in
+    clear_callback id;
+    Hashtbl.remove fd_table key:(fd, 'w');
+    if !Protocol.debug then begin
+      prerr_string "clear "; 
+      Protocol.prerr_cbid id;
+      prerr_endline " for fileoutput"
+    end;
+    rem_file_output fd
+  with
+    Not_found -> ()
+
diff --git a/otherlibs/labltk/support/fileevent.mli b/otherlibs/labltk/support/fileevent.mli
new file mode 100644
index 0000000000..b72f6c78c1
--- /dev/null
+++ b/otherlibs/labltk/support/fileevent.mli
@@ -0,0 +1,7 @@
+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/may.ml b/otherlibs/labltk/support/may.ml
new file mode 100644
index 0000000000..202b561d9e
--- /dev/null
+++ b/otherlibs/labltk/support/may.ml
@@ -0,0 +1,10 @@
+
+(* 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/protocol.ml b/otherlibs/labltk/support/protocol.ml
new file mode 100644
index 0000000000..6da2a1daad
--- /dev/null
+++ b/otherlibs/labltk/support/protocol.ml
@@ -0,0 +1,190 @@
+(* $Id$ *)
+
+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 : string -> string -> 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"
+
+exception TkError of string
+      (* Raised by the communication functions *)
+let _ = Callback.register_exception "tkerror" (TkError "")
+
+(* Debugging support *)
+let debug = 
+ ref (try 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 fun:print_arg l
+  | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} "
+ in
+  Array.iter fun: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
+
+(*
+ * Callbacks
+ *)
+
+let cCAMLtoTKwidget w = 
+  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 key:id data:f;
+    if (forget_type w) <> (forget_type Widget.dummy) then 
+      Hashtbl.add callback_memo_table key:(forget_type w) data:id;
+    (string_of_cbid id)
+
+let clear_callback id =
+  Hashtbl.remove callback_naming_table key: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 key:w in
+    List.iter fun:clear_callback cb_ids;
+    for i = 1 to List.length cb_ids do
+      Hashtbl.remove callback_memo_table key: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:(fun f -> f w) !destroy_hooks
+    | _ -> raise (TkError "bad cleanup callback") in
+  let fid = new_function_id () in
+  Hashtbl.add callback_naming_table key:fid data:call_destroy_hooks;
+  (* setup general destroy callback *)
+  tcl_eval ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}")
+
+
+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:(fun x -> prerr_string " "; prerr_string x) args;
+    prerr_newline()
+    end;
+  (Hashtbl.find callback_naming_table key:id) args;
+  if !debug then prerr_endline "<<-"
+
+let protected_dispatch id args =
+  try
+    Printexc.print (dispatch_callback id) args
+  with
+     Out_of_memory -> raise Out_of_memory
+   | Sys.Break -> raise Sys.Break
+   | e -> flush Pervasives.stderr
+
+let _ = Callback.register "camlcb" protected_dispatch
+
+(* Make sure the C variables are initialised *)
+let _ = callback_init ()
+
+(* Different version of initialisation functions *)
+(* Native opentk is [opentk display class]       *)
+let openTk () =
+  opentk "" "LablTk";
+  install_cleanup();
+  Widget.default_toplevel
+
+let openTkClass s =
+  opentk "" s;
+  install_cleanup();
+  Widget.default_toplevel
+
+let openTkDisplayClass display:disp cl =
+  opentk disp cl;
+  install_cleanup();
+  Widget.default_toplevel
+
+(* Destroy all widgets, thus cleaning up table and exiting the loop *)
+let closeTk () =
+  tcl_eval "destroy ."; ()
+
+let mainLoop =
+  tk_mainloop 
+
+
+(* [register tclname f] makes [f] available from Tcl with 
+   name [tclname] *)
+let register tclname callback:cb =
+  let s = register_callback Widget.default_toplevel callback:cb in
+    tcl_eval (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
new file mode 100644
index 0000000000..4febdc87da
--- /dev/null
+++ b/otherlibs/labltk/support/protocol.mli
@@ -0,0 +1,66 @@
+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   openTk : unit -> toplevel widget
+val   openTkClass: string -> toplevel widget
+val   openTkDisplayClass: display:string -> string -> toplevel widget
+val   closeTk : unit -> unit
+val   mainLoop : unit -> unit
+
+
+(* Direct evaluation of tcl code *)
+val   tkEval : tkArgs array -> string
+
+(* 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/report.ml b/otherlibs/labltk/support/report.ml
new file mode 100644
index 0000000000..ee040de379
--- /dev/null
+++ b/otherlibs/labltk/support/report.ml
@@ -0,0 +1,7 @@
+(* Report globals from protocol to tk *)
+let openTk = openTk
+and openTkClass = openTkClass
+and openTkDisplayClass = openTkDisplayClass
+and closeTk = closeTk
+and mainLoop = mainLoop
+and register = register
diff --git a/otherlibs/labltk/support/support.ml b/otherlibs/labltk/support/support.ml
new file mode 100644
index 0000000000..4f67d62c78
--- /dev/null
+++ b/otherlibs/labltk/support/support.ml
@@ -0,0 +1,61 @@
+(* $Id$ *)
+
+(* Extensible buffers *)
+type extensible_buffer = {
+    mutable buffer : string;
+    mutable pos : int;
+    mutable len : int}
+
+let new_buffer () = {
+   buffer = String.create len:128;
+   pos = 0;
+   len = 128
+   }
+
+let print_in_buffer buf s =
+  let l = String.length s in
+  if buf.pos + l > buf.len then begin
+    buf.buffer <- buf.buffer ^ (String.create len:(l+128));
+    buf.len <- buf.len + 128 + l
+    end;
+  String.blit s pos:0 to:buf.buffer to_pos:buf.pos len:l;
+  buf.pos <- buf.pos + l
+
+let get_buffer buf = 
+  String.sub buf.buffer pos:0 len:buf.pos
+
+
+
+(* Used by list converters *)
+let catenate_sep sep =
+  function 
+    [] -> ""
+  | [x] -> x
+  | x::l -> 
+      let b = new_buffer() in
+      	print_in_buffer b x;
+	List.iter l 
+      	  fun:(function s -> print_in_buffer b sep; print_in_buffer b s);
+      get_buffer b
+
+(* Parsing results of Tcl *)
+(* List.split a string according to char_sep predicate *)
+let split_str 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 pos:beg len:(len - beg)]
+    else if char_sep str.[cur] 
+         then 
+      	   let nextw = skip_sep cur in
+      	    (String.sub str pos:beg len:(cur - beg))
+      	      ::(split nextw nextw)
+	 else split beg (succ cur) in
+  let wstart = skip_sep 0 in
+  split wstart wstart
+
diff --git a/otherlibs/labltk/support/support.mli b/otherlibs/labltk/support/support.mli
new file mode 100644
index 0000000000..7988422980
--- /dev/null
+++ b/otherlibs/labltk/support/support.mli
@@ -0,0 +1,11 @@
+(* Extensible buffers *)
+type extensible_buffer
+val new_buffer : unit -> extensible_buffer
+val   print_in_buffer : extensible_buffer -> string -> unit
+val   get_buffer : extensible_buffer -> string
+
+
+val catenate_sep : string -> string list -> string
+val split_str : (char -> bool) -> string -> string list
+      (* Various string manipulations *)
+
diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml
new file mode 100644
index 0000000000..2d4b26f4fd
--- /dev/null
+++ b/otherlibs/labltk/support/textvariable.ml
@@ -0,0 +1,135 @@
+(* $Id$ *)
+
+open Protocol
+
+external internal_tracevar : string -> cbid -> unit
+      	= "camltk_trace_var"
+external internal_untracevar : string -> cbid -> unit
+      	= "camltk_untrace_var"
+external set : string -> to: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 key:var in
+    r := cbid :: !r
+  with
+    Not_found -> 
+      Hashtbl.add handles key:var data:(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 key:var in
+    match exceptq cbid !r with
+      [] -> Hashtbl.remove handles key: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 key:var in
+    List.iter fun:(internal_untracevar var) !r;
+    Hashtbl.remove handles key:var
+  with
+    Not_found -> ()
+
+
+(* Variable trace *)
+let handle vname f =
+  let id = new_function_id() in
+  let wrapped _ =
+    clear_callback id;
+    rem_handle vname id;
+    f() in
+  Hashtbl.add callback_naming_table key:id data:wrapped;
+  add_handle vname id;
+  if !Protocol.debug then begin
+    prerr_cbid id; prerr_string " for variable "; prerr_endline vname
+  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 key:w 
+    with
+      Not_found -> 
+      	let r = ref StringSet.empty in
+	  Hashtbl.add memo key:w data:r;
+	  r in
+   r := StringSet.add !r elt:v
+
+(* to be used with care ! *)
+let free v =
+  rem_all_handles v;
+  freelist := StringSet.add elt:v !freelist
+
+(* Free variables associated with a widget *)
+let freew w =
+  try
+    let r = Hashtbl.find memo key:w in
+    StringSet.iter fun:free !r;
+    Hashtbl.remove memo key: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 elt:v !freelist;
+	v in
+    set v to:"";
+    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 elt: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
new file mode 100644
index 0000000000..bcc6842a25
--- /dev/null
+++ b/otherlibs/labltk/support/textvariable.mli
@@ -0,0 +1,29 @@
+(* $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 -> to: 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
diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml
new file mode 100644
index 0000000000..531695fe0d
--- /dev/null
+++ b/otherlibs/labltk/support/timer.ml
@@ -0,0 +1,33 @@
+(* $Id$ *)
+
+(* Timers *)
+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:milli callback: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 key:id data:wrapped;
+  if !Protocol.debug then begin
+    prerr_cbid id; prerr_endline " for timer"
+  end;
+  let t = internal_add_timer milli id in
+   t,id
+
+(* 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
new file mode 100644
index 0000000000..6e7610ce2f
--- /dev/null
+++ b/otherlibs/labltk/support/timer.mli
@@ -0,0 +1,4 @@
+type t
+
+val  add : ms:int -> callback:(unit -> unit) -> t
+val  remove : t -> unit
diff --git a/otherlibs/labltk/support/tkwait.ml b/otherlibs/labltk/support/tkwait.ml
new file mode 100644
index 0000000000..48a1db782b
--- /dev/null
+++ b/otherlibs/labltk/support/tkwait.ml
@@ -0,0 +1,5 @@
+
+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
new file mode 100644
index 0000000000..975d97565f
--- /dev/null
+++ b/otherlibs/labltk/support/widget.ml
@@ -0,0 +1,160 @@
+(* $Id$ *)
+
+(*
+ * Widgets
+ *)
+
+exception IllegalWidgetType of string
+      (* Raised when widget command applied illegally*)
+
+(***************************************************)
+(* Widgets *)
+(***************************************************)
+type 'a widget = 
+  Untyped of string
+| Typed of string * string
+
+type 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 widget) : any widget)
+let coe = forget_type
+
+(* table of widgets *)
+let table = (Hashtbl.create 401 : (string, any 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 key:wname data: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 key:(name w)
+
+(* Retype widgets returned from Tk *)
+(* JPF report: sometime s is "", see Protocol.cTKtoCAMLwidget *)
+let get_atom s =
+  try
+    Hashtbl.find table key: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 fun: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 key: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 "." ^ (new_suffix clas !counter)
+	  else parentpath ^ "." ^ name
+    in
+      let w = Typed(path,clas) in
+        Hashtbl.add table key:path data: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
+
+
+
+(* 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 clas elt:c then ()
+      	 else raise (IllegalWidgetType c)
+
+
+(* Checking membership of constructor in subtype table *)
+let chk_sub errname table c =
+  if List.mem table elt:c then ()
+  else raise (Invalid_argument errname)
diff --git a/otherlibs/labltk/support/widget.mli b/otherlibs/labltk/support/widget.mli
new file mode 100644
index 0000000000..cf139a03f0
--- /dev/null
+++ b/otherlibs/labltk/support/widget.mli
@@ -0,0 +1,91 @@
+(* Support for widget manipulations *)
+
+type 'a widget
+  (* widget is an abstract type *)
+
+type 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*)