diff options
155 files changed, 15896 insertions, 0 deletions
diff --git a/otherlibs/labltk/.cvsignore b/otherlibs/labltk/.cvsignore new file mode 100644 index 000000000..65fc49b97 --- /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 000000000..2f9626cca --- /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 000000000..70369fb7c --- /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 000000000..ed8743964 --- /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 000000000..af3130c49 --- /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 000000000..ba3b9e833 --- /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 000000000..102b0fd82 --- /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 000000000..79c92bd72 --- /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 000000000..c5fa6cd38 --- /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 000000000..de782f073 --- /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 000000000..94b11d80c --- /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 000000000..ca28b5132 --- /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 000000000..c5c662f01 --- /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 000000000..d186e4874 --- /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 000000000..e0d0e7c33 --- /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 000000000..789cd17e2 --- /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 000000000..9d30f5793 --- /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 000000000..3889f20fd --- /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 000000000..f71bd0e7f --- /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 000000000..db56374aa --- /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 000000000..8836af09f --- /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 000000000..427e74455 --- /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 000000000..330efa7e5 --- /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 000000000..183035108 --- /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 000000000..d9109d83a --- /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 000000000..43a5eb15b --- /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 000000000..8d08111b1 --- /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 000000000..21295f3d6 --- /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 000000000..9385f37d0 --- /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 000000000..8862702c6 --- /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 000000000..161e21534 --- /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 000000000..fbd1ab13a --- /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 000000000..2477e9acc --- /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 000000000..8b3880eef --- /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 000000000..da5f4930c --- /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 000000000..c36a215ef --- /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 000000000..e98096c2e --- /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 000000000..d9711f5fc --- /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 000000000..6ab8b7863 --- /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 000000000..681342cff --- /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 000000000..582295c39 --- /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 000000000..a43085752 --- /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 000000000..0d7458e70 --- /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 000000000..9883ea50c --- /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 000000000..eeae7f32c --- /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 000000000..99c045d97 --- /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 000000000..9801f83e7 --- /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 000000000..5af22d1b4 --- /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 000000000..adea44551 --- /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 000000000..8c1e29deb --- /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 000000000..fd9970495 --- /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 000000000..33dd20f2b --- /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 000000000..23699155a --- /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 000000000..bc9d7228b --- /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 000000000..798afeb08 --- /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 000000000..31b807e68 --- /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 000000000..7e0401592 --- /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 000000000..f760dce75 --- /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 000000000..54ef88187 --- /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 000000000..41ebfe846 --- /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 000000000..6461df43c --- /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 000000000..917ac410a --- /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 000000000..1bf305490 --- /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 000000000..1b6d6facd --- /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 000000000..e69de29bb --- /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 000000000..5a3dd19a2 --- /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 000000000..d18111127 --- /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 000000000..8c63876cb --- /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 000000000..e47048aec --- /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 000000000..8327ab6f7 --- /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 000000000..8dbde204b --- /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 000000000..7bbfe5963 --- /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 000000000..b0a88b269 --- /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 000000000..8d07d9647 --- /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 000000000..1c7e2d7c0 --- /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 000000000..2a8923333 --- /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 000000000..55c3ec364 --- /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 000000000..cfde292af --- /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 000000000..d0f6398c3 --- /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 000000000..d3b471859 --- /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 000000000..39707e9ff --- /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 000000000..2cdd0abe7 --- /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 000000000..d1d996399 --- /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 000000000..feffcdf96 --- /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 000000000..d05450903 --- /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 000000000..79b2e6cb3 --- /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 000000000..c78a35e62 --- /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 000000000..76df1025f --- /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 000000000..0baf36ebd --- /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 000000000..178a0fab7 --- /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 000000000..16916fe66 --- /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 000000000..7d826a161 --- /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 000000000..dbc777da1 --- /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 000000000..6ecb84ae2 --- /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 000000000..065edd3a4 --- /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 000000000..aa9412933 --- /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 000000000..4920c5c62 --- /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 000000000..4a606014d --- /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 000000000..b82028924 --- /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 000000000..fe8e18ef1 --- /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 000000000..05097b94a --- /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 Binary files differnew file mode 100644 index 000000000..7cb3d2c13 --- /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 000000000..c30d2aa38 --- /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 000000000..71bbaca79 --- /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 000000000..a330a9ecb --- /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 000000000..0aa0ab74d --- /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 000000000..897d4b9e4 --- /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 000000000..1f281d66c --- /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 000000000..5e890aada --- /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 000000000..9e9985c15 --- /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 000000000..bfc60db07 --- /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 000000000..0e3182305 --- /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 000000000..52f00c839 --- /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 000000000..32d2365d6 --- /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 000000000..c3403ac17 --- /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 000000000..2720d3b55 --- /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 000000000..6f7f15b9d --- /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 Binary files differnew file mode 100644 index 000000000..78e98dd4a --- /dev/null +++ b/otherlibs/labltk/labl.gif diff --git a/otherlibs/labltk/labltk.in b/otherlibs/labltk/labltk.in new file mode 100644 index 000000000..cc0d1b15c --- /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 000000000..e4f87210c --- /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 000000000..d54f6a223 --- /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 000000000..d17e6e43d --- /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 000000000..c55569311 --- /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 000000000..0931fee20 --- /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 000000000..4f41c54cf --- /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 000000000..66312c70e --- /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 000000000..8a6335ac3 --- /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 000000000..23a7f4694 --- /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 000000000..176ad8a8b --- /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 000000000..bb87ba5bd --- /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 000000000..06449faf7 --- /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 000000000..ac0d3e15c --- /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 = "edargv[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 000000000..92221b963 --- /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 000000000..a890aba11 --- /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 000000000..372372a1d --- /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 000000000..22db83e46 --- /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 000000000..2b8ec0e1b --- /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 000000000..9d0f08351 --- /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 000000000..7645dd931 --- /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 000000000..1562fbec1 --- /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 000000000..ffebc909b --- /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 000000000..b72f6c78c --- /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 000000000..202b561d9 --- /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 000000000..6da2a1daa --- /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 000000000..4febdc87d --- /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 000000000..ee040de37 --- /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 000000000..4f67d62c7 --- /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 000000000..798842298 --- /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 000000000..2d4b26f4f --- /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 000000000..bcc6842a2 --- /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 000000000..531695fe0 --- /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 000000000..6e7610ce2 --- /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 000000000..48a1db782 --- /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 000000000..975d97565 --- /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 000000000..cf139a03f --- /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*) |
