From 16b9866295a2ced47943bd47bd5d35f0ab6f515e Mon Sep 17 00:00:00 2001 From: Luc Maranget Date: Fri, 10 Aug 2012 14:47:46 +0000 Subject: [PATCH] delete useless librairies git-svn-id: http://caml.inria.fr/svn/ocaml/branches/jocamltrunk@12859 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- otherlibs/labltk/.ignore | 4 - otherlibs/labltk/Changes | 13 - otherlibs/labltk/Makefile | 93 - otherlibs/labltk/Makefile.nt | 72 - otherlibs/labltk/README | 151 -- otherlibs/labltk/Widgets.src | 2304 ----------------- otherlibs/labltk/browser/.depend | 101 - otherlibs/labltk/browser/.ignore | 3 - otherlibs/labltk/browser/Makefile | 22 - otherlibs/labltk/browser/Makefile.nt | 35 - otherlibs/labltk/browser/README | 170 -- otherlibs/labltk/browser/dummyUnix.mli | 27 - otherlibs/labltk/browser/dummyWin.mli | 15 - otherlibs/labltk/browser/editor.ml | 671 ----- otherlibs/labltk/browser/editor.mli | 20 - otherlibs/labltk/browser/fileselect.ml | 290 --- otherlibs/labltk/browser/fileselect.mli | 39 - otherlibs/labltk/browser/help.txt | 166 -- otherlibs/labltk/browser/jg_bind.ml | 28 - otherlibs/labltk/browser/jg_bind.mli | 21 - otherlibs/labltk/browser/jg_box.ml | 82 - otherlibs/labltk/browser/jg_button.ml | 25 - otherlibs/labltk/browser/jg_completion.ml | 53 - otherlibs/labltk/browser/jg_completion.mli | 25 - otherlibs/labltk/browser/jg_config.ml | 40 - otherlibs/labltk/browser/jg_config.mli | 17 - otherlibs/labltk/browser/jg_entry.ml | 27 - otherlibs/labltk/browser/jg_memo.ml | 33 - otherlibs/labltk/browser/jg_memo.mli | 19 - otherlibs/labltk/browser/jg_menu.ml | 42 - otherlibs/labltk/browser/jg_message.ml | 111 - otherlibs/labltk/browser/jg_message.mli | 33 - otherlibs/labltk/browser/jg_multibox.ml | 185 -- otherlibs/labltk/browser/jg_multibox.mli | 35 - otherlibs/labltk/browser/jg_text.ml | 104 - otherlibs/labltk/browser/jg_text.mli | 28 - otherlibs/labltk/browser/jg_tk.ml | 24 - otherlibs/labltk/browser/jg_toplevel.ml | 25 - otherlibs/labltk/browser/lexical.ml | 150 -- otherlibs/labltk/browser/lexical.mli | 20 - otherlibs/labltk/browser/list2.ml | 23 - otherlibs/labltk/browser/main.ml | 131 - otherlibs/labltk/browser/mytypes.mli | 29 - otherlibs/labltk/browser/searchid.ml | 537 ---- otherlibs/labltk/browser/searchid.mli | 45 - otherlibs/labltk/browser/searchpos.ml | 890 ------- otherlibs/labltk/browser/searchpos.mli | 77 - otherlibs/labltk/browser/setpath.ml | 162 -- otherlibs/labltk/browser/setpath.mli | 25 - otherlibs/labltk/browser/shell.ml | 367 --- otherlibs/labltk/browser/shell.mli | 46 - otherlibs/labltk/browser/typecheck.ml | 181 -- otherlibs/labltk/browser/typecheck.mli | 23 - otherlibs/labltk/browser/useunix.ml | 69 - otherlibs/labltk/browser/useunix.mli | 23 - otherlibs/labltk/browser/viewer.ml | 640 ----- otherlibs/labltk/browser/viewer.mli | 31 - otherlibs/labltk/browser/winmain.c | 34 - otherlibs/labltk/builtin/LICENSE | 19 - .../labltk/builtin/builtin_FilePattern.ml | 20 - otherlibs/labltk/builtin/builtin_GetBitmap.ml | 22 - otherlibs/labltk/builtin/builtin_GetCursor.ml | 60 - otherlibs/labltk/builtin/builtin_GetPixel.ml | 28 - .../labltk/builtin/builtin_ScrollValue.ml | 22 - otherlibs/labltk/builtin/builtin_bind.ml | 469 ---- otherlibs/labltk/builtin/builtin_bindtags.ml | 20 - otherlibs/labltk/builtin/builtin_font.ml | 3 - otherlibs/labltk/builtin/builtin_grab.ml | 3 - otherlibs/labltk/builtin/builtin_index.ml | 92 - otherlibs/labltk/builtin/builtin_palette.ml | 20 - otherlibs/labltk/builtin/builtin_text.ml | 50 - otherlibs/labltk/builtin/builtina_empty.ml | 0 otherlibs/labltk/builtin/builtinf_GetPixel.ml | 23 - otherlibs/labltk/builtin/builtinf_bind.ml | 133 - .../labltk/builtin/builtini_GetBitmap.ml | 28 - .../labltk/builtin/builtini_GetCursor.ml | 55 - otherlibs/labltk/builtin/builtini_GetPixel.ml | 43 - .../labltk/builtin/builtini_ScrollValue.ml | 45 - otherlibs/labltk/builtin/builtini_bind.ml | 136 - otherlibs/labltk/builtin/builtini_bindtags.ml | 29 - otherlibs/labltk/builtin/builtini_font.ml | 2 - otherlibs/labltk/builtin/builtini_grab.ml | 2 - otherlibs/labltk/builtin/builtini_index.ml | 140 - otherlibs/labltk/builtin/builtini_palette.ml | 19 - otherlibs/labltk/builtin/builtini_text.ml | 64 - otherlibs/labltk/builtin/canvas_bind.ml | 52 - otherlibs/labltk/builtin/canvas_bind.mli | 16 - otherlibs/labltk/builtin/dialog.ml | 45 - otherlibs/labltk/builtin/dialog.mli | 24 - otherlibs/labltk/builtin/image.ml | 33 - otherlibs/labltk/builtin/image.mli | 9 - otherlibs/labltk/builtin/optionmenu.ml | 54 - otherlibs/labltk/builtin/optionmenu.mli | 21 - otherlibs/labltk/builtin/rawimg.ml | 142 - otherlibs/labltk/builtin/rawimg.mli | 44 - otherlibs/labltk/builtin/report.ml | 17 - .../labltk/builtin/selection_handle_set.ml | 41 - .../labltk/builtin/selection_handle_set.mli | 13 - otherlibs/labltk/builtin/selection_own_set.ml | 29 - .../labltk/builtin/selection_own_set.mli | 12 - otherlibs/labltk/builtin/text_tag_bind.ml | 55 - otherlibs/labltk/builtin/text_tag_bind.mli | 13 - otherlibs/labltk/builtin/winfo_contained.ml | 13 - otherlibs/labltk/builtin/winfo_contained.mli | 11 - otherlibs/labltk/camltk/.ignore | 4 - otherlibs/labltk/camltk/Makefile | 61 - otherlibs/labltk/camltk/Makefile.gen | 62 - otherlibs/labltk/camltk/Makefile.gen.nt | 46 - otherlibs/labltk/camltk/Makefile.nt | 43 - otherlibs/labltk/camltk/modules | 80 - otherlibs/labltk/compiler/.depend | 28 - otherlibs/labltk/compiler/.ignore | 11 - otherlibs/labltk/compiler/Makefile | 79 - otherlibs/labltk/compiler/Makefile.nt | 63 - otherlibs/labltk/compiler/code.mli | 22 - otherlibs/labltk/compiler/compile.ml | 1074 -------- otherlibs/labltk/compiler/copyright | 15 - otherlibs/labltk/compiler/flags.ml | 17 - otherlibs/labltk/compiler/intf.ml | 191 -- otherlibs/labltk/compiler/lexer.mll | 170 -- otherlibs/labltk/compiler/maincompile.ml | 418 --- otherlibs/labltk/compiler/parser.mly | 330 --- otherlibs/labltk/compiler/pp.ml | 23 - otherlibs/labltk/compiler/ppexec.ml | 60 - otherlibs/labltk/compiler/pplex.mli | 18 - otherlibs/labltk/compiler/pplex.mll | 56 - otherlibs/labltk/compiler/ppparse.ml | 36 - otherlibs/labltk/compiler/ppyac.mly | 52 - otherlibs/labltk/compiler/printer.ml | 173 -- otherlibs/labltk/compiler/tables.ml | 427 --- otherlibs/labltk/compiler/tsort.ml | 87 - otherlibs/labltk/examples_camltk/.ignore | 8 - otherlibs/labltk/examples_camltk/Makefile | 60 - otherlibs/labltk/examples_camltk/Makefile.nt | 38 - otherlibs/labltk/examples_camltk/addition.ml | 53 - otherlibs/labltk/examples_camltk/eyes.ml | 63 - otherlibs/labltk/examples_camltk/fileinput.ml | 35 - otherlibs/labltk/examples_camltk/fileopen.ml | 56 - .../labltk/examples_camltk/helloworld.ml | 37 - .../examples_camltk/images/CamlBook.gif | Bin 15167 -> 0 bytes .../examples_camltk/images/Lambda2.back.gif | Bin 53441 -> 0 bytes .../examples_camltk/images/dojoji.back.gif | Bin 49934 -> 0 bytes otherlibs/labltk/examples_camltk/jptest.ml | 23 - otherlibs/labltk/examples_camltk/mytext.ml | 62 - .../labltk/examples_camltk/socketinput.ml | 42 - otherlibs/labltk/examples_camltk/taddition.ml | 53 - otherlibs/labltk/examples_camltk/tetris.ml | 684 ----- otherlibs/labltk/examples_camltk/text.ml | 54 - otherlibs/labltk/examples_camltk/winskel.ml | 63 - otherlibs/labltk/examples_labltk/.ignore | 8 - .../labltk/examples_labltk/Lambda2.back.gif | Bin 53441 -> 0 bytes otherlibs/labltk/examples_labltk/Makefile | 53 - otherlibs/labltk/examples_labltk/Makefile.nt | 50 - otherlibs/labltk/examples_labltk/README | 20 - otherlibs/labltk/examples_labltk/calc.ml | 129 - otherlibs/labltk/examples_labltk/clock.ml | 133 - otherlibs/labltk/examples_labltk/demo.ml | 166 -- otherlibs/labltk/examples_labltk/eyes.ml | 62 - otherlibs/labltk/examples_labltk/hello.ml | 38 - otherlibs/labltk/examples_labltk/hello.tcl | 5 - otherlibs/labltk/examples_labltk/lang.ml | 75 - otherlibs/labltk/examples_labltk/taquin.ml | 143 - otherlibs/labltk/examples_labltk/tetris.ml | 710 ----- otherlibs/labltk/frx/.depend | 38 - otherlibs/labltk/frx/Makefile | 67 - otherlibs/labltk/frx/Makefile.nt | 53 - otherlibs/labltk/frx/README | 2 - otherlibs/labltk/frx/frx_after.ml | 24 - otherlibs/labltk/frx/frx_after.mli | 17 - otherlibs/labltk/frx/frx_color.ml | 35 - otherlibs/labltk/frx/frx_color.mli | 16 - otherlibs/labltk/frx/frx_ctext.ml | 66 - otherlibs/labltk/frx/frx_ctext.mli | 23 - otherlibs/labltk/frx/frx_dialog.ml | 115 - otherlibs/labltk/frx/frx_dialog.mli | 22 - otherlibs/labltk/frx/frx_entry.ml | 40 - otherlibs/labltk/frx/frx_entry.mli | 31 - otherlibs/labltk/frx/frx_fileinput.ml | 39 - otherlibs/labltk/frx/frx_fillbox.ml | 65 - otherlibs/labltk/frx/frx_fillbox.mli | 31 - otherlibs/labltk/frx/frx_fit.ml | 83 - otherlibs/labltk/frx/frx_fit.mli | 29 - otherlibs/labltk/frx/frx_focus.ml | 26 - otherlibs/labltk/frx/frx_focus.mli | 18 - otherlibs/labltk/frx/frx_font.ml | 50 - otherlibs/labltk/frx/frx_font.mli | 20 - otherlibs/labltk/frx/frx_group.ml | 22 - otherlibs/labltk/frx/frx_lbutton.ml | 50 - otherlibs/labltk/frx/frx_lbutton.mli | 23 - otherlibs/labltk/frx/frx_listbox.ml | 92 - otherlibs/labltk/frx/frx_listbox.mli | 32 - otherlibs/labltk/frx/frx_mem.ml | 89 - otherlibs/labltk/frx/frx_mem.mli | 22 - otherlibs/labltk/frx/frx_misc.ml | 69 - otherlibs/labltk/frx/frx_misc.mli | 21 - otherlibs/labltk/frx/frx_req.ml | 198 -- otherlibs/labltk/frx/frx_req.mli | 43 - otherlibs/labltk/frx/frx_rpc.ml | 55 - otherlibs/labltk/frx/frx_rpc.mli | 25 - otherlibs/labltk/frx/frx_selection.ml | 45 - otherlibs/labltk/frx/frx_selection.mli | 17 - otherlibs/labltk/frx/frx_synth.ml | 88 - otherlibs/labltk/frx/frx_synth.mli | 31 - otherlibs/labltk/frx/frx_text.ml | 228 -- otherlibs/labltk/frx/frx_text.mli | 46 - otherlibs/labltk/frx/frx_toplevel.mli | 17 - otherlibs/labltk/frx/frx_widget.ml | 23 - otherlibs/labltk/frx/frx_widget.mli | 18 - otherlibs/labltk/jpf/Makefile | 93 - otherlibs/labltk/jpf/Makefile.nt | 75 - otherlibs/labltk/jpf/README | 2 - otherlibs/labltk/jpf/balloon.ml | 102 - otherlibs/labltk/jpf/balloon.mli | 24 - otherlibs/labltk/jpf/balloontest.ml | 31 - otherlibs/labltk/jpf/fileselect.ml | 367 --- otherlibs/labltk/jpf/fileselect.mli | 37 - otherlibs/labltk/jpf/jpf_font.ml | 218 -- otherlibs/labltk/jpf/jpf_font.mli | 54 - otherlibs/labltk/jpf/shell.ml | 35 - otherlibs/labltk/jpf/shell.mli | 16 - otherlibs/labltk/labl.gif | Bin 1533 -> 0 bytes otherlibs/labltk/labltk/.ignore | 4 - otherlibs/labltk/labltk/Makefile | 59 - otherlibs/labltk/labltk/Makefile.gen | 61 - otherlibs/labltk/labltk/Makefile.gen.nt | 40 - otherlibs/labltk/labltk/Makefile.nt | 43 - otherlibs/labltk/labltk/modules | 77 - otherlibs/labltk/lib/.ignore | 7 - otherlibs/labltk/lib/Makefile | 109 - otherlibs/labltk/lib/Makefile.nt | 60 - otherlibs/labltk/lib/labltk.bat | 1 - otherlibs/labltk/support/.depend | 59 - otherlibs/labltk/support/Makefile | 92 - otherlibs/labltk/support/Makefile.common | 43 - otherlibs/labltk/support/Makefile.common.nt | 30 - otherlibs/labltk/support/Makefile.nt | 80 - otherlibs/labltk/support/camltk.h | 60 - otherlibs/labltk/support/camltkwrap.ml | 77 - otherlibs/labltk/support/camltkwrap.mli | 251 -- otherlibs/labltk/support/cltkCaml.c | 83 - otherlibs/labltk/support/cltkDMain.c | 247 -- otherlibs/labltk/support/cltkEval.c | 244 -- otherlibs/labltk/support/cltkEvent.c | 54 - otherlibs/labltk/support/cltkFile.c | 158 -- otherlibs/labltk/support/cltkImg.c | 114 - otherlibs/labltk/support/cltkMain.c | 181 -- otherlibs/labltk/support/cltkMisc.c | 62 - otherlibs/labltk/support/cltkTimer.c | 44 - otherlibs/labltk/support/cltkUtf.c | 89 - otherlibs/labltk/support/cltkVar.c | 128 - otherlibs/labltk/support/cltkWait.c | 102 - otherlibs/labltk/support/fileevent.ml | 80 - otherlibs/labltk/support/fileevent.mli | 25 - otherlibs/labltk/support/protocol.ml | 275 -- otherlibs/labltk/support/protocol.mli | 115 - otherlibs/labltk/support/rawwidget.ml | 176 -- otherlibs/labltk/support/rawwidget.mli | 109 - otherlibs/labltk/support/slave.ml | 51 - otherlibs/labltk/support/support.ml | 48 - otherlibs/labltk/support/support.mli | 21 - otherlibs/labltk/support/textvariable.ml | 151 -- otherlibs/labltk/support/textvariable.mli | 45 - otherlibs/labltk/support/timer.ml | 57 - otherlibs/labltk/support/timer.mli | 23 - otherlibs/labltk/support/tkthread.ml | 67 - otherlibs/labltk/support/tkthread.mli | 41 - otherlibs/labltk/support/tkwait.ml | 25 - otherlibs/labltk/support/widget.ml | 23 - otherlibs/labltk/support/widget.mli | 109 - otherlibs/str/.depend | 10 - otherlibs/str/Makefile | 87 - otherlibs/str/Makefile.nt | 91 - otherlibs/str/libstr.clib | 1 - otherlibs/str/str.ml | 754 ------ otherlibs/str/str.mli | 248 -- otherlibs/str/strstubs.c | 532 ---- otherlibs/win32graph/.ignore | 2 - otherlibs/win32graph/Makefile.nt | 94 - otherlibs/win32graph/dib.c | 496 ---- otherlibs/win32graph/draw.c | 650 ----- otherlibs/win32graph/events.c | 200 -- otherlibs/win32graph/libgraph.h | 78 - otherlibs/win32graph/libgraphics.clib | 1 - otherlibs/win32graph/open.c | 365 --- 284 files changed, 28343 deletions(-) delete mode 100644 otherlibs/labltk/.ignore delete mode 100644 otherlibs/labltk/Changes delete mode 100644 otherlibs/labltk/Makefile delete mode 100644 otherlibs/labltk/Makefile.nt delete mode 100644 otherlibs/labltk/README delete mode 100644 otherlibs/labltk/Widgets.src delete mode 100644 otherlibs/labltk/browser/.depend delete mode 100644 otherlibs/labltk/browser/.ignore delete mode 100644 otherlibs/labltk/browser/Makefile delete mode 100644 otherlibs/labltk/browser/Makefile.nt delete mode 100644 otherlibs/labltk/browser/README delete mode 100644 otherlibs/labltk/browser/dummyUnix.mli delete mode 100644 otherlibs/labltk/browser/dummyWin.mli delete mode 100644 otherlibs/labltk/browser/editor.ml delete mode 100644 otherlibs/labltk/browser/editor.mli delete mode 100644 otherlibs/labltk/browser/fileselect.ml delete mode 100644 otherlibs/labltk/browser/fileselect.mli delete mode 100644 otherlibs/labltk/browser/help.txt delete mode 100644 otherlibs/labltk/browser/jg_bind.ml delete mode 100644 otherlibs/labltk/browser/jg_bind.mli delete mode 100644 otherlibs/labltk/browser/jg_box.ml delete mode 100644 otherlibs/labltk/browser/jg_button.ml delete mode 100644 otherlibs/labltk/browser/jg_completion.ml delete mode 100644 otherlibs/labltk/browser/jg_completion.mli delete mode 100644 otherlibs/labltk/browser/jg_config.ml delete mode 100644 otherlibs/labltk/browser/jg_config.mli delete mode 100644 otherlibs/labltk/browser/jg_entry.ml delete mode 100644 otherlibs/labltk/browser/jg_memo.ml delete mode 100644 otherlibs/labltk/browser/jg_memo.mli delete mode 100644 otherlibs/labltk/browser/jg_menu.ml delete mode 100644 otherlibs/labltk/browser/jg_message.ml delete mode 100644 otherlibs/labltk/browser/jg_message.mli delete mode 100644 otherlibs/labltk/browser/jg_multibox.ml delete mode 100644 otherlibs/labltk/browser/jg_multibox.mli delete mode 100644 otherlibs/labltk/browser/jg_text.ml delete mode 100644 otherlibs/labltk/browser/jg_text.mli delete mode 100644 otherlibs/labltk/browser/jg_tk.ml delete mode 100644 otherlibs/labltk/browser/jg_toplevel.ml delete mode 100644 otherlibs/labltk/browser/lexical.ml delete mode 100644 otherlibs/labltk/browser/lexical.mli delete mode 100644 otherlibs/labltk/browser/list2.ml delete mode 100644 otherlibs/labltk/browser/main.ml delete mode 100644 otherlibs/labltk/browser/mytypes.mli delete mode 100644 otherlibs/labltk/browser/searchid.ml delete mode 100644 otherlibs/labltk/browser/searchid.mli delete mode 100644 otherlibs/labltk/browser/searchpos.ml delete mode 100644 otherlibs/labltk/browser/searchpos.mli delete mode 100644 otherlibs/labltk/browser/setpath.ml delete mode 100644 otherlibs/labltk/browser/setpath.mli delete mode 100644 otherlibs/labltk/browser/shell.ml delete mode 100644 otherlibs/labltk/browser/shell.mli delete mode 100644 otherlibs/labltk/browser/typecheck.ml delete mode 100644 otherlibs/labltk/browser/typecheck.mli delete mode 100644 otherlibs/labltk/browser/useunix.ml delete mode 100644 otherlibs/labltk/browser/useunix.mli delete mode 100644 otherlibs/labltk/browser/viewer.ml delete mode 100644 otherlibs/labltk/browser/viewer.mli delete mode 100644 otherlibs/labltk/browser/winmain.c delete mode 100644 otherlibs/labltk/builtin/LICENSE delete mode 100644 otherlibs/labltk/builtin/builtin_FilePattern.ml delete mode 100644 otherlibs/labltk/builtin/builtin_GetBitmap.ml delete mode 100644 otherlibs/labltk/builtin/builtin_GetCursor.ml delete mode 100644 otherlibs/labltk/builtin/builtin_GetPixel.ml delete mode 100644 otherlibs/labltk/builtin/builtin_ScrollValue.ml delete mode 100644 otherlibs/labltk/builtin/builtin_bind.ml delete mode 100644 otherlibs/labltk/builtin/builtin_bindtags.ml delete mode 100644 otherlibs/labltk/builtin/builtin_font.ml delete mode 100644 otherlibs/labltk/builtin/builtin_grab.ml delete mode 100644 otherlibs/labltk/builtin/builtin_index.ml delete mode 100644 otherlibs/labltk/builtin/builtin_palette.ml delete mode 100644 otherlibs/labltk/builtin/builtin_text.ml delete mode 100644 otherlibs/labltk/builtin/builtina_empty.ml delete mode 100644 otherlibs/labltk/builtin/builtinf_GetPixel.ml delete mode 100644 otherlibs/labltk/builtin/builtinf_bind.ml delete mode 100644 otherlibs/labltk/builtin/builtini_GetBitmap.ml delete mode 100644 otherlibs/labltk/builtin/builtini_GetCursor.ml delete mode 100644 otherlibs/labltk/builtin/builtini_GetPixel.ml delete mode 100644 otherlibs/labltk/builtin/builtini_ScrollValue.ml delete mode 100644 otherlibs/labltk/builtin/builtini_bind.ml delete mode 100644 otherlibs/labltk/builtin/builtini_bindtags.ml delete mode 100644 otherlibs/labltk/builtin/builtini_font.ml delete mode 100644 otherlibs/labltk/builtin/builtini_grab.ml delete mode 100644 otherlibs/labltk/builtin/builtini_index.ml delete mode 100644 otherlibs/labltk/builtin/builtini_palette.ml delete mode 100644 otherlibs/labltk/builtin/builtini_text.ml delete mode 100644 otherlibs/labltk/builtin/canvas_bind.ml delete mode 100644 otherlibs/labltk/builtin/canvas_bind.mli delete mode 100644 otherlibs/labltk/builtin/dialog.ml delete mode 100644 otherlibs/labltk/builtin/dialog.mli delete mode 100644 otherlibs/labltk/builtin/image.ml delete mode 100644 otherlibs/labltk/builtin/image.mli delete mode 100644 otherlibs/labltk/builtin/optionmenu.ml delete mode 100644 otherlibs/labltk/builtin/optionmenu.mli delete mode 100644 otherlibs/labltk/builtin/rawimg.ml delete mode 100644 otherlibs/labltk/builtin/rawimg.mli delete mode 100644 otherlibs/labltk/builtin/report.ml delete mode 100644 otherlibs/labltk/builtin/selection_handle_set.ml delete mode 100644 otherlibs/labltk/builtin/selection_handle_set.mli delete mode 100644 otherlibs/labltk/builtin/selection_own_set.ml delete mode 100644 otherlibs/labltk/builtin/selection_own_set.mli delete mode 100644 otherlibs/labltk/builtin/text_tag_bind.ml delete mode 100644 otherlibs/labltk/builtin/text_tag_bind.mli delete mode 100644 otherlibs/labltk/builtin/winfo_contained.ml delete mode 100644 otherlibs/labltk/builtin/winfo_contained.mli delete mode 100644 otherlibs/labltk/camltk/.ignore delete mode 100644 otherlibs/labltk/camltk/Makefile delete mode 100644 otherlibs/labltk/camltk/Makefile.gen delete mode 100644 otherlibs/labltk/camltk/Makefile.gen.nt delete mode 100644 otherlibs/labltk/camltk/Makefile.nt delete mode 100644 otherlibs/labltk/camltk/modules delete mode 100644 otherlibs/labltk/compiler/.depend delete mode 100644 otherlibs/labltk/compiler/.ignore delete mode 100644 otherlibs/labltk/compiler/Makefile delete mode 100644 otherlibs/labltk/compiler/Makefile.nt delete mode 100644 otherlibs/labltk/compiler/code.mli delete mode 100644 otherlibs/labltk/compiler/compile.ml delete mode 100644 otherlibs/labltk/compiler/copyright delete mode 100644 otherlibs/labltk/compiler/flags.ml delete mode 100644 otherlibs/labltk/compiler/intf.ml delete mode 100644 otherlibs/labltk/compiler/lexer.mll delete mode 100644 otherlibs/labltk/compiler/maincompile.ml delete mode 100644 otherlibs/labltk/compiler/parser.mly delete mode 100644 otherlibs/labltk/compiler/pp.ml delete mode 100644 otherlibs/labltk/compiler/ppexec.ml delete mode 100644 otherlibs/labltk/compiler/pplex.mli delete mode 100644 otherlibs/labltk/compiler/pplex.mll delete mode 100644 otherlibs/labltk/compiler/ppparse.ml delete mode 100644 otherlibs/labltk/compiler/ppyac.mly delete mode 100644 otherlibs/labltk/compiler/printer.ml delete mode 100644 otherlibs/labltk/compiler/tables.ml delete mode 100644 otherlibs/labltk/compiler/tsort.ml delete mode 100644 otherlibs/labltk/examples_camltk/.ignore delete mode 100644 otherlibs/labltk/examples_camltk/Makefile delete mode 100644 otherlibs/labltk/examples_camltk/Makefile.nt delete mode 100644 otherlibs/labltk/examples_camltk/addition.ml delete mode 100644 otherlibs/labltk/examples_camltk/eyes.ml delete mode 100644 otherlibs/labltk/examples_camltk/fileinput.ml delete mode 100644 otherlibs/labltk/examples_camltk/fileopen.ml delete mode 100644 otherlibs/labltk/examples_camltk/helloworld.ml delete mode 100644 otherlibs/labltk/examples_camltk/images/CamlBook.gif delete mode 100644 otherlibs/labltk/examples_camltk/images/Lambda2.back.gif delete mode 100644 otherlibs/labltk/examples_camltk/images/dojoji.back.gif delete mode 100644 otherlibs/labltk/examples_camltk/jptest.ml delete mode 100644 otherlibs/labltk/examples_camltk/mytext.ml delete mode 100644 otherlibs/labltk/examples_camltk/socketinput.ml delete mode 100644 otherlibs/labltk/examples_camltk/taddition.ml delete mode 100644 otherlibs/labltk/examples_camltk/tetris.ml delete mode 100644 otherlibs/labltk/examples_camltk/text.ml delete mode 100644 otherlibs/labltk/examples_camltk/winskel.ml delete mode 100644 otherlibs/labltk/examples_labltk/.ignore delete mode 100644 otherlibs/labltk/examples_labltk/Lambda2.back.gif delete mode 100644 otherlibs/labltk/examples_labltk/Makefile delete mode 100644 otherlibs/labltk/examples_labltk/Makefile.nt delete mode 100644 otherlibs/labltk/examples_labltk/README delete mode 100644 otherlibs/labltk/examples_labltk/calc.ml delete mode 100644 otherlibs/labltk/examples_labltk/clock.ml delete mode 100644 otherlibs/labltk/examples_labltk/demo.ml delete mode 100644 otherlibs/labltk/examples_labltk/eyes.ml delete mode 100644 otherlibs/labltk/examples_labltk/hello.ml delete mode 100755 otherlibs/labltk/examples_labltk/hello.tcl delete mode 100644 otherlibs/labltk/examples_labltk/lang.ml delete mode 100644 otherlibs/labltk/examples_labltk/taquin.ml delete mode 100644 otherlibs/labltk/examples_labltk/tetris.ml delete mode 100644 otherlibs/labltk/frx/.depend delete mode 100644 otherlibs/labltk/frx/Makefile delete mode 100644 otherlibs/labltk/frx/Makefile.nt delete mode 100644 otherlibs/labltk/frx/README delete mode 100644 otherlibs/labltk/frx/frx_after.ml delete mode 100644 otherlibs/labltk/frx/frx_after.mli delete mode 100644 otherlibs/labltk/frx/frx_color.ml delete mode 100644 otherlibs/labltk/frx/frx_color.mli delete mode 100644 otherlibs/labltk/frx/frx_ctext.ml delete mode 100644 otherlibs/labltk/frx/frx_ctext.mli delete mode 100644 otherlibs/labltk/frx/frx_dialog.ml delete mode 100644 otherlibs/labltk/frx/frx_dialog.mli delete mode 100644 otherlibs/labltk/frx/frx_entry.ml delete mode 100644 otherlibs/labltk/frx/frx_entry.mli delete mode 100644 otherlibs/labltk/frx/frx_fileinput.ml delete mode 100644 otherlibs/labltk/frx/frx_fillbox.ml delete mode 100644 otherlibs/labltk/frx/frx_fillbox.mli delete mode 100644 otherlibs/labltk/frx/frx_fit.ml delete mode 100644 otherlibs/labltk/frx/frx_fit.mli delete mode 100644 otherlibs/labltk/frx/frx_focus.ml delete mode 100644 otherlibs/labltk/frx/frx_focus.mli delete mode 100644 otherlibs/labltk/frx/frx_font.ml delete mode 100644 otherlibs/labltk/frx/frx_font.mli delete mode 100644 otherlibs/labltk/frx/frx_group.ml delete mode 100644 otherlibs/labltk/frx/frx_lbutton.ml delete mode 100644 otherlibs/labltk/frx/frx_lbutton.mli delete mode 100644 otherlibs/labltk/frx/frx_listbox.ml delete mode 100644 otherlibs/labltk/frx/frx_listbox.mli delete mode 100644 otherlibs/labltk/frx/frx_mem.ml delete mode 100644 otherlibs/labltk/frx/frx_mem.mli delete mode 100644 otherlibs/labltk/frx/frx_misc.ml delete mode 100644 otherlibs/labltk/frx/frx_misc.mli delete mode 100644 otherlibs/labltk/frx/frx_req.ml delete mode 100644 otherlibs/labltk/frx/frx_req.mli delete mode 100644 otherlibs/labltk/frx/frx_rpc.ml delete mode 100644 otherlibs/labltk/frx/frx_rpc.mli delete mode 100644 otherlibs/labltk/frx/frx_selection.ml delete mode 100644 otherlibs/labltk/frx/frx_selection.mli delete mode 100644 otherlibs/labltk/frx/frx_synth.ml delete mode 100644 otherlibs/labltk/frx/frx_synth.mli delete mode 100644 otherlibs/labltk/frx/frx_text.ml delete mode 100644 otherlibs/labltk/frx/frx_text.mli delete mode 100644 otherlibs/labltk/frx/frx_toplevel.mli delete mode 100644 otherlibs/labltk/frx/frx_widget.ml delete mode 100644 otherlibs/labltk/frx/frx_widget.mli delete mode 100644 otherlibs/labltk/jpf/Makefile delete mode 100644 otherlibs/labltk/jpf/Makefile.nt delete mode 100644 otherlibs/labltk/jpf/README delete mode 100644 otherlibs/labltk/jpf/balloon.ml delete mode 100644 otherlibs/labltk/jpf/balloon.mli delete mode 100644 otherlibs/labltk/jpf/balloontest.ml delete mode 100644 otherlibs/labltk/jpf/fileselect.ml delete mode 100644 otherlibs/labltk/jpf/fileselect.mli delete mode 100644 otherlibs/labltk/jpf/jpf_font.ml delete mode 100644 otherlibs/labltk/jpf/jpf_font.mli delete mode 100644 otherlibs/labltk/jpf/shell.ml delete mode 100644 otherlibs/labltk/jpf/shell.mli delete mode 100644 otherlibs/labltk/labl.gif delete mode 100644 otherlibs/labltk/labltk/.ignore delete mode 100644 otherlibs/labltk/labltk/Makefile delete mode 100644 otherlibs/labltk/labltk/Makefile.gen delete mode 100644 otherlibs/labltk/labltk/Makefile.gen.nt delete mode 100644 otherlibs/labltk/labltk/Makefile.nt delete mode 100644 otherlibs/labltk/labltk/modules delete mode 100644 otherlibs/labltk/lib/.ignore delete mode 100644 otherlibs/labltk/lib/Makefile delete mode 100644 otherlibs/labltk/lib/Makefile.nt delete mode 100755 otherlibs/labltk/lib/labltk.bat delete mode 100644 otherlibs/labltk/support/.depend delete mode 100644 otherlibs/labltk/support/Makefile delete mode 100644 otherlibs/labltk/support/Makefile.common delete mode 100644 otherlibs/labltk/support/Makefile.common.nt delete mode 100644 otherlibs/labltk/support/Makefile.nt delete mode 100644 otherlibs/labltk/support/camltk.h delete mode 100644 otherlibs/labltk/support/camltkwrap.ml delete mode 100644 otherlibs/labltk/support/camltkwrap.mli delete mode 100644 otherlibs/labltk/support/cltkCaml.c delete mode 100644 otherlibs/labltk/support/cltkDMain.c delete mode 100644 otherlibs/labltk/support/cltkEval.c delete mode 100644 otherlibs/labltk/support/cltkEvent.c delete mode 100644 otherlibs/labltk/support/cltkFile.c delete mode 100644 otherlibs/labltk/support/cltkImg.c delete mode 100644 otherlibs/labltk/support/cltkMain.c delete mode 100644 otherlibs/labltk/support/cltkMisc.c delete mode 100644 otherlibs/labltk/support/cltkTimer.c delete mode 100644 otherlibs/labltk/support/cltkUtf.c delete mode 100644 otherlibs/labltk/support/cltkVar.c delete mode 100644 otherlibs/labltk/support/cltkWait.c delete mode 100644 otherlibs/labltk/support/fileevent.ml delete mode 100644 otherlibs/labltk/support/fileevent.mli delete mode 100644 otherlibs/labltk/support/protocol.ml delete mode 100644 otherlibs/labltk/support/protocol.mli delete mode 100644 otherlibs/labltk/support/rawwidget.ml delete mode 100644 otherlibs/labltk/support/rawwidget.mli delete mode 100644 otherlibs/labltk/support/slave.ml delete mode 100644 otherlibs/labltk/support/support.ml delete mode 100644 otherlibs/labltk/support/support.mli delete mode 100644 otherlibs/labltk/support/textvariable.ml delete mode 100644 otherlibs/labltk/support/textvariable.mli delete mode 100644 otherlibs/labltk/support/timer.ml delete mode 100644 otherlibs/labltk/support/timer.mli delete mode 100644 otherlibs/labltk/support/tkthread.ml delete mode 100644 otherlibs/labltk/support/tkthread.mli delete mode 100644 otherlibs/labltk/support/tkwait.ml delete mode 100644 otherlibs/labltk/support/widget.ml delete mode 100644 otherlibs/labltk/support/widget.mli delete mode 100644 otherlibs/str/.depend delete mode 100644 otherlibs/str/Makefile delete mode 100644 otherlibs/str/Makefile.nt delete mode 100644 otherlibs/str/libstr.clib delete mode 100644 otherlibs/str/str.ml delete mode 100644 otherlibs/str/str.mli delete mode 100644 otherlibs/str/strstubs.c delete mode 100644 otherlibs/win32graph/.ignore delete mode 100644 otherlibs/win32graph/Makefile.nt delete mode 100644 otherlibs/win32graph/dib.c delete mode 100644 otherlibs/win32graph/draw.c delete mode 100755 otherlibs/win32graph/events.c delete mode 100644 otherlibs/win32graph/libgraph.h delete mode 100644 otherlibs/win32graph/libgraphics.clib delete mode 100644 otherlibs/win32graph/open.c diff --git a/otherlibs/labltk/.ignore b/otherlibs/labltk/.ignore deleted file mode 100644 index f58b0734b68c..000000000000 --- a/otherlibs/labltk/.ignore +++ /dev/null @@ -1,4 +0,0 @@ -labltklink -labltkopt -Makefile.config -config.status diff --git a/otherlibs/labltk/Changes b/otherlibs/labltk/Changes deleted file mode 100644 index bd671fdb67b4..000000000000 --- a/otherlibs/labltk/Changes +++ /dev/null @@ -1,13 +0,0 @@ -version 1.0a1 - -General Changes -* Merging CamlTk and LablTk API interfaces -* Activate and Deactivate Events are added -* Virtual events support -* Added UTF conversion - -Incompatibilities between the previous camltk/labltk versions -* CamlTk's bind_tag and bind_class superseded tag_bind and class_bind. -* added optional arguments to some functions of CamlTk. -* The library name libfrx and libjpf are changed to frxlib and jpflib - respectively, to avoid the library name confusion. diff --git a/otherlibs/labltk/Makefile b/otherlibs/labltk/Makefile deleted file mode 100644 index d08f5f51eb8c..000000000000 --- a/otherlibs/labltk/Makefile +++ /dev/null @@ -1,93 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -# Top Makefile for mlTk - -SUBDIRS=compiler support lib jpf frx examples_labltk \ - examples_camltk browser -SUBDIRS_GENERATED=camltk labltk - - -all: - cd support; $(MAKE) - cd compiler; $(MAKE) - cd labltk; $(MAKE) -f Makefile.gen - cd labltk; $(MAKE) - cd camltk; $(MAKE) -f Makefile.gen - cd camltk; $(MAKE) - cd lib; $(MAKE) - cd jpf; $(MAKE) - cd frx; $(MAKE) - cd browser; $(MAKE) - -allopt: - cd support; $(MAKE) opt - cd labltk; $(MAKE) -f Makefile.gen - cd labltk; $(MAKE) opt - cd camltk; $(MAKE) -f Makefile.gen - cd camltk; $(MAKE) opt - cd lib; $(MAKE) opt - cd jpf; $(MAKE) opt - cd frx; $(MAKE) opt - -byte: all -opt: allopt - -.PHONY: labltk camltk examples_labltk examples_camltk - -labltk: Widgets.src - compiler/tkcompiler -outdir labltk - cd labltk; $(MAKE) - -camltk: Widgets.src - compiler/tkcompiler -camltk -outdir camltk - cd camltk; $(MAKE) - -examples: examples_labltk examples_camltk - -examples_labltk: - cd examples_labltk; $(MAKE) all - -examples_camltk: - cd examples_camltk; $(MAKE) all - -install: - cd support; $(MAKE) install - cd lib; $(MAKE) install - cd labltk; $(MAKE) install - cd camltk; $(MAKE) install - cd compiler; $(MAKE) install - cd jpf; $(MAKE) install - cd frx; $(MAKE) install - cd browser; $(MAKE) install - -installopt: - cd support; $(MAKE) installopt - cd lib; $(MAKE) installopt - cd labltk; $(MAKE) installopt - cd camltk; $(MAKE) installopt - cd jpf; $(MAKE) installopt - cd frx; $(MAKE) installopt - -partialclean clean: - for d in $(SUBDIRS); do \ - cd $$d; $(MAKE) -f Makefile clean; cd ..; \ - done - for d in $(SUBDIRS_GENERATED); do \ - cd $$d; $(MAKE) -f Makefile.gen clean; cd ..; \ - done - -depend: diff --git a/otherlibs/labltk/Makefile.nt b/otherlibs/labltk/Makefile.nt deleted file mode 100644 index a0654b6ab559..000000000000 --- a/otherlibs/labltk/Makefile.nt +++ /dev/null @@ -1,72 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 2000 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -# Top Makefile for LablTk - -include ../../config/Makefile - -SUBDIRS=compiler support lib labltk camltk jpf frx examples_labltk examples_camltk browser - -all: - cd support ; $(MAKEREC) - cd compiler ; $(MAKEREC) - cd labltk ; $(MAKECMD) -f Makefile.gen.nt - cd labltk ; $(MAKEREC) - cd camltk ; $(MAKECMD) -f Makefile.gen.nt - cd camltk ; $(MAKEREC) - cd lib ; $(MAKEREC) - cd jpf ; $(MAKEREC) - cd frx ; $(MAKEREC) - cd browser ; $(MAKEREC) - -allopt: - cd support ; $(MAKEREC) opt - cd labltk ; $(MAKECMD) -f Makefile.gen.nt - cd labltk ; $(MAKEREC) opt - cd camltk ; $(MAKECMD) -f Makefile.gen.nt - cd camltk ; $(MAKEREC) opt - cd lib ; $(MAKEREC) opt - cd jpf ; $(MAKEREC) opt - cd frx ; $(MAKEREC) opt - -example: examples_labltk/all examples_camltk/all - -examples_labltk/all: - cd examples_labltk ; $(MAKEREC) all - -examples_camltk/all: - cd examples_camltk ; $(MAKEREC) all - -install: - cd labltk ; $(MAKEREC) install - cd camltk ; $(MAKEREC) install - cd lib ; $(MAKEREC) install - cd support ; $(MAKEREC) install - cd compiler ; $(MAKEREC) install - cd jpf ; $(MAKEREC) install - cd frx ; $(MAKEREC) install - cd browser ; $(MAKEREC) install - -installopt: - cd support ; $(MAKEREC) installopt - cd labltk ; $(MAKEREC) installopt - cd camltk ; $(MAKEREC) installopt - cd lib ; $(MAKEREC) installopt - cd jpf ; $(MAKEREC) installopt - cd frx ; $(MAKEREC) installopt - -partialclean clean: - for d in $(SUBDIRS); do $(MAKEREC) -C $$d clean; done diff --git a/otherlibs/labltk/README b/otherlibs/labltk/README deleted file mode 100644 index 6815b6669dc0..000000000000 --- a/otherlibs/labltk/README +++ /dev/null @@ -1,151 +0,0 @@ -INTRODUCTION -============ -mlTk is a library for interfacing OCaml with the scripting -language Tcl/Tk (all versions since 8.0.3, but no betas). - -In addition to the basic interface with Tcl/Tk, this package contains - * the OCamlBrowser code editor / library browser written by Jacques - Garrigue. - * the "jpf" library, written by Jun P. Furuse; it contains a "file - selector" and "balloon help" support - * the "frx" library, written by Francois Rouaix - * the "tkanim" library, which supports animated gif loading/display - -mlTk = CamlTk + LablTk -====================== -There existed two parallel Tcl/Tk interfaces for OCaml, CamlTk and LablTk. - -CamlTk uses classical features only, therefore it is easy to understand for -the beginners of ML. It makes many conservative OCaml gurus also happy. -LablTk, on the other hand, uses rather newer features of OCaml, the labeled -optional arguments and polymorphic variants. Its syntax has much more Tcl/Tk -script flavor, but provides more powerful typing than CamlTk at the same time -(i.e. less run time type checking of widgets). -Until now, these two interfaces have been distributed and maintained -independently. - -mlTk unifies these libraries into one. Since mlTk provides the both API's, -both CamlTk and LablTk users can compile their applications with mlTk, -just with little fixes. - -REQUIREMENTS -============ -You must have already installed - * OCaml source, version 3.04+8 or later - - * Tcl/Tk 8.0.3 or later - http://www.scriptics.com/ or various mirrors - -PLATFORMS: -Essentially any Unix/X Window System platform. We have tested -releases on Linux (ELF x86), FreeBSD (x86), SunOS4.1.x (sparc), DEC -OSF/1 V4.0 (alpha), DGUX SVR4 (m88k) and Windows (VC++ and Cygwin). - -INSTALLATION -============ - -0. Check-out the OCaml CVS source code tree. - -1. Compile OCaml (= make world). If you want, also make opt. - -2. Untar this mlTk distribution in the otherlibs directory, just like - the labltk source tree. - -3. change directory to otherlibs/mltk, and make (and make opt) - -4. To install the library, make install (and make installopt) - -To compile mlTk, you need the OCaml source tree, since mltk/camlbrowser -requires some modules of OCaml. If you are not interested in camlbrowser, -you can compile mlTk without the OCaml source tree, but you have to modify -support/Makefile.common. - - -Compile your CamlTk/LablTk applications with mlTk -================================================= - -* General - -The names of the additional libraries libjpf and libfrx are changed -to jpflib and frxlib respectively, to avoid the library name space confusion. - -* LablTk users - -Just change the occurrences of labltk in your Makefiles to mltk -(i.e. -I +labltk => -I +mltk, labltk.cma => mltk.cma, and so on) -Since the API functions are 100% compatible, you need not to change -your .ml files. - -* CamlTk users - - - Makefiles : apply the same modification explained above for LablTk users. - - - open Camltk : The API modules and functions are stored in the modules - Camltk. Therefore you need to replace the module name Tk to Camltk. - For example, open Tk => open Camltk. - - open Camltk (* instead of open Tk *) - - let t = openTk ();; - let b = Button.create t [];; - - - You may also need to open the Camltk module explicitly, when your - original module source contain no open Tk phrase. Widget and the other - Tcl/Tk related types are now under Camltk. (e.g. Widget.widget is now - Camltk.Widget.widget) Add open Camltk at the beginning of .mli files, - if these types are used: - - open Camltk (* added for compiling under mlTk *) - - val create_progress_bar : Widget.widget -> Widget.widget - - - Eta expansion to flush optional arguments at registering callbacks. - Functions with the _displayof suffix are unified with their non-displayof - versions, using optional labeled arguments. For example, Bell.ring - had/have the following types: - - before: Bell.ring : unit -> unit - now: Bell.ring : ?displayof:Camltk.widget -> unit -> unit - - If you use these functions as callbacks directly like Command Bell.ring, - you need eta-expansions to flush these new optional arguments: - - Button.create w [Command Bell.ring] - - => Button.create w [Command (fun () -> Bell.ring ())] - -Use the both API's at the same time -=================================== -It is possible to use the both API's in one program. If you want to use -a widget library written in the different API from you use, you need to -do it. (It will be confusing, but easier than porting the library itself -from one to the other API.) - -For the users who mainly use LablTk API, CamlTk API is available -in the modules start with 'C'. For example, the source file of -the CamlTk button widget functions is CButton (and exported also as -Camltk.Button). - -For the users who mainly use CamlTk API, LablTk API modules are exported -inside Labltk module. For example, LablTk's Button module can be also -accessible as Labltk.Button. - -In CamlTk, we have only one widget type, [widget]. This type is equivalent -to the LablTk's type [any widget]. Therefore, if you want to apply CamlTk -functions to LablTk widget, you can use [coe] function to coerce it to -[any widget]. - -To do the converse, the "widget-typers" are available inside the module Labltk. -For example, to recover the type of a button widget, use Labltk.button. -These widget-typers checks the types of widgets at run-time. If the widget -type is different from the context type, a run-time exception is raised. - - open Tk (* open LablTk API *) - - let t = openTk ();; (* t is LablTk widget, toplevel widget *) - (* CButton.create takes [any widget]; [t] must be coerced to the type. *) - let caml_b = CButton.create (coe t) [];; - (* caml_b is [any widget], must be explicitly typed as [button widget], - when it is used with LablTk API functions *) - let b = Labltk.button caml_b in (* recover the type [button widget] *) - ... diff --git a/otherlibs/labltk/Widgets.src b/otherlibs/labltk/Widgets.src deleted file mode 100644 index e662682788d1..000000000000 --- a/otherlibs/labltk/Widgets.src +++ /dev/null @@ -1,2304 +0,0 @@ -%(***********************************************************************) -%(* *) -%(* MLTk, Tcl/Tk interface of OCaml *) -%(* *) -%(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -%(* projet Cristal, INRIA Rocquencourt *) -%(* Jacques Garrigue, Kyoto University RIMS *) -%(* *) -%(* Copyright 2002 Institut National de Recherche en Informatique et *) -%(* en Automatique and Kyoto University. All rights reserved. *) -%(* This file is distributed under the terms of the GNU Library *) -%(* General Public License, with the special exception on linking *) -%(* described in file LICENSE found in the OCaml source tree. *) -%(* *) -%(***********************************************************************) - -%%%%%%%%%%%%%% Standard Tk8.0.3 Widgets and functions %%%%%%%%%%%%%% -type Widget external - -% cget will probably never be implemented with verifications -function (string) cgets [widget; "cget"; string] -% another version with some hack is -type options_constrs external -function (string) cget [widget; "cget"; options_constrs] -% constructors of type options_constrs are of the form C -% where is an option constructor (e.g. CBackground) - -%%%%% Some types for standard options of widgets -type Anchor { - NW ["nw"] N ["n"] NE ["ne"] - W ["w"] Center ["center"] E ["e"] - SW ["sw"] S ["s"] SE ["se"] -} - -type Bitmap external % builtin_GetBitmap.ml -type Cursor external % builtin_GetCursor.ml -type Color external % builtin_GetCursor.ml - -##ifdef CAMLTK - -type ImageBitmap { - BitmapImage [string] - } -type ImagePhoto { - PhotoImage [string] - } - -##else - -variant type ImageBitmap { - Bitmap [string] - } -variant type ImagePhoto { - Photo [string] - } -variant type Image { - Bitmap [string] - Photo [string] -} - -##endif - -type Justification { - Justify_Left ["left"] - Justify_Center ["center"] - Justify_Right ["right"] -} - -type Orientation { - Vertical ["vertical"] - Horizontal ["horizontal"] -} - -type Relief { - Raised ["raised"] - Sunken ["sunken"] - Flat ["flat"] - Ridge ["ridge"] - Solid ["solid"] - Groove ["groove"] -} - -type TextVariable external % textvariable.ml -type Units external % builtin_GetPixel.ml - -%%%%% The standard options, as defined in man page options(n) -%%%%% The subtype is never used -subtype option(standard) { - ActiveBackground ["-activebackground"; Color] - ActiveBorderWidth ["-activeborderwidth"; Units/int] - ActiveForeground ["-activeforeground"; Color] - Anchor ["-anchor"; Anchor] - Background ["-background"; Color] - Bitmap ["-bitmap"; Bitmap] - BorderWidth ["-borderwidth"; Units/int] - Cursor ["-cursor"; Cursor] - DisabledForeground ["-disabledforeground"; Color] - ExportSelection ["-exportselection"; bool] - Font ["-font"; string] - Foreground ["-foreground"; Color] -% Geometry is not one of standard options... - Geometry ["-geometry"; string] % Too variable to encode - HighlightBackground ["-highlightbackground"; Color] - HighlightColor ["-highlightcolor"; Color] - HighlightThickness ["-highlightthickness"; Units/int] -##ifdef CAMLTK - % images are split, to do additionnal static typing - ImageBitmap (ImageBitmap) ["-image"; ImageBitmap] - ImagePhoto (ImagePhoto) ["-image"; ImagePhoto] -##else - Image ["-image"; Image] -##endif - InsertBackground ["-insertbackground"; Color] - InsertBorderWidth ["-insertborderwidth"; Units/int] - InsertOffTime ["-insertofftime"; int] % Positive only - InsertOnTime ["-insertontime"; int] % Idem - InsertWidth ["-insertwidth"; Units/int] - Jump ["-jump"; bool] - Justify ["-justify"; Justification] - Orient ["-orient"; Orientation] - PadX ["-padx"; Units/int] - PadY ["-pady"; Units/int] - Relief ["-relief"; Relief] - RepeatDelay ["-repeatdelay"; int] - RepeatInterval ["-repeatinterval"; int] - SelectBackground ["-selectbackground"; Color] - SelectBorderWidth ["-selectborderwidth"; Units/int] - SelectForeground ["-selectforeground"; Color] - SetGrid ["-setgrid"; bool] - % incomplete description of TakeFocus - TakeFocus ["-takefocus"; bool] - Text ["-text"; string] - TextVariable ["-textvariable"; TextVariable] - TroughColor ["-troughcolor"; Color] - UnderlinedChar ["-underline"; int] - WrapLength ["-wraplength"; Units/int] - XScrollCommand ["-xscrollcommand"; function(first:float, last:float)] - YScrollCommand ["-yscrollcommand"; function(first:float, last:float)] -} - -%%%% Some other common types -type Index external % builtin_index.ml -type sequence ScrollValue external % builtin_ScrollValue.ml -% type sequence ScrollValue { -% MoveTo ["moveto"; float] -% ScrollUnit ["scroll"; int; "unit"] -% ScrollPage ["scroll"; int; "page"] -% } - - - -%%%%% bell(n) -module Bell { -##ifdef CAMLTK - function () ring ["bell"; ?displayof:["-displayof"; widget]] - function () ring_displayof ["bell"; "-displayof" ; displayof: widget] -##else - function () ring ["bell"; ?displayof:["-displayof"; widget]] -##endif - } - -%%%%% bind(n) -% builtin_bind.ml - - -%%%%% bindtags(n) -%type Bindings { -% TagBindings [string] -% WidgetBindings [widget] -% } - -type Bindings external - -function () bindtags ["bindtags"; widget; [bindings: Bindings list]] -function (Bindings list) bindtags_get ["bindtags"; widget] - -%%%%% bitmap(n) -subtype option(bitmapimage) { - Background - Data ["-data"; string] - File ["-file"; string] - Foreground - Maskdata ["-maskdata"; string] - Maskfile ["-maskfile"; string] - } - -module Imagebitmap { - function (ImageBitmap) create ["image"; "create"; "bitmap"; ?name:[ImageBitmap]; option(bitmapimage) list] -##ifdef CAMLTK - function (ImageBitmap) create_named ["image"; "create"; "bitmap"; ImageBitmap; option(bitmapimage) list] -##endif - function () delete ["image"; "delete"; ImageBitmap] - function (int) height ["image"; "height"; ImageBitmap] - function (int) width ["image"; "width"; ImageBitmap] - function () configure [ImageBitmap; "configure"; option(bitmapimage) list] - function (string) configure_get [ImageBitmap; "configure"] - % Functions inherited from the "image" TK class - } - -%%%%% button(n) - -type State { - Normal ["normal"] - Active ["active"] - Disabled ["disabled"] - Hidden ["hidden"] % introduced in tk8.3, requested for Syndex -} - -widget button { - % Standard options - option ActiveBackground - option ActiveForeground - option Anchor - option Background - option Bitmap - option BorderWidth - option Cursor - option DisabledForeground - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness -##ifdef CAMLTK - option ImageBitmap - option ImagePhoto -##else - option Image -##endif - option Justify - option PadX - option PadY - option Relief - option TakeFocus - option Text - option TextVariable - option UnderlinedChar - option WrapLength - % Widget specific options - option Command ["-command"; function ()] - option Default ["-default"; State] - option Height ["-height"; Units/int] - option State ["-state"; State] - option Width ["-width"; Units/int] - - function () configure [widget(button); "configure"; option(button) list] - function (string) configure_get [widget(button); "configure"] - function () flash [widget(button); "flash"] - function () invoke [widget(button); "invoke"] - } - - -%%%%%% canvas(n) -% Item ids and tags -type TagOrId { - Tag [string] - Id [int] -} - -% Indices: defined internally -% subtype Index(canvas) { -% Number End Insert SelFirst SelLast AtXY -% } - -type SearchSpec { - Above ["above"; TagOrId] - All ["all"] - Below ["below"; TagOrId] - Closest ["closest"; Units/int; Units/int] - ClosestHalo (Closesthalo) ["closest"; Units/int; Units/int; Units/int] - ClosestHaloStart (Closesthalostart) ["closest"; Units/int; Units/int; Units/int; TagOrId] - Enclosed ["enclosed"; Units/int;Units/int;Units/int;Units/int] - Overlapping ["overlapping"; int;int;int;int] - Withtag ["withtag"; TagOrId] -} - -type ColorMode { - Color ["color"] - Gray ["gray"] - Mono ["mono"] -} - -subtype option(postscript) { - % Cannot support this without array variables - % Colormap ["-colormap"; TextVariable] - Colormode ["-colormode"; ColorMode] - File ["-file"; string] - % Fontmap ["-fontmap"; TextVariable] - Height - PageAnchor ["-pageanchor"; Anchor] - PageHeight ["-pageheight"; Units/int] - PageWidth ["-pagewidth"; Units/int] - PageX ["-pagex"; Units/int] - PageY ["-pagey"; Units/int] - Rotate ["-rotate"; bool] - Width - X ["-x"; Units/int] - Y ["-y"; Units/int] - } - - -% Arc item configuration -type ArcStyle { - Arc ["arc"] - Chord ["chord"] - PieSlice ["pieslice"] -} - -subtype option(arc) { - Extent ["-extent"; float] - Dash ["-dash"; string] - % Fill is used by packer - FillColor ["-fill"; Color] - Outline ["-outline"; Color] - OutlineStipple ["-outlinestipple"; Bitmap] - Start ["-start"; float] - Stipple ["-stipple"; Bitmap] - ArcStyle ["-style"; ArcStyle] - Tags ["-tags"; [TagOrId/string list]] - Width - } - -% Bitmap item configuration -subtype option(bitmap) { - Anchor - Background - Bitmap - Foreground - Tags -} - -% Image item configuration -subtype option(image) { - Anchor -##ifdef CAMLTK - ImagePhoto - ImageBitmap -##else - Image -##endif - Tags -} - -% Line item configuration -type ArrowStyle { - Arrow_None ["none"] - Arrow_First ["first"] - Arrow_Last ["last"] - Arrow_Both ["both"] -} - -type CapStyle { - Cap_Butt ["butt"] - Cap_Projecting ["projecting"] - Cap_Round ["round"] -} - -type JoinStyle { - Join_Bevel ["bevel"] - Join_Miter ["miter"] - Join_Round ["round"] -} - -subtype option(line) { - ArrowStyle ["-arrow"; ArrowStyle] - ArrowShape ["-arrowshape"; [Units/int; Units/int; Units/int]] - CapStyle ["-capstyle"; CapStyle] - Dash - FillColor - JoinStyle ["-joinstyle"; JoinStyle] - Smooth ["-smooth"; bool] - SplineSteps ["-splinesteps"; int] - Stipple - Tags - Width - } - -% Oval item configuration -subtype option(oval) { - Dash FillColor Outline Stipple Tags Width - } - -% Polygon item configuration -subtype option(polygon) { - Dash FillColor Outline Smooth SplineSteps - Stipple Tags Width - } - -% Rectangle item configuration -subtype option(rectangle) { - Dash FillColor Outline Stipple Tags Width - } - -% Text item configuration - -##ifndef CAMLTK -% Only for Labltk. CanvasTextState is unified as State in Camltk -type CanvasTextState { - Normal ["normal"] - Disabled ["disabled"] - Hidden ["hidden"] -} -##endif - -subtype option(canvastext) { - Anchor FillColor Font Justify - Stipple Tags Text Width -##ifdef CAMLTK - State % introduced in tk8.3, requested for Syndex -##else - CanvasTextState ["-state"; CanvasTextState] % introduced in tk8.3, requested for Syndex -##endif - } - -% Window item configuration -subtype option(window) { - Anchor Height Tags Width - Window ["-window"; widget] - Dash - } - -% Types of items -type CanvasItem { - Arc_item ["arc"] - Bitmap_item ["bitmap"] - Image_item ["image"] - Line_item ["line"] - Oval_item ["oval"] - Polygon_item ["polygon"] - Rectangle_item ["rectangle"] - Text_item ["text"] - Window_item ["window"] - User_item [string] -} - -widget canvas { - % Standard options - option Background - option BorderWidth - option Cursor - option HighlightBackground - option HighlightColor - option HighlightThickness - option InsertBackground - option InsertBorderWidth - option InsertOffTime - option InsertOnTime - option InsertWidth - option Relief - option SelectBackground - option SelectBorderWidth - option SelectForeground - option TakeFocus - option XScrollCommand - option YScrollCommand - % Widget specific options - option CloseEnough ["-closeenough"; float] - option Confine ["-confine"; bool] - option Height ["-height"; Units/int] - option ScrollRegion ["-scrollregion"; [Units/int;Units/int;Units/int;Units/int]] - option Width ["-width"; Units/int] - option XScrollIncrement ["-xscrollincrement"; Units/int] - option YScrollIncrement ["-yscrollincrement"; Units/int] - - - function () addtag [widget(canvas); "addtag"; tag: TagOrId/string; specs: SearchSpec list] % Tag only - % bbox not fully supported. should be builtin because of ambiguous result - % will raise Protocol.TkError if no items match TagOrId - function (int,int,int,int) bbox [widget(canvas); "bbox"; TagOrId list] - external bind "builtin/canvas_bind" -##ifdef CAMLTK - function (float) canvasx [widget(canvas); "canvasx"; ?spacing:[Units]; Units] - function (float) canvasy [widget(canvas); "canvasy"; ?spacing:[Units]; Units] - function (float) canvasx_grid [widget(canvas); "canvasx"; Units; Units] - function (float) canvasy_grid [widget(canvas); "canvasy"; Units; Units] -##else - function (float) canvasx [widget(canvas); "canvasx"; x:int; ?spacing:[int]] - function (float) canvasy [widget(canvas); "canvasy"; y:int; ?spacing:[int]] -##endif - function () configure [widget(canvas); "configure"; option(canvas) list] - function (string) configure_get [widget(canvas); "configure"] - % TODO: check result - function (float list) coords_get [widget(canvas); "coords"; TagOrId] -##ifdef CAMLTK - function () coords_set [widget(canvas); "coords"; TagOrId; xys: Units list] -##else - function () coords_set [widget(canvas); "coords"; TagOrId; xys: {int, int} list] -##endif - % create variations (see below) - function () dchars [widget(canvas); "dchars"; TagOrId; first: Index(canvas); last: Index(canvas)] - function () delete [widget(canvas); "delete"; TagOrId list] - function () dtag [widget(canvas); "dtag"; TagOrId; tag: TagOrId/string] - function (TagOrId list) find [widget(canvas); "find"; specs: SearchSpec list] - % focus variations - function () focus_reset [widget(canvas); "focus"; ""] - function (TagOrId) focus_get [widget(canvas); "focus"] - function () focus [widget(canvas); "focus"; TagOrId] - function (TagOrId/string list) gettags [widget(canvas); "gettags"; TagOrId] - function () icursor [widget(canvas); "icursor"; TagOrId; index: Index(canvas)] - function (int) index [widget(canvas); "index"; TagOrId; index: Index(canvas)] - function () insert [widget(canvas); "insert"; TagOrId; before: Index(canvas); text: string] - % itemcget, itemconfigure are defined later - function () lower [widget(canvas); "lower"; TagOrId; ?below: [TagOrId]] -##ifdef CAMLTK - function () lower_below [widget(canvas); "lower"; TagOrId; TagOrId] - function () lower_bot [widget(canvas); "lower"; TagOrId] -##endif - function () move [widget(canvas); "move"; TagOrId; x: Units/int; y: Units/int] - unsafe function (string) postscript [widget(canvas); "postscript"; option(postscript) list] - % We use raise with Module name - function () raise [widget(canvas); "raise"; TagOrId; ?above:[TagOrId]] -##ifdef CAMLTK - function () raise_above [widget(canvas); "raise"; TagOrId; TagOrId] - function () raise_top [widget(canvas); "raise"; TagOrId] -##endif - function () scale [widget(canvas); "scale"; TagOrId; xorigin: Units/int; yorigin: Units/int; xscale: float; yscale: float] - % For scan, use x:int and y:int since common usage is with mouse coordinates - function () scan_mark [widget(canvas); "scan"; "mark"; x: int; y: int] - function () scan_dragto [widget(canvas); "scan"; "dragto"; x: int; y: int] - % select variations - function () select_adjust [widget(canvas); "select"; "adjust"; TagOrId; index: Index(canvas)] - function () select_clear [widget(canvas); "select"; "clear"] - function () select_from [widget(canvas); "select"; "from"; TagOrId; index: Index(canvas)] - function (TagOrId) select_item [widget(canvas); "select"; "item"] - function () select_to [widget(canvas); "select"; "to"; TagOrId; index: Index(canvas)] - - function (CanvasItem) typeof [widget(canvas); "type"; TagOrId] - function (float,float) xview_get [widget(canvas); "xview"] - function (float,float) yview_get [widget(canvas); "yview"] - function () xview [widget(canvas); "xview"; scroll: ScrollValue] - function () yview [widget(canvas); "yview"; scroll: ScrollValue] - - % create and configure variations - function (TagOrId) create_arc [widget(canvas); "create"; "arc"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(arc) list] - function (TagOrId) create_bitmap [widget(canvas); "create"; "bitmap"; x: Units/int; y: Units/int; option(bitmap) list] - function (TagOrId) create_image [widget(canvas); "create"; "image"; x: Units/int; y: Units/int; option(image) list] -##ifdef CAMLTK - function (TagOrId) create_line [widget(canvas); "create"; "line"; Units list; option(line) list] - function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; Units list; option(polygon) list] -##else - function (TagOrId) create_line [widget(canvas); "create"; "line"; xys: {int, int} list; option(line) list] - function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; xys: {int, int} list; option(polygon) list] -##endif - function (TagOrId) create_oval [widget(canvas); "create"; "oval"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(oval) list] - function (TagOrId) create_rectangle [widget(canvas); "create"; "rectangle"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(rectangle) list] - function (TagOrId) create_text [widget(canvas); "create"; "text"; x: Units/int; y: Units/int; option(canvastext) list] - function (TagOrId) create_window [widget(canvas); "create"; "window"; x: Units/int; y: Units/int; option(window) list] - - function (string) itemconfigure_get [widget(canvas); "itemconfigure"; TagOrId] - - function () configure_arc [widget(canvas); "itemconfigure"; TagOrId; option(arc) list] - function () configure_bitmap [widget(canvas); "itemconfigure"; TagOrId; option(bitmap) list] - function () configure_image [widget(canvas); "itemconfigure"; TagOrId; option(image) list] - function () configure_line [widget(canvas); "itemconfigure"; TagOrId; option(line) list] - function () configure_oval [widget(canvas); "itemconfigure"; TagOrId; option(oval) list] - function () configure_polygon [widget(canvas); "itemconfigure"; TagOrId; option(polygon) list] - function () configure_rectangle [widget(canvas); "itemconfigure"; TagOrId; option(rectangle) list] - function () configure_text [widget(canvas); "itemconfigure"; TagOrId; option(canvastext) list] - function () configure_window [widget(canvas); "itemconfigure"; TagOrId; option(window) list] - } - - -%%%%% checkbutton(n) -widget checkbutton { - % Standard options - option ActiveBackground - option ActiveForeground - option Anchor - option Background - option Bitmap - option BorderWidth - option Cursor - option DisabledForeground - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness -##ifdef CAMLTK - option ImageBitmap - option ImagePhoto -##else - option Image -##endif - option Justify - option PadX - option PadY - option Relief - option TakeFocus - option Text - option TextVariable - option UnderlinedChar - option WrapLength - % Widget specific options - option Command - option Height - option IndicatorOn ["-indicatoron"; bool] - option OffValue ["-offvalue"; string] - option OnValue ["-onvalue"; string] - option SelectColor ["-selectcolor"; Color] -##ifdef CAMLTK - option SelectImageBitmap (SelectImageBitmap) ["-selectimage"; ImageBitmap] - option SelectImagePhoto (SelectImagePhoto) ["-selectimage"; ImagePhoto] -##else - option SelectImage ["-selectimage"; Image] -##endif - option State - option Variable ["-variable"; TextVariable] - option Width - - function () configure [widget(checkbutton); "configure"; option(checkbutton) list] - function (string) configure_get [widget(checkbutton); "configure"] - function () deselect [widget(checkbutton); "deselect"] - function () flash [widget(checkbutton); "flash"] - function () invoke [widget(checkbutton); "invoke"] - function () select [widget(checkbutton); "select"] - function () toggle [widget(checkbutton); "toggle"] - } - -%%%%% clipboard(n) -subtype icccm(clipboard_append) { - ICCCMFormat ["-format"; string] - ICCCMType ["-type"; string] - } - -module Clipboard { - function () clear ["clipboard"; "clear"; ?displayof:["-displayof"; widget]] - function () append ["clipboard"; "append"; ?displayof:["-displayof"; widget]; icccm(clipboard_append) list; "--"; data: string] - } - -%%%%% destroy(n) -function () destroy ["destroy"; widget] - -%%%%% tk_dialog(n) -module Dialog { - external create "builtin/dialog" - } - -%%%%% entry(n) -% Defined internally -% subtype Index(entry) { -% Number End Insert SelFirst SelLast At AnchorPoint -% } - -##ifndef CAMLTK -% Only for Labltk. InputState is unified as State in Camltk -type InputState { - Normal ["normal"] - Disabled ["disabled"] -} -##endif - -widget entry { - % Standard options - option Background - option BorderWidth - option Cursor - option ExportSelection - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness - option InsertBackground - option InsertBorderWidth - option InsertOffTime - option InsertOnTime - option InsertWidth - option Justify - option Relief - option SelectBackground - option SelectBorderWidth - option SelectForeground - option TakeFocus - option TextVariable - option XScrollCommand - - % Widget specific options - option Show ["-show"; char] -##ifdef CAMLTK - option State -##else - option EntryState ["-state"; InputState] -##endif - option TextWidth (Textwidth) ["-width"; int] - - function (int,int,int,int) bbox [widget(entry); "bbox"; Index(entry)] - function () configure [widget(entry); "configure"; option(entry) list] - function (string) configure_get [widget(entry); "configure"] - function () delete_single [widget(entry); "delete"; index: Index(entry)] - function () delete_range [widget(entry); "delete"; start: Index(entry); stop: Index(entry)] - function (string) get [widget(entry); "get"] - function () icursor [widget(entry); "icursor"; index: Index(entry)] - function (int) index [widget(entry); "index"; index: Index(entry)] - function () insert [widget(entry); "insert"; index: Index(entry); text: string] - function () scan_mark [widget(entry); "scan"; "mark"; x: int] - function () scan_dragto [widget(entry); "scan"; "dragto"; x: int] - % selection variation - function () selection_adjust [widget(entry); "selection"; "adjust"; index: Index(entry)] - function () selection_clear [widget(entry); "selection"; "clear"] - function () selection_from [widget(entry); "selection"; "from"; index: Index(entry)] - function (bool) selection_present [widget(entry); "selection"; "present"] - function () selection_range [widget(entry); "selection"; "range"; start: Index(entry) ; stop: Index(entry)] - function () selection_to [widget(entry); "selection"; "to"; index: Index(entry)] - - function (float,float) xview_get [widget(entry); "xview"] - function () xview [widget(entry); "xview"; scroll: ScrollValue] - function () xview_index [widget(entry); "xview"; index: Index(entry)] - function (float, float) xview_get [widget(entry); "xview"] - } - - -%%%%% focus(n) -%%%%% tk_focusNext(n) -module Focus { - unsafe function (widget) get ["focus"; ?displayof:["-displayof"; widget]] - unsafe function (widget) displayof ["focus"; "-displayof"; widget] - function () set ["focus"; widget] - function () force ["focus"; "-force"; widget] - unsafe function (widget) lastfor ["focus"; "-lastfor"; widget] - unsafe function (widget) next ["tk_focusNext"; widget] - unsafe function (widget) prev ["tk_focusPrev"; widget] - function () follows_mouse ["tk_focusFollowsMouse"] -} - -type font external % builtin/builtin_font.ml - -type weight { - Weight_Normal(Normal) ["normal"] - Weight_Bold(Bold) ["bold"] -} - -type slant { - Slant_Roman(Roman) ["roman"] - Slant_Italic(Italic) ["italic"] -} - -type fontMetrics { - Ascent ["-ascent"] - Descent ["-descent"] - Linespace ["-linespace"] - Fixed ["-fixed"] -} - -subtype options(font) { - Font_Family ["-family"; string] - Font_Size ["-size"; int] - Font_Weight ["-weight"; weight] - Font_Slant ["-slant"; slant] - Font_Underline ["-underline"; bool] - Font_Overstrike ["-overstrike"; bool] -% later, JP only -% Charset ["-charset"; string] -%% Beware of the order of Compound ! Put it as the first option -% Compound ["-compound"; [font list]] -% Copy ["-copy"; string] -} - -module Font { - function (string) actual_family ["font"; "actual"; font; - ?displayof:["-displayof"; widget]; - "-family"] - function (int) actual_size ["font"; "actual"; font; - ?displayof:["-displayof"; widget]; - "-size"] - function (string) actual_weight ["font"; "actual"; font; - ?displayof:["-displayof"; widget]; - "-weight"] - function (string) actual_slant ["font"; "actual"; font; - ?displayof:["-displayof"; widget]; - "-slant"] - function (bool) actual_underline ["font"; "actual"; font; - ?displayof:["-displayof"; widget]; - "-underline"] - function (bool) actual_overstrike ["font"; "actual"; font; - ?displayof:["-displayof"; widget]; - "-overstrike"] - - function () configure ["font"; "configure"; font; options(font) list] - function (font) create ["font"; "create"; ?name:[string]; options(font) list] -##ifdef CAMLTK - function (font) create_named ["font"; "create"; string; options(font) list] -##endif - function () delete ["font"; "delete"; font] - function (string list) families ["font"; "families"; - ?displayof:["-displayof"; widget]] -##ifdef CAMLTK - function (string list) families_displayof ["font"; "families"; - "-displayof"; widget] -##endif - function (int) measure ["font"; "measure"; font; string; - ?displayof:["-displayof"; widget]] -##ifdef CAMLTK - function (int) measure_displayof ["font"; "measure"; font; - "-displayof"; widget; string ] -##endif - function (int) metrics ["font"; "metrics"; font; - ?displayof:["-displayof"; widget]; - fontMetrics ] -##ifdef CAMLTK - function (int) metrics_displayof ["font"; "metrics"; font; - "-displayof"; widget; - fontMetrics ] -##endif - function (string list) names ["font"; "names"] -% JP -% function () failsafe ["font"; "failsafe"; string] -} - -%%%%% frame(n) -type Colormap { - NewColormap (New) ["new"] - WidgetColormap (Widget) [widget] - } - -% Visual classes are: directcolor, grayscale, greyscale, pseudocolor, -% staticcolor, staticgray, staticgrey, truecolor -type Visual { - ClassVisual (Clas) [[string; int]] - DefaultVisual ["default"] - WidgetVisual (Widget) [widget] - BestDepth (Bestdepth) [["best"; int]] - Best ["best"] - } - -widget frame { - % Standard options - option BorderWidth - option Cursor - option HighlightBackground - option HighlightColor - option HighlightThickness - option Relief - option TakeFocus - - % Widget specific options - option Background -##ifdef CAMLTK - option Class ["-class"; string] -##else - option Clas ["-class"; string] -##endif - option Colormap ["-colormap"; Colormap] - option Container ["-container"; bool] - option Height - option Visual ["-visual"; Visual] - option Width - - % Class and Colormap and Visual cannot be changed - function () configure [widget(frame); "configure"; option(frame) list] - function (string) configure_get [widget(frame); "configure"] - } - - - -%%%%% grab(n) -type GrabStatus { - GrabNone ["none"] - GrabLocal ["local"] - GrabGlobal ["global"] -} -type GrabGlobal external -module Grab { - function () set ["grab"; "set"; ?global:[GrabGlobal]; widget] -##ifdef CAMLTK - function () set_global ["grab"; "set"; "-global"; widget] -##endif - unsafe function (widget list) current ["grab"; "current"; ?displayof:[widget]] -##ifdef CAMLTK - % all_current is now current. - % The old current is now current_of - unsafe function (widget list) current_of ["grab"; "current"; widget] -##endif - function () release ["grab"; "release"; widget] - function (GrabStatus) status ["grab"; "status"; widget] -} - -subtype option(rowcolumnconfigure) { - Minsize ["-minsize"; Units/int] - Weight ["-weight"; int] - Pad ["-pad"; Units/int] -} - -subtype option(grid) { - Column ["-column"; int] - ColumnSpan ["-columnspan"; int] - In(Inside) ["-in"; widget] - IPadX ["-ipadx"; Units/int] - IPadY ["-ipady"; Units/int] - PadX - PadY - Row ["-row"; int] - RowSpan ["-rowspan"; int] - Sticky ["-sticky"; string] - } - -% Same as pack -function () grid ["grid"; widget list; option(grid) list] - -module Grid { - function (int,int,int,int) bbox ["grid"; "bbox"; widget] - function (int,int,int,int) bbox_cell ["grid"; "bbox"; widget; column: int; row: int] - function (int,int,int,int) bbox_span ["grid"; "bbox"; widget; column1: int; row1: int; column2: int; row2: int] - function () column_configure - ["grid"; "columnconfigure"; widget; int; - option(rowcolumnconfigure) list] - function () configure ["grid"; "configure"; widget list; option(grid) list] - function (string) column_configure_get ["grid"; "columnconfigure"; widget; - int] - function () forget ["grid"; "forget"; widget list] - %% info returns only a string - function (string) info ["grid"; "info"; widget] - %% TODO: check result values - function (int,int) location ["grid"; "location"; widget; x:Units/int; y:Units/int] - function (bool) propagate_get ["grid"; "propagate"; widget] - function () propagate_set ["grid"; "propagate"; widget; bool] - function () row_configure - ["grid"; "rowconfigure"; widget; int; option(rowcolumnconfigure) list] - function (string) row_configure_get ["grid"; "rowconfigure"; widget; int] - function (int,int) size ["grid"; "size"; widget] - -##ifdef CAMLTK - function (widget list) slaves ["grid"; "slaves"; widget; ?column:["-column"; int]; ?row:["-row"; int]] - function (widget list) row_slaves ["grid"; "slaves"; widget; "-row"; int] - function (widget list) column_slaves ["grid"; "slaves"; widget; "-column"; int] -##else - function (widget list) slaves ["grid"; "slaves"; widget; ?column:["-column"; int]; ?row:["-row"; int]] -##endif - } - -%%%%% image(n) -%%%%% cf Imagephoto and Imagebitmap -% Some functions on images are implemented in Imagephoto or Imagebitmap. -module Image { - external names "builtin/image" -} - -%%%%% label(n) -widget label { - % Standard options - option Anchor - option Background - option Bitmap - option BorderWidth - option Cursor - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness -##ifdef CAMLTK - option ImageBitmap - option ImagePhoto -##else - option Image -##endif - option Justify - option PadX - option PadY - option Relief - option TakeFocus - option Text - option TextVariable - option UnderlinedChar - option WrapLength - - % Widget specific options - option Height - % use according to label contents - option Width - option TextWidth - - function () configure [widget(label); "configure"; option(label) list] - function (string) configure_get [widget(label); "configure"] - } - - -%%%%% listbox(n) - -% Defined internally -% subtype Index(listbox) { -% Number Active AnchorPoint End AtXY -%} - -type SelectModeType { - Single ["single"] - Browse ["browse"] - Multiple ["multiple"] - Extended ["extended"] - } - - -widget listbox { - % Standard options - option Background - option BorderWidth - option Cursor - option ExportSelection - option Font - option Foreground - % Height is TextHeight - option HighlightBackground - option HighlightColor - option HighlightThickness - option Relief - option SelectBackground - option SelectBorderWidth - option SelectForeground - option SetGrid - option TakeFocus - % Width is TextWidth - option XScrollCommand - option YScrollCommand - % Widget specific options - option TextHeight ["-height"; int] - option TextWidth - option SelectMode ["-selectmode"; SelectModeType] - - function () activate [widget(listbox); "activate"; index: Index(listbox)] - function (int,int,int,int) bbox [widget(listbox); "bbox"; index: Index(listbox)] - function () configure [widget(listbox); "configure"; option(listbox) list] - function (string) configure_get [widget(listbox); "configure"] - function (Index(listbox) as "[>`Num of int]" list) curselection [widget(listbox); "curselection"] - function () delete [widget(listbox); "delete"; first: Index(listbox); last: Index(listbox)] - function (string) get [widget(listbox); "get"; index: Index(listbox)] - function (string list) get_range [widget(listbox); "get"; first: Index(listbox); last: Index(listbox)] - function (Index(listbox) as "[>`Num of int]") index [widget(listbox); "index"; index: Index(listbox)] - function () insert [widget(listbox); "insert"; index: Index(listbox); texts: string list] - function (Index(listbox) as "[>`Num of int]") nearest [widget(listbox); "nearest"; y: int] - function () scan_mark [widget(listbox); "scan"; "mark"; x: int; y: int] - function () scan_dragto [widget(listbox); "scan"; "dragto"; x: int; y: int] - function () see [widget(listbox); "see"; index: Index(listbox)] - function () selection_anchor [widget(listbox); "selection"; "anchor"; index: Index(listbox)] - function () selection_clear [widget(listbox); "selection"; "clear"; first: Index(listbox); last: Index(listbox)] - function (bool) selection_includes [widget(listbox); "selection"; "includes"; index: Index(listbox)] - function () selection_set [widget(listbox); "selection"; "set"; first: Index(listbox); last: Index(listbox)] - function (int) size [widget(listbox); "size"] - - function (float,float) xview_get [widget(listbox); "xview"] - function (float,float) yview_get [widget(listbox); "yview"] - function () xview_index [widget(listbox); "xview"; index: Index(listbox)] - function () yview_index [widget(listbox); "yview"; index: Index(listbox)] - function () xview [widget(listbox); "xview"; scroll: ScrollValue] - function () yview [widget(listbox); "yview"; scroll: ScrollValue] - } - -%%%%% lower(n) -function () lower_window ["lower"; widget; ?below:[widget]] -##ifdef CAMLTK -function () lower_window_below ["lower"; widget; below: widget] -##endif - - -%%%%% menu(n) -%%%%% tk_popup(n) -% defined internally -% subtype Index(menu) { -% Number Active End Last None At Pattern -% } - -type MenuItem { - Cascade_Item ["cascade"] - Checkbutton_Item ["checkbutton"] - Command_Item ["command"] - Radiobutton_Item ["radiobutton"] - Separator_Item ["separator"] - TearOff_Item ["tearoff"] -} - -% notused as a subtype. just for cleaning up the rest. -subtype option(menuentry) { - ActiveBackground - ActiveForeground - Accelerator ["-accelerator"; string] - Background - Bitmap - ColumnBreak ["-columnbreak"; bool] - Command - Font - Foreground - HideMargin ["-hidemargin"; bool] -##ifdef CAMLTK - ImageBitmap - ImagePhoto -##else - Image -##endif - IndicatorOn - Label ["-label"; string] - Menu ["-menu"; widget(menu)] - OffValue - OnValue - SelectColor -##ifdef CAMLTK - SelectImageBitmap - SelectImagePhoto -##else - SelectImage -##endif - State - UnderlinedChar - Value ["-value"; string] - Variable - } - -% Options for cascade entry -subtype option(menucascade) { - ActiveBackground ActiveForeground Accelerator - Background Bitmap ColumnBreak Command Font Foreground - HideMargin -##ifdef CAMLTK - ImageBitmap ImagePhoto -##else - Image -##endif - IndicatorOn Label Menu State UnderlinedChar - } - -% Options for radiobutton entry -subtype option(menuradio) { - ActiveBackground ActiveForeground Accelerator - Background Bitmap ColumnBreak Command Font Foreground -##ifdef CAMLTK - ImageBitmap ImagePhoto SelectImageBitmap SelectImagePhoto -##else - Image SelectImage -##endif - IndicatorOn Label SelectColor - State UnderlinedChar Value Variable - } - -% Options for checkbutton entry -subtype option(menucheck) { - ActiveBackground ActiveForeground Accelerator - Background Bitmap ColumnBreak Command Font Foreground -##ifdef CAMLTK - ImageBitmap SelectImageBitmap ImagePhoto SelectImagePhoto -##else - Image SelectImage -##endif - IndicatorOn Label - OffValue OnValue SelectColor - State UnderlinedChar Variable - } - -% Options for command entry -subtype option(menucommand) { - ActiveBackground ActiveForeground Accelerator - Background Bitmap ColumnBreak Command Font Foreground -##ifdef CAMLTK - ImageBitmap ImagePhoto -##else - Image -##endif - Label State UnderlinedChar - } - -type menuType { - Menu_Menubar ["menubar"] - Menu_Tearoff ["tearoff"] - Menu_Normal ["normal"] -} - -% Separators and tearoffs don't have options - -widget menu { - % Standard options - option ActiveBackground - option ActiveBorderWidth - option ActiveForeground - option Background - option BorderWidth - option Cursor - option DisabledForeground - option Font - option Foreground - option Relief - option TakeFocus - % Widget specific options - option PostCommand ["-postcommand"; function()] - option SelectColor - option TearOff ["-tearoff"; bool] - option TearOffCommand ["-tearoffcommand"; function(menu: widget(any), tornoff: widget(any)) ] - option MenuTitle ["-title"; string] - option MenuType ["-type"; menuType] - - function () activate [widget(menu); "activate"; index: Index(menu)] - % add variations - function () add_cascade [widget(menu); "add"; "cascade"; option(menucascade) list] - function () add_checkbutton [widget(menu); "add"; "checkbutton"; option(menucheck) list] - function () add_command [widget(menu); "add"; "command"; option(menucommand) list] - function () add_radiobutton [widget(menu); "add"; "radiobutton"; option(menuradio) list] - function () add_separator [widget(menu); "add"; "separator"] - % not for user: function clone [widget(menu); "clone"; ???; menuType] - function () configure [widget(menu); "configure"; option(menu) list] - function (string) configure_get [widget(menu); "configure"] - % beware of possible callback leak when deleting menu entries - function () delete [widget(menu); "delete"; first: Index(menu); last: Index(menu)] - function () configure_cascade [widget(menu); "entryconfigure"; Index(menu); option(menucascade) list] - function () configure_checkbutton [widget(menu); "entryconfigure"; Index(menu); option(menucheck) list] - function () configure_command [widget(menu); "entryconfigure"; Index(menu); option(menucommand) list] - function () configure_radiobutton [widget(menu); "entryconfigure"; Index(menu); option(menuradio) list] - function (string) entryconfigure_get [widget(menu); "entryconfigure"; Index(menu)] - function (int) index [widget(menu); "index"; Index(menu)] - function () insert_cascade [widget(menu); "insert"; index: Index(menu); "cascade"; option(menucascade) list] - function () insert_checkbutton [widget(menu); "insert"; index: Index(menu); "checkbutton"; option(menucheck) list] - function () insert_command [widget(menu); "insert"; index: Index(menu); "command"; option(menucommand) list] - function () insert_radiobutton [widget(menu); "insert"; index: Index(menu); "radiobutton"; option(menuradio) list] - function () insert_separator [widget(menu); "insert"; index: Index(menu); "separator"] - function (string) invoke [widget(menu); "invoke"; index: Index(menu)] - function () post [widget(menu); "post"; x: int; y: int] - function () postcascade [widget(menu); "postcascade"; index: Index(menu)] - % can't use type of course - function (MenuItem) typeof [widget(menu); "type"; index: Index(menu)] - function () unpost [widget(menu); "unpost"] - function (int) yposition [widget(menu); "yposition"; index: Index(menu)] - - function () popup ["tk_popup"; widget(menu); x: int; y: int; ?entry:[Index(menu)]] -##ifdef CAMLTK - function () popup_entry ["tk_popup"; widget(menu); x: int; y: int; index: Index(menu)] -##endif - } - - -%%%%% menubutton(n) - -type menubuttonDirection { - Dir_Above ["above"] - Dir_Below ["below"] - Dir_Left ["left"] - Dir_Right ["right"] -} - -widget menubutton { - % Standard options - option ActiveBackground - option ActiveForeground - option Anchor - option Background - option Bitmap - option BorderWidth - option Cursor - option DisabledForeground - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness -##ifdef CAMLTK - option ImageBitmap - option ImagePhoto -##else - option Image -##endif - option Justify - option PadX - option PadY - option Relief - option TakeFocus - option Text - option TextVariable - option UnderlinedChar - option WrapLength - % Widget specific options - option Direction ["-direction"; menubuttonDirection ] - option Height - option IndicatorOn - option Menu ["-menu"; widget(menu)] - option State - option Width - option TextWidth - - function () configure [widget(menubutton); "configure"; option(menubutton) list] - function (string) configure_get [widget(menubutton); "configure"] - } - - - -%%%%% message(n) -widget message { - % Standard options - option Anchor - option Background - option BorderWidth - option Cursor - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness - option PadX - option PadY - option Relief - option TakeFocus - option Text - option TextVariable - % Widget specific options - option Aspect ["-aspect"; int] - option Justify - option Width - - function () configure [widget(message); "configure"; option(message) list] - function (string) configure_get [widget(message); "configure"] - } - - -%%%%% option(n) -type OptionPriority { - WidgetDefault ["widgetDefault"] - StartupFile ["startupFile"] - UserDefault ["userDefault"] - Interactive ["interactive"] - Priority [int] - } - -##ifdef CAMLTK - -module Option { - unsafe function () add ["option"; "add"; string; string; OptionPriority] - function () clear ["option"; "clear"] - function (string) get ["option"; "get"; widget; string; string] - unsafe function () readfile ["option"; "readfile"; string; OptionPriority] - } -%% Resource is now superseded by Option -module Resource { - unsafe function () add ["option"; "add"; string; string; OptionPriority] - function () clear ["option"; "clear"] - function (string) get ["option"; "get"; widget; string; string] - unsafe function () readfile ["option"; "readfile"; string; OptionPriority] - } -##else -module Option { - unsafe function () add - ["option"; "add"; path: string; string; ?priority:[OptionPriority]] - function () clear ["option"; "clear"] - function (string) get ["option"; "get"; widget; name: string; clas: string] - unsafe function () readfile - ["option"; "readfile"; string; ?priority:[OptionPriority]] - } -##endif - -%%%%% tk_optionMenu(n) -module Optionmenu { - external create "builtin/optionmenu" - } - - -%%%%% pack(n) -type Side { - Side_Left ["left"] - Side_Right ["right"] - Side_Top ["top"] - Side_Bottom ["bottom"] -} - -type FillMode { - Fill_None ["none"] - Fill_X ["x"] - Fill_Y ["y"] - Fill_Both ["both"] -} - -subtype option(pack) { - After ["-after"; widget] - Anchor - Before ["-before"; widget] - Expand ["-expand"; bool] - Fill ["-fill"; FillMode] - In(Inside) ["-in"; widget] - IPadX ["-ipadx"; Units/int] - IPadY ["-ipady"; Units/int] - PadX - PadY - Side ["-side"; Side] -} - -function () pack ["pack"; widget list; option(pack) list] - -module Pack { - function () configure ["pack"; "configure"; widget list; option(pack) list] - function () forget ["pack"; "forget"; widget list] - function (string) info ["pack"; "info"; widget] - function (bool) propagate_get ["pack"; "propagate"; widget] - function () propagate_set ["pack"; "propagate"; widget; bool] - function (widget list) slaves ["pack"; "slaves"; widget] - } - -subtype TkPalette(any) { % Not sophisticated... - PaletteActiveBackground ["activeBackground"; Color] - PaletteActiveForeground ["activeForeground"; Color] - PaletteBackground ["background"; Color] - PaletteDisabledForeground ["disabledForeground"; Color] - PaletteForeground ["foreground"; Color] - PaletteHighlightBackground ["hilightBackground"; Color] - PaletteHighlightColor ["highlightColor"; Color] - PaletteInsertBackground ["insertBackground"; Color] - PaletteSelectColor ["selectColor"; Color] - PaletteSelectBackground ["selectBackground"; Color] - PaletteForegroundselectColor ["selectForeground"; Color] - PaletteTroughColor ["troughColor"; Color] -} - -%%%%% tk_setPalette(n) -%%%% can't simply encode general form of tk_setPalette -module Palette { - function () set_background ["tk_setPalette"; Color] - function () set ["tk_setPalette"; TkPalette(any) list] - function () bisque ["tk_bisque"] - } - -%%%%% photo(n) -type PaletteType external % builtin_palette.ml - -subtype option(photoimage) { - % Channel ["-channel"; file_descr] % removed in 8.3 ? - Data - Format ["-format"; string] - File - Gamma ["-gamma"; float] - Height - Palette ["-palette"; PaletteType] - Width - } - -subtype photo(copy) { - ImgFrom(Src_area) ["-from"; int; int; int; int] - ImgTo(Dst_area) ["-to"; int; int; int; int] - Shrink ["-shrink"] - Zoom ["-zoom"; int; int] - Subsample ["-subsample"; int; int] - } - -subtype photo(put) { - ImgTo - } - -subtype photo(read) { - ImgFormat ["-format"; string] - ImgFrom - Shrink - TopLeft(Dst_pos) ["-to"; int; int] - } - -subtype photo(write) { - ImgFormat ImgFrom - } - -module Imagephoto { - function (ImagePhoto) create ["image"; "create"; "photo"; ?name:[ImagePhoto]; option(photoimage) list] -##ifdef CAMLTK - function (ImagePhoto) create_named ["image"; "create"; "photo"; ImagePhoto; option(photoimage) list] -##endif - function () delete ["image"; "delete"; ImagePhoto] - function (int) height ["image"; "height"; ImagePhoto] - function (int) width ["image"; "width"; ImagePhoto] - -%name -%type - - function () blank [ImagePhoto; "blank"] - function () configure [ImagePhoto; "configure"; option(photoimage) list] - function (string) configure_get [ImagePhoto; "configure"] - function () copy [ImagePhoto; "copy"; src: ImagePhoto; photo(copy) list] - function (int, int, int) get [ImagePhoto; "get"; x: int; y: int] -% it is buggy ? can't express nested lists ? - function () put [ImagePhoto; "put"; [Color list list]; photo(put) list] -% external put "builtin/imagephoto_put" - function () read [ImagePhoto; "read"; file: string; photo(read) list] - function () redither [ImagePhoto; "redither"] - function () write [ImagePhoto; "write"; file: string; photo(write) list] - % Functions inherited from the "image" TK class - } - - -%%%%% place(n) -type BorderMode { - Inside ["inside"] - Outside ["outside"] - Ignore ["ignore"] -} - -subtype option(place) { - In - X - RelX ["-relx"; float] - Y - RelY ["-rely"; float] - Anchor - Width - RelWidth ["-relwidth"; float] - Height - RelHeight ["-relheight"; float] - BorderMode ["-bordermode"; BorderMode] -} - -function () place ["place"; widget; option(place) list] - -module Place { - function () configure ["place"; "configure"; widget; option(place) list] - function () forget ["place"; "forget"; widget] - function (string) info ["place"; "info"; widget] - function (widget list) slaves ["place"; "slaves"; widget] -} - - -%%%%% radiobutton(n) - -widget radiobutton { - % Standard options - option ActiveBackground - option ActiveForeground - option Anchor - option Background - option Bitmap - option BorderWidth - option Cursor - option DisabledForeground - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness -##ifdef CAMLTK - option ImageBitmap - option ImagePhoto -##else - option Image -##endif - option Justify - option PadX - option PadY - option Relief - option TakeFocus - option Text - option TextVariable - option UnderlinedChar - option WrapLength - - % Widget specific options - option Command - option Height - option IndicatorOn - option SelectColor -##ifdef CAMLTK - option SelectImageBitmap - option SelectImagePhoto -##else - option SelectImage -##endif - option State - option Value - option Variable - option Width - - function () configure [widget(radiobutton); "configure"; option(radiobutton) list] - function (string) configure_get [widget(radiobutton); "configure"] - function () deselect [widget(radiobutton); "deselect"] - function () flash [widget(radiobutton); "flash"] - function () invoke [widget(radiobutton); "invoke"] - function () select [widget(radiobutton); "select"] - } - - -%%%%% raise(n) -% We cannot use raise !! -function () raise_window ["raise"; widget; ?above:[widget]] -##ifdef CAMLTK -function () raise_window_above ["raise"; widget; widget] -##endif - -%%%%% scale(n) -%% shared with scrollbars -##ifdef CAMLTK -subtype WidgetElement(scale) { - Slider ["slider"] - Trough1 ["trough1"] - Trough2 ["trough2"] - Beyond [""] - } -##else -type ScaleElement { - Slider ["slider"] - Trough1 ["trough1"] - Trough2 ["trough2"] - Beyond [""] - } -##endif - -widget scale { - % Standard options - option ActiveBackground - option Background - option BorderWidth - option Cursor - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness - option Orient - option Relief - option RepeatDelay - option RepeatInterval - option TakeFocus - option TroughColor - - % Widget specific options - option BigIncrement ["-bigincrement"; float] - option ScaleCommand ["-command"; function (float)] - option Digits ["-digits"; int] - option From(Min) ["-from"; float] - option Label ["-label"; string] - option Length ["-length"; Units/int] - option Resolution ["-resolution"; float] - option ShowValue ["-showvalue"; bool] - option SliderLength ["-sliderlength"; Units/int] - option State - option TickInterval ["-tickinterval"; float] - option To(Max) ["-to"; float] - option Variable - option Width - -##ifdef CAMLTK - function (int,int) coords [widget(scale); "coords"] - function (int,int) coords_at [widget(scale); "coords"; at: float] -##else - function (int,int) coords [widget(scale); "coords"; ?at: [float]] -##endif - function () configure [widget(scale); "configure"; option(scale) list] - function (string) configure_get [widget(scale); "configure"] - function (float) get [widget(scale); "get"] - function (float) get_xy [widget(scale); "get"; x: int; y: int] - function (WidgetElement/ScaleElement) identify [widget(scale); x: int; y: int] - function () set [widget(scale); "set"; float] - } - - -%%%%% scrollbar(n) -##ifdef CAMLTK -subtype WidgetElement(scrollbar) { - Arrow1 ["arrow1"] - Trough1 - Trough2 - Slider - Arrow2 ["arrow2"] - Beyond - } -##else -type ScrollbarElement { - Arrow1 ["arrow1"] - Trough1 ["through1"] - Trough2 ["through2"] - Slider ["slider"] - Arrow2 ["arrow2"] - Beyond [""] - } -##endif - -widget scrollbar { - % Standard options - option ActiveBackground - option Background - option BorderWidth - option Cursor - option HighlightBackground - option HighlightColor - option HighlightThickness - option Jump - option Orient - option Relief - option RepeatDelay - option RepeatInterval - option TakeFocus - option TroughColor - % Widget specific options - option ActiveRelief ["-activerelief"; Relief] - option ScrollCommand ["-command"; function(scroll: ScrollValue)] - option ElementBorderWidth ["-elementborderwidth"; Units/int] - option Width - -##ifdef CAMLTK - function () activate [widget(scrollbar); "activate"; element: WidgetElement(scrollbar)] -##else - function () activate [widget(scrollbar); "activate"; element: ScrollbarElement] -##endif - function (WidgetElement/ScrollbarElement) activate_get [widget(scrollbar); "activate"] - function () configure [widget(scrollbar); "configure"; option(scrollbar) list] - function (string) configure_get [widget(scrollbar); "configure"] - function (float) delta [widget(scrollbar); "delta"; x: int; y: int] - function (float) fraction [widget(scrollbar); "fraction"; x: int; y: int] - function (float, float) get [widget(scrollbar); "get"] - function (int,int,int,int) old_get [widget(scrollbar); "get"] - function (WidgetElement/ScrollbarElement) identify [widget(scale); "identify"; int; int] - function () set [widget(scrollbar); "set"; first: float; last: float] - function () old_set [widget(scrollbar); "set"; total:int; window:int; first:int; last:int] - } - - -%%%%% selection(n) - -subtype icccm(selection_clear) { - DisplayOf ["-displayof"; widget] - Selection ["-selection"; string] - } - -subtype icccm(selection_get) { - DisplayOf - Selection - ICCCMType - } - -subtype icccm(selection_ownset) { - LostCommand ["-command"; function()] - Selection - } - -subtype icccm(selection_handle) { - Selection - ICCCMType - ICCCMFormat ["-format"; string] - } - -module Selection { - function () clear ["selection"; "clear"; icccm(selection_clear) list] - function (string) get ["selection"; "get"; icccm(selection_get) list] - - % function () handle_set ["selection"; "handle"; icccm(selection_handle) list; widget; function(int,int)] - external handle_set "builtin/selection_handle_set" - unsafe function (widget) own_get ["selection"; "own"; icccm(selection_clear) list] - % builtin - % function () own_set ["selection"; "own"; widget; icccm(selection_ownset) list] - external own_set "builtin/selection_own_set" - } - - -%%%%% send(n) -type SendOption { - SendDisplayOf ["-displayof"; widget] % DisplayOf is used for icccm ! - SendAsync ["-async"] -} - -unsafe function () send ["send"; SendOption list; "--"; app: string; command: string list] - -%%%%% text(n) - -type TextIndex external -type TextTag external -type TextMark external - - -type TabType { - TabLeft [Units/int; "left"] - TabRight [Units/int; "right"] - TabCenter [Units/int; "center"] - TabNumeric [Units/int; "numeric"] - } - -type WrapMode { - WrapNone ["none"] - WrapChar ["char"] - WrapWord ["word"] -} - -type Comparison { - LT (Lt) ["<"] - LE (Le) ["<="] - EQ (Eq) ["=="] - GE (Ge) [">="] - GT (Gt) [">"] - NEQ (Neq) ["!="] -} - -type MarkDirection { - Mark_Left ["left"] - Mark_Right ["right"] - } - -type AlignType { - Align_Top ["top"] - Align_Bottom ["bottom"] - Align_Center ["center"] - Align_Baseline ["baseline"] - } - -subtype option(embeddedi) { - Align ["-align"; AlignType] -##ifdef CAMLTK - ImageBitmap - ImagePhoto -##else - Image -##endif - Name ["-name"; string] - PadX - PadY - } - -subtype option(embeddedw) { - Align ["-align"; AlignType] - PadX - PadY - Stretch ["-stretch"; bool] - Window - } - -type TextSearch { - Forwards ["-forwards"] - Backwards ["-backwards"] - Exact ["-exact"] - Regexp ["-regexp"] - Nocase ["-nocase"] - Count ["-count"; TextVariable] - } - -type text_dump { - DumpAll ["-all"] - DumpCommand ["-command"; function (key: string, value: string, index: string)] - DumpMark ["-mark"] - DumpTag ["-tag"] - DumpText ["-text"] - DumpWindow ["-window"] - } - -widget text { - % Standard options - option Background - option BorderWidth - option Cursor - option ExportSelection - option Font - option Foreground - option HighlightBackground - option HighlightColor - option HighlightThickness - option InsertBackground - option InsertBorderWidth - option InsertOffTime - option InsertOnTime - option InsertWidth - option PadX - option PadY - option Relief - option SelectBackground - option SelectBorderWidth - option SelectForeground - option SetGrid - option TakeFocus - option XScrollCommand - option YScrollCommand - - % Widget specific options - option TextHeight - option Spacing1 ["-spacing1"; Units/int] - option Spacing2 ["-spacing2"; Units/int] - option Spacing3 ["-spacing3"; Units/int] -##ifdef CAMLTK - option State -##else - option EntryState -##endif - option Tabs ["-tabs"; [TabType list]] - option TextWidth - option Wrap ["-wrap"; WrapMode] - - function (int,int,int,int) bbox [widget(text); "bbox"; index: TextIndex] - function (bool) compare [widget(text); "compare"; index: TextIndex; op: Comparison; index: TextIndex] - function () configure [widget(text); "configure"; option(text) list] - function (string) configure_get [widget(text); "configure"] - function () debug [widget(text); "debug"; bool] - function () delete [widget(text); "delete"; start: TextIndex; stop: TextIndex] - function () delete_char [widget(text); "delete"; index: TextIndex] - function (int, int, int, int, int) dlineinfo [widget(text); "dlineinfo"; index: TextIndex] - - % require result parser - function (string list) dump [widget(text); "dump"; text_dump list; start: TextIndex; stop: TextIndex] - function (string list) dump_char [widget(text); "dump"; text_dump list; index: TextIndex] - - function (string) get [widget(text); "get"; start: TextIndex; stop: TextIndex] - function (string) get_char [widget(text); "get"; index: TextIndex] - function () image_configure - [widget(text); "image"; "configure"; name: string; option(embeddedi) list] - function (string) image_configure_get - [widget(text); "image"; "cgets"; name: string] - function (string) image_create - [widget(text); "image"; "create"; index: TextIndex; option(embeddedi) list] - function (string list) image_names [widget(text); "image"; "names"] - function (Index(text) as "[>`Linechar of int * int]") index [widget(text); "index"; index: TextIndex] -##ifdef CAMLTK - function () insert [widget(text); "insert"; index: TextIndex; text: string; [TextTag list]] -##else - function () insert [widget(text); "insert"; index: TextIndex; text: string; ?tags: [TextTag list]] -##endif - % Mark - function () mark_gravity_set [widget(text); "mark"; "gravity"; mark: TextMark; direction: MarkDirection] - function (MarkDirection) mark_gravity_get [widget(text); "mark"; "gravity"; mark: TextMark] - function (TextMark list) mark_names [widget(text); "mark"; "names"] - function (TextMark) mark_next [widget(text); "mark"; "next"; index: TextIndex] - function (TextMark) mark_previous [widget(text); "mark"; "previous"; index: TextIndex] - function () mark_set [widget(text); "mark"; "set"; mark: TextMark; index: TextIndex] - function () mark_unset [widget(text); "mark"; "unset"; marks: TextMark list] - % Scan - function () scan_mark [widget(text); "scan"; "mark"; x: int; y: int] - function () scan_dragto [widget(text); "scan"; "dragto"; x: int; y: int] -##ifdef CAMLTK - function (Index) search [widget(text); "search"; TextSearch list; "--"; string; TextIndex; TextIndex] -##else - function (Index(text) as "[>`Linechar of int * int]") search [widget(text); "search"; switches: TextSearch list; "--"; pattern: string; start: TextIndex; ?stop: [TextIndex]] -##endif - function () see [widget(text); "see"; index: TextIndex] - % Tags - function () tag_add [widget(text); "tag"; "add"; tag: TextTag; start: TextIndex; stop: TextIndex] - function () tag_add_char [widget(text); "tag"; "add"; tag: TextTag; index: TextIndex] - external tag_bind "builtin/text_tag_bind" - function () tag_configure [widget(text); "tag"; "configure"; tag: TextTag; option(texttag) list] - function () tag_delete [widget(text); "tag"; "delete"; TextTag list] - - function () tag_lower [widget(text); "tag"; "lower"; tag: TextTag; ?below: [TextTag]] -##ifdef CAMLTK - function () tag_lower_below [widget(text); "tag"; "lower"; TextTag; TextTag] - function () tag_lower_bot [widget(text); "tag"; "lower"; TextTag] -##endif - - function (TextTag list) tag_names [widget(text); "tag"; "names"; ?index: [TextIndex]] -##ifdef CAMLTK - function (TextTag list) tag_allnames [widget(text); "tag"; "names"] - function (TextTag list) tag_indexnames [widget(text); "tag"; "names"; TextIndex] -##endif - -##ifdef CAMLTK - function (Index, Index) tag_nextrange [widget(text); "tag"; "nextrange"; TextTag; start: TextIndex; stop: TextIndex] - function (Index, Index) tag_prevrange [widget(text); "tag"; "prevrange"; TextTag; start: TextIndex; stop: TextIndex] -##else - function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_nextrange [widget(text); "tag"; "nextrange"; tag: TextTag; start: TextIndex; ?stop: [TextIndex]] - function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_prevrange [widget(text); "tag"; "prevrange"; tag: TextTag; start: TextIndex; ?stop: [TextIndex]] -##endif - - function () tag_raise [widget(text); "tag"; "raise"; tag: TextTag; ?above: [TextTag]] -##ifdef CAMLTK - function () tag_raise_above [widget(text); "tag"; "raise"; TextTag; TextTag] - function () tag_raise_top [widget(text); "tag"; "raise"; TextTag] -##endif - -##ifdef CAMLTK - function (Index list) tag_ranges [widget(text); "tag"; "ranges"; TextTag] -##else - function (Index(text) as "[>`Linechar of int * int]" list) tag_ranges [widget(text); "tag"; "ranges"; tag: TextTag] -##endif - - function () tag_remove [widget(text); "tag"; "remove"; tag: TextTag; start: TextIndex; stop: TextIndex] - function () tag_remove_char [widget(text); "tag"; "remove"; tag: TextTag; index: TextIndex] - - function () window_configure [widget(text); "window"; "configure"; tag: TextTag; option(embeddedw) list] - function () window_create [widget(text); "window"; "create"; index: TextIndex; option(embeddedw) list] - function (widget list) window_names [widget(text); "window"; "names"] - % scrolling - function (float,float) xview_get [widget(text); "xview"] - function (float,float) yview_get [widget(text); "yview"] - function () xview [widget(text); "xview"; scroll: ScrollValue] - function () yview [widget(text); "yview"; scroll: ScrollValue] - function () yview_index [widget(text); "yview"; index: TextIndex] - function () yview_index_pickplace [widget(text); "yview"; "-pickplace"; index: TextIndex] - function () yview_line [widget(text); "yview"; line: int] % obsolete - } - -subtype option(texttag) { - Background - BgStipple ["-bgstipple"; Bitmap] - BorderWidth - FgStipple ["-fgstipple"; Bitmap] - Font - Foreground - Justify - LMargin1 ["-lmargin1"; Units/int] - LMargin2 ["-lmargin2"; Units/int] - Offset ["-offset"; Units/int] - OverStrike ["-overstrike"; bool] - Relief - RMargin ["-rmargin"; Units/int] - Spacing1 - Spacing2 - Spacing3 - Tabs - Underline ["-underline"; bool] - Wrap ["-wrap"; WrapMode] - } - - -%%%%% tk(n) -unsafe function () appname_set ["tk"; "appname"; string] -unsafe function (string) appname_get ["tk"; "appname"] -function (float) scaling_get ["tk"; "scaling"; ?displayof:["-displayof"; widget]] -unsafe function () scaling_set ["tk"; "scaling"; ?displayof:["-displayof"; widget]; float] - -%%%%% tk_chooseColor(n) - -subtype option(chooseColor){ - InitialColor ["-initialcolor"; Color] - Parent ["-parent"; widget] - Title ["-title"; string] - } -function (Color) chooseColor ["tk_chooseColor"; option(chooseColor) list] - -%%%%% tkwait(n) -module Tkwait { - function () variable ["tkwait"; "variable"; TextVariable] - function () visibility ["tkwait"; "visibility"; widget] - function () window ["tkwait"; "window"; widget] - } - - -%%%%% toplevel(n) -% This module will be renamed "toplevelw" to avoid collision with -% Caml Light standard toplevel module. -widget toplevel { - % Standard options - option BorderWidth - option Cursor - option HighlightBackground - option HighlightColor - option HighlightThickness - option Relief - option TakeFocus - - % Widget specific options - option Background -##ifdef CAMLTK - option Class -##else - option Clas -##endif - option Colormap - option Container ["-container"; bool] - option Height - option Menu - option Screen ["-screen"; string] - option Use ["-use"; string] % must be hexadecimal "0x????" - option Visual - option Width - - function () configure [widget(toplevel); "configure"; option(toplevel) list] - function (string) configure_get [widget(toplevel); "configure"] - } - - -%%%%% update(n) -function () update ["update"] -function () update_idletasks ["update"; "idletasks"] - - -%%%%% winfo(n) - -type AtomId { - AtomId [int] - } - -module Winfo { - - unsafe function (AtomId) atom ["winfo"; "atom"; ?displayof:["-displayof"; widget]; string] - unsafe function (string) atomname ["winfo"; "atomname"; ?displayof:["-displayof"; widget]; AtomId] -##ifdef CAMLTK - unsafe function (AtomId) atom_displayof ["winfo"; "atom"; "-displayof"; widget; string] - unsafe function (string) atomname_displayof ["winfo"; "atomname"; "-displayof"; widget; AtomId] -##endif - function (int) cells ["winfo"; "cells"; widget] - function (widget list) children ["winfo"; "children"; widget] - function (string) class_name ["winfo"; "class"; widget] - function (bool) colormapfull ["winfo"; "colormapfull"; widget] - unsafe function (widget) containing ["winfo"; "containing"; ?displayof:["-displayof"; widget]; x: int; y: int] -##ifdef CAMLTK - unsafe function (widget) containing_displayof ["winfo"; "containing"; "-displayof"; widget; int; int] -##endif - % addition for applets - external contained "builtin/winfo_contained" - function (int) depth ["winfo"; "depth"; widget] - function (bool) exists ["winfo"; "exists"; widget] - function (float) fpixels ["winfo"; "fpixels"; widget; length: Units] - function (string) geometry ["winfo"; "geometry"; widget] - function (int) height ["winfo"; "height"; widget] - unsafe function (string) id ["winfo"; "id"; widget] - unsafe function (string list) interps ["winfo"; "interps"; ?displayof:["-displayof"; widget]] -##ifdef CAMLTK - unsafe function (string list) interps_displayof ["winfo"; "interps"; "-displayof"; widget] -##endif - function (bool) ismapped ["winfo"; "ismapped"; widget] - function (string) manager ["winfo"; "manager"; widget] - function (string) name ["winfo"; "name"; widget] - unsafe function (widget) parent ["winfo"; "parent"; widget] % bogus for top - unsafe function (widget) pathname ["winfo"; "pathname"; ?displayof:["-displayof"; widget]; string] -##ifdef CAMLTK - unsafe function (widget) pathname_displayof ["winfo"; "pathname"; "-displayof"; widget; string] -##endif - function (int) pixels ["winfo"; "pixels"; widget; length: Units] - function (int) pointerx ["winfo"; "pointerx"; widget] - function (int) pointery ["winfo"; "pointery"; widget] - function (int, int) pointerxy ["winfo"; "pointerxy"; widget] - function (int) reqheight ["winfo"; "reqheight"; widget] - function (int) reqwidth ["winfo"; "reqwidth"; widget] - function (int,int,int) rgb ["winfo"; "rgb"; widget; color: Color] - function (int) rootx ["winfo"; "rootx"; widget] - function (int) rooty ["winfo"; "rooty"; widget] - unsafe function (string) screen ["winfo"; "screen"; widget] - function (int) screencells ["winfo"; "screencells"; widget] - function (int) screendepth ["winfo"; "screendepth"; widget] - function (int) screenheight ["winfo"; "screenheight"; widget] - function (int) screenmmheight ["winfo"; "screenmmheight"; widget] - function (int) screenmmwidth ["winfo"; "screenmmwidth"; widget] - function (string) screenvisual ["winfo"; "screenvisual"; widget] - function (int) screenwidth ["winfo"; "screenwidth"; widget] - unsafe function (string) server ["winfo"; "server"; widget] - unsafe function (widget(toplevel)) toplevel ["winfo"; "toplevel"; widget] - function (bool) viewable ["winfo"; "viewable"; widget] - function (string) visual ["winfo"; "visual"; widget] - function (int) visualid ["winfo"; "visualid"; widget] - % need special parser - function (string) visualsavailable ["winfo"; "visualsavailable"; widget; ?includeids: [int list]] - function (int) vrootheight ["winfo"; "vrootheight"; widget] - function (int) vrootwidth ["winfo"; "vrootwidth"; widget] - function (int) vrootx ["winfo"; "vrootx"; widget] - function (int) vrooty ["winfo"; "vrooty"; widget] - function (int) width ["winfo"; "width"; widget] - function (int) x ["winfo"; "x"; widget] - function (int) y ["winfo"; "y"; widget] -} - - -%%%%% wm(n) - -type FocusModel { - FocusActive ["active"] - FocusPassive ["passive"] -} - -type WmFrom { - User ["user"] - Program ["program"] -} - -module Wm { -%%% Aspect - function () aspect_set ["wm"; "aspect"; widget(toplevel); minnum:int; mindenom:int; maxnum:int; maxdenom:int] - % aspect: problem with empty return - function (int,int,int,int) aspect_get ["wm"; "aspect"; widget(toplevel)] -%%% WM_CLIENT_MACHINE - function () client_set ["wm"; "client"; widget(toplevel); name: string] - function (string) client_get ["wm"; "client"; widget(toplevel)] -%%% WM_COLORMAP_WINDOWS - function () colormapwindows_set - ["wm"; "colormapwindows"; widget(toplevel); [windows: widget list]] - unsafe function (widget list) colormapwindows_get - ["wm"; "colormapwindows"; widget(toplevel)] -%%% WM_COMMAND - function () command_clear ["wm"; "command"; widget(toplevel); ""] - function () command_set ["wm"; "command"; widget(toplevel); [string list]] - function (string list) command_get ["wm"; "command"; widget(toplevel)] - - function () deiconify ["wm"; "deiconify"; widget(toplevel)] - -%%% Focus model - function () focusmodel_set ["wm"; "focusmodel"; widget(toplevel); FocusModel] - function (FocusModel) focusmodel_get ["wm"; "focusmodel"; widget(toplevel)] - - function (string) frame ["wm"; "frame"; widget(toplevel)] - -%%% Geometry - function () geometry_set ["wm"; "geometry"; widget(toplevel); string] - function (string) geometry_get ["wm"; "geometry"; widget(toplevel)] - -%%% Grid - function () grid_clear ["wm"; "grid"; widget(toplevel); ""; ""; ""; ""] - function () grid_set ["wm"; "grid"; widget(toplevel); basewidth: int; baseheight: int; widthinc: int; heightinc: int] - function (int,int,int,int) grid_get ["wm"; "grid"; widget(toplevel)] - -%%% Groups - function () group_clear ["wm"; "group"; widget(toplevel); ""] - function () group_set ["wm"; "group"; widget(toplevel); leader: widget] - unsafe function (widget) group_get ["wm"; "group"; widget(toplevel)] -%%% Icon bitmap - function () iconbitmap_clear ["wm"; "iconbitmap"; widget(toplevel); ""] - function () iconbitmap_set ["wm"; "iconbitmap"; widget(toplevel); Bitmap] - function (Bitmap) iconbitmap_get ["wm"; "iconbitmap"; widget(toplevel)] - - function () iconify ["wm"; "iconify"; widget(toplevel)] - -%%% Icon mask - function () iconmask_clear ["wm"; "iconmask"; widget(toplevel); ""] - function () iconmask_set ["wm"; "iconmask"; widget(toplevel); Bitmap] - function (Bitmap) iconmask_get ["wm"; "iconmask"; widget(toplevel)] - -%%% Icon name - function () iconname_set ["wm"; "iconname"; widget(toplevel); string] - function (string) iconname_get ["wm"; "iconname"; widget(toplevel)] -%%% Icon position - function () iconposition_clear ["wm"; "iconposition"; widget(toplevel); ""; ""] - function () iconposition_set ["wm"; "iconposition"; widget(toplevel); x: int; y: int] - function (int,int) iconposition_get ["wm"; "iconposition"; widget(toplevel)] -%%% Icon window - function () iconwindow_clear ["wm"; "iconwindow"; widget(toplevel); ""] - function () iconwindow_set ["wm"; "iconwindow"; widget(toplevel); icon: widget(toplevel)] - unsafe function (widget(toplevel)) iconwindow_get ["wm"; "iconwindow"; widget(toplevel)] - -%%% Sizes - function () maxsize_set ["wm"; "maxsize"; widget(toplevel); width: int; height: int] - function (int,int) maxsize_get ["wm"; "maxsize"; widget(toplevel)] - function () minsize_set ["wm"; "minsize"; widget(toplevel); width: int; height: int] - function (int,int) minsize_get ["wm"; "minsize"; widget(toplevel)] -%%% Override - unsafe function () overrideredirect_set ["wm"; "overrideredirect"; widget(toplevel); bool] - function (bool) overrideredirect_get ["wm"; "overrideredirect"; widget(toplevel)] -%%% Position - function () positionfrom_clear ["wm"; "positionfrom"; widget(toplevel); ""] - function () positionfrom_set ["wm"; "positionfrom"; widget(toplevel); WmFrom] - function (WmFrom) positionfrom_get ["wm"; "positionfrom"; widget(toplevel)] -%%% Protocols - function () protocol_set ["wm"; "protocol"; widget(toplevel); name: string; command: function()] - function () protocol_clear ["wm"; "protocol"; widget(toplevel); name: string; ""] - function (string list) protocols ["wm"; "protocol"; widget(toplevel)] -%%% Resize - function () resizable_set ["wm"; "resizable"; widget(toplevel); width: bool; height: bool] - function (bool, bool) resizable_get ["wm"; "resizable"; widget(toplevel)] -%%% Sizefrom - function () sizefrom_clear ["wm"; "sizefrom"; widget(toplevel); ""] - function () sizefrom_set ["wm"; "sizefrom"; widget(toplevel); WmFrom] - function (WmFrom) sizefrom_get ["wm"; "sizefrom"; widget(toplevel)] - - function (string) state ["wm"; "state"; widget(toplevel)] - -%%% Title - function (string) title_get ["wm"; "title"; widget(toplevel)] - function () title_set ["wm"; "title"; widget(toplevel); string] -%%% Transient - function () transient_clear ["wm"; "transient"; widget(toplevel); ""] - function () transient_set ["wm"; "transient"; widget(toplevel); master: widget] - unsafe function (widget) transient_get ["wm"; "transient"; widget(toplevel)] - - function () withdraw ["wm"; "withdraw"; widget(toplevel)] - -} - -%%%%% tk_getOpenFile(n) (since version 8.0) -type FilePattern external - -subtype option(getFile) { - DefaultExtension ["-defaultextension"; string] - FileTypes ["-filetypes"; [FilePattern list]] - InitialDir ["-initialdir"; string] - InitialFile ["-initialfile"; string] - Parent ["-parent"; widget] - Title ["-title"; string] -} - -function (string) getOpenFile ["tk_getOpenFile"; option(getFile) list] -function (string) getSaveFile ["tk_getSaveFile"; option(getFile) list] - -%%%%% tk_messageBox -type MessageIcon { - Error ["error"] - Info ["info"] - Question ["question"] - Warning ["warning"] -} -type MessageType { - AbortRetryIgnore ["abortretryignore"] - Ok ["ok"] - OkCancel ["okcancel"] - RetryCancel ["retrycancel"] - YesNo ["yesno"] - YesNoCancel ["yesnocancel"] -} -subtype option(messageBox) { - MessageDefault ["-default"; string] - MessageIcon ["-icon"; MessageIcon] - Message ["-message"; string] - Parent - Title - MessageType ["-type"; MessageType] -} - -function (string) messageBox ["tk_messageBox"; option(messageBox) list] - -module Tkvars { - function (string) library ["$tk_library"] - function (string) patchLevel ["$tk_patchLevel"] - function (bool) strictMotif ["$tk_strictMotif"] - function () set_strictMotif ["set"; "tk_strictMotif"; bool] - function (string) version ["$tk_version"] -} - -% Direct API calls, non Tcl-based modules - -module Pixmap { - external create "builtin/rawimg" - } - -%%% encodings : require if you want write your application international - -module Encoding { - function (string) convertfrom ["encoding"; "convertfrom"; - ?encoding: [string]; string] - function (string) convertto ["encoding"; "convertto"; - ?encoding: [string]; string] - function (string list) names ["encoding"; "names"] - function () system_set ["encoding"; "system"; string] - function (string) system_get ["encoding"; "system"] -} diff --git a/otherlibs/labltk/browser/.depend b/otherlibs/labltk/browser/.depend deleted file mode 100644 index 4a0040b3b92e..000000000000 --- a/otherlibs/labltk/browser/.depend +++ /dev/null @@ -1,101 +0,0 @@ -editor.cmo : viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \ - searchid.cmi mytypes.cmi lexical.cmi jg_toplevel.cmo jg_tk.cmo \ - jg_text.cmi jg_message.cmi jg_menu.cmo jg_button.cmo jg_bind.cmi \ - fileselect.cmi editor.cmi -editor.cmx : viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \ - searchid.cmx mytypes.cmi lexical.cmx jg_toplevel.cmx jg_tk.cmx \ - jg_text.cmx jg_message.cmx jg_menu.cmx jg_button.cmx jg_bind.cmx \ - fileselect.cmx editor.cmi -fileselect.cmo : useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo \ - jg_memo.cmi jg_entry.cmo jg_box.cmo fileselect.cmi -fileselect.cmx : useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx \ - jg_memo.cmx jg_entry.cmx jg_box.cmx fileselect.cmi -help.cmo : -help.cmx : -jg_bind.cmo : jg_bind.cmi -jg_bind.cmx : jg_bind.cmi -jg_box.cmo : jg_completion.cmi jg_bind.cmi -jg_box.cmx : jg_completion.cmx jg_bind.cmx -jg_button.cmo : -jg_button.cmx : -jg_completion.cmo : jg_completion.cmi -jg_completion.cmx : jg_completion.cmi -jg_config.cmo : jg_tk.cmo jg_config.cmi -jg_config.cmx : jg_tk.cmx jg_config.cmi -jg_entry.cmo : jg_bind.cmi -jg_entry.cmx : jg_bind.cmx -jg_memo.cmo : jg_memo.cmi -jg_memo.cmx : jg_memo.cmi -jg_menu.cmo : -jg_menu.cmx : -jg_message.cmo : jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \ - jg_message.cmi -jg_message.cmx : jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \ - jg_message.cmi -jg_multibox.cmo : jg_completion.cmi jg_bind.cmi jg_multibox.cmi -jg_multibox.cmx : jg_completion.cmx jg_bind.cmx jg_multibox.cmi -jg_text.cmo : jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi \ - jg_text.cmi -jg_text.cmx : jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx \ - jg_text.cmi -jg_tk.cmo : -jg_tk.cmx : -jg_toplevel.cmo : -jg_toplevel.cmx : -lexical.cmo : jg_tk.cmo lexical.cmi -lexical.cmx : jg_tk.cmx lexical.cmi -list2.cmo : -list2.cmx : -main.cmo : viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \ - editor.cmi -main.cmx : viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.cmx \ - editor.cmx -searchid.cmo : list2.cmo searchid.cmi -searchid.cmx : list2.cmx searchid.cmi -searchpos.cmo : searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi \ - jg_message.cmi jg_memo.cmi jg_bind.cmi searchpos.cmi -searchpos.cmx : searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx \ - jg_message.cmx jg_memo.cmx jg_bind.cmx searchpos.cmi -setpath.cmo : useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \ - jg_bind.cmi setpath.cmi -setpath.cmx : useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \ - jg_bind.cmx setpath.cmi -shell.cmo : list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \ - jg_message.cmi jg_menu.cmo jg_memo.cmi fileselect.cmi dummy.cmi shell.cmi -shell.cmx : list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \ - jg_message.cmx jg_menu.cmx jg_memo.cmx fileselect.cmx dummy.cmi shell.cmi -typecheck.cmo : mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \ - typecheck.cmi -typecheck.cmx : mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx \ - typecheck.cmi -useunix.cmo : useunix.cmi -useunix.cmx : useunix.cmi -viewer.cmo : useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \ - mytypes.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_multibox.cmi \ - jg_message.cmi jg_menu.cmo jg_entry.cmo jg_completion.cmi jg_button.cmo \ - jg_box.cmo jg_bind.cmi help.cmo viewer.cmi -viewer.cmx : useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \ - mytypes.cmi jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_multibox.cmx \ - jg_message.cmx jg_menu.cmx jg_entry.cmx jg_completion.cmx jg_button.cmx \ - jg_box.cmx jg_bind.cmx help.cmx viewer.cmi -dummy.cmi : -dummyUnix.cmi : -dummyWin.cmi : -editor.cmi : -fileselect.cmi : -jg_bind.cmi : -jg_completion.cmi : -jg_config.cmi : -jg_memo.cmi : -jg_message.cmi : -jg_multibox.cmi : -jg_text.cmi : -lexical.cmi : -mytypes.cmi : shell.cmi -searchid.cmi : -searchpos.cmi : -setpath.cmi : -shell.cmi : -typecheck.cmi : mytypes.cmi -useunix.cmi : -viewer.cmi : diff --git a/otherlibs/labltk/browser/.ignore b/otherlibs/labltk/browser/.ignore deleted file mode 100644 index 8d7632f46b96..000000000000 --- a/otherlibs/labltk/browser/.ignore +++ /dev/null @@ -1,3 +0,0 @@ -ocamlbrowser -dummy.mli -help.ml diff --git a/otherlibs/labltk/browser/Makefile b/otherlibs/labltk/browser/Makefile deleted file mode 100644 index a21973e7c54f..000000000000 --- a/otherlibs/labltk/browser/Makefile +++ /dev/null @@ -1,22 +0,0 @@ -######################################################################### -# # -# OCaml LablTk library # -# # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file ../../../LICENSE. # -# # -######################################################################### - -# $Id$ - -OTHERSLIB=-I $(OTHERS)/unix -I $(OTHERS)/str - -include Makefile.shared - -dummy.mli: - cp dummyUnix.mli dummy.mli diff --git a/otherlibs/labltk/browser/Makefile.nt b/otherlibs/labltk/browser/Makefile.nt deleted file mode 100644 index 289b0924c3be..000000000000 --- a/otherlibs/labltk/browser/Makefile.nt +++ /dev/null @@ -1,35 +0,0 @@ -######################################################################### -# # -# OCaml LablTk library # -# # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 2000 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file ../../../LICENSE. # -# # -######################################################################### - -# $Id$ - -OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/str -I $(OTHERS)/systhreads - -CCFLAGS=-I../../../byterun $(TK_DEFS) - -include ../support/Makefile.common - -ifeq ($(CCOMPTYPE),cc) -WINDOWS_APP=-ccopt "-link -Wl,--subsystem,windows" -else -WINDOWS_APP=-ccopt "-link /subsystem:windows" -endif - -XTRAOBJ=winmain.$(O) -XTRALIBS=threads.cma -custom $(WINDOWS_APP) - -include Makefile.shared - -dummy.mli: - cp dummyWin.mli dummy.mli diff --git a/otherlibs/labltk/browser/README b/otherlibs/labltk/browser/README deleted file mode 100644 index e8953541bfcb..000000000000 --- a/otherlibs/labltk/browser/README +++ /dev/null @@ -1,170 +0,0 @@ - - Installing and Using OCamlBrowser - - -INSTALLATION - If you installed it with LablTk, nothing to do. - Otherwise, the source is in labltk/browser. - After installing LablTk, simply do "make" and "make install". - The name of the command is `ocamlbrowser'. - -USE - OCamlBrowser is composed of three tools, the Viewer, to walk around - compiled modules, the Editor, which allows one to - edit/typecheck/analyse .mli and .ml files, and the Shell, to run an - OCaml subshell. You may only have one instance of Editor and - Viewer, but you may use several subshells. - - As with the compiler, you may specify a different path for the - standard library by setting CAMLLIB. You may also extend the - initial load path (only standard library by default) by using the - -I command line option, or set various other options (see -help). - - If you prefered the old GUI, it is still available with the option - -oldui, otherwise you get a new Smalltalkish user interface. - -1) Viewer - - Menus - - File - Open and File - Editor give access to the editor. - - File - Shell opens an OCaml shell. - - View - Show all defs displays all the interface of the currently - selected module - View - Search entry shows/hides the search entry at the top of the - window - - Modules - Path editor changes the load path. - Pressing [Add to path] or Insert key adds selected directories - to the load path. - Pressing [Remove from path] or Delete key removes selected - paths from the load path. - Modules - Reset cache rescans the load path and resets the module - cache. Do it if you recompile some interface, or change the load - path in a conflictual way. - - Modules - Search symbol allows to search a symbol either by its - name, like the bottom line of the viewer, or, more - interestingly, by its type. Exact type searches for a type - with exactly the same information as the pattern (variables - match only variables), included type allows to give only - partial information: the actual type may take more arguments - and return more results, and variables in the pattern match - anything. In both cases, argument and tuple order is - irrelevant (*), and unlabeled arguments in the pattern match - any label. - - (*) To avoid combinatorial explosion of the search space, optional - arguments in the actual type are ignored if (1) there are to many - of them, and (2) they do not appear explicitly in the pattern. - - Search entry - - The entry line at the top allows one to search for an identifier - in all modules, either by its name (? and * patterns allowed) or by - its type. When search by type is used, it is done in inclusion mode - (cf. Modules - search symbol) - - The Close all button at the bottom is there to dismiss the windows - created by the Detach button. By double-clicking on it you will - quit the browser. - - Module browsing - - You select a module in the leftmost box by either cliking on it or - pressing return when it is selected. Fast access is available in - all boxes pressing the first few letter of the desired - name. Double-clicking / double-return displays the whole signature - for the module. - - Defined identifiers inside the module are displayed in a box to the - right of the previous one. If you click on one, this will either - display its contents in another box (if this is a sub-module) or - display the signature for this identifier below. - - Signatures are clickable. Double clicking with the left mouse - button on an identifier in a signature brings you to its signature. - A single click on the right button pops up a menu displaying the - type declaration for the selected identifier. Its title, when - selectable, also brings you to its signature. - - At the bottom, a series of buttons, depending on the context. - * Detach copies the currently displayed signature in a new window, - to keep it. You can discard these windows with Close all. - * Impl and Intf bring you to the implementation or interface of - the currently displayed signature, if it is available. - - C-s opens a text search dialog for the displayed signature. - -2) Editor - You can edit files with it, but there is no auto-save nor undo at - the moment. Otherwise you can use it as a browser, making - occasional corrections. - - The Edit menu contains commands for jump (C-g), search (C-s), and - sending the current selection to a sub-shell (M-x). For this last - option, you may choose the shell via a dialog. - - Essential function are in the Compiler menu. - - Preferences opens a dialog to set internals of the editor and - type checker. - - Lex (M-l) adds colors according to lexical categories. - - Typecheck (M-t) verifies typing, and memorizes it to let one see an - expression's type by double-clicking on it. This is also valid for - interfaces. If an error occurs, the part of the interface preceding - the error is computed. - - After typechecking, pressing the right button pops up a menu giving - the type of the pointed expression, and eventually allowing to - follow some links. - - Clear errors dismisses type checker error messages and warnings. - - Signature shows the signature of the current file. - -3) Shell - When you create a shell, a dialog is presented to you, letting you - choose which command you want to run, and the title of the shell - (to choose it in the Editor). - - You may change the default command by setting the OLABL environment - variable. - - The executed subshell is given the current load path. - File: use a source file or load a bytecode file. - You may also import the browser's path into the subprocess. - History: M-p and M-n browse up and down. - Signal: C-c interrupts and you can kill the subprocess. - -BUGS - -* This not really a bug, but OCamlBrowser is a huge memory consumer. - Go and buy some. - -* When you quit the editor and some file was modified, a dialogue is - displayed asking wether you want to really quit or not. But 1) if - you quit directly from the viewer, there is no dialogue at all, and - 2) if you close from the window manager, the dialogue is displayed, - but you cannot cancel the destruction... Beware. - -* When you run it through xon, the shell hangs at the first error. But - its ok if you start ocamlbrowser from a remote shell... - -TODO - -* Complete cross-references. - -* Power up editor. - -* Add support for the debugger. - -* Make this a real programming environment, both for beginners an - experimented users. - - -Bug reports and comments to diff --git a/otherlibs/labltk/browser/dummyUnix.mli b/otherlibs/labltk/browser/dummyUnix.mli deleted file mode 100644 index 137368118814..000000000000 --- a/otherlibs/labltk/browser/dummyUnix.mli +++ /dev/null @@ -1,27 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -module Mutex : sig - type t - external create : unit -> t = "%ignore" - external lock : t -> unit = "%ignore" - external unlock : t -> unit = "%ignore" -end - -module Thread : sig - type t - external create : ('a -> 'b) -> 'a -> t = "caml_ml_input" -end diff --git a/otherlibs/labltk/browser/dummyWin.mli b/otherlibs/labltk/browser/dummyWin.mli deleted file mode 100644 index 3f8c26e63c26..000000000000 --- a/otherlibs/labltk/browser/dummyWin.mli +++ /dev/null @@ -1,15 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2000 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml deleted file mode 100644 index 2f17d6978239..000000000000 --- a/otherlibs/labltk/browser/editor.ml +++ /dev/null @@ -1,671 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk -open Parsetree -open Location -open Jg_tk -open Mytypes - -let lex_on_load = ref true -and type_on_load = ref false - -let compiler_preferences master = - let tl = Jg_toplevel.titled "Compiler" in - Wm.transient_set tl ~master; - let mk_chkbutton ~text ~ref ~invert = - let variable = Textvariable.create ~on:tl () in - if (if invert then not !ref else !ref) then - Textvariable.set variable "1"; - Checkbutton.create tl ~text ~variable, - (fun () -> - ref := Textvariable.get variable = (if invert then "0" else "1")) - in - let use_pp = ref (!Clflags.preprocessor <> None) in - let chkbuttons, setflags = List.split - (List.map - ~f:(fun (text, ref, invert) -> mk_chkbutton ~text ~ref ~invert) - [ "No pervasives", Clflags.nopervasives, false; - "No warnings", Typecheck.nowarnings, false; - "No labels", Clflags.classic, false; - "Recursive types", Clflags.recursive_types, false; - "Lex on load", lex_on_load, false; - "Type on load", type_on_load, false; - "Preprocessor", use_pp, false ]) - in - let pp_command = Entry.create tl (* ~state:(if !use_pp then `Normal else`Disabled) *) in - begin match !Clflags.preprocessor with None -> () - | Some pp -> Entry.insert pp_command ~index:(`Num 0) ~text:pp - end; - let buttons = Frame.create tl in - let ok = Button.create buttons ~text:"Ok" ~padx:20 ~command: - begin fun () -> - List.iter ~f:(fun f -> f ()) setflags; - Clflags.preprocessor := - if !use_pp then Some (Entry.get pp_command) else None; - destroy tl - end - and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" - in - pack chkbuttons ~side:`Top ~anchor:`W; - pack [pp_command] ~side:`Top ~anchor:`E; - pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true; - pack [buttons] ~side:`Bottom ~fill:`X - -let rec exclude txt = function - [] -> [] - | x :: l -> if txt.number = x.number then l else x :: exclude txt l - -let goto_line tw = - let tl = Jg_toplevel.titled "Go to" in - Wm.transient_set tl ~master:(Winfo.toplevel tw); - Jg_bind.escape_destroy tl; - let ef = Frame.create tl in - let fl = Frame.create ef - and fi = Frame.create ef in - let ll = Label.create fl ~text:"Line ~number:" - and il = Entry.create fi ~width:10 - and lc = Label.create fl ~text:"Col ~number:" - and ic = Entry.create fi ~width:10 - and get_int ew = - try int_of_string (Entry.get ew) - with Failure "int_of_string" -> 0 - in - let buttons = Frame.create tl in - let ok = Button.create buttons ~text:"Ok" ~command: - begin fun () -> - let l = get_int il - and c = get_int ic in - Text.mark_set tw ~mark:"insert" ~index:(`Linechar (l,0), [`Char c]); - Text.see tw ~index:(`Mark "insert", []); - destroy tl - end - and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in - - Focus.set il; - List.iter [il; ic] ~f: - begin fun w -> - Jg_bind.enter_focus w; - Jg_bind.return_invoke w ~button:ok - end; - pack [ll; lc] ~side:`Top ~anchor:`W; - pack [il; ic] ~side:`Top ~fill:`X ~expand:true; - pack [fl; fi] ~side:`Left ~fill:`X ~expand:true; - pack [ok; cancel] ~side:`Left ~fill:`X ~expand:true; - pack [ef; buttons] ~side:`Top ~fill:`X ~expand:true - -let select_shell txt = - let shells = Shell.get_all () in - let shells = List.sort shells ~cmp:compare in - let tl = Jg_toplevel.titled "Select Shell" in - Jg_bind.escape_destroy tl; - Wm.transient_set tl ~master:(Winfo.toplevel txt.tw); - let label = Label.create tl ~text:"Send to:" - and box = Listbox.create tl - and frame = Frame.create tl in - Jg_bind.enter_focus box; - let cancel = Jg_button.create_destroyer tl ~parent:frame ~text:"Cancel" - and ok = Button.create frame ~text:"Ok" ~command: - begin fun () -> - try - let name = Listbox.get box ~index:`Active in - txt.shell <- Some (name, List.assoc name shells); - destroy tl - with Not_found -> txt.shell <- None; destroy tl - end - in - Listbox.insert box ~index:`End ~texts:(List.map ~f:fst shells); - Listbox.configure box ~height:(List.length shells); - bind box ~events:[`KeyPressDetail"Return"] ~breakable:true - ~action:(fun _ -> Button.invoke ok; break ()); - bind box ~events:[`Modified([`Double],`ButtonPressDetail 1)] ~breakable:true - ~fields:[`MouseX;`MouseY] - ~action:(fun ev -> - Listbox.activate box ~index:(`Atxy (ev.ev_MouseX, ev.ev_MouseY)); - Button.invoke ok; break ()); - pack [label] ~side:`Top ~anchor:`W; - pack [box] ~side:`Top ~fill:`Both; - pack [frame] ~side:`Bottom ~fill:`X ~expand:true; - pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true - -open Parser - -let send_phrase txt = - if txt.shell = None then begin - match Shell.get_all () with [] -> () - | [sh] -> txt.shell <- Some sh - | l -> select_shell txt - end; - match txt.shell with None -> () - | Some (_,sh) -> - try - let i1,i2 = Text.tag_nextrange txt.tw ~tag:"sel" ~start:tstart in - let phrase = Text.get txt.tw ~start:(i1,[]) ~stop:(i2,[]) in - sh#send phrase; - if Str.string_match (Str.regexp ";;") phrase 0 - then sh#send "\n" else sh#send ";;\n" - with Not_found | Protocol.TkError _ -> - let text = Text.get txt.tw ~start:tstart ~stop:tend in - let buffer = Lexing.from_string text in - let start = ref 0 - and block_start = ref [] - and pend = ref (-1) - and after = ref false in - while !pend = -1 do - let token = Lexer.token buffer in - let pos = - if token = SEMISEMI then Lexing.lexeme_end buffer - else Lexing.lexeme_start buffer - in - let bol = (pos = 0) || text.[pos-1] = '\n' in - if not !after && - Text.compare txt.tw ~index:(tpos pos) ~op:(if bol then `Gt else `Ge) - ~index:(`Mark"insert",[]) - then begin - after := true; - let anon, real = - List.partition !block_start ~f:(fun x -> x = -1) in - block_start := anon; - if real <> [] then start := List.hd real; - end; - match token with - CLASS | EXTERNAL | EXCEPTION | FUNCTOR - | LET | MODULE | OPEN | TYPE | VAL | SHARP when bol -> - if !block_start = [] then - if !after then pend := pos else start := pos - else block_start := pos :: List.tl !block_start - | SEMISEMI -> - if !block_start = [] then - if !after then pend := Lexing.lexeme_start buffer - else start := pos - else block_start := pos :: List.tl !block_start - | BEGIN | OBJECT -> - block_start := -1 :: !block_start - | STRUCT | SIG -> - block_start := Lexing.lexeme_end buffer :: !block_start - | END -> - if !block_start = [] then - if !after then pend := pos else () - else block_start := List.tl !block_start - | EOF -> - pend := pos - | _ -> - () - done; - let phrase = String.sub text ~pos:!start ~len:(!pend - !start) in - sh#send phrase; - sh#send ";;\n" - -let search_pos_window txt ~x ~y = - if txt.type_info = [] && txt.psignature = [] then () else - let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in - let text = Jg_text.get_all txt.tw in - let pos = Searchpos.lines_to_chars l ~text + c in - try if txt.type_info <> [] then begin match - Searchpos.search_pos_info txt.type_info ~pos - with [] -> () - | (kind, env, loc) :: _ -> Searchpos.view_type kind ~env - end else begin match - Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env - with [] -> () - | ((kind, lid), env, loc) :: _ -> - Searchpos.view_decl lid ~kind ~env - end - with Not_found -> () - -let search_pos_menu txt ~x ~y = - if txt.type_info = [] && txt.psignature = [] then () else - let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in - let text = Jg_text.get_all txt.tw in - let pos = Searchpos.lines_to_chars l ~text + c in - try if txt.type_info <> [] then begin match - Searchpos.search_pos_info txt.type_info ~pos - with [] -> () - | (kind, env, loc) :: _ -> - let menu = Searchpos.view_type_menu kind ~env ~parent:txt.tw in - let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in - Menu.popup menu ~x ~y - end else begin match - Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env - with [] -> () - | ((kind, lid), env, loc) :: _ -> - let menu = Searchpos.view_decl_menu lid ~kind ~env ~parent:txt.tw in - let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in - Menu.popup menu ~x ~y - end - with Not_found -> () - -let string_width s = - let width = ref 0 in - for i = 0 to String.length s - 1 do - if s.[i] = '\t' then width := (!width / 8 + 1) * 8 - else incr width - done; - !width - -let indent_line = - let ins = `Mark"insert" and reg = Str.regexp "[ \t]*" in - fun tw -> - let `Linechar(l,c) = Text.index tw ~index:(ins,[]) - and line = Text.get tw ~start:(ins,[`Linestart]) ~stop:(ins,[`Lineend]) in - ignore (Str.string_match reg line 0); - let len = Str.match_end () in - if len < c then Text.insert tw ~index:(ins,[]) ~text:"\t" else - let width = string_width (Str.matched_string line) in - Text.mark_set tw ~mark:"insert" ~index:(ins,[`Linestart;`Char len]); - let indent = - if l <= 1 then 2 else - let previous = - Text.get tw ~start:(ins,[`Line(-1);`Linestart]) - ~stop:(ins,[`Line(-1);`Lineend]) in - ignore (Str.string_match reg previous 0); - let previous = Str.matched_string previous in - let width_previous = string_width previous in - if width_previous <= width then 2 else width_previous - width - in - Text.insert tw ~index:(ins,[]) ~text:(String.make indent ' ') - -(* The editor class *) - -class editor ~top ~menus = object (self) - val file_menu = new Jg_menu.c "File" ~parent:menus - val edit_menu = new Jg_menu.c "Edit" ~parent:menus - val compiler_menu = new Jg_menu.c "Compiler" ~parent:menus - val module_menu = new Jg_menu.c "Modules" ~parent:menus - val window_menu = new Jg_menu.c "Windows" ~parent:menus - val label = - Checkbutton.create menus ~state:`Disabled - ~onvalue:"modified" ~offvalue:"unchanged" - val mutable current_dir = Unix.getcwd () - val mutable error_messages = [] - val mutable windows = [] - val mutable current_tw = Text.create top - val vwindow = Textvariable.create ~on:top () - val mutable window_counter = 0 - - method has_window name = - List.exists windows ~f:(fun x -> x.name = name) - - method reset_window_menu = - Menu.delete window_menu#menu ~first:(`Num 0) ~last:`End; - List.iter - (List.sort windows ~cmp: - (fun w1 w2 -> - compare (Filename.basename w1.name) (Filename.basename w2.name))) - ~f: - begin fun txt -> - Menu.add_radiobutton window_menu#menu - ~label:(Filename.basename txt.name) - ~variable:vwindow ~value:txt.number - ~command:(fun () -> self#set_edit txt) - end - - method set_edit txt = - if windows <> [] then - Pack.forget [(List.hd windows).frame]; - windows <- txt :: exclude txt windows; - self#reset_window_menu; - current_tw <- txt.tw; - Checkbutton.configure label ~text:(Filename.basename txt.name) - ~variable:txt.modified; - Textvariable.set vwindow txt.number; - Text.yview txt.tw ~scroll:(`Page 0); - pack [txt.frame] ~fill:`Both ~expand:true ~side:`Bottom - - method new_window name = - let tl, tw, sb = Jg_text.create_with_scrollbar top in - Text.configure tw ~background:`White; - Jg_bind.enter_focus tw; - window_counter <- window_counter + 1; - let txt = - { name = name; tw = tw; frame = tl; - number = string_of_int window_counter; - modified = Textvariable.create ~on:tw (); - shell = None; - structure = []; type_info = []; signature = []; psignature = [] } - in - let control c = Char.chr (Char.code c - 96) in - bind tw ~events:[`Modified([`Alt], `KeyPress)] ~action:ignore; - bind tw ~events:[`KeyPress] ~fields:[`Char] - ~action:(fun ev -> - if ev.ev_Char <> "" && - (ev.ev_Char.[0] >= ' ' || - List.mem ev.ev_Char.[0] - (List.map ~f:control ['d'; 'h'; 'i'; 'k'; 'o'; 't'; 'w'; 'y'])) - then Textvariable.set txt.modified "modified"); - bind tw ~events:[`KeyPressDetail"Tab"] ~breakable:true - ~action:(fun _ -> - indent_line tw; - Textvariable.set txt.modified "modified"; - break ()); - bind tw ~events:[`Modified([`Control],`KeyPressDetail"k")] - ~action:(fun _ -> - let text = - Text.get tw ~start:(`Mark"insert",[]) ~stop:(`Mark"insert",[`Lineend]) - in ignore (Str.string_match (Str.regexp "[ \t]*") text 0); - if Str.match_end () <> String.length text then begin - Clipboard.clear (); - Clipboard.append ~data:text () - end); - bind tw ~events:[`KeyRelease] ~fields:[`Char] - ~action:(fun ev -> - if ev.ev_Char <> "" then - Lexical.tag tw ~start:(`Mark"insert", [`Linestart]) - ~stop:(`Mark"insert", [`Lineend])); - bind tw ~events:[`Motion] ~action:(fun _ -> Focus.set tw); - bind tw ~events:[`ButtonPressDetail 2] - ~action:(fun _ -> - Textvariable.set txt.modified "modified"; - Lexical.tag txt.tw ~start:(`Mark"insert", [`Linestart]) - ~stop:(`Mark"insert", [`Lineend])); - bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~fields:[`MouseX;`MouseY] - ~action:(fun ev -> search_pos_window txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY); - bind tw ~events:[`ButtonPressDetail 3] ~fields:[`MouseX;`MouseY] - ~action:(fun ev -> search_pos_menu txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY); - - pack [sb] ~fill:`Y ~side:`Right; - pack [tw] ~fill:`Both ~expand:true ~side:`Left; - self#set_edit txt; - Checkbutton.deselect label; - Lexical.init_tags txt.tw - - method clear_errors () = - Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend; - List.iter error_messages - ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ()); - error_messages <- [] - - method typecheck () = - self#clear_errors (); - error_messages <- Typecheck.f (List.hd windows) - - method lex () = - List.iter [ Widget.default_toplevel; top ] - ~f:(Toplevel.configure ~cursor:(`Xcursor "watch")); - Text.configure current_tw ~cursor:(`Xcursor "watch"); - ignore (Timer.add ~ms:1 ~callback: - begin fun () -> - Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend; - Lexical.tag current_tw; - Text.configure current_tw ~cursor:(`Xcursor "xterm"); - List.iter [ Widget.default_toplevel; top ] - ~f:(Toplevel.configure ~cursor:(`Xcursor "")) - end) - - method save_text ?name:l txt = - let l = match l with None -> [txt.name] | Some l -> l in - if l = [] then () else - let name = List.hd l in - if txt.name <> name then current_dir <- Filename.dirname name; - try - if Sys.file_exists name then - if txt.name = name then begin - let backup = name ^ "~" in - if Sys.file_exists backup then Sys.remove backup; - try Sys.rename name backup with Sys_error _ -> () - end else begin - match Jg_message.ask ~master:top ~title:"Save" - ("File `" ^ name ^ "' exists. Overwrite it?") - with `Yes -> Sys.remove name - | `No -> raise (Sys_error "") - | `Cancel -> raise Exit - end; - let file = open_out name in - let text = Text.get txt.tw ~start:tstart ~stop:(tposend 1) in - output_string file text; - close_out file; - Checkbutton.configure label ~text:(Filename.basename name); - Checkbutton.deselect label; - txt.name <- name - with - Sys_error _ -> - Jg_message.info ~master:top ~title:"Error" - ("Could not save `" ^ name ^ "'.") - | Exit -> () - - method load_text l = - if l = [] then () else - let name = List.hd l in - try - let index = - try - self#set_edit (List.find windows ~f:(fun x -> x.name = name)); - let txt = List.hd windows in - if Textvariable.get txt.modified = "modified" then - begin match Jg_message.ask ~master:top ~title:"Open" - ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") - with `Yes -> self#save_text txt - | `No -> () - | `Cancel -> raise Exit - end; - Checkbutton.deselect label; - (Text.index current_tw ~index:(`Mark"insert", []), []) - with Not_found -> self#new_window name; tstart - in - current_dir <- Filename.dirname name; - let file = open_in name - and tw = current_tw - and len = ref 0 - and buf = String.create 4096 in - Text.delete tw ~start:tstart ~stop:tend; - while - len := input file buf 0 4096; - !len > 0 - do - Jg_text.output tw ~buf ~pos:0 ~len:!len - done; - close_in file; - Text.mark_set tw ~mark:"insert" ~index; - Text.see tw ~index; - if Filename.check_suffix name ".ml" || - Filename.check_suffix name ".mli" - then begin - if !lex_on_load then self#lex (); - if !type_on_load then self#typecheck () - end - with - Sys_error _ | Exit -> () - - method close_window txt = - try - if Textvariable.get txt.modified = "modified" then - begin match Jg_message.ask ~master:top ~title:"Close" - ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") - with `Yes -> self#save_text txt - | `No -> () - | `Cancel -> raise Exit - end; - windows <- exclude txt windows; - if windows = [] then - self#new_window (current_dir ^ "/untitled") - else self#set_edit (List.hd windows); - destroy txt.frame - with Exit -> () - - method open_file () = - Fileselect.f ~title:"Open File" ~action:self#load_text - ~dir:current_dir ~filter:("*.{ml,mli}") ~sync:true () - - method save_file () = self#save_text (List.hd windows) - - method close_file () = self#close_window (List.hd windows) - - method quit ?(cancel=true) () = - try - List.iter windows ~f: - begin fun txt -> - if Textvariable.get txt.modified = "modified" then - match Jg_message.ask ~master:top ~title:"Quit" ~cancel - ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") - with `Yes -> self#save_text txt - | `No -> () - | `Cancel -> raise Exit - end; - bind top ~events:[`Destroy]; - destroy top - with Exit -> () - - method reopen ~file ~pos = - if not (Winfo.ismapped top) then Wm.deiconify top; - match file with None -> () - | Some file -> - self#load_text [file]; - Text.mark_set current_tw ~mark:"insert" ~index:(tpos pos); - try - let index = - Text.search current_tw ~switches:[`Backwards] ~pattern:"*)" - ~start:(tpos pos) ~stop:(tpos pos ~modi:[`Line(-1)]) in - let index = - Text.search current_tw ~switches:[`Backwards] ~pattern:"(*" - ~start:(index,[]) ~stop:(tpos pos ~modi:[`Line(-20)]) in - let s = Text.get current_tw ~start:(index,[`Line(-1);`Linestart]) - ~stop:(index,[`Line(-1);`Lineend]) in - for i = 0 to String.length s - 1 do - match s.[i] with '\t'|' ' -> () | _ -> raise Not_found - done; - Text.yview_index current_tw ~index:(index,[`Line(-1)]) - with _ -> - Text.yview_index current_tw ~index:(tpos pos ~modi:[`Line(-2)]) - - initializer - (* Create a first window *) - self#new_window (current_dir ^ "/untitled"); - - (* Bindings for the main window *) - List.iter - [ [`Control], "s", (fun () -> Jg_text.search_string current_tw); - [`Control], "g", (fun () -> goto_line current_tw); - [`Alt], "s", self#save_file; - [`Alt], "x", (fun () -> send_phrase (List.hd windows)); - [`Alt], "l", self#lex; - [`Alt], "t", self#typecheck ] - ~f:begin fun (modi,key,act) -> - bind top ~events:[`Modified(modi, `KeyPressDetail key)] ~breakable:true - ~action:(fun _ -> act (); break ()) - end; - - bind top ~events:[`Destroy] ~fields:[`Widget] ~action: - begin fun ev -> - if Widget.name ev.ev_Widget = Widget.name top - then self#quit ~cancel:false () - end; - - (* File menu *) - file_menu#add_command "Open File..." ~command:self#open_file; - file_menu#add_command "Reopen" - ~command:(fun () -> self#load_text [(List.hd windows).name]); - file_menu#add_command "Save File" ~command:self#save_file ~accelerator:"M-s"; - file_menu#add_command "Save As..." ~underline:5 ~command: - begin fun () -> - let txt = List.hd windows in - Fileselect.f ~title:"Save as File" - ~action:(fun name -> self#save_text txt ~name) - ~dir:(Filename.dirname txt.name) - ~filter:"*.{ml,mli}" - ~file:(Filename.basename txt.name) - ~sync:true ~usepath:false () - end; - file_menu#add_command "Close File" ~command:self#close_file; - file_menu#add_command "Close Window" ~command:self#quit ~underline:6; - - (* Edit menu *) - edit_menu#add_command "Paste selection" ~command: - begin fun () -> - Text.insert current_tw ~index:(`Mark"insert",[]) - ~text:(Selection.get ~displayof:top ()) - end; - edit_menu#add_command "Goto..." ~accelerator:"C-g" - ~command:(fun () -> goto_line current_tw); - edit_menu#add_command "Search..." ~accelerator:"C-s" - ~command:(fun () -> Jg_text.search_string current_tw); - edit_menu#add_command "To shell" ~accelerator:"M-x" - ~command:(fun () -> send_phrase (List.hd windows)); - edit_menu#add_command "Select shell..." - ~command:(fun () -> select_shell (List.hd windows)); - - (* Compiler menu *) - compiler_menu#add_command "Preferences..." - ~command:(fun () -> compiler_preferences top); - compiler_menu#add_command "Lex" ~accelerator:"M-l" - ~command:self#lex; - compiler_menu#add_command "Typecheck" ~accelerator:"M-t" - ~command:self#typecheck; - compiler_menu#add_command "Clear errors" - ~command:self#clear_errors; - compiler_menu#add_command "Signature..." ~command: - begin fun () -> - let txt = List.hd windows in if txt.signature <> [] then - let basename = Filename.basename txt.name in - let modname = String.capitalize - (try Filename.chop_extension basename with _ -> basename) in - let env = - Env.add_module (Ident.create modname) - (Types.Tmty_signature txt.signature) - Env.initial - in Viewer.view_defined (Longident.Lident modname) ~env ~show_all:true - end; - - (* Modules *) - module_menu#add_command "Path editor..." - ~command:(fun () -> Setpath.set ~dir:current_dir); - module_menu#add_command "Reset cache" - ~command:(fun () -> Setpath.exec_update_hooks (); Env.reset_cache ()); - module_menu#add_command "Search symbol..." - ~command:Viewer.search_symbol; - module_menu#add_command "Close all" - ~command:Viewer.close_all_views; - - (* pack everything *) - pack (List.map ~f:(fun m -> coe m#button) - [file_menu; edit_menu; compiler_menu; module_menu; window_menu] - @ [coe label]) - ~side:`Left ~ipadx:5 ~anchor:`W; - pack [menus] ~before:(List.hd windows).frame ~side:`Top ~fill:`X -end - -(* The main function starts here ! *) - -let already_open : editor list ref = ref [] - -let editor ?file ?(pos=0) ?(reuse=false) () = - - if !already_open <> [] && - let ed = List.hd !already_open - (* try - let name = match file with Some f -> f | None -> raise Not_found in - List.find !already_open ~f:(fun ed -> ed#has_window name) - with Not_found -> List.hd !already_open *) - in try - ed#reopen ~file ~pos; - true - with Protocol.TkError _ -> - already_open := [] (* List.filter !already_open ~f:((<>) ed) *); - false - then () else - let top = Jg_toplevel.titled "OCamlBrowser Editor" in - let menus = Frame.create top ~name:"menubar" in - let ed = new editor ~top ~menus in - already_open := !already_open @ [ed]; - if file <> None then ed#reopen ~file ~pos - -let f ?file ?pos ?(opendialog=false) () = - if opendialog then - Fileselect.f ~title:"Open File" - ~action:(function [file] -> editor ~file () | _ -> ()) - ~filter:("*.{ml,mli}") ~sync:true () - else editor ?file ?pos ~reuse:(file <> None) () diff --git a/otherlibs/labltk/browser/editor.mli b/otherlibs/labltk/browser/editor.mli deleted file mode 100644 index 2d5e90492a73..000000000000 --- a/otherlibs/labltk/browser/editor.mli +++ /dev/null @@ -1,20 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val f : ?file:string -> ?pos:int -> ?opendialog:bool -> unit -> unit - (* open the file editor *) diff --git a/otherlibs/labltk/browser/fileselect.ml b/otherlibs/labltk/browser/fileselect.ml deleted file mode 100644 index d62b8ba3cdf5..000000000000 --- a/otherlibs/labltk/browser/fileselect.ml +++ /dev/null @@ -1,290 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -(* file selection box *) - -open StdLabels -open Str -open Filename -open Tk - -open Useunix - -(**** Memoized rexgexp *) - -let (~!) = Jg_memo.fast ~f:Str.regexp - -(************************************************************ Path name *) - -(* Convert Windows-style directory separator '\' to caml-style '/' *) -let caml_dir path = - if Sys.os_type = "Win32" then - global_replace ~!"\\\\" "/" path - else path - -let parse_filter s = - let s = caml_dir s in - (* replace // by / *) - let s = global_replace ~!"/+" "/" s in - (* replace /./ by / *) - let s = global_replace ~!"/\\./" "/" s in - (* replace hoge/../ by "" *) - let s = global_replace - ~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./" "" s in - (* replace hoge/..$ by *) - let s = global_replace - ~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$" "" s in - (* replace ^/hoge/../ by / *) - let s = global_replace ~!"^\\(/\\.\\.\\)+/" "/" s in - if string_match ~!"^\\([^\\*?[]*[/:]\\)\\(.*\\)" s 0 then - let dirs = matched_group 1 s - and ptrn = matched_group 2 s - in - dirs, ptrn - else "", s - -let rec fixpoint ~f v = - let v' = f v in - if v = v' then v else fixpoint ~f v' - -let unix_regexp s = - let s = Str.global_replace ~!"[$^.+]" "\\\\\\0" s in - let s = Str.global_replace ~!"\\*" ".*" s in - let s = Str.global_replace ~!"\\?" ".?" s in - let s = - fixpoint s - ~f:(Str.replace_first ~!"\\({.*\\),\\(.*}\\)" "\\1\\|\\2") in - let s = - Str.global_replace ~!"{\\(.*\\)}" "\\(\\1\\)" s in - Str.regexp s - -let exact_match ~pat s = - Str.string_match pat s 0 && Str.match_end () = String.length s - -let ls ~dir ~pattern = - let files = get_files_in_directory dir in - let regexp = unix_regexp pattern in - List.filter files ~f:(exact_match ~pat:regexp) - -(********************************************* Creation *) -let load_in_path = ref false - -let search_in_path ~name = Misc.find_in_path !Config.load_path name - -let f ~title ~action:proc ?(dir = Unix.getcwd ()) - ?filter:(deffilter ="*") ?file:(deffile ="") - ?(multi=false) ?(sync=false) ?(usepath=true) () = - - let current_pattern = ref "" - and current_dir = ref (caml_dir dir) in - - let may_prefix name = - if Filename.is_relative name then concat !current_dir name else name in - - let tl = Jg_toplevel.titled title in - Focus.set tl; - - let new_var () = Textvariable.create ~on:tl () in - let filter_var = new_var () - and selection_var = new_var () - and sync_var = new_var () in - Textvariable.set filter_var deffilter; - - let frm = Frame.create tl ~borderwidth:1 ~relief:`Raised in - let df = Frame.create frm in - let dfl = Frame.create df in - let dfll = Label.create dfl ~text:"Directories" in - let dflf, directory_listbox, directory_scrollbar = - Jg_box.create_with_scrollbar dfl in - let dfr = Frame.create df in - let dfrl = Label.create dfr ~text:"Files" in - let dfrf, filter_listbox, filter_scrollbar = - Jg_box.create_with_scrollbar dfr in - let cfrm = Frame.create tl ~borderwidth:1 ~relief:`Raised in - - let configure ~filter = - let filter = may_prefix filter in - let dir, pattern = parse_filter filter in - let dir = if !load_in_path && usepath then "" else - (current_dir := Filename.dirname dir; dir) - and pattern = if pattern = "" then "*" else pattern in - current_pattern := pattern; - let filter = - if !load_in_path && usepath then pattern else dir ^ pattern in - let directories = get_directories_in_files ~path:dir - (get_files_in_directory dir) in - let matched_files = (* get matched file by subshell call. *) - if !load_in_path && usepath then - List.fold_left !Config.load_path ~init:[] ~f: - begin fun acc dir -> - let files = ls ~dir ~pattern in - Sort.merge (<) files - (List.fold_left files ~init:acc - ~f:(fun acc name -> List2.exclude name acc)) - end - else - List.fold_left directories ~init:(ls ~dir ~pattern) - ~f:(fun acc dir -> List2.exclude dir acc) - in - Textvariable.set filter_var filter; - Textvariable.set selection_var (dir ^ deffile); - Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End; - Listbox.insert filter_listbox ~index:`End ~texts:matched_files; - Jg_box.recenter filter_listbox ~index:(`Num 0); - if !load_in_path && usepath then - Listbox.configure directory_listbox ~takefocus:false - else - begin - Listbox.configure directory_listbox ~takefocus:true; - Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End; - Listbox.insert directory_listbox ~index:`End ~texts:directories; - Jg_box.recenter directory_listbox ~index:(`Num 0) - end - in - - let selected_files = ref [] in (* used for synchronous mode *) - let activate l = - Grab.release tl; - destroy tl; - let l = - if !load_in_path && usepath then - List.fold_right l ~init:[] ~f: - begin fun name acc -> - if not (Filename.is_implicit name) then - may_prefix name :: acc - else try search_in_path ~name :: acc with Not_found -> acc - end - else - List.map l ~f:may_prefix - in - if sync then - begin - selected_files := l; - Textvariable.set sync_var "1" - end - else proc l - in - - (* entries *) - let fl = Label.create frm ~text:"Filter" in - let sl = Label.create frm ~text:"Selection" in - let filter_entry = Jg_entry.create frm ~textvariable:filter_var - ~command:(fun filter -> configure ~filter) in - let selection_entry = Jg_entry.create frm ~textvariable:selection_var - ~command:(fun file -> activate [file]) in - - (* and buttons *) - let set_path = Button.create dfl ~text:"Path editor" ~command: - begin fun () -> - Setpath.add_update_hook (fun () -> configure ~filter:!current_pattern); - let w = Setpath.f ~dir:!current_dir in - Grab.set w; - bind w ~events:[`Destroy] ~extend:true ~action:(fun _ -> Grab.set tl) - end in - let toggle_in_path = Checkbutton.create dfl ~text:"Use load path" - ~command: - begin fun () -> - load_in_path := not !load_in_path; - if !load_in_path then - pack [set_path] ~side:`Bottom ~fill:`X ~expand:true - else - Pack.forget [set_path]; - configure ~filter:(Textvariable.get filter_var) - end - and okb = Button.create cfrm ~text:"Ok" ~command: - begin fun () -> - let files = - List.map (Listbox.curselection filter_listbox) ~f: - begin fun x -> - !current_dir ^ Listbox.get filter_listbox ~index:x - end - in - let files = if files = [] then [Textvariable.get selection_var] - else files in - activate files - end - and flb = Button.create cfrm ~text:"Filter" - ~command:(fun () -> configure ~filter:(Textvariable.get filter_var)) - and ccb = Button.create cfrm ~text:"Cancel" - ~command:(fun () -> activate []) in - - (* binding *) - bind tl ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> activate []); - Jg_box.add_completion filter_listbox - ~action:(fun index -> activate [Listbox.get filter_listbox ~index]); - if multi then Listbox.configure filter_listbox ~selectmode:`Multiple else - bind filter_listbox ~events:[`ButtonPressDetail 1] ~fields:[`MouseY] - ~action:(fun ev -> - let name = Listbox.get filter_listbox - ~index:(Listbox.nearest filter_listbox ~y:ev.ev_MouseY) in - if !load_in_path && usepath then - try Textvariable.set selection_var (search_in_path ~name) - with Not_found -> () - else Textvariable.set selection_var (may_prefix name)); - - Jg_box.add_completion directory_listbox ~action: - begin fun index -> - let filter = - may_prefix (Listbox.get directory_listbox ~index) ^ - "/" ^ !current_pattern - in configure ~filter - end; - - pack [frm] ~fill:`Both ~expand:true; - (* filter *) - pack [fl] ~side:`Top ~anchor:`W; - pack [filter_entry] ~side:`Top ~fill:`X; - - (* directory + files *) - pack [df] ~side:`Top ~fill:`Both ~expand:true; - (* directory *) - pack [dfl] ~side:`Left ~fill:`Both ~expand:true; - pack [dfll] ~side:`Top ~anchor:`W; - if usepath then pack [toggle_in_path] ~side:`Bottom ~anchor:`W; - pack [dflf] ~side:`Top ~fill:`Both ~expand:true; - pack [directory_scrollbar] ~side:`Right ~fill:`Y; - pack [directory_listbox] ~side:`Left ~fill:`Both ~expand:true; - (* files *) - pack [dfr] ~side:`Right ~fill:`Both ~expand:true; - pack [dfrl] ~side:`Top ~anchor:`W; - pack [dfrf] ~side:`Top ~fill:`Both ~expand:true; - pack [filter_scrollbar] ~side:`Right ~fill:`Y; - pack [filter_listbox] ~side:`Left ~fill:`Both ~expand:true; - - (* selection *) - pack [sl] ~before:df ~side:`Bottom ~anchor:`W; - pack [selection_entry] ~before:sl ~side:`Bottom ~fill:`X; - - (* create OK, Filter and Cancel buttons *) - pack [okb; flb; ccb] ~side:`Left ~fill:`X ~expand:true; - pack [cfrm] ~before:frm ~side:`Bottom ~fill:`X; - - if !load_in_path && usepath then begin - load_in_path := false; - Checkbutton.invoke toggle_in_path; - Checkbutton.select toggle_in_path - end - else configure ~filter:deffilter; - - Tkwait.visibility tl; - Grab.set tl; - - if sync then - begin - Tkwait.variable sync_var; - proc !selected_files - end; - () diff --git a/otherlibs/labltk/browser/fileselect.mli b/otherlibs/labltk/browser/fileselect.mli deleted file mode 100644 index ed10eaf68fb7..000000000000 --- a/otherlibs/labltk/browser/fileselect.mli +++ /dev/null @@ -1,39 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -val f : - title:string -> - action:(string list -> unit) -> - ?dir:string -> - ?filter:string -> - ?file:string -> - ?multi:bool -> ?sync:bool -> ?usepath:bool -> unit -> unit - -(* action - [] means canceled - if multi select is false, then the list is null or a singleton *) - -(* multi - If true then more than one file are selectable *) - -(* sync - If true then synchronous mode *) - -(* usepath - Enables/disables load path search. Defaults to true *) - -val caml_dir : string -> string -(* Convert Windows-style directory separator '\' to caml-style '/' *) diff --git a/otherlibs/labltk/browser/help.txt b/otherlibs/labltk/browser/help.txt deleted file mode 100644 index 3b8c9b865534..000000000000 --- a/otherlibs/labltk/browser/help.txt +++ /dev/null @@ -1,166 +0,0 @@ - OCamlBrowser Help - -USE - - OCamlBrowser is composed of three tools, the Editor, which allows - one to edit/typecheck/analyse .mli and .ml files, the Viewer, to - walk around compiled modules, and the Shell, to run an OCaml - subshell. You may only have one instance of Editor and Viewer, but - you may use several subshells. - - As with the compiler, you may specify a different path for the - standard library by setting OCAMLLIB. You may also extend the - initial load path (only standard library by default) by using the - -I command line option. The -nolabels, -rectypes and -w options are - also accepted, and inherited by subshells. - The -oldui options selects the old multi-window interface. The - default is now more like Smalltalk's class browser. - -1) Viewer - - This is the first window you get when you start OCamlBrowser. It - displays a search window, and the list of modules in the load path. - At the top a row of menus. - - File - Open and File - Editor give access to the editor. - - File - Shell opens an OCaml shell. - - View - Show all defs displays the signature of the currently - selected module. - - View - Search entry shows/hides the search entry just - below the menu bar. - - Modules - Path editor changes the load path. - Pressing [Add to path] or Insert key adds selected directories - to the load path. - Pressing [Remove from path] or Delete key removes selected - paths from the load path. - - Modules - Reset cache rescans the load path and resets the module - cache. Do it if you recompile some interface, or change the load - path in a conflictual way. - - Modules - Search symbol allows to search a symbol either by its - name, like the bottom line of the viewer, or, more interestingly, - by its type. Exact type searches for a type with exactly the same - information as the pattern (variables match only variables), - included type allows to give only partial information: the actual - type may take more arguments and return more results, and variables - in the pattern match anything. In both cases, argument and tuple - order is irrelevant (*), and unlabeled arguments in the pattern - match any label. - - (*) To avoid combinatorial explosion of the search space, optional - arguments in the actual type are ignored if (1) there are to many - of them, and (2) they do not appear explicitly in the pattern. - - The Search entry just below the menu bar allows one to search for - an identifier in all modules, either by its name (? and * patterns - allowed) or by its type (if there is an arrow in the input). When - search by type is used, it is done in inclusion mode (cf. Modules - - search symbol) - - The Close all button is there to dismiss the windows created - by the Detach button. By double-clicking on it you will quit the - browser. - - -2) Module browsing - - You select a module in the leftmost box by either cliking on it or - pressing return when it is selected. Fast access is available in - all boxes pressing the first few letter of the desired name. - Double-clicking / double-return displays the whole signature for - the module. - - Defined identifiers inside the module are displayed in a box to the - right of the previous one. If you click on one, this will either - display its contents in another box (if this is a sub-module) or - display the signature for this identifier below. - - Signatures are clickable. Double clicking with the left mouse - button on an identifier in a signature brings you to its signature, - inside its module box. - A single click on the right button pops up a menu displaying the - type declaration for the selected identifier. Its title, when - selectable, also brings you to its signature. - - At the bottom, a series of buttons, depending on the context. - * Detach copies the currently displayed signature in a new window, - to keep it. - * Impl and Intf bring you to the implementation or interface of - the currently displayed signature, if it is available. - - C-s opens a text search dialog for the displayed signature. - -3) File editor - - You can edit files with it, but there is no auto-save nor undo at - the moment. Otherwise you can use it as a browser, making - occasional corrections. - - The Edit menu contains commands for jump (C-g), search (C-s), and - sending the current selection to a sub-shell (M-x). For this last - option, you may choose the shell via a dialog. - - Essential function are in the Compiler menu. - - Preferences opens a dialog to set internals of the editor and - type checker. - - Lex (M-l) adds colors according to lexical categories. - - Typecheck (M-t) verifies typing, and memorizes it to let one see an - expression's type by double-clicking on it. This is also valid for - interfaces. If an error occurs, the part of the interface preceding - the error is computed. - - After typechecking, pressing the right button pops up a menu giving - the type of the pointed expression, and eventually allowing to - follow some links. - - Clear errors dismisses type checker error messages and warnings. - - Signature shows the signature of the current file. - -4) Shell - - When you create a shell, a dialog is presented to you, letting you - choose which command you want to run, and the title of the shell - (to choose it in the Editor). - - You may change the default command by setting the OLABL environment - variable. - - The executed subshell is given the current load path. - File: use a source file or load a bytecode file. - You may also import the browser's path into the subprocess. - History: M-p and M-n browse up and down. - Signal: C-c interrupts and you can kill the subprocess. - -BUGS - -* When you quit the editor and some file was modified, a dialogue is - displayed asking wether you want to really quit or not. But 1) if - you quit directly from the viewer, there is no dialogue at all, and - 2) if you close from the window manager, the dialogue is displayed, - but you cannot cancel the destruction... Beware. - -* When you run it through xon, the shell hangs at the first error. But - its ok if you start ocamlbrowser from a remote shell... - -TODO - -* Complete cross-references. - -* Power up editor. - -* Add support for the debugger. - -* Make this a real programming environment, both for beginners and - experimented users. - - -Bug reports and comments to diff --git a/otherlibs/labltk/browser/jg_bind.ml b/otherlibs/labltk/browser/jg_bind.ml deleted file mode 100644 index 3fb854b09644..000000000000 --- a/otherlibs/labltk/browser/jg_bind.ml +++ /dev/null @@ -1,28 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -let enter_focus w = - bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w) - -let escape_destroy ?destroy:tl w = - let tl = match tl with Some w -> w | None -> w in - bind w ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> destroy tl) - -let return_invoke w ~button = - bind w ~events:[`KeyPressDetail "Return"] - ~action:(fun _ -> Button.invoke button) diff --git a/otherlibs/labltk/browser/jg_bind.mli b/otherlibs/labltk/browser/jg_bind.mli deleted file mode 100644 index 70e323bee8a2..000000000000 --- a/otherlibs/labltk/browser/jg_bind.mli +++ /dev/null @@ -1,21 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val enter_focus : 'a widget -> unit -val escape_destroy : ?destroy:'a widget -> 'a widget ->unit -val return_invoke : 'a widget -> button:button widget -> unit diff --git a/otherlibs/labltk/browser/jg_box.ml b/otherlibs/labltk/browser/jg_box.ml deleted file mode 100644 index bc865f6d5b1f..000000000000 --- a/otherlibs/labltk/browser/jg_box.ml +++ /dev/null @@ -1,82 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -let add_scrollbar lb = - let sb = - Scrollbar.create (Winfo.parent lb) ~command:(Listbox.yview lb) in - Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb); sb - -let create_with_scrollbar ?selectmode parent = - let frame = Frame.create parent in - let lb = Listbox.create frame ?selectmode in - frame, lb, add_scrollbar lb - -(* from frx_listbox,adapted *) - -let recenter lb ~index = - Listbox.selection_clear lb ~first:(`Num 0) ~last:`End; - (* Activate it, to keep consistent with Up/Down. - You have to be in Extended or Browse mode *) - Listbox.activate lb ~index; - Listbox.selection_anchor lb ~index; - Listbox.yview_index lb ~index - -class timed ?wait ?nocase get_texts = object - val get_texts = get_texts - inherit Jg_completion.timed [] ?wait ?nocase as super - method! reset = - texts <- get_texts (); - super#reset -end - -let add_completion ?action ?wait ?nocase ?(double=true) lb = - let comp = - new timed ?wait ?nocase - (fun () -> Listbox.get_range lb ~first:(`Num 0) ~last:`End) in - - Jg_bind.enter_focus lb; - - bind lb ~events:[`KeyPress] ~fields:[`Char] ~action: - begin fun ev -> - (* consider only keys producing characters. The callback is called - even if you press Shift. *) - if ev.ev_Char <> "" then - recenter lb ~index:(`Num (comp#add ev.ev_Char)) - end; - - begin match action with - Some action -> - bind lb ~events:[`KeyPressDetail "Return"] - ~action:(fun _ -> action `Active); - let bmod = if double then [`Double] else [] in - bind lb ~events:[`Modified(bmod, `ButtonPressDetail 1)] - ~breakable:true ~fields:[`MouseY] - ~action: - begin fun ev -> - let index = Listbox.nearest lb ~y:ev.ev_MouseY in - if not double then begin - Listbox.selection_clear lb ~first:(`Num 0) ~last:`End; - Listbox.selection_set lb ~first:index ~last:index; - end; - action index; - break () - end - | None -> () - end; - - recenter lb ~index:(`Num 0) (* so that first item is active *) diff --git a/otherlibs/labltk/browser/jg_button.ml b/otherlibs/labltk/browser/jg_button.ml deleted file mode 100644 index de8d3582b9be..000000000000 --- a/otherlibs/labltk/browser/jg_button.ml +++ /dev/null @@ -1,25 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -let create_destroyer ~parent ?(text="Ok") tl = - Button.create parent ~text ~command:(fun () -> destroy tl) - -let add_destroyer ?text tl = - let b = create_destroyer tl ~parent:tl ?text in - pack [b] ~side:`Bottom ~fill:`X; - b diff --git a/otherlibs/labltk/browser/jg_completion.ml b/otherlibs/labltk/browser/jg_completion.ml deleted file mode 100644 index a5457a65b718..000000000000 --- a/otherlibs/labltk/browser/jg_completion.ml +++ /dev/null @@ -1,53 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -let lt_string ?(nocase=false) s1 s2 = - if nocase then String.lowercase s1 < String.lowercase s2 else s1 < s2 - -class completion ?nocase texts = object - val mutable texts = texts - val nocase = nocase - val mutable prefix = "" - val mutable current = 0 - method add c = - prefix <- prefix ^ c; - while current < List.length texts - 1 && - lt_string (List.nth texts current) prefix ?nocase - do - current <- current + 1 - done; - current - method current = current - method get_current = List.nth texts current - method reset = - prefix <- ""; - current <- 0 -end - -class timed ?nocase ?wait texts = object (self) - inherit completion texts ?nocase as super - val wait = match wait with None -> 500 | Some n -> n - val mutable timer = None - method! add c = - begin match timer with - None -> self#reset - | Some t -> Timer.remove t - end; - timer <- Some (Timer.add ~ms:wait ~callback:(fun () -> self#reset)); - super#add c - method! reset = - timer <- None; super#reset -end diff --git a/otherlibs/labltk/browser/jg_completion.mli b/otherlibs/labltk/browser/jg_completion.mli deleted file mode 100644 index 40c2db3ceecb..000000000000 --- a/otherlibs/labltk/browser/jg_completion.mli +++ /dev/null @@ -1,25 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -val lt_string : ?nocase:bool -> string -> string -> bool - -class timed : ?nocase:bool -> ?wait:int -> string list -> object - val mutable texts : string list - method add : string -> int - method current : int - method get_current : string - method reset : unit -end diff --git a/otherlibs/labltk/browser/jg_config.ml b/otherlibs/labltk/browser/jg_config.ml deleted file mode 100644 index fbbd2ef1bb75..000000000000 --- a/otherlibs/labltk/browser/jg_config.ml +++ /dev/null @@ -1,40 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Jg_tk - -let fixed = if wingui then "{Courier New} 8" else "fixed" -let variable = if wingui then "Arial 9" else "variable" - -let init () = - if wingui then Option.add ~path:"*font" fixed; - let font = - let font = - Option.get Widget.default_toplevel ~name:"variableFont" ~clas:"Font" in - if font = "" then variable else font - in - List.iter ["Button"; "Label"; "Menu"; "Menubutton"; "Radiobutton"] - ~f:(fun cl -> Option.add ~path:("*" ^ cl ^ ".font") font); - Option.add ~path:"*Menu.tearOff" "0" ~priority:`StartupFile; - Option.add ~path:"*Button.padY" "0" ~priority:`StartupFile; - Option.add ~path:"*Text.highlightThickness" "0" ~priority:`StartupFile; - Option.add ~path:"*interface.background" "gray85" ~priority:`StartupFile; - let foreground = - Option.get Widget.default_toplevel - ~name:"disabledForeground" ~clas:"Foreground" in - if foreground = "" then - Option.add ~path:"*disabledForeground" "black" diff --git a/otherlibs/labltk/browser/jg_config.mli b/otherlibs/labltk/browser/jg_config.mli deleted file mode 100644 index fdaab3fe1d3f..000000000000 --- a/otherlibs/labltk/browser/jg_config.mli +++ /dev/null @@ -1,17 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -val init: unit -> unit diff --git a/otherlibs/labltk/browser/jg_entry.ml b/otherlibs/labltk/browser/jg_entry.ml deleted file mode 100644 index 1f7aab751af2..000000000000 --- a/otherlibs/labltk/browser/jg_entry.ml +++ /dev/null @@ -1,27 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -let create ?command ?width ?textvariable parent = - let ew = Entry.create parent ?width ?textvariable in - Jg_bind.enter_focus ew; - begin match command with Some command -> - bind ew ~events:[`KeyPressDetail "Return"] - ~action:(fun _ -> command (Entry.get ew)) - | None -> () - end; - ew diff --git a/otherlibs/labltk/browser/jg_memo.ml b/otherlibs/labltk/browser/jg_memo.ml deleted file mode 100644 index fb1c05efaf67..000000000000 --- a/otherlibs/labltk/browser/jg_memo.ml +++ /dev/null @@ -1,33 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -type ('a, 'b) assoc_list = - Nil - | Cons of 'a * 'b * ('a, 'b) assoc_list - -let rec assq key = function - Nil -> raise Not_found - | Cons (a, b, l) -> - if key == a then b else assq key l - -let fast ~f = - let memo = ref Nil in - fun key -> - try assq key !memo - with Not_found -> - let data = f key in - memo := Cons(key, data, !memo); - data diff --git a/otherlibs/labltk/browser/jg_memo.mli b/otherlibs/labltk/browser/jg_memo.mli deleted file mode 100644 index 14443ad16a1e..000000000000 --- a/otherlibs/labltk/browser/jg_memo.mli +++ /dev/null @@ -1,19 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -val fast : f:('a -> 'b) -> 'a -> 'b -(* "fast" memoizer: uses a List.assq like function *) -(* Good for a smallish number of keys, phisically equal *) diff --git a/otherlibs/labltk/browser/jg_menu.ml b/otherlibs/labltk/browser/jg_menu.ml deleted file mode 100644 index 072c13b1dd41..000000000000 --- a/otherlibs/labltk/browser/jg_menu.ml +++ /dev/null @@ -1,42 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -class c ~parent ?underline:(n=0) text = object (self) - val pair = - let button = - Menubutton.create parent ~text ~underline:n in - let menu = Menu.create button in - Menubutton.configure button ~menu; - button, menu - method button = fst pair - method menu = snd pair - method virtual add_command : - ?underline:int -> - ?accelerator:string -> ?activebackground:color -> - ?activeforeground:color -> ?background:color -> - ?bitmap:bitmap -> ?command:(unit -> unit) -> - ?font:string -> ?foreground:color -> - ?image:image -> ?state:state -> - string -> unit - method add_command ?underline:(n=0) ?accelerator ?activebackground - ?activeforeground ?background ?bitmap ?command ?font ?foreground - ?image ?state label = - Menu.add_command (self#menu) ~label ~underline:n ?accelerator - ?activebackground ?activeforeground ?background ?bitmap - ?command ?font ?foreground ?image ?state -end diff --git a/otherlibs/labltk/browser/jg_message.ml b/otherlibs/labltk/browser/jg_message.ml deleted file mode 100644 index d4d3ebbd2644..000000000000 --- a/otherlibs/labltk/browser/jg_message.ml +++ /dev/null @@ -1,111 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk -open Jg_tk - -(* -class formatted ~parent ~width ~maxheight ~minheight = - val parent = (parent : Widget.any Widget.widget) - val width = width - val maxheight = maxheight - val minheight = minheight - val tw = Text.create ~parent ~width ~wrap:`Word - val fof = Format.get_formatter_output_functions () - method parent = parent - method init = - pack [tw] ~side:`Left ~fill:`Both ~expand:true; - Format.print_flush (); - Format.set_margin (width - 2); - Format.set_formatter_output_functions ~out:(Jg_text.output tw) - ~flush:(fun () -> ()) - method finish = - Format.print_flush (); - Format.set_formatter_output_functions ~out:(fst fof) ~flush:(snd fof); - let `Linechar (l, _) = Text.index tw ~index:(tposend 1) in - Text.configure tw ~height:(max minheight (min l maxheight)); - if l > 5 then - pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y -end -*) - -let formatted ~title ?on ?(ppf = Format.std_formatter) - ?(width=60) ?(maxheight=10) ?(minheight=0) () = - let tl, frame = - match on with - Some frame -> -(* let label = Label.create frame ~anchor:`W ~padx:10 ~text:title in - pack [label] ~side:`Top ~fill:`X; - let frame2 = Frame.create frame in - pack [frame2] ~side:`Bottom ~fill:`Both ~expand:true; *) - coe frame, frame - | None -> - let tl = Jg_toplevel.titled title in - Jg_bind.escape_destroy tl; - let frame = Frame.create tl in - pack [frame] ~side:`Top ~fill:`Both ~expand:true; - coe tl, frame - in - let tw = Text.create frame ~width ~wrap:`Word in - pack [tw] ~side:`Left ~fill:`Both ~expand:true; - Format.pp_print_flush ppf (); - Format.pp_set_margin ppf (width - 2); - let fof,fff = Format.pp_get_formatter_output_functions ppf () in - Format.pp_set_formatter_output_functions ppf - (fun buf pos len -> Jg_text.output tw ~buf ~pos ~len) - ignore; - tl, tw, - begin fun () -> - Format.pp_print_flush ppf (); - Format.pp_set_formatter_output_functions ppf fof fff; - let `Linechar (l, _) = Text.index tw ~index:(tposend 1) in - Text.configure tw ~height:(max minheight (min l maxheight)); - if l > 5 then - pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y - end - -let ask ~title ?master ?(no=true) ?(cancel=true) text = - let tl = Jg_toplevel.titled title in - begin match master with None -> () - | Some master -> Wm.transient_set tl ~master - end; - let mw = Message.create tl ~text ~padx:20 ~pady:10 - ~width:250 ~justify:`Left ~aspect:400 ~anchor:`W - and fw = Frame.create tl - and sync = Textvariable.create ~on:tl () - and r = ref (`Cancel : [`Yes|`No|`Cancel]) in - let accept = Button.create fw - ~text:(if no || cancel then "Yes" else "Dismiss") - ~command:(fun () -> r := `Yes; destroy tl) - and refuse = Button.create fw ~text:"No" - ~command:(fun () -> r := `No; destroy tl) - and cancelB = Button.create fw ~text:"Cancel" - ~command:(fun () -> r := `Cancel; destroy tl) - in - bind tl ~events:[`Destroy] ~extend:true - ~action:(fun _ -> Textvariable.set sync "1"); - pack [accept] ~side:`Left ~fill:`X ~expand:true; - if no then pack [refuse] ~side:`Left ~fill:`X ~expand:true; - if cancel then pack [cancelB] ~side:`Left ~fill:`X ~expand:true; - pack [mw] ~side:`Top ~fill:`Both; - pack [fw] ~side:`Bottom ~fill:`X ~expand:true; - Grab.set tl; - Tkwait.variable sync; - !r - -let info ~title ?master text = - ignore (ask ~title ?master ~no:false ~cancel:false text) diff --git a/otherlibs/labltk/browser/jg_message.mli b/otherlibs/labltk/browser/jg_message.mli deleted file mode 100644 index 0e123ac2c72b..000000000000 --- a/otherlibs/labltk/browser/jg_message.mli +++ /dev/null @@ -1,33 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val formatted : - title:string -> - ?on:frame widget -> - ?ppf:Format.formatter -> - ?width:int -> - ?maxheight:int -> - ?minheight:int -> - unit -> any widget * text widget * (unit -> unit) - -val ask : - title:string -> ?master:toplevel widget -> - ?no:bool -> ?cancel:bool -> string -> [`Cancel|`No|`Yes] - -val info : - title:string -> ?master:toplevel widget -> string -> unit diff --git a/otherlibs/labltk/browser/jg_multibox.ml b/otherlibs/labltk/browser/jg_multibox.ml deleted file mode 100644 index 39082e329d61..000000000000 --- a/otherlibs/labltk/browser/jg_multibox.ml +++ /dev/null @@ -1,185 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels - -let rec gen_list ~f:f ~len = - if len = 0 then [] else f () :: gen_list ~f:f ~len:(len - 1) - -let rec make_list ~len ~fill = - if len = 0 then [] else fill :: make_list ~len:(len - 1) ~fill - -(* By column version -let rec firsts ~len l = - if len = 0 then ([],l) else - match l with - a::l -> - let (f,l) = firsts l len:(len - 1) in - (a::f,l) - | [] -> - (l,[]) - -let rec split ~len = function - [] -> [] - | l -> - let (f,r) = firsts l ~len in - let ret = split ~len r in - f :: ret - -let extend l ~len ~fill = - if List.length l >= len then l - else l @ make_list ~fill len:(len - List.length l) -*) - -(* By row version *) - -let rec first l ~len = - if len = 0 then [], l else - match l with - [] -> make_list ~len ~fill:"", [] - | a::l -> - let (l',r) = first ~len:(len - 1) l in a::l',r - -let rec split l ~len = - if l = [] then make_list ~len ~fill:[] else - let (cars,r) = first l ~len in - let cdrs = split r ~len in - List.map2 cars cdrs ~f:(fun a l -> a::l) - - -open Tk - -class c ~cols ~texts ?maxheight ?width parent = object (self) - val parent' = coe parent - val length = List.length texts - val boxes = - let height = (List.length texts - 1) / cols + 1 in - let height = - match maxheight with None -> height - | Some max -> min max height - in - gen_list ~len:cols ~f: - begin fun () -> - Listbox.create parent ~height ?width - ~highlightthickness:0 - ~borderwidth:1 - end - val mutable current = 0 - method cols = cols - method texts = texts - method parent = parent' - method boxes = boxes - method current = current - method recenter ?(aligntop=false) n = - current <- - if n < 0 then 0 else - if n < length then n else length - 1; - (* Activate it, to keep consistent with Up/Down. - You have to be in Extended or Browse mode *) - let box = List.nth boxes (current mod cols) - and index = `Num (current / cols) in - List.iter boxes ~f: - begin fun box -> - Listbox.selection_clear box ~first:(`Num 0) ~last:`End; - Listbox.selection_anchor box ~index; - Listbox.activate box ~index - end; - Focus.set box; - if aligntop then Listbox.yview_index box ~index - else Listbox.see box ~index; - let (first,last) = Listbox.yview_get box in - List.iter boxes ~f:(Listbox.yview ~scroll:(`Moveto first)) - method init = - let textl = split ~len:cols texts in - List.iter2 boxes textl ~f: - begin fun box texts -> - Jg_bind.enter_focus box; - Listbox.insert box ~texts ~index:`End - end; - pack boxes ~side:`Left ~expand:true ~fill:`Both; - self#bind_mouse ~events:[`ButtonPressDetail 1] - ~action:(fun _ ~index:n -> self#recenter n; break ()); - let current_height () = - let (top,bottom) = Listbox.yview_get (List.hd boxes) in - truncate ((bottom -. top) *. float (Listbox.size (List.hd boxes)) - +. 0.99) - in - List.iter - [ "Right", (fun n -> n+1); - "Left", (fun n -> n-1); - "Up", (fun n -> n-cols); - "Down", (fun n -> n+cols); - "Prior", (fun n -> n - current_height () * cols); - "Next", (fun n -> n + current_height () * cols); - "Home", (fun _ -> 0); - "End", (fun _ -> List.length texts) ] - ~f:begin fun (key,f) -> - self#bind_kbd ~events:[`KeyPressDetail key] - ~action:(fun _ ~index:n -> self#recenter (f n); break ()) - end; - self#recenter 0 - method bind_mouse ~events ~action = - let i = ref 0 in - List.iter boxes ~f: - begin fun box -> - let b = !i in - bind box ~events ~breakable:true ~fields:[`MouseX;`MouseY] - ~action:(fun ev -> - let `Num n = Listbox.nearest box ~y:ev.ev_MouseY - in action ev ~index:(n * cols + b)); - incr i - end - method bind_kbd ~events ~action = - let i = ref 0 in - List.iter boxes ~f: - begin fun box -> - let b = !i in - bind box ~events ~breakable:true ~fields:[`Char] - ~action:(fun ev -> - let `Num n = Listbox.index box ~index:`Active in - action ev ~index:(n * cols + b)); - incr i - end -end - -let add_scrollbar (box : c) = - let boxes = box#boxes in - let sb = - Scrollbar.create (box#parent) - ~command:(fun ~scroll -> List.iter boxes ~f:(Listbox.yview ~scroll)) in - List.iter boxes - ~f:(fun lb -> Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb)); - pack [sb] ~before:(List.hd boxes) ~side:`Right ~fill:`Y; - sb - -let add_completion ?action ?wait (box : c) = - let comp = new Jg_completion.timed (box#texts) ?wait in - box#bind_kbd ~events:[`KeyPress] - ~action:(fun ev ~index -> - (* consider only keys producing characters. The callback is called - * even if you press Shift. *) - if ev.ev_Char <> "" then - box#recenter (comp#add ev.ev_Char) ~aligntop:true); - match action with - Some action -> - box#bind_kbd ~events:[`KeyPressDetail "space"] - ~action:(fun ev ~index -> action (box#current)); - box#bind_kbd ~events:[`KeyPressDetail "Return"] - ~action:(fun ev ~index -> action (box#current)); - box#bind_mouse ~events:[`ButtonPressDetail 1] - ~action:(fun ev ~index -> - box#recenter index; action (box#current); break ()) - | None -> () diff --git a/otherlibs/labltk/browser/jg_multibox.mli b/otherlibs/labltk/browser/jg_multibox.mli deleted file mode 100644 index bccca506257c..000000000000 --- a/otherlibs/labltk/browser/jg_multibox.mli +++ /dev/null @@ -1,35 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -class c : - cols:int -> texts:string list -> - ?maxheight:int -> ?width:int -> 'a Widget.widget -> -object - method cols : int - method texts : string list - method parent : Widget.any Widget.widget - method boxes : Widget.listbox Widget.widget list - method current : int - method init : unit - method recenter : ?aligntop:bool -> int -> unit - method bind_mouse : - events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit - method bind_kbd : - events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit -end - -val add_scrollbar : c -> Widget.scrollbar Widget.widget -val add_completion : ?action:(int -> unit) -> ?wait:int -> c -> unit diff --git a/otherlibs/labltk/browser/jg_text.ml b/otherlibs/labltk/browser/jg_text.ml deleted file mode 100644 index 76eeb92a74ca..000000000000 --- a/otherlibs/labltk/browser/jg_text.ml +++ /dev/null @@ -1,104 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk -open Jg_tk - -let get_all tw = Text.get tw ~start:tstart ~stop:(tposend 1) - -let tag_and_see tw ~tag ~start ~stop = - Text.tag_remove tw ~start:(tpos 0) ~stop:tend ~tag; - Text.tag_add tw ~start ~stop ~tag; - try - Text.see tw ~index:(`Tagfirst tag, []); - Text.mark_set tw ~mark:"insert" ~index:(`Tagfirst tag, []) - with Protocol.TkError _ -> () - -let output tw ~buf ~pos ~len = - Text.insert tw ~index:tend ~text:(String.sub buf ~pos ~len) - -let add_scrollbar tw = - let sb = Scrollbar.create (Winfo.parent tw) ~command:(Text.yview tw) - in Text.configure tw ~yscrollcommand:(Scrollbar.set sb); sb - -let create_with_scrollbar parent = - let frame = Frame.create parent in - let tw = Text.create frame in - frame, tw, add_scrollbar tw - -let goto_tag tw ~tag = - let index = (`Tagfirst tag, []) in - try Text.see tw ~index; - Text.mark_set tw ~index ~mark:"insert" - with Protocol.TkError _ -> () - -let search_string tw = - let tl = Jg_toplevel.titled "Search" in - Wm.transient_set tl ~master:(Winfo.toplevel tw); - let fi = Frame.create tl - and fd = Frame.create tl - and fm = Frame.create tl - and buttons = Frame.create tl - and direction = Textvariable.create ~on:tl () - and mode = Textvariable.create ~on:tl () - and count = Textvariable.create ~on:tl () - in - let label = Label.create fi ~text:"Pattern:" - and text = Entry.create fi ~width:20 - and back = Radiobutton.create fd ~variable:direction - ~text:"Backwards" ~value:"backward" - and forw = Radiobutton.create fd ~variable:direction - ~text:"Forwards" ~value:"forward" - and exact = Radiobutton.create fm ~variable:mode - ~text:"Exact" ~value:"exact" - and nocase = Radiobutton.create fm ~variable:mode - ~text:"No case" ~value:"nocase" - and regexp = Radiobutton.create fm ~variable:mode - ~text:"Regexp" ~value:"regexp" - in - let search = Button.create buttons ~text:"Search" ~command: - begin fun () -> - try - let pattern = Entry.get text in - let dir, ofs = match Textvariable.get direction with - "forward" -> `Forwards, 1 - | "backward" -> `Backwards, -1 - | _ -> assert false - and mode = match Textvariable.get mode with "exact" -> [`Exact] - | "nocase" -> [`Nocase] | "regexp" -> [`Regexp] | _ -> [] - in - let ndx = - Text.search tw ~pattern ~switches:([dir;`Count count] @ mode) - ~start:(`Mark "insert", [`Char ofs]) - in - tag_and_see tw ~tag:"sel" ~start:(ndx,[]) - ~stop:(ndx,[`Char(int_of_string (Textvariable.get count))]) - with Invalid_argument _ -> () - end - and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in - - Focus.set text; - Jg_bind.return_invoke text ~button:search; - Jg_bind.escape_destroy tl; - Textvariable.set direction "forward"; - Textvariable.set mode "nocase"; - pack [label] ~side:`Left; - pack [text] ~side:`Right ~fill:`X ~expand:true; - pack [back; forw] ~side:`Left; - pack [exact; nocase; regexp] ~side:`Left; - pack [search; ok] ~side:`Left ~fill:`X ~expand:true; - pack [fi; fd; fm; buttons] ~side:`Top ~fill:`X diff --git a/otherlibs/labltk/browser/jg_text.mli b/otherlibs/labltk/browser/jg_text.mli deleted file mode 100644 index 44cba0232a97..000000000000 --- a/otherlibs/labltk/browser/jg_text.mli +++ /dev/null @@ -1,28 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val get_all : text widget -> string -val tag_and_see : - text widget -> - tag:Tk.textTag -> start:Tk.textIndex -> stop:Tk.textIndex -> unit -val output : text widget -> buf:string -> pos:int -> len:int -> unit -val add_scrollbar : text widget -> scrollbar widget -val create_with_scrollbar : - 'a widget -> frame widget * text widget * scrollbar widget -val goto_tag : text widget -> tag:string -> unit -val search_string : text widget -> unit diff --git a/otherlibs/labltk/browser/jg_tk.ml b/otherlibs/labltk/browser/jg_tk.ml deleted file mode 100644 index 16106eebff0d..000000000000 --- a/otherlibs/labltk/browser/jg_tk.ml +++ /dev/null @@ -1,24 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -let tpos ?(modi=[]) x : textIndex = `Linechar (1,0), `Char x :: modi -and tposend ?(modi=[]) x : textIndex = `End, `Char (-x) :: modi -let tstart : textIndex = `Linechar (1,0), [] -and tend : textIndex = `End, [] - -let wingui = Sys.os_type = "Win32" || Sys.os_type = "Cygwin" diff --git a/otherlibs/labltk/browser/jg_toplevel.ml b/otherlibs/labltk/browser/jg_toplevel.ml deleted file mode 100644 index d77845df58f3..000000000000 --- a/otherlibs/labltk/browser/jg_toplevel.ml +++ /dev/null @@ -1,25 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Tk - -let titled ?iconname title = - let iconname = match iconname with None -> title | Some s -> s in - let tl = Toplevel.create Widget.default_toplevel in - Wm.title_set tl title; - Wm.iconname_set tl iconname; - Wm.group_set tl ~leader: Widget.default_toplevel; - tl diff --git a/otherlibs/labltk/browser/lexical.ml b/otherlibs/labltk/browser/lexical.ml deleted file mode 100644 index ef9491c4a01a..000000000000 --- a/otherlibs/labltk/browser/lexical.ml +++ /dev/null @@ -1,150 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk -open Jg_tk -open Parser - -let tags = - ["control"; "define"; "structure"; "char"; - "infix"; "label"; "uident"] -and colors = - ["blue"; "forestgreen"; "purple"; "gray40"; - "indianred4"; "saddlebrown"; "midnightblue"] - -let init_tags tw = - List.iter2 tags colors ~f: - begin fun tag col -> - Text.tag_configure tw ~tag ~foreground:(`Color col) - end; - Text.tag_configure tw ~tag:"error" ~foreground:`Red; - Text.tag_configure tw ~tag:"error" ~relief:`Raised; - Text.tag_raise tw ~tag:"error" - -let tag ?(start=tstart) ?(stop=tend) tw = - let tpos c = (Text.index tw ~index:start, [`Char c]) in - let text = Text.get tw ~start ~stop in - let buffer = Lexing.from_string text in - List.iter tags - ~f:(fun tag -> Text.tag_remove tw ~start ~stop ~tag); - let last = ref (EOF, 0, 0) in - try - while true do - let token = Lexer.token buffer - and start = Lexing.lexeme_start buffer - and stop = Lexing.lexeme_end buffer in - let tag = - match token with - AMPERAMPER - | AMPERSAND - | BARBAR - | DO | DONE - | DOWNTO - | ELSE - | FOR - | IF - | LAZY - | MATCH - | OR -(*> JOCAML *) - | REPLY - | SPAWN -(*< JOCAML *) - | THEN - | TO - | TRY - | WHEN - | WHILE - | WITH - -> "control" - | AND - | AS - | BAR - | CLASS - | CONSTRAINT -(*> JOCAML *) - | DEF -(*< JOCAML *) - | EXCEPTION - | EXTERNAL - | FUN - | FUNCTION - | FUNCTOR - | IN - | INHERIT - | INITIALIZER - | LET - | METHOD - | MODULE - | MUTABLE - | NEW - | OF - | PRIVATE - | REC - | TYPE - | VAL - | VIRTUAL - -> "define" - | BEGIN - | END - | INCLUDE - | OBJECT - | OPEN - | SIG - | STRUCT - -> "structure" - | CHAR _ - | STRING _ - -> "char" - | BACKQUOTE - | INFIXOP1 _ - | INFIXOP2 _ - | INFIXOP3 _ - | INFIXOP4 _ - | PREFIXOP _ - | SHARP - -> "infix" - | LABEL _ - | OPTLABEL _ - | QUESTION - | TILDE - -> "label" - | UIDENT _ -> "uident" - | LIDENT _ -> - begin match !last with - (QUESTION | TILDE), _, _ -> "label" - | _ -> "" - end - | COLON -> - begin match !last with - LIDENT _, lstart, lstop -> - if lstop = start then - Text.tag_add tw ~tag:"label" - ~start:(tpos lstart) ~stop:(tpos stop); - "" - | _ -> "" - end - | EOF -> raise End_of_file - | _ -> "" - in - if tag <> "" then - Text.tag_add tw ~tag ~start:(tpos start) ~stop:(tpos stop); - last := (token, start, stop) - done - with - End_of_file -> () - | Lexer.Error (err, loc) -> () diff --git a/otherlibs/labltk/browser/lexical.mli b/otherlibs/labltk/browser/lexical.mli deleted file mode 100644 index 52d09e35f57b..000000000000 --- a/otherlibs/labltk/browser/lexical.mli +++ /dev/null @@ -1,20 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val init_tags : text widget -> unit -val tag : ?start:Tk.textIndex -> ?stop:Tk.textIndex -> text widget -> unit diff --git a/otherlibs/labltk/browser/list2.ml b/otherlibs/labltk/browser/list2.ml deleted file mode 100644 index 4439e7410ea1..000000000000 --- a/otherlibs/labltk/browser/list2.ml +++ /dev/null @@ -1,23 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels - -let exclude x l = List.filter l ~f:((<>) x) - -let rec flat_map ~f = function - [] -> [] - | x :: l -> f x @ flat_map ~f l diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml deleted file mode 100644 index a433ad43ff22..000000000000 --- a/otherlibs/labltk/browser/main.ml +++ /dev/null @@ -1,131 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -module Unix = UnixLabels -open Tk - -let fatal_error text = - let top = openTk ~clas:"OCamlBrowser" () in - let mw = Message.create top ~text ~padx:20 ~pady:10 - ~width:400 ~justify:`Left ~aspect:400 ~anchor:`W - and b = Button.create top ~text:"OK" ~command:(fun () -> destroy top) in - pack [mw] ~side:`Top ~fill:`Both; - pack [b] ~side:`Bottom; - mainLoop (); - exit 0 - -let rec get_incr key = function - [] -> raise Not_found - | (k, c, d) :: rem -> - if k = key then - match c with Arg.Set _ | Arg.Clear _ | Arg.Unit _ -> false | _ -> true - else get_incr key rem - -let check ~spec argv = - let i = ref 1 in - while !i < Array.length argv do - try - let a = get_incr argv.(!i) spec in - incr i; if a then incr i - with Not_found -> - i := Array.length argv + 1 - done; - !i = Array.length argv - -open Printf - -let print_version () = - printf "The OCaml browser, version %s\n" Sys.ocaml_version; - exit 0; -;; - -let print_version_num () = - printf "%s\n" Sys.ocaml_version; - exit 0; -;; - -let usage ~spec errmsg = - let b = Buffer.create 1024 in - bprintf b "%s\n" errmsg; - List.iter (function (key, _, doc) -> bprintf b " %s %s\n" key doc) spec; - Buffer.contents b - -let _ = - let is_win32 = Sys.os_type = "Win32" in - if is_win32 then - Format.pp_set_formatter_output_functions Format.err_formatter - (fun _ _ _ -> ()) (fun _ -> ()); - - let path = ref [] in - let st = ref true in - let spec = - [ "-I", Arg.String (fun s -> path := s :: !path), - " Add to the list of include directories"; - "-labels", Arg.Clear Clflags.classic, " "; - "-nolabels", Arg.Set Clflags.classic, - " Ignore non-optional labels in types"; - "-oldui", Arg.Clear st, " Revert back to old UI"; - "-pp", Arg.String (fun s -> Clflags.preprocessor := Some s), - " Pipe sources through preprocessor "; - "-rectypes", Arg.Set Clflags.recursive_types, - " Allow arbitrary recursive types"; - "-version", Arg.Unit print_version, - " Print version and exit"; - "-vnum", Arg.Unit print_version_num, " Print version number and exit"; - "-w", Arg.String (fun s -> Shell.warnings := s), - " Enable or disable warnings according to "; ] - and errmsg = "Command line: ocamlbrowser " in - if not (check ~spec Sys.argv) then fatal_error (usage ~spec errmsg); - Arg.parse spec - (fun name -> raise(Arg.Bad("don't know what to do with " ^ name))) - errmsg; - Config.load_path := - Sys.getcwd () - :: List.rev_map ~f:(Misc.expand_directory Config.standard_library) !path - @ [Config.standard_library]; - Warnings.parse_options false !Shell.warnings; - Unix.putenv "TERM" "noterminal"; - begin - try Searchid.start_env := Env.open_pers_signature "Pervasives" Env.initial - with _ -> - fatal_error - (Printf.sprintf "%s\nPlease check that %s %s\nCurrent value is `%s'" - "Couldn't initialize environment." - (if is_win32 then "%OCAMLLIB%" else "$OCAMLLIB") - "points to the OCaml library." - Config.standard_library) - end; - - Searchpos.view_defined_ref := (fun s ~env -> Viewer.view_defined s ~env); - Searchpos.editor_ref := Editor.f; - - let top = openTk ~clas:"OCamlBrowser" () in - Jg_config.init (); - - (* bind top ~events:[`Destroy] ~action:(fun _ -> exit 0); *) - at_exit Shell.kill_all; - - - if !st then Viewer.st_viewer ~on:top () - else Viewer.f ~on:top (); - - while true do - try - if is_win32 then mainLoop () - else Printexc.print mainLoop () - with Protocol.TkError _ -> () - done diff --git a/otherlibs/labltk/browser/mytypes.mli b/otherlibs/labltk/browser/mytypes.mli deleted file mode 100644 index 2f7bc7489d2d..000000000000 --- a/otherlibs/labltk/browser/mytypes.mli +++ /dev/null @@ -1,29 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -type edit_window = - { mutable name: string; - tw: text widget; - frame: frame widget; - modified: Textvariable.textVariable; - mutable shell: (string * Shell.shell) option; - mutable structure: Typedtree.structure; - mutable type_info: Stypes.type_info list; - mutable signature: Types.signature; - mutable psignature: Parsetree.signature; - number: string } diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml deleted file mode 100644 index 6804f79d8c01..000000000000 --- a/otherlibs/labltk/browser/searchid.ml +++ /dev/null @@ -1,537 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Location -open Longident -open Path -open Types -open Typedtree -open Env -open Btype -open Ctype - -(* only initial here, but replaced by Pervasives later *) -let start_env = ref initial -let module_list = ref [] - -type pkind = - Pvalue - | Ptype - | Plabel - | Pconstructor - | Pmodule - | Pmodtype - | Pclass - | Pcltype - -let string_of_kind = function - Pvalue -> "v" - | Ptype -> "t" - | Plabel -> "l" - | Pconstructor -> "cn" - | Pmodule -> "m" - | Pmodtype -> "s" - | Pclass -> "c" - | Pcltype -> "ct" - -let rec longident_of_path = function - Pident id -> Lident (Ident.name id) - | Pdot (path, s, _) -> Ldot (longident_of_path path, s) - | Papply (p1, p2) -> Lapply (longident_of_path p1, longident_of_path p2) - -let rec remove_prefix lid ~prefix = - let rec remove_hd lid ~name = - match lid with - Ldot (Lident s1, s2) when s1 = name -> Lident s2 - | Ldot (l, s) -> Ldot (remove_hd ~name l, s) - | _ -> raise Not_found - in - match prefix with - [] -> lid - | name :: prefix -> - try remove_prefix ~prefix (remove_hd ~name lid) - with Not_found -> lid - -let rec permutations l = match l with - [] | [_] -> [l] - | [a;b] -> [l; [b;a]] - | _ -> - let _, perms = - List.fold_left l ~init:(l,[]) ~f: - begin fun (l, perms) a -> - let l = List.tl l in - l @ [a], - List.map (permutations l) ~f:(fun l -> a :: l) @ perms - end - in perms - -let rec choose n ~card:l = - let len = List.length l in - if n = len then [l] else - if n = 1 then List.map l ~f:(fun x -> [x]) else - if n = 0 then [[]] else - if n > len then [] else - match l with [] -> [] - | a :: l -> - List.map (choose (n-1) ~card:l) ~f:(fun l -> a :: l) - @ choose n ~card:l - -let rec arr p ~card:n = - if p = 0 then 1 else n * arr (p-1) ~card:(n-1) - -let rec all_args ty = - let ty = repr ty in - match ty.desc with - Tarrow(l, ty1, ty2, _) -> let (tl,ty) = all_args ty2 in ((l,ty1)::tl, ty) - | _ -> ([], ty) - -let rec equal ~prefix t1 t2 = - match (repr t1).desc, (repr t2).desc with - Tvar _, Tvar _ -> true - | Tvariant row1, Tvariant row2 -> - let row1 = row_repr row1 and row2 = row_repr row2 in - let fields1 = filter_row_fields false row1.row_fields - and fields2 = filter_row_fields false row1.row_fields - in - let r1, r2, pairs = merge_row_fields fields1 fields2 in - row1.row_closed = row2.row_closed && r1 = [] && r2 = [] && - List.for_all pairs ~f: - begin fun (_,f1,f2) -> - match row_field_repr f1, row_field_repr f2 with - Rpresent None, Rpresent None -> true - | Rpresent(Some t1), Rpresent (Some t2) -> equal t1 t2 ~prefix - | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) -> - c1 = c2 && List.length tl1 = List.length tl2 && - List.for_all2 tl1 tl2 ~f:(equal ~prefix) - | _ -> false - end - | Tarrow _, Tarrow _ -> - let l1, t1 = all_args t1 and l2, t2 = all_args t2 in - equal t1 t2 ~prefix && - List.length l1 = List.length l2 && - List.exists (permutations l1) ~f: - begin fun l1 -> - List.for_all2 l1 l2 ~f: - begin fun (p1,t1) (p2,t2) -> - (p1 = "" || p1 = p2) && equal t1 t2 ~prefix - end - end - | Ttuple l1, Ttuple l2 -> - List.length l1 = List.length l2 && - List.for_all2 l1 l2 ~f:(equal ~prefix) - | Tconstr (p1, l1, _), Tconstr (p2, l2, _) -> - remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2) - && List.length l1 = List.length l2 - && List.for_all2 l1 l2 ~f:(equal ~prefix) - | _ -> false - -let is_opt s = s <> "" && s.[0] = '?' -let get_options = List.filter ~f:is_opt - -let rec included ~prefix t1 t2 = - match (repr t1).desc, (repr t2).desc with - Tvar _, _ -> true - | Tvariant row1, Tvariant row2 -> - let row1 = row_repr row1 and row2 = row_repr row2 in - let fields1 = filter_row_fields false row1.row_fields - and fields2 = filter_row_fields false row2.row_fields - in - let r1, r2, pairs = merge_row_fields fields1 fields2 in - r1 = [] && - List.for_all pairs ~f: - begin fun (_,f1,f2) -> - match row_field_repr f1, row_field_repr f2 with - Rpresent None, Rpresent None -> true - | Rpresent(Some t1), Rpresent (Some t2) -> included t1 t2 ~prefix - | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) -> - c1 = c2 && List.length tl1 = List.length tl2 && - List.for_all2 tl1 tl2 ~f:(included ~prefix) - | _ -> false - end - | Tarrow _, Tarrow _ -> - let l1, t1 = all_args t1 and l2, t2 = all_args t2 in - included t1 t2 ~prefix && - let len1 = List.length l1 and len2 = List.length l2 in - let l2 = if arr len1 ~card:len2 < 100 then l2 else - let ll1 = get_options (fst (List.split l1)) in - List.filter l2 - ~f:(fun (l,_) -> not (is_opt l) || List.mem l ll1) - in - len1 <= len2 && - List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f: - begin fun l2 -> - List.for_all2 l1 l2 ~f: - begin fun (p1,t1) (p2,t2) -> - (p1 = "" || p1 = p2) && included t1 t2 ~prefix - end - end - | Ttuple l1, Ttuple l2 -> - let len1 = List.length l1 in - len1 <= List.length l2 && - List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f: - begin fun l2 -> - List.for_all2 l1 l2 ~f:(included ~prefix) - end - | _, Ttuple _ -> included (newty (Ttuple [t1])) t2 ~prefix - | Tconstr (p1, l1, _), Tconstr (p2, l2, _) -> - remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2) - && List.length l1 = List.length l2 - && List.for_all2 l1 l2 ~f:(included ~prefix) - | _ -> false - -let mklid = function - [] -> raise (Invalid_argument "Searchid.mklid") - | x :: l -> - List.fold_left l ~init:(Lident x) ~f:(fun acc x -> Ldot (acc, x)) - -let mkpath = function - [] -> raise (Invalid_argument "Searchid.mklid") - | x :: l -> - List.fold_left l ~init:(Pident (Ident.create x)) - ~f:(fun acc x -> Pdot (acc, x, 0)) - -let get_fields ~prefix ~sign self = - let env = open_signature (mkpath prefix) sign initial in - match (expand_head env self).desc with - Tobject (ty_obj, _) -> - let l,_ = flatten_fields ty_obj in l - | _ -> [] - -let rec search_type_in_signature t ~sign ~prefix ~mode = - let matches = match mode with - `Included -> included t ~prefix - | `Exact -> equal t ~prefix - and lid_of_id id = mklid (prefix @ [Ident.name id]) in - List2.flat_map sign ~f: - begin fun item -> match item with - Tsig_value (id, vd) -> - if matches vd.val_type then [lid_of_id id, Pvalue] else [] - | Tsig_type (id, td, _) -> - if - matches (newconstr (Pident id) td.type_params) || - begin match td.type_manifest with - None -> false - | Some t -> matches t - end || - begin match td.type_kind with - Type_abstract -> false - | Type_variant(l, priv) -> - List.exists l ~f: - begin fun (_, l, r) -> - List.exists l ~f:matches || - match r with None -> false | Some x -> matches x - end - | Type_record(l, rep, priv) -> - List.exists l ~f:(fun (_, _, t) -> matches t) - end - then [lid_of_id id, Ptype] else [] - | Tsig_exception (id, l) -> - if List.exists l.exn_args ~f:matches - then [lid_of_id id, Pconstructor] - else [] - | Tsig_module (id, Tmty_signature sign, _) -> - search_type_in_signature t ~sign ~mode - ~prefix:(prefix @ [Ident.name id]) - | Tsig_module _ -> [] - | Tsig_modtype _ -> [] - | Tsig_class (id, cl, _) -> - let self = self_type cl.cty_type in - if matches self - || (match cl.cty_new with None -> false | Some ty -> matches ty) - (* || List.exists (get_fields ~prefix ~sign self) - ~f:(fun (_,_,ty_field) -> matches ty_field) *) - then [lid_of_id id, Pclass] else [] - | Tsig_cltype (id, cl, _) -> - let self = self_type cl.clty_type in - if matches self - (* || List.exists (get_fields ~prefix ~sign self) - ~f:(fun (_,_,ty_field) -> matches ty_field) *) - then [lid_of_id id, Pclass] else [] - end - -let search_all_types t ~mode = - let tl = match mode, t.desc with - `Exact, _ -> [t] - | `Included, Tarrow _ -> [t] - | `Included, _ -> - [t; newty(Tarrow("",t,newvar(),Cok)); newty(Tarrow("",newvar(),t,Cok))] - in List2.flat_map !module_list ~f: - begin fun modname -> - let mlid = Lident modname in - try match lookup_module mlid initial with - _, Tmty_signature sign -> - List2.flat_map tl - ~f:(search_type_in_signature ~sign ~prefix:[modname] ~mode) - | _ -> [] - with Not_found | Env.Error _ -> [] - end - -exception Error of int * int - -let search_string_type text ~mode = - try - let sexp = Parse.interface (Lexing.from_string ("val z : " ^ text)) in - let sign = - try Typemod.transl_signature !start_env sexp with _ -> - let env = List.fold_left !module_list ~init:initial ~f: - begin fun acc m -> - try open_pers_signature m acc with Env.Error _ -> acc - end in - try Typemod.transl_signature env sexp - with Env.Error err -> [] - | Typemod.Error (l,_) -> - let start_c = l.loc_start.Lexing.pos_cnum in - let end_c = l.loc_end.Lexing.pos_cnum in - raise (Error (start_c - 8, end_c - 8)) - | Typetexp.Error (l,_) -> - let start_c = l.loc_start.Lexing.pos_cnum in - let end_c = l.loc_end.Lexing.pos_cnum in - raise (Error (start_c - 8, end_c - 8)) - in match sign with - [Tsig_value (_, vd)] -> - search_all_types vd.val_type ~mode - | _ -> [] - with - Syntaxerr.Error(Syntaxerr.Unclosed(l,_,_,_)) -> - let start_c = l.loc_start.Lexing.pos_cnum in - let end_c = l.loc_end.Lexing.pos_cnum in - raise (Error (start_c - 8, end_c - 8)) - | Syntaxerr.Error(Syntaxerr.Other l) -> - let start_c = l.loc_start.Lexing.pos_cnum in - let end_c = l.loc_end.Lexing.pos_cnum in - raise (Error (start_c - 8, end_c - 8)) - | Lexer.Error (_, l) -> - let start_c = l.loc_start.Lexing.pos_cnum in - let end_c = l.loc_end.Lexing.pos_cnum in - raise (Error (start_c - 8, end_c - 8)) - -let longident_of_string text = - let exploded = ref [] and l = ref 0 in - for i = 0 to String.length text - 2 do - if text.[i] ='.' then - (exploded := String.sub text ~pos:!l ~len:(i - !l) :: !exploded; l := i+1) - done; - let sym = String.sub text ~pos:!l ~len:(String.length text - !l) in - let rec mklid = function - [s] -> Lident s - | s :: l -> Ldot (mklid l, s) - | [] -> assert false in - sym, fun l -> mklid (sym :: !exploded @ l) - - -let explode s = - let l = ref [] in - for i = String.length s - 1 downto 0 do - l := s.[i] :: !l - done; !l - -let rec check_match ~pattern s = - match pattern, s with - [], [] -> true - | '*'::l, l' -> check_match ~pattern:l l' - || check_match ~pattern:('?'::'*'::l) l' - | '?'::l, _::l' -> check_match ~pattern:l l' - | x::l, y::l' when x == y -> check_match ~pattern:l l' - | _ -> false - -let search_pattern_symbol text = - if text = "" then [] else - let pattern = explode text in - let check i = check_match ~pattern (explode (Ident.name i)) in - let l = List.map !module_list ~f: - begin fun modname -> Lident modname, - try match lookup_module (Lident modname) initial with - _, Tmty_signature sign -> - List2.flat_map sign ~f: - begin function - Tsig_value (i, _) when check i -> [i, Pvalue] - | Tsig_type (i, _, _) when check i -> [i, Ptype] - | Tsig_exception (i, _) when check i -> [i, Pconstructor] - | Tsig_module (i, _, _) when check i -> [i, Pmodule] - | Tsig_modtype (i, _) when check i -> [i, Pmodtype] - | Tsig_class (i, cl, _) when check i - || List.exists - (get_fields ~prefix:[modname] ~sign (self_type cl.cty_type)) - ~f:(fun (name,_,_) -> check_match ~pattern (explode name)) - -> [i, Pclass] - | Tsig_cltype (i, cl, _) when check i - || List.exists - (get_fields ~prefix:[modname] ~sign (self_type cl.clty_type)) - ~f:(fun (name,_,_) -> check_match ~pattern (explode name)) - -> [i, Pcltype] - | _ -> [] - end - | _ -> [] - with Env.Error _ -> [] - end - in - List2.flat_map l ~f: - begin fun (m, l) -> - List.map l ~f:(fun (i, p) -> Ldot (m, Ident.name i), p) - end - -(* -let is_pattern s = - try for i = 0 to String.length s -1 do - if s.[i] = '?' || s.[i] = '*' then raise Exit - done; false - with Exit -> true -*) - -let search_string_symbol text = - if text = "" then [] else - let lid = snd (longident_of_string text) [] in - let try_lookup f k = - try let _ = f lid Env.initial in [lid, k] - with Not_found | Env.Error _ -> [] - in - try_lookup lookup_constructor Pconstructor @ - try_lookup lookup_module Pmodule @ - try_lookup lookup_modtype Pmodtype @ - try_lookup lookup_value Pvalue @ - try_lookup lookup_type Ptype @ - try_lookup lookup_label Plabel @ - try_lookup lookup_class Pclass - -open Parsetree - -let rec bound_variables pat = - match pat.ppat_desc with - Ppat_any | Ppat_constant _ | Ppat_type _ | Ppat_unpack _ -> [] - | Ppat_var s -> [s] - | Ppat_alias (pat,s) -> s :: bound_variables pat - | Ppat_tuple l -> List2.flat_map l ~f:bound_variables - | Ppat_construct (_,None,_) -> [] - | Ppat_construct (_,Some pat,_) -> bound_variables pat - | Ppat_variant (_,None) -> [] - | Ppat_variant (_,Some pat) -> bound_variables pat - | Ppat_record (l, _) -> - List2.flat_map l ~f:(fun (_,pat) -> bound_variables pat) - | Ppat_array l -> - List2.flat_map l ~f:bound_variables - | Ppat_or (pat1,pat2) -> - bound_variables pat1 @ bound_variables pat2 - | Ppat_constraint (pat,_) -> bound_variables pat - -let search_structure str ~name ~kind ~prefix = - let loc = ref 0 in - let rec search_module str ~prefix = - match prefix with [] -> str - | modu::prefix -> - let str = - List.fold_left ~init:[] str ~f: - begin fun acc item -> - match item.pstr_desc with - Pstr_module (s, mexp) when s = modu -> - loc := mexp.pmod_loc.loc_start.Lexing.pos_cnum; - begin match mexp.pmod_desc with - Pmod_structure str -> str - | _ -> [] - end - | _ -> acc - end - in search_module str ~prefix - in - List.iter (search_module str ~prefix) ~f: - begin fun item -> - if match item.pstr_desc with - Pstr_value (_, l) when kind = Pvalue -> - List.iter l ~f: - begin fun (pat,_) -> - if List.mem name (bound_variables pat) - then loc := pat.ppat_loc.loc_start.Lexing.pos_cnum - end; - false - | Pstr_primitive (s, _) when kind = Pvalue -> name = s - | Pstr_type l when kind = Ptype -> - List.iter l ~f: - begin fun (s, td) -> - if s = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum - end; - false - | Pstr_exception (s, _) when kind = Pconstructor -> name = s - | Pstr_module (s, _) when kind = Pmodule -> name = s - | Pstr_modtype (s, _) when kind = Pmodtype -> name = s - | Pstr_class l when kind = Pclass || kind = Ptype || kind = Pcltype -> - List.iter l ~f: - begin fun c -> - if c.pci_name = name - then loc := c.pci_loc.loc_start.Lexing.pos_cnum - end; - false - | Pstr_class_type l when kind = Pcltype || kind = Ptype -> - List.iter l ~f: - begin fun c -> - if c.pci_name = name - then loc := c.pci_loc.loc_start.Lexing.pos_cnum - end; - false - | _ -> false - then loc := item.pstr_loc.loc_start.Lexing.pos_cnum - end; - !loc - -let search_signature sign ~name ~kind ~prefix = - let loc = ref 0 in - let rec search_module_type sign ~prefix = - match prefix with [] -> sign - | modu::prefix -> - let sign = - List.fold_left ~init:[] sign ~f: - begin fun acc item -> - match item.psig_desc with - Psig_module (s, mtyp) when s = modu -> - loc := mtyp.pmty_loc.loc_start.Lexing.pos_cnum; - begin match mtyp.pmty_desc with - Pmty_signature sign -> sign - | _ -> [] - end - | _ -> acc - end - in search_module_type sign ~prefix - in - List.iter (search_module_type sign ~prefix) ~f: - begin fun item -> - if match item.psig_desc with - Psig_value (s, _) when kind = Pvalue -> name = s - | Psig_type l when kind = Ptype -> - List.iter l ~f: - begin fun (s, td) -> - if s = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum - end; - false - | Psig_exception (s, _) when kind = Pconstructor -> name = s - | Psig_module (s, _) when kind = Pmodule -> name = s - | Psig_modtype (s, _) when kind = Pmodtype -> name = s - | Psig_class l when kind = Pclass || kind = Ptype || kind = Pcltype -> - List.iter l ~f: - begin fun c -> - if c.pci_name = name - then loc := c.pci_loc.loc_start.Lexing.pos_cnum - end; - false - | Psig_class_type l when kind = Ptype || kind = Pcltype -> - List.iter l ~f: - begin fun c -> - if c.pci_name = name - then loc := c.pci_loc.loc_start.Lexing.pos_cnum - end; - false - | _ -> false - then loc := item.psig_loc.loc_start.Lexing.pos_cnum - end; - !loc diff --git a/otherlibs/labltk/browser/searchid.mli b/otherlibs/labltk/browser/searchid.mli deleted file mode 100644 index 9e0c8ad98981..000000000000 --- a/otherlibs/labltk/browser/searchid.mli +++ /dev/null @@ -1,45 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -val start_env : Env.t ref -val module_list : string list ref -val longident_of_path : Path.t ->Longident.t - -type pkind = - Pvalue - | Ptype - | Plabel - | Pconstructor - | Pmodule - | Pmodtype - | Pclass - | Pcltype - -val string_of_kind : pkind -> string - -exception Error of int * int - -val search_string_type : - string -> mode:[`Exact|`Included] -> (Longident.t * pkind) list -val search_pattern_symbol : string -> (Longident.t * pkind) list -val search_string_symbol : string -> (Longident.t * pkind) list - -val search_structure : - Parsetree.structure -> - name:string -> kind:pkind -> prefix:string list -> int -val search_signature : - Parsetree.signature -> - name:string -> kind:pkind -> prefix:string list -> int diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml deleted file mode 100644 index 6fe46ae4f71a..000000000000 --- a/otherlibs/labltk/browser/searchpos.ml +++ /dev/null @@ -1,890 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Support -open Tk -open Jg_tk -open Parsetree -open Types -open Typedtree -open Location -open Longident -open Path -open Env -open Searchid - -(* auxiliary functions *) - -let (~!) = Jg_memo.fast ~f:Str.regexp - -let lines_to_chars n ~text:s = - let l = String.length s in - let rec ltc n ~pos = - if n = 1 || pos >= l then pos else - if s.[pos] = '\n' then ltc (n-1) ~pos:(pos+1) else ltc n ~pos:(pos+1) - in ltc n ~pos:0 - -let in_loc loc ~pos = - loc.loc_ghost || pos >= loc.loc_start.Lexing.pos_cnum - && pos < loc.loc_end.Lexing.pos_cnum - -let le_loc loc1 loc2 = - loc1.loc_start.Lexing.pos_cnum <= loc2.loc_start.Lexing.pos_cnum - && loc1.loc_end.Lexing.pos_cnum >= loc2.loc_end.Lexing.pos_cnum - -let add_found ~found sol ~env ~loc = - if loc.loc_ghost then () else - if List.exists !found ~f:(fun (_,_,loc') -> le_loc loc loc') then () - else found := (sol, env, loc) :: - List.filter !found ~f:(fun (_,_,loc') -> not (le_loc loc' loc)) - -let observe ~ref ?init f x = - let old = !ref in - begin match init with None -> () | Some x -> ref := x end; - try (f x : unit); let v = !ref in ref := old; v - with exn -> ref := old; raise exn - -let rec string_of_longident = function - Lident s -> s - | Ldot (id,s) -> string_of_longident id ^ "." ^ s - | Lapply (id1, id2) -> - string_of_longident id1 ^ "(" ^ string_of_longident id2 ^ ")" - -let string_of_path p = string_of_longident (Searchid.longident_of_path p) - -let parent_path = function - Pdot (path, _, _) -> Some path - | Pident _ | Papply _ -> None - -let ident_of_path ~default = function - Pident i -> i - | Pdot (_, s, _) -> Ident.create s - | Papply _ -> Ident.create default - -let rec head_id = function - Pident id -> id - | Pdot (path,_,_) -> head_id path - | Papply (path,_) -> head_id path (* wrong, but ... *) - -let rec list_of_path = function - Pident id -> [Ident.name id] - | Pdot (path, s, _) -> list_of_path path @ [s] - | Papply (path, _) -> list_of_path path (* wrong, but ... *) - -(* a simple wrapper *) - -class buffer ~size = object - val buffer = Buffer.create size - method out buf = Buffer.add_substring buffer buf - method get = Buffer.contents buffer -end - -(* Search in a signature *) - -type skind = [`Type|`Class|`Module|`Modtype] - -let found_sig = ref ([] : ((skind * Longident.t) * Env.t * Location.t) list) -let add_found_sig = add_found ~found:found_sig - -let rec search_pos_type t ~pos ~env = - if in_loc ~pos t.ptyp_loc then - begin match t.ptyp_desc with - Ptyp_any - | Ptyp_var _ -> () - | Ptyp_variant(tl, _, _) -> - List.iter tl ~f: - begin function - Rtag (_,_,tl) -> List.iter tl ~f:(search_pos_type ~pos ~env) - | Rinherit st -> search_pos_type ~pos ~env st - end - | Ptyp_arrow (_, t1, t2) -> - search_pos_type t1 ~pos ~env; - search_pos_type t2 ~pos ~env - | Ptyp_tuple tl -> - List.iter tl ~f:(search_pos_type ~pos ~env) - | Ptyp_constr (lid, tl) -> - List.iter tl ~f:(search_pos_type ~pos ~env); - add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc - | Ptyp_object fl -> - List.iter fl ~f: - begin function - | {pfield_desc = Pfield (_, ty)} -> search_pos_type ty ~pos ~env - | _ -> () - end - | Ptyp_class (lid, tl, _) -> - List.iter tl ~f:(search_pos_type ~pos ~env); - add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc - | Ptyp_alias (t, _) - | Ptyp_poly (_, t) -> search_pos_type ~pos ~env t - | Ptyp_package (_, stl) -> - List.iter stl ~f:(fun (_, ty) -> search_pos_type ty ~pos ~env) - end - -let rec search_pos_class_type cl ~pos ~env = - if in_loc cl.pcty_loc ~pos then - begin match cl.pcty_desc with - Pcty_constr (lid, _) -> - add_found_sig (`Class, lid) ~env ~loc:cl.pcty_loc - | Pcty_signature (_, cfl) -> - List.iter cfl ~f: - begin function - Pctf_inher cty -> search_pos_class_type cty ~pos ~env - | Pctf_val (_, _, Some ty, loc) -> - if in_loc loc ~pos then search_pos_type ty ~pos ~env - | Pctf_val _ -> () - | Pctf_virt (_, _, ty, loc) -> - if in_loc loc ~pos then search_pos_type ty ~pos ~env - | Pctf_meth (_, _, ty, loc) -> - if in_loc loc ~pos then search_pos_type ty ~pos ~env - | Pctf_cstr (ty1, ty2, loc) -> - if in_loc loc ~pos then begin - search_pos_type ty1 ~pos ~env; - search_pos_type ty2 ~pos ~env - end - end - | Pcty_fun (_, ty, cty) -> - search_pos_type ty ~pos ~env; - search_pos_class_type cty ~pos ~env - end - -let search_pos_type_decl td ~pos ~env = - if in_loc ~pos td.ptype_loc then begin - begin match td.ptype_manifest with - Some t -> search_pos_type t ~pos ~env - | None -> () - end; - let rec search_tkind = function - Ptype_abstract | Ptype_private -> () - | Ptype_variant (dl, _) -> - List.iter dl - ~f:(fun (_, tl, _, _) -> List.iter tl ~f:(search_pos_type ~pos ~env)) - | Ptype_record (dl, _) -> - List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in - search_tkind td.ptype_kind; - List.iter td.ptype_cstrs ~f: - begin fun (t1, t2, _) -> - search_pos_type t1 ~pos ~env; - search_pos_type t2 ~pos ~env - end - end - -let rec search_pos_signature l ~pos ~env = - ignore ( - List.fold_left l ~init:env ~f: - begin fun env pt -> - let env = match pt.psig_desc with - Psig_open id -> - let path, mt = lookup_module id env in - begin match mt with - Tmty_signature sign -> open_signature path sign env - | _ -> env - end - | sign_item -> - try add_signature (Typemod.transl_signature env [pt]) env - with Typemod.Error _ | Typeclass.Error _ - | Typetexp.Error _ | Typedecl.Error _ -> env - in - if in_loc ~pos pt.psig_loc then - begin match pt.psig_desc with - Psig_value (_, desc) -> search_pos_type desc.pval_type ~pos ~env - | Psig_type l -> - List.iter l ~f:(fun (_,desc) -> search_pos_type_decl ~pos desc ~env) - | Psig_exception (_, l) -> - List.iter l ~f:(search_pos_type ~pos ~env); - add_found_sig (`Type, Lident "exn") ~env ~loc:pt.psig_loc - | Psig_module (_, t) -> - search_pos_module t ~pos ~env - | Psig_recmodule decls -> - List.iter decls ~f:(fun (_, 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 - ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env) - | Psig_class_type l -> - List.iter l - ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env) - (* The last cases should not happen in generated interfaces *) - | Psig_open lid -> add_found_sig (`Module, lid) ~env ~loc:pt.psig_loc - | Psig_include t -> search_pos_module t ~pos ~env - end; - env - end) - -and search_pos_module m ~pos ~env = - if in_loc m.pmty_loc ~pos then begin - begin match m.pmty_desc with - Pmty_ident lid -> add_found_sig (`Modtype, lid) ~env ~loc:m.pmty_loc - | Pmty_signature sg -> search_pos_signature sg ~pos ~env - | Pmty_functor (_ , m1, m2) -> - search_pos_module m1 ~pos ~env; - search_pos_module m2 ~pos ~env - | Pmty_with (m, l) -> - search_pos_module m ~pos ~env; - List.iter l ~f: - begin function - _, Pwith_type t -> search_pos_type_decl t ~pos ~env - | _ -> () - end - | Pmty_typeof md -> - () (* TODO? *) - end - end - -let search_pos_signature l ~pos ~env = - observe ~ref:found_sig (search_pos_signature ~pos ~env) l - -(* the module display machinery *) - -type module_widgets = - { mw_frame: Widget.frame Widget.widget; - mw_title: Widget.label Widget.widget option; - mw_detach: Widget.button Widget.widget; - mw_edit: Widget.button Widget.widget; - mw_intf: Widget.button Widget.widget } - -let shown_modules = Hashtbl.create 17 -let default_frame = ref None -let set_path = ref (fun _ ~sign -> assert false) -let filter_modules () = - Hashtbl.iter - (fun key data -> - if not (Winfo.exists data.mw_frame) then - Hashtbl.remove shown_modules key) - shown_modules -let add_shown_module path ~widgets = - Hashtbl.add shown_modules path widgets -let find_shown_module path = - try - filter_modules (); - Hashtbl.find shown_modules path - with Not_found -> - match !default_frame with - None -> raise Not_found - | Some mw -> mw - -let is_shown_module path = - !default_frame <> None || - (filter_modules (); Hashtbl.mem shown_modules path) - -(* Viewing a signature *) - -(* Forward definitions of Viewer.view_defined and Editor.editor *) -let view_defined_ref = ref (fun lid ~env -> ()) -let editor_ref = ref (fun ?file ?pos ?opendialog () -> ()) - -let edit_source ~file ~path ~sign = - match sign with - [item] -> - let id, kind = - match item with - Tsig_value (id, _) -> id, Pvalue - | Tsig_type (id, _, _) -> id, Ptype - | Tsig_exception (id, _) -> id, Pconstructor - | Tsig_module (id, _, _) -> id, Pmodule - | Tsig_modtype (id, _) -> id, Pmodtype - | Tsig_class (id, _, _) -> id, Pclass - | Tsig_cltype (id, _, _) -> id, Pcltype - in - let prefix = List.tl (list_of_path path) and name = Ident.name id in - let pos = - try - let chan = open_in file in - if Filename.check_suffix file ".ml" then - let parsed = Parse.implementation (Lexing.from_channel chan) in - close_in chan; - Searchid.search_structure parsed ~name ~kind ~prefix - else - let parsed = Parse.interface (Lexing.from_channel chan) in - close_in chan; - Searchid.search_signature parsed ~name ~kind ~prefix - with _ -> 0 - in !editor_ref ~file ~pos () - | _ -> !editor_ref ~file () - -(* List of windows to destroy by Close All *) -let top_widgets = ref [] - -let dummy_item = Tsig_modtype (Ident.create "dummy", Tmodtype_abstract) - -let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign = - let env = - match path with None -> env - | Some path -> Env.open_signature path sign env in - let title = - match title, path with Some title, _ -> title - | None, Some path -> string_of_path path - | None, None -> "Signature" - in - let tl, tw, finish = - try match path, !default_frame with - None, Some ({mw_title=Some label} as mw) when not detach -> - Button.configure mw.mw_detach - ~command:(fun () -> view_signature sign ~title ~env ~detach:true); - pack [mw.mw_detach] ~side:`Left; - Pack.forget [mw.mw_edit; mw.mw_intf]; - List.iter ~f:destroy (Winfo.children mw.mw_frame); - Label.configure label ~text:title; - pack [label] ~fill:`X ~side:`Bottom; - Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 () - | None, _ -> raise Not_found - | Some path, _ -> - let mw = - try find_shown_module path - with Not_found -> - view_module path ~env; - find_shown_module path - in - (try !set_path path ~sign with _ -> ()); - begin match mw.mw_title with None -> () - | Some label -> - Label.configure label ~text:title; - pack [label] ~fill:`X ~side:`Bottom - end; - Button.configure mw.mw_detach - ~command:(fun () -> view_signature sign ~title ~env ~detach:true); - pack [mw.mw_detach] ~side:`Left; - let repack = ref false in - List.iter2 [mw.mw_edit; mw.mw_intf] [".ml"; ".mli"] ~f: - begin fun button ext -> - try - let id = head_id path in - let file = - Misc.find_in_path_uncap !Config.load_path - ((Ident.name id) ^ ext) in - Button.configure button - ~command:(fun () -> edit_source ~file ~path ~sign); - if !repack then Pack.forget [button] else - if not (Winfo.viewable button) then repack := true; - pack [button] ~side:`Left - with Not_found -> - Pack.forget [button] - end; - let top = Winfo.toplevel mw.mw_frame in - if not (Winfo.ismapped top) then Wm.deiconify top; - List.iter ~f:destroy (Winfo.children mw.mw_frame); - Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 () - with Not_found -> - let tl, tw, finish = Jg_message.formatted ~title ~maxheight:15 () in - top_widgets := tl :: !top_widgets; - tl, tw, finish - in - Format.set_max_boxes 100; - Printtyp.signature Format.std_formatter sign; - finish (); - Lexical.init_tags tw; - Lexical.tag tw; - Text.configure tw ~state:`Disabled; - let text = Jg_text.get_all tw in - let pt = - try Parse.interface (Lexing.from_string text) - with Syntaxerr.Error e -> - let l = - match e with - Syntaxerr.Unclosed(l,_,_,_) -> l - | Syntaxerr.Applicative_path l -> l - | Syntaxerr.Other l -> l - in - Jg_text.tag_and_see tw ~start:(tpos l.loc_start.Lexing.pos_cnum) - ~stop:(tpos l.loc_end.Lexing.pos_cnum) ~tag:"error"; [] - | Lexer.Error (_, l) -> - let s = l.loc_start.Lexing.pos_cnum in - let e = l.loc_end.Lexing.pos_cnum in - Jg_text.tag_and_see tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error"; [] - in - Jg_bind.enter_focus tw; - bind tw ~events:[`Modified([`Control], `KeyPressDetail"s")] - ~action:(fun _ -> Jg_text.search_string tw); - bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~fields:[`MouseX;`MouseY] ~breakable:true - ~action:(fun ev -> - let `Linechar (l, c) = - Text.index tw ~index:(`Atxy(ev.ev_MouseX,ev.ev_MouseY), []) in - try - match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env - with [] -> break () - | ((kind, lid), env, loc) :: _ -> view_decl lid ~kind ~env - with Not_found | Env.Error _ -> ()); - bind tw ~events:[`ButtonPressDetail 3] ~breakable:true - ~fields:[`MouseX;`MouseY] - ~action:(fun ev -> - let x = ev.ev_MouseX and y = ev.ev_MouseY in - let `Linechar (l, c) = - Text.index tw ~index:(`Atxy(x,y), []) in - try - match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env - with [] -> break () - | ((kind, lid), env, loc) :: _ -> - let menu = view_decl_menu lid ~kind ~env ~parent:tw in - let x = x + Winfo.rootx tw and y = y + Winfo.rooty tw - 10 in - Menu.popup menu ~x ~y - with Not_found -> ()) - -and view_signature_item sign ~path ~env = - view_signature sign ~title:(string_of_path path) - ?path:(parent_path path) ~env - -and view_module path ~env = - match find_module path env with - Tmty_signature sign -> - !view_defined_ref (Searchid.longident_of_path path) ~env - | modtype -> - let id = ident_of_path path ~default:"M" in - view_signature_item [Tsig_module (id, modtype, Trec_not)] ~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, Trec_first); - dummy_item; dummy_item] - | _ -> raise Not_found - with Not_found -> - view_signature_item ~path ~env - [Tsig_type(ident_of_path path ~default:"t", td, Trec_first)] - -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, Trec_first); - dummy_item; dummy_item; dummy_item] - -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, Trec_first); - dummy_item; dummy_item] - -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; - val_loc = Location.none})] - -and view_decl lid ~kind ~env = - match kind with - `Type -> view_type_id lid ~env - | `Class -> view_class_id lid ~env - | `Module -> view_module_id lid ~env - | `Modtype -> view_modtype_id lid ~env - -and view_decl_menu lid ~kind ~env ~parent = - let path, kname = - try match kind with - `Type -> fst (lookup_type lid env), "Type" - | `Class -> fst (lookup_class lid env), "Class" - | `Module -> fst (lookup_module lid env), "Module" - | `Modtype -> fst (lookup_modtype lid env), "Module type" - with Env.Error _ -> raise Not_found - in - let menu = Menu.create parent ~tearoff:false in - let label = kname ^ " " ^ string_of_path path in - begin match path with - Pident _ -> - Menu.add_command menu ~label ~state:`Disabled - | _ -> - Menu.add_command menu ~label - ~command:(fun () -> view_decl lid ~kind ~env); - end; - if kind = `Type || kind = `Modtype then begin - let buf = new buffer ~size:60 in - let (fo,ff) = Format.get_formatter_output_functions () - and margin = Format.get_margin () in - Format.set_formatter_output_functions buf#out (fun () -> ()); - Format.set_margin 60; - Format.open_hbox (); - if kind = `Type then - Printtyp.type_declaration - (ident_of_path path ~default:"t") - Format.std_formatter - (find_type path env) - else - Printtyp.modtype_declaration - (ident_of_path path ~default:"S") - Format.std_formatter - (find_modtype path env); - Format.close_box (); Format.print_flush (); - Format.set_formatter_output_functions fo ff; - Format.set_margin margin; - let l = Str.split ~!"\n" buf#get in - let font = - let font = - Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in - if font = "" then "7x14" else font - in - (* Menu.add_separator menu; *) - List.iter l - ~f:(fun label -> Menu.add_command menu ~label ~font ~state:`Disabled) - end; - menu - -(* search and view in a structure *) - -type fkind = [ - `Exp of - [`Expr|`Pat|`Const|`Val of Path.t|`Var of Path.t|`New of Path.t] - * Types.type_expr - | `Class of Path.t * Types.class_type - | `Module of Path.t * Types.module_type -] - -let view_type kind ~env = - match kind with - `Exp (k, ty) -> - begin match k with - `Expr -> view_expr_type ty ~title:"Expression type" ~env - | `Pat -> view_expr_type ty ~title:"Pattern type" ~env - | `Const -> view_expr_type ty ~title:"Constant type" ~env - | `Val path -> - begin try - let vd = find_value path env in - view_signature_item ~path ~env - [Tsig_value(ident_of_path path ~default:"v", vd)] - with Not_found -> - view_expr_type ty ~path ~env - end - | `Var path -> - let vd = find_value path env in - view_expr_type vd.val_type ~env ~path ~title:"Variable type" - | `New path -> - let cl = find_class path env in - view_signature_item ~path ~env - [Tsig_class(ident_of_path path ~default:"c", cl, Trec_first)] - end - | `Class (path, cty) -> - let cld = { cty_params = []; cty_variance = []; cty_type = cty; - cty_path = path; cty_new = None } in - view_signature_item ~path ~env - [Tsig_class(ident_of_path path ~default:"c", cld, Trec_first)] - | `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, Trec_not)] - -let view_type_menu kind ~env ~parent = - let title = - match kind with - `Exp (`Expr,_) -> "Expression :" - | `Exp (`Pat, _) -> "Pattern :" - | `Exp (`Const, _) -> "Constant :" - | `Exp (`Val path, _) -> "Value " ^ string_of_path path ^ " :" - | `Exp (`Var path, _) -> - "Variable " ^ Ident.name (ident_of_path path ~default:"noname") ^ " :" - | `Exp (`New path, _) -> "Class " ^ string_of_path path ^ " :" - | `Class (path, _) -> "Class " ^ string_of_path path ^ " :" - | `Module (path,_) -> "Module " ^ string_of_path path in - let menu = Menu.create parent ~tearoff:false in - begin match kind with - `Exp((`Expr | `Pat | `Const | `Val (Pident _)),_) -> - Menu.add_command menu ~label:title ~state:`Disabled - | `Exp _ | `Class _ | `Module _ -> - Menu.add_command menu ~label:title - ~command:(fun () -> view_type kind ~env) - end; - begin match kind with `Module _ | `Class _ -> () - | `Exp(_, ty) -> - let buf = new buffer ~size:60 in - let (fo,ff) = Format.get_formatter_output_functions () - and margin = Format.get_margin () in - Format.set_formatter_output_functions buf#out ignore; - Format.set_margin 60; - Format.open_hbox (); - Printtyp.reset (); - Printtyp.mark_loops ty; - Printtyp.type_expr Format.std_formatter ty; - Format.close_box (); Format.print_flush (); - Format.set_formatter_output_functions fo ff; - Format.set_margin margin; - let l = Str.split ~!"\n" buf#get in - let font = - let font = - Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in - if font = "" then "7x14" else font - in - (* Menu.add_separator menu; *) - List.iter l ~f: - begin fun label -> match (Ctype.repr ty).desc with - Tconstr (path,_,_) -> - Menu.add_command menu ~label ~font - ~command:(fun () -> view_type_decl path ~env) - | Tvariant {row_name = Some (path, _)} -> - Menu.add_command menu ~label ~font - ~command:(fun () -> view_type_decl path ~env) - | _ -> - Menu.add_command menu ~label ~font ~state:`Disabled - end - end; - menu - -let found_str = ref ([] : (fkind * Env.t * Location.t) list) -let add_found_str = add_found ~found:found_str - -let rec search_pos_structure ~pos str = - List.iter str ~f: - begin function - Tstr_eval exp -> search_pos_expr exp ~pos - | Tstr_value (rec_flag, l) -> - List.iter l ~f: - begin fun (pat, exp) -> - let env = - if rec_flag = Asttypes.Recursive then exp.exp_env else Env.empty in - search_pos_pat pat ~pos ~env; - search_pos_expr exp ~pos - end - | Tstr_primitive (_, vd) ->() - | Tstr_type _ -> () - | Tstr_exception _ -> () - | Tstr_exn_rebind(_, _) -> () - | Tstr_module (_, m) -> search_pos_module_expr m ~pos - | Tstr_recmodule bindings -> - List.iter bindings ~f:(fun (_, m) -> search_pos_module_expr m ~pos) - | Tstr_modtype _ -> () - | Tstr_open _ -> () - | Tstr_class l -> - List.iter l ~f:(fun (id, _, _, cl) -> search_pos_class_expr cl ~pos) - | Tstr_cltype _ -> () - | Tstr_include (m, _) -> search_pos_module_expr m ~pos -(*>JOCAML*) - | Tstr_exn_global (_, _) -> () - |Tstr_loc _|Tstr_def _ -> assert false -(* - search_pos_class_expr cl ~pos - | Cf_val (_, _, exp) -> search_pos_expr exp ~pos - | Cf_meth (_, exp) -> search_pos_expr exp ~pos - | Cf_init exp -> search_pos_expr exp ~pos - end - -and search_pos_class_expr ~pos cl = - if in_loc cl.cl_loc ~pos then begin - begin match cl.cl_desc with - Tclass_ident path -> - add_found_str (`Class (path, cl.cl_type)) - ~env:!start_env ~loc:cl.cl_loc - | Tclass_structure cls -> - search_pos_class_structure ~pos cls - | Tclass_fun (pat, iel, cl, _) -> - search_pos_pat pat ~pos ~env:pat.pat_env; - List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos); - search_pos_class_expr cl ~pos - | Tclass_apply (cl, el) -> - search_pos_class_expr cl ~pos; - List.iter el ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x) - | Tclass_let (_, pel, iel, cl) -> - List.iter pel ~f: - begin fun (pat, exp) -> - search_pos_pat pat ~pos ~env:exp.exp_env; - search_pos_expr exp ~pos - end; - List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos); - search_pos_class_expr cl ~pos - | Tclass_constraint (cl, _, _, _) -> - search_pos_class_expr cl ~pos - end; - add_found_str (`Class (Pident (Ident.create "c"), cl.cl_type)) - ~env:!start_env ~loc:cl.cl_loc - end - -and search_pos_expr ~pos exp = - if in_loc exp.exp_loc ~pos then begin - begin match exp.exp_desc with - Texp_ident (path, _) -> - add_found_str (`Exp(`Val path, exp.exp_type)) - ~env:exp.exp_env ~loc:exp.exp_loc - | Texp_constant v -> - add_found_str (`Exp(`Const, exp.exp_type)) - ~env:exp.exp_env ~loc:exp.exp_loc - | Texp_let (_, expl, exp) -> - List.iter expl ~f: - begin fun (pat, exp') -> - search_pos_pat pat ~pos ~env:exp.exp_env; - search_pos_expr exp' ~pos - end; - search_pos_expr exp ~pos - | Texp_function (l, _) -> - List.iter l ~f: - begin fun (pat, exp) -> - search_pos_pat pat ~pos ~env:exp.exp_env; - search_pos_expr exp ~pos - end - | Texp_apply (exp, l) -> - List.iter l ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x); - search_pos_expr exp ~pos - | Texp_match (exp, l, _) -> - search_pos_expr exp ~pos; - List.iter l ~f: - begin fun (pat, exp) -> - search_pos_pat pat ~pos ~env:exp.exp_env; - search_pos_expr exp ~pos - end - | Texp_try (exp, l) -> - search_pos_expr exp ~pos; - List.iter l ~f: - begin fun (pat, exp) -> - search_pos_pat pat ~pos ~env:exp.exp_env; - search_pos_expr exp ~pos - end - | Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos) - | Texp_construct (_, l) -> List.iter l ~f:(search_pos_expr ~pos) - | Texp_variant (_, None) -> () - | Texp_variant (_, Some exp) -> search_pos_expr exp ~pos - | Texp_record (l, opt) -> - List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos); - (match opt with None -> () | Some exp -> search_pos_expr exp ~pos) - | Texp_field (exp, _) -> search_pos_expr exp ~pos - | Texp_setfield (a, _, b) -> - search_pos_expr a ~pos; search_pos_expr b ~pos - | Texp_array l -> List.iter l ~f:(search_pos_expr ~pos) - | Texp_ifthenelse (a, b, c) -> - search_pos_expr a ~pos; search_pos_expr b ~pos; - begin match c with None -> () - | Some exp -> search_pos_expr exp ~pos - end - | Texp_sequence (a,b) -> - search_pos_expr a ~pos; search_pos_expr b ~pos - | Texp_while (a,b) -> - search_pos_expr a ~pos; search_pos_expr b ~pos - | Texp_for (_, a, b, _, c) -> - List.iter [a;b;c] ~f:(search_pos_expr ~pos) - | Texp_when (a, b) -> - search_pos_expr a ~pos; search_pos_expr b ~pos - | Texp_send (exp, _) -> search_pos_expr exp ~pos - | Texp_new (path, _) -> - add_found_str (`Exp(`New path, exp.exp_type)) - ~env:exp.exp_env ~loc:exp.exp_loc - | Texp_instvar (_,path) -> - add_found_str (`Exp(`Var path, exp.exp_type)) - ~env:exp.exp_env ~loc:exp.exp_loc - | Texp_setinstvar (_, path, exp) -> - search_pos_expr exp ~pos; - add_found_str (`Exp(`Var path, exp.exp_type)) - ~env:exp.exp_env ~loc:exp.exp_loc - | Texp_override (_, l) -> - List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos) - | Texp_letmodule (id, modexp, exp) -> - search_pos_module_expr modexp ~pos; - search_pos_expr exp ~pos - | Texp_assertfalse -> () - | Texp_assert exp -> - search_pos_expr exp ~pos - | Texp_lazy exp -> - search_pos_expr exp ~pos - | Texp_object (cls, _, _) -> - search_pos_class_structure ~pos cls - | Texp_pack modexp -> - search_pos_module_expr modexp ~pos - | Texp_loc (_, _) - | Texp_def (_, _)|Texp_reply (_, _)|Texp_par (_, _)|Texp_spawn _ - | Texp_asyncsend (_, _)|Texp_null - -> assert false (* no browser for jocaml *) - end; - add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc - end - -and search_pos_pat ~pos ~env pat = - if in_loc pat.pat_loc ~pos then begin - begin match pat.pat_desc with - Tpat_any -> () - | Tpat_var id -> - add_found_str (`Exp(`Val (Pident id), pat.pat_type)) - ~env ~loc:pat.pat_loc - | Tpat_alias (pat, _) -> search_pos_pat pat ~pos ~env - | Tpat_constant _ -> - add_found_str (`Exp(`Const, pat.pat_type)) ~env ~loc:pat.pat_loc - | Tpat_tuple l -> - List.iter l ~f:(search_pos_pat ~pos ~env) - | Tpat_construct (_, l) -> - List.iter l ~f:(search_pos_pat ~pos ~env) - | Tpat_variant (_, None, _) -> () - | Tpat_variant (_, Some pat, _) -> search_pos_pat pat ~pos ~env - | Tpat_record l -> - List.iter l ~f:(fun (_, pat) -> search_pos_pat pat ~pos ~env) - | Tpat_array l -> - List.iter l ~f:(search_pos_pat ~pos ~env) - | Tpat_or (a, b, None) -> - search_pos_pat a ~pos ~env; search_pos_pat b ~pos ~env - | Tpat_or (_, _, Some _) -> - () - end; - add_found_str (`Exp(`Pat, pat.pat_type)) ~env ~loc:pat.pat_loc - end - -and search_pos_module_expr ~pos m = - if in_loc m.mod_loc ~pos then begin - begin match m.mod_desc with - Tmod_ident path -> - add_found_str (`Module (path, m.mod_type)) - ~env:m.mod_env ~loc:m.mod_loc - | Tmod_structure str -> search_pos_structure str ~pos - | Tmod_functor (_, _, m) -> search_pos_module_expr m ~pos - | Tmod_apply (a, b, _) -> - search_pos_module_expr a ~pos; search_pos_module_expr b ~pos - | Tmod_constraint (m, _, _) -> search_pos_module_expr m ~pos - | Tmod_unpack (e, _) -> search_pos_expr e ~pos - end; - add_found_str (`Module (Pident (Ident.create "M"), m.mod_type)) - ~env:m.mod_env ~loc:m.mod_loc - end - -let search_pos_structure ~pos str = - observe ~ref:found_str (search_pos_structure ~pos) str - -open Stypes - -let search_pos_ti ~pos = function - Ti_pat p -> search_pos_pat ~pos ~env:p.pat_env p - | Ti_expr e -> search_pos_expr ~pos e - | Ti_class c -> search_pos_class_expr ~pos c - | Ti_mod m -> search_pos_module_expr ~pos m - -let rec search_pos_info ~pos = function - [] -> [] - | ti :: l -> - if in_loc ~pos (get_location ti) - then observe ~ref:found_str (search_pos_ti ~pos) ti - else search_pos_info ~pos l diff --git a/otherlibs/labltk/browser/searchpos.mli b/otherlibs/labltk/browser/searchpos.mli deleted file mode 100644 index 57162a836d4d..000000000000 --- a/otherlibs/labltk/browser/searchpos.mli +++ /dev/null @@ -1,77 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val top_widgets : any widget list ref - -type module_widgets = - { mw_frame: frame widget; - mw_title: label widget option; - mw_detach: button widget; - mw_edit: button widget; - mw_intf: button widget } - -val add_shown_module : Path.t -> widgets:module_widgets -> unit -val find_shown_module : Path.t -> module_widgets -val is_shown_module : Path.t -> bool -val default_frame : module_widgets option ref -val set_path : (Path.t -> sign:Types.signature -> unit) ref - -val view_defined_ref : (Longident.t -> env:Env.t -> unit) ref -val editor_ref : - (?file:string -> ?pos:int -> ?opendialog:bool -> unit -> unit) ref - -val view_signature : - ?title:string -> - ?path:Path.t -> ?env:Env.t -> ?detach:bool -> Types.signature -> unit -val view_signature_item : - Types.signature -> path:Path.t -> env:Env.t -> unit -val view_module_id : Longident.t -> env:Env.t -> unit -val view_type_id : Longident.t -> env:Env.t -> unit -val view_class_id : Longident.t -> env:Env.t -> unit -val view_cltype_id : Longident.t -> env:Env.t -> unit -val view_modtype_id : Longident.t -> env:Env.t -> unit -val view_type_decl : Path.t -> env:Env.t -> unit - -type skind = [`Type|`Class|`Module|`Modtype] -val search_pos_signature : - Parsetree.signature -> pos:int -> env:Env.t -> - ((skind * Longident.t) * Env.t * Location.t) list -val view_decl : Longident.t -> kind:skind -> env:Env.t -> unit -val view_decl_menu : - Longident.t -> - kind:skind -> env:Env.t -> parent:text widget -> menu widget - -type fkind = [ - `Exp of - [`Expr|`Pat|`Const|`Val of Path.t|`Var of Path.t|`New of Path.t] - * Types.type_expr - | `Class of Path.t * Types.class_type - | `Module of Path.t * Types.module_type -] -val search_pos_structure : - pos:int -> Typedtree.structure_item list -> - (fkind * Env.t * Location.t) list -val search_pos_info : - pos:int -> Stypes.type_info list -> (fkind * Env.t * Location.t) list -val view_type : fkind -> env:Env.t -> unit -val view_type_menu : fkind -> env:Env.t -> parent:'a widget -> menu widget - -val parent_path : Path.t -> Path.t option -val string_of_path : Path.t -> string -val string_of_longident : Longident.t -> string -val lines_to_chars : int -> text:string -> int diff --git a/otherlibs/labltk/browser/setpath.ml b/otherlibs/labltk/browser/setpath.ml deleted file mode 100644 index 018657610b5d..000000000000 --- a/otherlibs/labltk/browser/setpath.ml +++ /dev/null @@ -1,162 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk - -(* Listboxes *) - -let update_hooks = ref [] - -let add_update_hook f = update_hooks := f :: !update_hooks - -let exec_update_hooks () = - update_hooks := List.filter !update_hooks ~f: - begin fun f -> - try f (); true - with Protocol.TkError _ -> false - end - -let set_load_path l = - Config.load_path := l; - exec_update_hooks () - -let get_load_path () = !Config.load_path - -let renew_dirs box ~var ~dir = - Textvariable.set var dir; - Listbox.delete box ~first:(`Num 0) ~last:`End; - Listbox.insert box ~index:`End - ~texts:(Useunix.get_directories_in_files ~path:dir - (Useunix.get_files_in_directory dir)); - Jg_box.recenter box ~index:(`Num 0) - -let renew_path box = - Listbox.delete box ~first:(`Num 0) ~last:`End; - Listbox.insert box ~index:`End ~texts:!Config.load_path; - Jg_box.recenter box ~index:(`Num 0) - -let add_to_path ~dirs ?(base="") box = - let dirs = - if base = "" then dirs else - if dirs = [] then [base] else - List.map dirs ~f: - begin function - "." -> base - | ".." -> Filename.dirname base - | x -> Filename.concat base x - end - in - set_load_path - (dirs @ List.fold_left dirs ~init:(get_load_path ()) - ~f:(fun acc x -> List2.exclude x acc)) - -let remove_path box ~dirs = - set_load_path - (List.fold_left dirs ~init:(get_load_path ()) - ~f:(fun acc x -> List2.exclude x acc)) - -(* main function *) - -let f ~dir = - let current_dir = ref dir in - let tl = Jg_toplevel.titled "Edit Load Path" in - Jg_bind.escape_destroy tl; - let var_dir = Textvariable.create ~on:tl () in - let caplab = Label.create tl ~text:"Path" - and dir_name = Entry.create tl ~textvariable:var_dir - and browse = Frame.create tl in - let dirs = Frame.create browse - and path = Frame.create browse in - let dirframe, dirbox, dirsb = Jg_box.create_with_scrollbar dirs - and pathframe, pathbox, pathsb = Jg_box.create_with_scrollbar path - in - add_update_hook (fun () -> renew_path pathbox); - Listbox.configure pathbox ~width:40 ~selectmode:`Multiple; - Listbox.configure dirbox ~selectmode:`Multiple; - Jg_box.add_completion dirbox ~action: - begin fun index -> - begin match Listbox.get dirbox ~index with - "." -> () - | ".." -> current_dir := Filename.dirname !current_dir - | x -> current_dir := !current_dir ^ "/" ^ x - end; - renew_dirs dirbox ~var:var_dir ~dir:!current_dir; - Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End - end; - Jg_box.add_completion pathbox ~action: - begin fun index -> - current_dir := Listbox.get pathbox ~index; - renew_dirs dirbox ~var:var_dir ~dir:!current_dir - end; - - bind dir_name ~events:[`KeyPressDetail"Return"] - ~action:(fun _ -> - let dir = Textvariable.get var_dir in - if Useunix.is_directory dir then begin - current_dir := dir; - renew_dirs dirbox ~var:var_dir ~dir - end); - - (* Avoid space being used by the completion mechanism *) - let bind_space_toggle lb = - bind lb ~events:[`KeyPressDetail "space"] ~extend:true ~action:ignore in - bind_space_toggle dirbox; - bind_space_toggle pathbox; - - let add_paths _ = - add_to_path pathbox ~base:!current_dir - ~dirs:(List.map (Listbox.curselection dirbox) - ~f:(fun x -> Listbox.get dirbox ~index:x)); - Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End - and remove_paths _ = - remove_path pathbox - ~dirs:(List.map (Listbox.curselection pathbox) - ~f:(fun x -> Listbox.get pathbox ~index:x)) - in - bind dirbox ~events:[`KeyPressDetail "Insert"] ~action:add_paths; - bind pathbox ~events:[`KeyPressDetail "Delete"] ~action:remove_paths; - - let dirlab = Label.create dirs ~text:"Directories" - and pathlab = Label.create path ~text:"Load path" - and addbutton = Button.create dirs ~text:"Add to path" ~command:add_paths - and pathbuttons = Frame.create path in - let removebutton = - Button.create pathbuttons ~text:"Remove from path" ~command:remove_paths - and ok = - Jg_button.create_destroyer tl ~parent:pathbuttons - in - renew_dirs dirbox ~var:var_dir ~dir:!current_dir; - renew_path pathbox; - pack [dirsb] ~side:`Right ~fill:`Y; - pack [dirbox] ~side:`Left ~fill:`Y ~expand:true; - pack [pathsb] ~side:`Right ~fill:`Y; - pack [pathbox] ~side:`Left ~fill:`Both ~expand:true; - pack [dirlab] ~side:`Top ~anchor:`W ~padx:10; - pack [addbutton] ~side:`Bottom ~fill:`X; - pack [dirframe] ~fill:`Y ~expand:true; - pack [pathlab] ~side:`Top ~anchor:`W ~padx:10; - pack [removebutton; ok] ~side:`Left ~fill:`X ~expand:true; - pack [pathbuttons] ~fill:`X ~side:`Bottom; - pack [pathframe] ~fill:`Both ~expand:true; - pack [dirs] ~side:`Left ~fill:`Y; - pack [path] ~side:`Right ~fill:`Both ~expand:true; - pack [caplab] ~side:`Top ~anchor:`W ~padx:10; - pack [dir_name] ~side:`Top ~anchor:`W ~fill:`X; - pack [browse] ~side:`Bottom ~expand:true ~fill:`Both; - tl - -let set ~dir = ignore (f ~dir);; diff --git a/otherlibs/labltk/browser/setpath.mli b/otherlibs/labltk/browser/setpath.mli deleted file mode 100644 index 6191b70c60e2..000000000000 --- a/otherlibs/labltk/browser/setpath.mli +++ /dev/null @@ -1,25 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget - -val add_update_hook : (unit -> unit) -> unit -val exec_update_hooks : unit -> unit - (* things to do when Config.load_path changes *) - -val set : dir:string -> unit -val f : dir:string -> toplevel widget - (* edit the load path *) diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml deleted file mode 100644 index 695ed82c8b14..000000000000 --- a/otherlibs/labltk/browser/shell.ml +++ /dev/null @@ -1,367 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -module Unix = UnixLabels -open Tk -open Jg_tk -open Dummy - -(* Here again, memoize regexps *) - -let (~!) = Jg_memo.fast ~f:Str.regexp - -(* Nice history class. May reuse *) - -class ['a] history () = object - val mutable history = ([] : 'a list) - val mutable count = 0 - method empty = history = [] - method add s = count <- 0; history <- s :: history - method previous = - let s = List.nth history count in - count <- (count + 1) mod List.length history; - s - method next = - let l = List.length history in - count <- (l + count - 1) mod l; - List.nth history ((l + count - 1) mod l) -end - -let dump_handle (h : Unix.file_descr) = - let obj = Obj.repr h in - if Obj.is_int obj || Obj.tag obj <> Obj.custom_tag then - invalid_arg "Shell.dump_handle"; - Nativeint.format "%x" (Obj.obj obj) - -(* The shell class. Now encapsulated *) - -let protect f x = try f x with _ -> () - -let is_win32 = Sys.os_type = "Win32" -let use_threads = is_win32 -let use_sigpipe = is_win32 - -class shell ~textw ~prog ~args ~env ~history = - let (in2,out1) = Unix.pipe () - and (in1,out2) = Unix.pipe () - and (err1,err2) = Unix.pipe () - and (sig2,sig1) = Unix.pipe () in -object (self) - val pid = - let env = - if use_sigpipe then - let sigdef = "CAMLSIGPIPE=" ^ dump_handle sig2 in - Array.append env [|sigdef|] - else env - in - Unix.create_process_env ~prog ~args ~env - ~stdin:in2 ~stdout:out2 ~stderr:err2 - val out = Unix.out_channel_of_descr out1 - val h : _ history = history - val mutable alive = true - val mutable reading = false - val ibuffer = Buffer.create 1024 - val imutex = Mutex.create () - val mutable ithreads = [] - method alive = alive - method kill = - if Winfo.exists textw then Text.configure textw ~state:`Disabled; - if alive then begin - alive <- false; - protect close_out out; - try - if use_sigpipe then ignore (Unix.write sig1 ~buf:"T" ~pos:0 ~len:1); - List.iter ~f:(protect Unix.close) [in1; err1; sig1; sig2]; - if not use_threads then begin - Fileevent.remove_fileinput ~fd:in1; - Fileevent.remove_fileinput ~fd:err1; - end; - if not use_sigpipe then begin - Unix.kill ~pid ~signal:Sys.sigkill; - ignore (Unix.waitpid ~mode:[] pid) - end - with _ -> () - end - method interrupt = - if alive then try - reading <- false; - if use_sigpipe then begin - ignore (Unix.write sig1 ~buf:"C" ~pos:0 ~len:1); - self#send " " - end else - Unix.kill ~pid ~signal:Sys.sigint - with Unix.Unix_error _ -> () - method send s = - if alive then try - output_string out s; - flush out - with Sys_error _ -> () - method private read ~fd ~len = - begin try - let buf = String.create len in - let len = Unix.read fd ~buf ~pos:0 ~len in - if len > 0 then begin - self#insert (String.sub buf ~pos:0 ~len); - Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) - end; - len - with Unix.Unix_error _ -> 0 - end; - method history (dir : [`Next|`Previous]) = - if not h#empty then begin - if reading then begin - Text.delete textw ~start:(`Mark"input",[`Char 1]) - ~stop:(`Mark"insert",[]) - end else begin - reading <- true; - Text.mark_set textw ~mark:"input" - ~index:(`Mark"insert",[`Char(-1)]) - end; - self#insert (if dir = `Previous then h#previous else h#next) - end - method private lex ?(start = `Mark"insert",[`Linestart]) - ?(stop = `Mark"insert",[`Lineend]) () = - Lexical.tag textw ~start ~stop - method insert text = - let idx = Text.index textw - ~index:(`Mark"insert",[`Char(-1);`Linestart]) in - Text.insert textw ~text ~index:(`Mark"insert",[]); - self#lex ~start:(idx,[`Linestart]) (); - Text.see textw ~index:(`Mark"insert",[]) - method private keypress c = - if not reading && c > " " then begin - reading <- true; - Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) - end - method private keyrelease c = if c <> "" then self#lex () - method private return = - if reading then reading <- false - else Text.mark_set textw ~mark:"input" - ~index:(`Mark"insert",[`Linestart;`Char 1]); - Text.mark_set textw ~mark:"insert"~index:(`Mark"insert",[`Line 1]); - self#lex ~start:(`Mark"input",[`Linestart]) (); - let s = - (* input is one character before real input *) - Text.get textw ~start:(`Mark"input",[`Char 1]) - ~stop:(`Mark"insert",[]) in - h#add s; - Text.insert textw ~index:(`Mark"insert",[]) ~text:"\n"; - Text.yview_index textw ~index:(`Mark"insert",[]); - self#send s; - self#send "\n" - method private paste ev = - if not reading then begin - reading <- true; - Text.mark_set textw ~mark:"input" - ~index:(`Atxy(ev.ev_MouseX, ev.ev_MouseY),[`Char(-1)]) - end - initializer - Lexical.init_tags textw; - let rec bindings = - [ ([], `KeyPress, [`Char], fun ev -> self#keypress ev.ev_Char); - ([], `KeyRelease, [`Char], fun ev -> self#keyrelease ev.ev_Char); - (* [], `KeyPressDetail"Return", [], fun _ -> self#return; *) - ([], `ButtonPressDetail 2, [`MouseX; `MouseY], self#paste); - ([`Alt], `KeyPressDetail"p", [], fun _ -> self#history `Previous); - ([`Alt], `KeyPressDetail"n", [], fun _ -> self#history `Next); - ([`Meta], `KeyPressDetail"p", [], fun _ -> self#history `Previous); - ([`Meta], `KeyPressDetail"n", [], fun _ -> self#history `Next); - ([`Control], `KeyPressDetail"c", [], fun _ -> self#interrupt); - ([], `Destroy, [], fun _ -> self#kill) ] - in - List.iter bindings ~f: - begin fun (modif,event,fields,action) -> - bind textw ~events:[`Modified(modif,event)] ~fields ~action - end; - bind textw ~events:[`KeyPressDetail"Return"] ~breakable:true - ~action:(fun _ -> self#return; break()); - List.iter ~f:Unix.close [in2;out2;err2]; - if use_threads then begin - let fileinput_thread fd = - let buf = String.create 1024 in - let len = ref 0 in - try while len := Unix.read fd ~buf ~pos:0 ~len:1024; !len > 0 do - Mutex.lock imutex; - Buffer.add_substring ibuffer buf 0 !len; - Mutex.unlock imutex - done with Unix.Unix_error _ -> () - in - ithreads <- List.map [in1; err1] ~f:(Thread.create fileinput_thread); - let rec read_buffer () = - Mutex.lock imutex; - if Buffer.length ibuffer > 0 then begin - self#insert (Str.global_replace ~!"\r\n" "\n" - (Buffer.contents ibuffer)); - Buffer.reset ibuffer; - Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) - end; - Mutex.unlock imutex; - Timer.set ~ms:100 ~callback:read_buffer - in - read_buffer () - end else begin - try - List.iter [in1;err1] ~f: - begin fun fd -> - Fileevent.add_fileinput ~fd - ~callback:(fun () -> ignore (self#read ~fd ~len:1024)) - end - with _ -> () - end -end - -(* Specific use of shell, for OCamlBrowser *) - -let shells : (string * shell) list ref = ref [] - -(* Called before exiting *) -let kill_all () = - List.iter !shells ~f:(fun (_,sh) -> if sh#alive then sh#kill); - shells := [] - -let get_all () = - let all = List.filter !shells ~f:(fun (_,sh) -> sh#alive) in - shells := all; - all - -let may_exec_unix prog = - try Unix.access prog ~perm:[Unix.X_OK]; prog - with Unix.Unix_error _ -> "" - -let may_exec_win prog = - let has_ext = - List.exists ~f:(Filename.check_suffix prog) ["exe"; "com"; "bat"] in - if has_ext then may_exec_unix prog else - List.fold_left [prog^".bat"; prog^".exe"; prog^".com"] ~init:"" - ~f:(fun res prog -> if res = "" then may_exec_unix prog else res) - -let may_exec = - if is_win32 then may_exec_win else may_exec_unix - -let path_sep = if is_win32 then ";" else ":" - -let warnings = ref Warnings.defaults_w - -let program_not_found prog = - Jg_message.info ~title:"Error" - ("Program \"" ^ prog ^ "\"\nwas not found in path") - -let protect_arg s = - if String.contains s ' ' then "\"" ^ s ^ "\"" else s - -let f ~prog ~title = - let progargs = - List.filter ~f:((<>) "") (Str.split ~!" " prog) in - if progargs = [] then () else - let prog = List.hd progargs in - let path = - try Sys.getenv "PATH" with Not_found -> "/bin" ^ path_sep ^ "/usr/bin" in - let exec_path = Str.split ~!path_sep path in - let exec_path = if is_win32 then "."::exec_path else exec_path in - let progpath = - if not (Filename.is_implicit prog) then may_exec prog else - List.fold_left exec_path ~init:"" ~f: - (fun res dir -> - if res = "" then may_exec (Filename.concat dir prog) else res) in - if progpath = "" then program_not_found prog else - let tl = Jg_toplevel.titled title in - let menus = Frame.create tl ~name:"menubar" in - let file_menu = new Jg_menu.c "File" ~parent:menus - and history_menu = new Jg_menu.c "History" ~parent:menus - and signal_menu = new Jg_menu.c "Signal" ~parent:menus in - pack [menus] ~side:`Top ~fill:`X; - pack [file_menu#button; history_menu#button; signal_menu#button] - ~side:`Left ~ipadx:5 ~anchor:`W; - let frame, tw, sb = Jg_text.create_with_scrollbar tl in - Text.configure tw ~background:`White; - pack [sb] ~fill:`Y ~side:`Right; - pack [tw] ~fill:`Both ~expand:true ~side:`Left; - pack [frame] ~fill:`Both ~expand:true; - let env = Array.map (Unix.environment ()) ~f: - begin fun s -> - if Str.string_match ~!"TERM=" s 0 then "TERM=dumb" else s - end in - let load_path = - List2.flat_map !Config.load_path ~f:(fun dir -> ["-I"; dir]) in - let load_path = - if is_win32 then List.map ~f:protect_arg load_path else load_path in - let labels = if !Clflags.classic then ["-nolabels"] else [] in - let rectypes = if !Clflags.recursive_types then ["-rectypes"] else [] in - let warnings = - if List.mem "-w" progargs || !warnings = "Al" then [] - else ["-w"; !warnings] - in - let args = - Array.of_list (progargs @ labels @ warnings @ rectypes @ load_path) in - let history = new history () in - let start_shell () = - let sh = new shell ~textw:tw ~prog:progpath ~env ~args ~history in - shells := (title, sh) :: !shells; - sh - in - let sh = ref (start_shell ()) in - let current_dir = ref (Unix.getcwd ()) in - file_menu#add_command "Restart" ~command: - begin fun () -> - (!sh)#kill; - Text.configure tw ~state:`Normal; - Text.insert tw ~index:(`End,[]) ~text:"\n"; - Text.see tw ~index:(`End,[]); - Text.mark_set tw ~mark:"insert" ~index:(`End,[]); - sh := start_shell (); - end; - file_menu#add_command "Use..." ~command: - begin fun () -> - Fileselect.f ~title:"Use File" ~filter:"*.ml" - ~sync:true ~dir:!current_dir () - ~action:(fun l -> - if l = [] then () else - let name = Fileselect.caml_dir (List.hd l) in - current_dir := Filename.dirname name; - if Filename.check_suffix name ".ml" - then - let cmd = "#use \"" ^ String.escaped name ^ "\";;\n" in - (!sh)#insert cmd; (!sh)#send cmd) - end; - file_menu#add_command "Load..." ~command: - begin fun () -> - Fileselect.f ~title:"Load File" ~filter:"*.cm[oa]" ~sync:true () - ~dir:!current_dir - ~action:(fun l -> - if l = [] then () else - let name = Fileselect.caml_dir (List.hd l) in - current_dir := Filename.dirname name; - if Filename.check_suffix name ".cmo" || - Filename.check_suffix name ".cma" - then - let cmd = "#load \"" ^ String.escaped name ^ "\";;\n" in - (!sh)#insert cmd; (!sh)#send cmd) - end; - file_menu#add_command "Import path" ~command: - begin fun () -> - List.iter (List.rev !Config.load_path) ~f: - (fun dir -> - (!sh)#send ("#directory \"" ^ String.escaped dir ^ "\";;\n")) - end; - file_menu#add_command "Close" ~command:(fun () -> destroy tl); - history_menu#add_command "Previous " ~accelerator:"M-p" - ~command:(fun () -> (!sh)#history `Previous); - history_menu#add_command "Next" ~accelerator:"M-n" - ~command:(fun () -> (!sh)#history `Next); - signal_menu#add_command "Interrupt " ~accelerator:"C-c" - ~command:(fun () -> (!sh)#interrupt); - signal_menu#add_command "Kill" ~command:(fun () -> (!sh)#kill) diff --git a/otherlibs/labltk/browser/shell.mli b/otherlibs/labltk/browser/shell.mli deleted file mode 100644 index 5bb1ff5a3d97..000000000000 --- a/otherlibs/labltk/browser/shell.mli +++ /dev/null @@ -1,46 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -class ['a] history : - unit -> - object - val mutable count : int - val mutable history : 'a list - method add : 'a -> unit - method empty : bool - method next : 'a - method previous : 'a - end - -(* toplevel shell *) - -class shell : - textw:Widget.text Widget.widget -> prog:string -> - args:string array -> env:string array -> history:string history -> - object - method alive : bool - method kill : unit - method interrupt : unit - method insert : string -> unit - method send : string -> unit - method history : [`Next|`Previous] -> unit - end - -val kill_all : unit -> unit -val get_all : unit -> (string * shell) list -val warnings : string ref - -val f : prog:string -> title:string -> unit diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml deleted file mode 100644 index 71d2aaff5f03..000000000000 --- a/otherlibs/labltk/browser/typecheck.ml +++ /dev/null @@ -1,181 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk -open Parsetree -open Location -open Jg_tk -open Mytypes - -(* Optionally preprocess a source file *) - -let preprocess ~pp ~ext text = - let sourcefile = Filename.temp_file "caml" ext in - begin try - let oc = open_out_bin sourcefile in - output_string oc text; - flush oc; - close_out oc - with _ -> - failwith "Preprocessing error" - end; - let tmpfile = Filename.temp_file "camlpp" ext in - let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in - if Ccomp.command comm <> 0 then begin - Sys.remove sourcefile; - Sys.remove tmpfile; - failwith "Preprocessing error" - end; - Sys.remove sourcefile; - tmpfile - -exception Outdated_version - -let parse_pp ~parse ~wrap ~ext text = - match !Clflags.preprocessor with - None -> parse (Lexing.from_string text) - | Some pp -> - let tmpfile = preprocess ~pp ~ext text in - let ast_magic = - if ext = ".ml" then Config.ast_impl_magic_number - else Config.ast_intf_magic_number in - let ic = open_in_bin tmpfile in - let ast = - try - let buffer = Misc.input_bytes ic (String.length ast_magic) in - if buffer = ast_magic then begin - ignore (input_value ic); - wrap (input_value ic) - end else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then - raise Outdated_version - else - raise Exit - with - Outdated_version -> - close_in ic; - Sys.remove tmpfile; - failwith "OCaml and preprocessor have incompatible versions" - | _ -> - seek_in ic 0; - parse (Lexing.from_channel ic) - in - close_in ic; - Sys.remove tmpfile; - ast - -let nowarnings = ref false - -let f txt = - let error_messages = ref [] in - let text = Jg_text.get_all txt.tw - and env = ref (Env.open_pers_signature "Pervasives" Env.initial) in - let tl, ew, end_message = - Jg_message.formatted ~title:"Warnings" ~ppf:Format.err_formatter () in - Text.tag_remove txt.tw ~tag:"error" ~start:tstart ~stop:tend; - txt.structure <- []; - txt.type_info <- []; - txt.signature <- []; - txt.psignature <- []; - ignore (Stypes.get_info ()); - Clflags.save_types := true; - - begin try - - if Filename.check_suffix txt.name ".mli" then - let psign = parse_pp text ~ext:".mli" - ~parse:Parse.interface ~wrap:(fun x -> x) in - txt.psignature <- psign; - txt.signature <- Typemod.transl_signature !env psign - - else (* others are interpreted as .ml *) - - let psl = parse_pp text ~ext:".ml" - ~parse:Parse.use_file ~wrap:(fun x -> [Parsetree.Ptop_def x]) in - List.iter psl ~f: - begin function - Ptop_def pstr -> - let str, sign, env' = Typemod.type_structure !env pstr in - txt.structure <- txt.structure @ str; - txt.signature <- txt.signature @ sign; - env := env' - | Ptop_dir _ -> () - end; - txt.type_info <- Stypes.get_info (); - - with - Lexer.Error _ | Syntaxerr.Error _ - | Typecore.Error _ | Typemod.Error _ - | Typeclass.Error _ | Typedecl.Error _ - | Typetexp.Error _ | Includemod.Error _ - | Env.Error _ | Ctype.Tags _ | Failure _ as exn -> - txt.type_info <- Stypes.get_info (); - let et, ew, end_message = Jg_message.formatted ~title:"Error !" () in - error_messages := et :: !error_messages; - let range = match exn with - Lexer.Error (err, l) -> - Lexer.report_error Format.std_formatter err; l - | Syntaxerr.Error err -> - Syntaxerr.report_error Format.std_formatter err; - begin match err with - Syntaxerr.Unclosed(l,_,_,_) -> l - | Syntaxerr.Applicative_path l -> l - | Syntaxerr.Other l -> l - end - | Typecore.Error (l,err) -> - Typecore.report_error Format.std_formatter err; l - | Typeclass.Error (l,err) -> - Typeclass.report_error Format.std_formatter err; l - | Typedecl.Error (l, err) -> - Typedecl.report_error Format.std_formatter err; l - | Typemod.Error (l,err) -> - Typemod.report_error Format.std_formatter err; l - | Typetexp.Error (l,err) -> - Typetexp.report_error Format.std_formatter err; l - | Includemod.Error errl -> - Includemod.report_error Format.std_formatter errl; Location.none - | Env.Error err -> - Env.report_error Format.std_formatter err; Location.none - | Ctype.Tags(l, l') -> - Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value.@." l l'; - Location.none - | Failure s -> - Format.printf "%s.@." s; Location.none - | _ -> assert false - in - end_message (); - let s = range.loc_start.Lexing.pos_cnum in - let e = range.loc_end.Lexing.pos_cnum in - if s < e then - Jg_text.tag_and_see txt.tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error" - end; - end_message (); - if !nowarnings || Text.index ew ~index:tend = `Linechar (2,0) - then destroy tl - else begin - error_messages := tl :: !error_messages; - Text.configure ew ~state:`Disabled; - bind ew ~events:[`Modified([`Double], `ButtonReleaseDetail 1)] - ~action:(fun _ -> - try - let start, ende = Text.tag_nextrange ew ~tag:"sel" ~start:(tpos 0) in - let s = Text.get ew ~start:(start,[]) ~stop:(ende,[]) in - let n = int_of_string s in - Text.mark_set txt.tw ~index:(tpos n) ~mark:"insert"; - Text.see txt.tw ~index:(`Mark "insert", []) - with _ -> ()) - end; - !error_messages diff --git a/otherlibs/labltk/browser/typecheck.mli b/otherlibs/labltk/browser/typecheck.mli deleted file mode 100644 index 08a16dd20c48..000000000000 --- a/otherlibs/labltk/browser/typecheck.mli +++ /dev/null @@ -1,23 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open Widget -open Mytypes - -val nowarnings : bool ref - -val f : edit_window -> any widget list - (* Typechecks the window as much as possible *) diff --git a/otherlibs/labltk/browser/useunix.ml b/otherlibs/labltk/browser/useunix.ml deleted file mode 100644 index 86554d48844e..000000000000 --- a/otherlibs/labltk/browser/useunix.ml +++ /dev/null @@ -1,69 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open UnixLabels - -let get_files_in_directory dir = - let len = String.length dir in - let dir = - if len > 0 && Sys.os_type = "Win32" && - (dir.[len-1] = '/' || dir.[len-1] = '\\') - then String.sub dir ~pos:0 ~len:(len-1) - else dir - in match - try Some(opendir dir) with Unix_error _ -> None - with - None -> [] - | Some dirh -> - let rec get_them l = - match - try Some(readdir dirh) with _ -> None - with - | Some x -> - get_them (x::l) - | None -> - closedir dirh; l - in - List.sort ~cmp:compare (get_them []) - -let is_directory name = - try - (stat name).st_kind = S_DIR - with _ -> false - -let concat dir name = - let len = String.length dir in - if len = 0 then name else - if dir.[len-1] = '/' then dir ^ name - else dir ^ "/" ^ name - -let get_directories_in_files ~path = - List.filter ~f:(fun x -> is_directory (concat path x)) - -(************************************************** Subshell call *) -let subshell ~cmd = - let rc = open_process_in cmd in - let rec it l = - match - try Some(input_line rc) with _ -> None - with - Some x -> it (x::l) - | None -> List.rev l - in - let answer = it [] in - ignore (close_process_in rc); - answer diff --git a/otherlibs/labltk/browser/useunix.mli b/otherlibs/labltk/browser/useunix.mli deleted file mode 100644 index 47d7a26aa55c..000000000000 --- a/otherlibs/labltk/browser/useunix.mli +++ /dev/null @@ -1,23 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -(* Unix utilities *) - -val get_files_in_directory : string -> string list -val is_directory : string -> bool -val concat : string -> string -> string -val get_directories_in_files : path:string -> string list -> string list -val subshell : cmd:string -> string list diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml deleted file mode 100644 index 395304ed2735..000000000000 --- a/otherlibs/labltk/browser/viewer.ml +++ /dev/null @@ -1,640 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -open StdLabels -open Tk -open Jg_tk -open Mytypes -open Longident -open Types -open Typedtree -open Env -open Searchpos -open Searchid - -(* Managing the module list *) - -let list_modules ~path = - List.fold_left path ~init:[] ~f: - begin fun modules dir -> - let l = - List.filter (Useunix.get_files_in_directory dir) - ~f:(fun x -> Filename.check_suffix x ".cmi") in - let l = List.map l ~f: - begin fun x -> - String.capitalize (Filename.chop_suffix x ".cmi") - end in - List.fold_left l ~init:modules - ~f:(fun modules item -> - if List.mem item modules then modules else item :: modules) - end - -let reset_modules box = - Listbox.delete box ~first:(`Num 0) ~last:`End; - module_list := Sort.list (Jg_completion.lt_string ~nocase:true) - (list_modules ~path:!Config.load_path); - Listbox.insert box ~index:`End ~texts:!module_list; - Jg_box.recenter box ~index:(`Num 0) - - -(* How to display a symbol *) - -let view_symbol ~kind ~env ?path id = - let name = match id with - Lident x -> x - | Ldot (_, x) -> x - | _ -> match kind with Pvalue | Ptype | Plabel -> "z" | _ -> "Z" - in - match kind with - Pvalue -> - let path, vd = lookup_value id env in - view_signature_item ~path ~env [Tsig_value (Ident.create name, vd)] - | Ptype -> view_type_id id ~env - | Plabel -> let ld = lookup_label id env in - begin match ld.lbl_res.desc with - Tconstr (path, _, _) -> view_type_decl path ~env - | _ -> () - end - | Pconstructor -> - let cd = lookup_constructor id env in - begin match cd.cstr_res.desc with - Tconstr (cpath, _, _) -> - if Path.same cpath Predef.path_exn then - view_signature ~title:(string_of_longident id) ~env ?path - [Tsig_exception (Ident.create name, {exn_loc = Location.none; exn_args = cd.cstr_args})] - else - view_type_decl cpath ~env - | _ -> () - end - | Pmodule -> view_module_id id ~env - | Pmodtype -> view_modtype_id id ~env - | Pclass -> view_class_id id ~env - | Pcltype -> view_cltype_id id ~env - - -(* Create a list of symbols you can choose from *) - -let choose_symbol ~title ~env ?signature ?path l = - if match path with - None -> false - | Some path -> is_shown_module path - then () else - let tl = Jg_toplevel.titled title in - Jg_bind.escape_destroy tl; - top_widgets := coe tl :: !top_widgets; - let buttons = Frame.create tl in - let all = Button.create buttons ~text:"Show all" ~padx:20 - and ok = Jg_button.create_destroyer tl ~parent:buttons - and detach = Button.create buttons ~text:"Detach" - and edit = Button.create buttons ~text:"Impl" - and intf = Button.create buttons ~text:"Intf" in - let l = List.sort l ~cmp:(fun (li1, _) (li2,_) -> compare li1 li2) in - let nl = List.map l ~f: - begin fun (li, k) -> - string_of_longident li ^ " (" ^ string_of_kind k ^ ")" - end in - let fb = Frame.create tl in - let box = - new Jg_multibox.c fb ~cols:3 ~texts:nl ~maxheight:3 ~width:21 in - box#init; - box#bind_kbd ~events:[`KeyPressDetail"Escape"] - ~action:(fun _ ~index -> destroy tl; break ()); - if List.length nl > 9 then ignore (Jg_multibox.add_scrollbar box); - Jg_multibox.add_completion box ~action: - begin fun pos -> - let li, k = List.nth l pos in - let path = - match path, li with - None, Ldot (lip, _) -> - begin try - Some (fst (lookup_module lip env)) - with Not_found -> None - end - | _ -> path - in view_symbol li ~kind:k ~env ?path - end; - pack [buttons] ~side:`Bottom ~fill:`X; - pack [fb] ~side:`Top ~fill:`Both ~expand:true; - begin match signature with - None -> pack [ok] ~fill:`X ~expand:true - | Some signature -> - Button.configure all ~command: - begin fun () -> - view_signature signature ~title ~env ?path - end; - pack [ok; all] ~side:`Right ~fill:`X ~expand:true - end; - begin match path with None -> () - | Some path -> - let frame = Frame.create tl in - pack [frame] ~side:`Bottom ~fill:`X; - add_shown_module path - ~widgets:{ mw_frame = frame; mw_title = None; mw_detach = detach; - mw_edit = edit; mw_intf = intf } - end - -let choose_symbol_ref = ref choose_symbol - - -(* Search, both by type and name *) - -let guess_search_mode s : [`Type | `Long | `Pattern] = - let is_type = ref false and is_long = ref false in - for i = 0 to String.length s - 2 do - if s.[i] = '-' && s.[i+1] = '>' then is_type := true; - if s.[i] = '.' then is_long := true - done; - if !is_type then `Type else if !is_long then `Long else `Pattern - - -let search_string ?(mode="symbol") ew = - let text = Entry.get ew in - try - if text = "" then () else - let l = match mode with - "Name" -> - begin match guess_search_mode text with - `Long -> search_string_symbol text - | `Pattern -> search_pattern_symbol text - | `Type -> search_string_type text ~mode:`Included - end - | "Type" -> search_string_type text ~mode:`Included - | "Exact" -> search_string_type text ~mode:`Exact - | _ -> assert false - in - match l with [] -> () - | [lid,kind] -> view_symbol lid ~kind ~env:!start_env - | l -> choose_symbol ~title:"Choose symbol" ~env:!start_env l - with Searchid.Error (s,e) -> - Entry.icursor ew ~index:(`Num s) - -let search_which = ref "Name" - -let search_symbol () = - if !module_list = [] then - module_list := List.sort ~cmp:compare (list_modules ~path:!Config.load_path); - let tl = Jg_toplevel.titled "Search symbol" in - Jg_bind.escape_destroy tl; - let ew = Entry.create tl ~width:30 in - let choice = Frame.create tl - and which = Textvariable.create ~on:tl () in - let itself = Radiobutton.create choice ~text:"Itself" - ~variable:which ~value:"Name" - and extype = Radiobutton.create choice ~text:"Exact type" - ~variable:which ~value:"Exact" - and iotype = Radiobutton.create choice ~text:"Included type" - ~variable:which ~value:"Type" - and buttons = Frame.create tl in - let search = Button.create buttons ~text:"Search" ~command: - begin fun () -> - search_which := Textvariable.get which; - search_string ew ~mode:!search_which - end - and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in - - Focus.set ew; - Jg_bind.return_invoke ew ~button:search; - Textvariable.set which !search_which; - pack [itself; extype; iotype] ~side:`Left ~anchor:`W; - pack [search; ok] ~side:`Left ~fill:`X ~expand:true; - pack [coe ew; coe choice; coe buttons] - ~side:`Top ~fill:`X ~expand:true - - -(* Display the contents of a module *) - -let ident_of_decl ~modlid = function - Tsig_value (id, _) -> Lident (Ident.name id), Pvalue - | Tsig_type (id, _, _) -> Lident (Ident.name id), Ptype - | Tsig_exception (id, _) -> Ldot (modlid, Ident.name id), Pconstructor - | Tsig_module (id, _, _) -> Lident (Ident.name id), Pmodule - | Tsig_modtype (id, _) -> Lident (Ident.name id), Pmodtype - | Tsig_class (id, _, _) -> Lident (Ident.name id), Pclass - | Tsig_cltype (id, _, _) -> Lident (Ident.name id), Pcltype - -let view_defined ~env ?(show_all=false) modlid = - try match lookup_module modlid env with path, Tmty_signature sign -> - let rec iter_sign sign idents = - match sign with - [] -> List.rev idents - | decl :: rem -> - let rem = match decl, rem with - Tsig_class _, cty :: ty1 :: ty2 :: rem -> rem - | Tsig_cltype _, ty1 :: ty2 :: rem -> rem - | _, rem -> rem - in iter_sign rem (ident_of_decl ~modlid decl :: idents) - in - let l = iter_sign sign [] in - let title = string_of_path path in - let env = open_signature path sign env in - !choose_symbol_ref l ~title ~signature:sign ~env ~path; - if show_all then view_signature sign ~title ~env ~path - | _ -> () - with Not_found -> () - | Env.Error err -> - let tl, tw, finish = Jg_message.formatted ~title:"Error!" () in - Env.report_error Format.std_formatter err; - finish () - - -(* Manage toplevel windows *) - -let close_all_views () = - List.iter !top_widgets - ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ()); - top_widgets := [] - - -(* Launch a shell *) - -let shell_counter = ref 1 -let default_shell = ref "ocaml" - -let start_shell master = - let tl = Jg_toplevel.titled "Start New Shell" in - Wm.transient_set tl ~master; - let input = Frame.create tl - and buttons = Frame.create tl in - let ok = Button.create buttons ~text:"Ok" - and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" - and labels = Frame.create input - and entries = Frame.create input in - let l1 = Label.create labels ~text:"Command:" - and l2 = Label.create labels ~text:"Title:" - and e1 = - Jg_entry.create entries ~command:(fun _ -> Button.invoke ok) - and e2 = - Jg_entry.create entries ~command:(fun _ -> Button.invoke ok) - and names = List.map ~f:fst (Shell.get_all ()) in - Entry.insert e1 ~index:`End ~text:!default_shell; - let shell_name () = "Shell #" ^ string_of_int !shell_counter in - while List.mem (shell_name ()) names do - incr shell_counter - done; - Entry.insert e2 ~index:`End ~text:(shell_name ()); - Button.configure ok ~command:(fun () -> - if not (List.mem (Entry.get e2) names) then begin - default_shell := Entry.get e1; - Shell.f ~prog:!default_shell ~title:(Entry.get e2); - destroy tl - end); - pack [l1;l2] ~side:`Top ~anchor:`W; - pack [e1;e2] ~side:`Top ~fill:`X ~expand:true; - pack [labels;entries] ~side:`Left ~fill:`X ~expand:true; - pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true; - pack [input;buttons] ~side:`Top ~fill:`X ~expand:true - - -(* Help window *) - -let show_help () = - let tl = Jg_toplevel.titled "OCamlBrowser Help" in - Jg_bind.escape_destroy tl; - let fw, tw, sb = Jg_text.create_with_scrollbar tl in - let ok = Jg_button.create_destroyer ~parent:tl ~text:"Ok" tl in - Text.insert tw ~index:tend ~text:Help.text; - Text.configure tw ~state:`Disabled; - Jg_bind.enter_focus tw; - pack [tw] ~side:`Left ~fill:`Both ~expand:true; - pack [sb] ~side:`Right ~fill:`Y; - pack [fw] ~side:`Top ~expand:true ~fill:`Both; - pack [ok] ~side:`Bottom ~fill:`X - -(* Launch the classical viewer *) - -let f ?(dir=Unix.getcwd()) ?on () = - let tl = match on with - None -> - let tl = Jg_toplevel.titled "Module viewer" in - ignore (Jg_bind.escape_destroy tl); coe tl - | Some top -> - Wm.title_set top "OCamlBrowser"; - Wm.iconname_set top "OCamlBrowser"; - let tl = Frame.create top in - bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0); - pack [tl] ~expand:true ~fill:`Both; - coe tl - in - let menus = Frame.create tl ~name:"menubar" in - let filemenu = new Jg_menu.c "File" ~parent:menus - and modmenu = new Jg_menu.c "Modules" ~parent:menus in - let fmbox, mbox, msb = Jg_box.create_with_scrollbar tl in - - Jg_box.add_completion mbox ~nocase:true ~action: - begin fun index -> - view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env - end; - Setpath.add_update_hook (fun () -> reset_modules mbox); - - let ew = Entry.create tl in - let buttons = Frame.create tl in - let search = Button.create buttons ~text:"Search" ~pady:1 - ~command:(fun () -> search_string ew) - and close = - Button.create buttons ~text:"Close all" ~pady:1 ~command:close_all_views - in - (* bindings *) - Jg_bind.enter_focus ew; - Jg_bind.return_invoke ew ~button:search; - bind close ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~action:(fun _ -> destroy tl); - - (* File menu *) - filemenu#add_command "Open..." - ~command:(fun () -> !editor_ref ~opendialog:true ()); - filemenu#add_command "Editor..." ~command:(fun () -> !editor_ref ()); - filemenu#add_command "Shell..." ~command:(fun () -> start_shell tl); - filemenu#add_command "Quit" ~command:(fun () -> destroy tl); - - (* modules menu *) - modmenu#add_command "Path editor..." - ~command:(fun () -> Setpath.set ~dir); - modmenu#add_command "Reset cache" - ~command:(fun () -> reset_modules mbox; Env.reset_cache ()); - modmenu#add_command "Search symbol..." ~command:search_symbol; - - pack [filemenu#button; modmenu#button] ~side:`Left ~ipadx:5 ~anchor:`W; - pack [menus] ~side:`Top ~fill:`X; - pack [close; search] ~fill:`X ~side:`Right ~expand:true; - pack [coe buttons; coe ew] ~fill:`X ~side:`Bottom; - pack [msb] ~side:`Right ~fill:`Y; - pack [mbox] ~side:`Left ~fill:`Both ~expand:true; - pack [fmbox] ~fill:`Both ~expand:true ~side:`Top; - reset_modules mbox - -(* Smalltalk-like version *) - -class st_viewer ?(dir=Unix.getcwd()) ?on () = - let tl = match on with - None -> - let tl = Jg_toplevel.titled "Module viewer" in - ignore (Jg_bind.escape_destroy tl); coe tl - | Some top -> - Wm.title_set top "OCamlBrowser"; - Wm.iconname_set top "OCamlBrowser"; - let tl = Frame.create top in - bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0); - pack [tl] ~expand:true ~fill:`Both; - coe tl - in - let menus = Frame.create tl ~name:"menubar" in - let filemenu = new Jg_menu.c "File" ~parent:menus - and modmenu = new Jg_menu.c "Modules" ~parent:menus - and viewmenu = new Jg_menu.c "View" ~parent:menus - and helpmenu = new Jg_menu.c "Help" ~parent:menus in - let search_frame = Frame.create tl in - let boxes_frame = Frame.create tl ~name:"boxes" in - let label = Label.create tl ~anchor:`W ~padx:5 in - let view = Frame.create tl in - let buttons = Frame.create tl in - let _all = Button.create buttons ~text:"Show all" ~padx:20 - and close = Button.create buttons ~text:"Close all" ~command:close_all_views - and detach = Button.create buttons ~text:"Detach" - and edit = Button.create buttons ~text:"Impl" - and intf = Button.create buttons ~text:"Intf" in -object (self) - val mutable boxes = [] - val mutable show_all = fun () -> () - - method create_box = - let fmbox, mbox, sb = Jg_box.create_with_scrollbar boxes_frame in - bind mbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~action:(fun _ -> show_all ()); - bind mbox ~events:[`Modified([`Double], `KeyPressDetail "Return")] - ~action:(fun _ -> show_all ()); - boxes <- boxes @ [fmbox, mbox]; - pack [sb] ~side:`Right ~fill:`Y; - pack [mbox] ~side:`Left ~fill:`Both ~expand:true; - pack [fmbox] ~side:`Left ~fill:`Both ~expand:true; - fmbox, mbox - - initializer - (* Search *) - let ew = Entry.create search_frame - and searchtype = Textvariable.create ~on:tl () in - bind ew ~events:[`KeyPressDetail "Return"] ~action: - (fun _ -> search_string ew ~mode:(Textvariable.get searchtype)); - Jg_bind.enter_focus ew; - let search_button ?value text = - Radiobutton.create search_frame - ~text ~variable:searchtype ~value:text in - let symbol = search_button "Name" - and atype = search_button "Type" in - Radiobutton.select symbol; - pack [Label.create search_frame ~text:"Search"] ~side:`Left ~ipadx:5; - pack [ew] ~fill:`X ~expand:true ~side:`Left; - pack [Label.create search_frame ~text:"by"] ~side:`Left ~ipadx:5; - pack [symbol; atype] ~side:`Left; - pack [Label.create search_frame] ~side:`Right - - initializer - (* Boxes *) - let fmbox, mbox = self#create_box in - Jg_box.add_completion mbox ~nocase:true ~double:false ~action: - begin fun index -> - view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env - end; - Setpath.add_update_hook (fun () -> reset_modules mbox; self#hide_after 1); - List.iter [1;2] ~f:(fun _ -> ignore self#create_box); - Searchpos.default_frame := Some - { mw_frame = view; mw_title = Some label; - mw_detach = detach; mw_edit = edit; mw_intf = intf }; - Searchpos.set_path := self#set_path; - - (* Buttons *) - pack [close] ~side:`Right ~fill:`X ~expand:true; - bind close ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~action:(fun _ -> destroy tl); - - (* File menu *) - filemenu#add_command "Open..." - ~command:(fun () -> !editor_ref ~opendialog:true ()); - filemenu#add_command "Editor..." ~command:(fun () -> !editor_ref ()); - filemenu#add_command "Shell..." ~command:(fun () -> start_shell tl); - filemenu#add_command "Quit" ~command:(fun () -> destroy tl); - - (* View menu *) - viewmenu#add_command "Show all defs" ~command:(fun () -> show_all ()); - let show_search = Textvariable.create ~on:tl () in - Textvariable.set show_search "1"; - Menu.add_checkbutton viewmenu#menu ~label:"Search Entry" - ~variable:show_search ~indicatoron:true ~state:`Active - ~command: - begin fun () -> - let v = Textvariable.get show_search in - if v = "1" then begin - pack [search_frame] ~after:menus ~fill:`X - end else Pack.forget [search_frame] - end; - - (* modules menu *) - modmenu#add_command "Path editor..." - ~command:(fun () -> Setpath.set ~dir); - modmenu#add_command "Reset cache" - ~command:(fun () -> reset_modules mbox; Env.reset_cache ()); - modmenu#add_command "Search symbol..." ~command:search_symbol; - - (* Help menu *) - helpmenu#add_command "Manual..." ~command:show_help; - -<<<<<<< .courant - pack [filemenu#button; viewmenu#button; modmenu#button] - ~side:`Left ~ipadx:5 ~anchor:`W; - pack [helpmenu#button] ~side:`Right ~anchor:`E ~ipadx:5; - pack [menus] ~fill:`X; - pack [search_frame] ~fill:`X; -======= - pack [search_frame] ~fill:`X; ->>>>>>> .fusion-droit.r10497 - pack [boxes_frame] ~fill:`Both ~expand:true; - pack [buttons] ~fill:`X ~side:`Bottom; - pack [view] ~fill:`Both ~side:`Bottom ~expand:true; - reset_modules mbox - - val mutable shown_paths = [] - - method hide_after n = - for i = n to List.length boxes - 1 do - let fm, box = List.nth boxes i in - if i < 3 then Listbox.delete box ~first:(`Num 0) ~last:`End - else destroy fm - done; - let rec firsts n = function [] -> [] - | a :: l -> if n > 0 then a :: firsts (pred n) l else [] in - shown_paths <- firsts (n-1) shown_paths; - boxes <- firsts (max 3 n) boxes - - method get_box ~path = - let rec path_index p = function - [] -> raise Not_found - | a :: l -> if Path.same p a then 1 else path_index p l + 1 in - try - let n = path_index path shown_paths in - self#hide_after (n+1); - n - with Not_found -> - match path with - Path.Pdot (path', _, _) -> - let n = self#get_box ~path:path' in - shown_paths <- shown_paths @ [path]; - if n + 1 >= List.length boxes then ignore self#create_box; - n+1 - | _ -> - self#hide_after 2; - shown_paths <- [path]; - 1 - - method set_path path ~sign = - let rec path_elems l path = - match path with - Path.Pdot (path, _, _) -> path_elems (path::l) path - | _ -> [] - in - let path_elems path = - match path with - | Path.Pident _ -> [path] - | _ -> path_elems [] path - in - let see_path ~box:n ?(sign=[]) path = - let (_, box) = List.nth boxes n in - let texts = Listbox.get_range box ~first:(`Num 0) ~last:`End in - let rec index s = function - [] -> raise Not_found - | a :: l -> if a = s then 0 else 1 + index s l - in - try - let modlid, s = - match path with - Path.Pdot (p, s, _) -> longident_of_path p, s - | Path.Pident i -> Longident.Lident "M", Ident.name i - | _ -> assert false - in - let li, k = - if sign = [] then Longident.Lident s, Pmodule else - ident_of_decl ~modlid (List.hd sign) in - let s = - if n = 0 then string_of_longident li else - string_of_longident li ^ " (" ^ string_of_kind k ^ ")" in - let n = index s texts in - Listbox.see box (`Num n); - Listbox.activate box (`Num n) - with Not_found -> () - in - let l = path_elems path in - if l <> [] then begin - List.iter l ~f: - begin fun path -> - if not (List.mem path shown_paths) then - view_symbol (longident_of_path path) ~kind:Pmodule - ~env:Env.initial ~path; - let n = self#get_box path - 1 in - see_path path ~box:n - end; - see_path path ~box:(self#get_box path) ~sign - end - - method choose_symbol ~title ~env ?signature ?path l = - let n = - match path with None -> 1 - | Some path -> self#get_box ~path - in - let l = List.sort l ~cmp:(fun (li1, _) (li2,_) -> compare li1 li2) in - let nl = List.map l ~f: - begin fun (li, k) -> - string_of_longident li ^ " (" ^ string_of_kind k ^ ")" - end in - let _, box = List.nth boxes n in - Listbox.delete box ~first:(`Num 0) ~last:`End; - Listbox.insert box ~index:`End ~texts:nl; - - let current = ref None in - let display index = - let `Num pos = Listbox.index box ~index in - try - let li, k = List.nth l pos in - self#hide_after (n+1); - if !current = Some (li,k) then () else - let path = - match path, li with - None, Ldot (lip, _) -> - begin try - Some (fst (lookup_module lip env)) - with Not_found -> None - end - | _ -> path - in - current := Some (li,k); - view_symbol li ~kind:k ~env ?path - with Failure "nth" -> () - in - Jg_box.add_completion box ~double:false ~action:display; - bind box ~events:[`KeyRelease] ~fields:[`Char] - ~action:(fun ev -> display `Active); - - begin match signature with - None -> () - | Some signature -> - show_all <- - begin fun () -> - current := None; - view_signature signature ~title ~env ?path - end - end -end - -let st_viewer ?dir ?on () = - let viewer = new st_viewer ?dir ?on () in - choose_symbol_ref := viewer#choose_symbol diff --git a/otherlibs/labltk/browser/viewer.mli b/otherlibs/labltk/browser/viewer.mli deleted file mode 100644 index c56c5e415e05..000000000000 --- a/otherlibs/labltk/browser/viewer.mli +++ /dev/null @@ -1,31 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -(* Module viewer *) -open Widget - -val search_symbol : unit -> unit - (* search a symbol in all modules in the path *) - -val f : ?dir:string -> ?on:toplevel widget -> unit -> unit - (* open then module viewer *) -val st_viewer : ?dir:string -> ?on:toplevel widget -> unit -> unit - (* one-box viewer *) - -val view_defined : env:Env.t -> ?show_all:bool -> Longident.t -> unit - (* displays a signature, found in environment *) - -val close_all_views : unit -> unit diff --git a/otherlibs/labltk/browser/winmain.c b/otherlibs/labltk/browser/winmain.c deleted file mode 100644 index 851fa5f6977c..000000000000 --- a/otherlibs/labltk/browser/winmain.c +++ /dev/null @@ -1,34 +0,0 @@ -/*************************************************************************/ -/* */ -/* OCaml LablTk library */ -/* */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file ../../../LICENSE. */ -/* */ -/*************************************************************************/ - -/* $Id$ */ - -#include -#include -#include -#include - -extern int __argc; -extern char **__argv; -extern void caml_expand_command_line(int * argcp, char *** argvp); -extern void caml_main (char **); - -int WINAPI WinMain(HINSTANCE h, HINSTANCE HPrevInstance, - LPSTR lpCmdLine, int nCmdShow) -{ - caml_expand_command_line(&__argc, &__argv); - caml_main(__argv); - sys_exit(Val_int(0)); - return 0; -} diff --git a/otherlibs/labltk/builtin/LICENSE b/otherlibs/labltk/builtin/LICENSE deleted file mode 100644 index dbad5f1c066e..000000000000 --- a/otherlibs/labltk/builtin/LICENSE +++ /dev/null @@ -1,19 +0,0 @@ -(*************************************************************************) -(* *) -(* OCaml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -All the files in this directory are subject to the above copyright notice. diff --git a/otherlibs/labltk/builtin/builtin_FilePattern.ml b/otherlibs/labltk/builtin/builtin_FilePattern.ml deleted file mode 100644 index ea77ff98dbc9..000000000000 --- a/otherlibs/labltk/builtin/builtin_FilePattern.ml +++ /dev/null @@ -1,20 +0,0 @@ -(* File patterns *) -(* type *) -type filePattern = { - typename : string; - extensions : string list; - mactypes : string list - } -(* /type *) - -let cCAMLtoTKfilePattern fp = - let typename = TkQuote (TkToken fp.typename) in - let extensions = - TkQuote (TkTokenList (List.map (fun x -> TkToken x) fp.extensions)) in - let mactypes = - match fp.mactypes with - | [] -> [] - | [s] -> [TkToken s] - | _ -> [TkQuote (TkTokenList (List.map (fun x -> TkToken x) fp.mactypes))] - in - TkQuote (TkTokenList (typename :: extensions :: mactypes)) diff --git a/otherlibs/labltk/builtin/builtin_GetBitmap.ml b/otherlibs/labltk/builtin/builtin_GetBitmap.ml deleted file mode 100644 index bf02d20f86c6..000000000000 --- a/otherlibs/labltk/builtin/builtin_GetBitmap.ml +++ /dev/null @@ -1,22 +0,0 @@ -(* Tk_GetBitmap emulation *) - -##ifdef CAMLTK - -(* type *) -type bitmap = - | BitmapFile of string (* path of file *) - | Predefined of string (* bitmap name *) -;; -(* /type *) - -##else - -(* type *) -type bitmap = [ - | `File of string (* path of file *) - | `Predefined of string (* bitmap name *) -] -;; -(* /type *) - -##endif diff --git a/otherlibs/labltk/builtin/builtin_GetCursor.ml b/otherlibs/labltk/builtin/builtin_GetCursor.ml deleted file mode 100644 index 4f7f6633fc59..000000000000 --- a/otherlibs/labltk/builtin/builtin_GetCursor.ml +++ /dev/null @@ -1,60 +0,0 @@ -(* Color *) - -##ifdef CAMLTK - -(* type *) -type color = - | NamedColor of string - | Black (* tk keyword: black *) - | White (* tk keyword: white *) - | Red (* tk keyword: red *) - | Green (* tk keyword: green *) - | Blue (* tk keyword: blue *) - | Yellow (* tk keyword: yellow *) -;; -(* /type *) - -##else - -(* type *) -type color = [ - | `Color of string - | `Black (* tk keyword: black *) - | `White (* tk keyword: white *) - | `Red (* tk keyword: red *) - | `Green (* tk keyword: green *) - | `Blue (* tk keyword: blue *) - | `Yellow (* tk keyword: yellow *) -] -;; -(* /type *) - -##endif - -##ifdef CAMLTK - -(* type *) -type cursor = - | XCursor of string - | XCursorFg of string * color - | XCursortFgBg of string * color * color - | CursorFileFg of string * color - | CursorMaskFile of string * string * color * color -;; -(* /type *) - -##else - -(* Tk_GetCursor emulation *) -(* type *) -type cursor = [ - | `Xcursor of string - | `Xcursorfg of string * color - | `Xcursorfgbg of string * color * color - | `Cursorfilefg of string * color - | `Cursormaskfile of string * string * color * color -] -;; -(* /type *) - -##endif diff --git a/otherlibs/labltk/builtin/builtin_GetPixel.ml b/otherlibs/labltk/builtin/builtin_GetPixel.ml deleted file mode 100644 index 772a2c284226..000000000000 --- a/otherlibs/labltk/builtin/builtin_GetPixel.ml +++ /dev/null @@ -1,28 +0,0 @@ -(* Tk_GetPixels emulation *) - -##ifdef CAMLTK - -(* type *) -type units = - | Pixels of int (* specified as floating-point, but inconvenient *) - | Centimeters of float - | Inches of float - | Millimeters of float - | PrinterPoint of float -;; -(* /type *) - -##else - -(* type *) -type units = [ - | `Pix of int - | `Cm of float - | `In of float - | `Mm of float - | `Pt of float -] -;; -(* /type *) - -##endif diff --git a/otherlibs/labltk/builtin/builtin_ScrollValue.ml b/otherlibs/labltk/builtin/builtin_ScrollValue.ml deleted file mode 100644 index 75a509e69aa1..000000000000 --- a/otherlibs/labltk/builtin/builtin_ScrollValue.ml +++ /dev/null @@ -1,22 +0,0 @@ -##ifdef CAMLTK - -(* type *) -type scrollValue = - | ScrollPage of int (* tk option: scroll page *) - | ScrollUnit of int (* tk option: scroll unit *) - | MoveTo of float (* tk option: moveto *) -;; -(* /type *) - -##else - -(* type *) -type scrollValue = [ - | `Page of int (* tk option: scroll page *) - | `Unit of int (* tk option: scroll unit *) - | `Moveto of float (* tk option: moveto *) -] -;; -(* /type *) - -##endif diff --git a/otherlibs/labltk/builtin/builtin_bind.ml b/otherlibs/labltk/builtin/builtin_bind.ml deleted file mode 100644 index 752a4ba3a4d4..000000000000 --- a/otherlibs/labltk/builtin/builtin_bind.ml +++ /dev/null @@ -1,469 +0,0 @@ -##ifdef CAMLTK - -open Widget;; - -(* Events and bindings *) -(* Builtin types *) -(* type *) -type xEvent = - | Activate - | ButtonPress (* also Button, but we omit it *) - | ButtonPressDetail of int - | ButtonRelease - | ButtonReleaseDetail of int - | Circulate - | ColorMap (* not Colormap, avoiding confusion between the Colormap option *) - | Configure - | Deactivate - | Destroy - | Enter - | Expose - | FocusIn - | FocusOut - | Gravity - | KeyPress (* also Key, but we omit it *) - | KeyPressDetail of string (* /usr/include/X11/keysymdef.h *) - | KeyRelease - | KeyReleaseDetail of string - | Leave - | Map - | Motion - | Property - | Reparent - | Unmap - | Visibility - | Virtual of string (* Virtual event. Must be without modifiers *) -;; -(* /type *) - -(* type *) -type modifier = - | Control - | Shift - | Lock - | Button1 - | Button2 - | Button3 - | Button4 - | Button5 - | Double - | Triple - | Mod1 - | Mod2 - | Mod3 - | Mod4 - | Mod5 - | Meta - | Alt -;; -(* /type *) - -(* Event structure, passed to bounded functions *) - -(* type *) -type eventInfo = - { - (* %# : event serial number is unsupported *) - mutable ev_Above : int; (* tk: %a *) - mutable ev_ButtonNumber : int; (* tk: %b *) - mutable ev_Count : int; (* tk: %c *) - mutable ev_Detail : string; (* tk: %d *) - mutable ev_Focus : bool; (* tk: %f *) - mutable ev_Height : int; (* tk: %h *) - mutable ev_KeyCode : int; (* tk: %k *) - mutable ev_Mode : string; (* tk: %m *) - mutable ev_OverrideRedirect : bool; (* tk: %o *) - mutable ev_Place : string; (* tk: %p *) - mutable ev_State : string; (* tk: %s *) - mutable ev_Time : int; (* tk: %t *) - mutable ev_Width : int; (* tk: %w *) - mutable ev_MouseX : int; (* tk: %x *) - mutable ev_MouseY : int; (* tk: %y *) - mutable ev_Char : string; (* tk: %A *) - mutable ev_BorderWidth : int; (* tk: %B *) - mutable ev_SendEvent : bool; (* tk: %E *) - mutable ev_KeySymString : string; (* tk: %K *) - mutable ev_KeySymInt : int; (* tk: %N *) - mutable ev_RootWindow : int; (* tk: %R *) - mutable ev_SubWindow : int; (* tk: %S *) - mutable ev_Type : int; (* tk: %T *) - mutable ev_Widget : widget; (* tk: %W *) - mutable ev_RootX : int; (* tk: %X *) - mutable ev_RootY : int (* tk: %Y *) - } -;; -(* /type *) - - -(* To avoid collision with other constructors (Width, State), - use Ev_ prefix *) -(* type *) -type eventField = - | Ev_Above - | Ev_ButtonNumber - | Ev_Count - | Ev_Detail - | Ev_Focus - | Ev_Height - | Ev_KeyCode - | Ev_Mode - | Ev_OverrideRedirect - | Ev_Place - | Ev_State - | Ev_Time - | Ev_Width - | Ev_MouseX - | Ev_MouseY - | Ev_Char - | Ev_BorderWidth - | Ev_SendEvent - | Ev_KeySymString - | Ev_KeySymInt - | Ev_RootWindow - | Ev_SubWindow - | Ev_Type - | Ev_Widget - | Ev_RootX - | Ev_RootY -;; -(* /type *) - -let filleventInfo ev v = function - | Ev_Above -> ev.ev_Above <- int_of_string v - | Ev_ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v - | Ev_Count -> ev.ev_Count <- int_of_string v - | Ev_Detail -> ev.ev_Detail <- v - | Ev_Focus -> ev.ev_Focus <- v = "1" - | Ev_Height -> ev.ev_Height <- int_of_string v - | Ev_KeyCode -> ev.ev_KeyCode <- int_of_string v - | Ev_Mode -> ev.ev_Mode <- v - | Ev_OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1" - | Ev_Place -> ev.ev_Place <- v - | Ev_State -> ev.ev_State <- v - | Ev_Time -> ev.ev_Time <- int_of_string v - | Ev_Width -> ev.ev_Width <- int_of_string v - | Ev_MouseX -> ev.ev_MouseX <- int_of_string v - | Ev_MouseY -> ev.ev_MouseY <- int_of_string v - | Ev_Char -> ev.ev_Char <- v - | Ev_BorderWidth -> ev.ev_BorderWidth <- int_of_string v - | Ev_SendEvent -> ev.ev_SendEvent <- v = "1" - | Ev_KeySymString -> ev.ev_KeySymString <- v - | Ev_KeySymInt -> ev.ev_KeySymInt <- int_of_string v - | Ev_RootWindow -> ev.ev_RootWindow <- int_of_string v - | Ev_SubWindow -> ev.ev_SubWindow <- int_of_string v - | Ev_Type -> ev.ev_Type <- int_of_string v - | Ev_Widget -> ev.ev_Widget <- cTKtoCAMLwidget v - | Ev_RootX -> ev.ev_RootX <- int_of_string v - | Ev_RootY -> ev.ev_RootY <- int_of_string v -;; - -let wrapeventInfo f what = - let ev = { - ev_Above = 0; - ev_ButtonNumber = 0; - ev_Count = 0; - ev_Detail = ""; - ev_Focus = false; - ev_Height = 0; - ev_KeyCode = 0; - ev_Mode = ""; - ev_OverrideRedirect = false; - ev_Place = ""; - ev_State = ""; - ev_Time = 0; - ev_Width = 0; - ev_MouseX = 0; - ev_MouseY = 0; - ev_Char = ""; - ev_BorderWidth = 0; - ev_SendEvent = false; - ev_KeySymString = ""; - ev_KeySymInt = 0; - ev_RootWindow = 0; - ev_SubWindow = 0; - ev_Type = 0; - ev_Widget = Widget.default_toplevel; - ev_RootX = 0; - ev_RootY = 0 } in - function args -> - let l = ref args in - List.iter (function field -> - match !l with - [] -> () - | v::rest -> filleventInfo ev v field; l:=rest) - what; - f ev -;; - -let rec writeeventField = function - | [] -> "" - | field::rest -> - begin - match field with - | Ev_Above -> " %a" - | Ev_ButtonNumber ->" %b" - | Ev_Count -> " %c" - | Ev_Detail -> " %d" - | Ev_Focus -> " %f" - | Ev_Height -> " %h" - | Ev_KeyCode -> " %k" - | Ev_Mode -> " %m" - | Ev_OverrideRedirect -> " %o" - | Ev_Place -> " %p" - | Ev_State -> " %s" - | Ev_Time -> " %t" - | Ev_Width -> " %w" - | Ev_MouseX -> " %x" - | Ev_MouseY -> " %y" - (* Quoting is done by Tk *) - | Ev_Char -> " %A" - | Ev_BorderWidth -> " %B" - | Ev_SendEvent -> " %E" - | Ev_KeySymString -> " %K" - | Ev_KeySymInt -> " %N" - | Ev_RootWindow ->" %R" - | Ev_SubWindow -> " %S" - | Ev_Type -> " %T" - | Ev_Widget ->" %W" - | Ev_RootX -> " %X" - | Ev_RootY -> " %Y" - end - ^ writeeventField rest -;; - -##else - -open Widget;; - -(* Events and bindings *) -(* Builtin types *) - -(* type *) -type event = [ - | `Activate - | `ButtonPress (* also Button, but we omit it *) - | `ButtonPressDetail of int - | `ButtonRelease - | `ButtonReleaseDetail of int - | `Circulate - | `Colormap - | `Configure - | `Deactivate - | `Destroy - | `Enter - | `Expose - | `FocusIn - | `FocusOut - | `Gravity - | `KeyPress (* also Key, but we omit it *) - | `KeyPressDetail of string (* /usr/include/X11/keysymdef.h *) - | `KeyRelease - | `KeyReleaseDetail of string - | `Leave - | `Map - | `Motion - | `Property - | `Reparent - | `Unmap - | `Visibility - | `Virtual of string (* Virtual event. Must be without modifiers *) - | `Modified of modifier list * event -] - -and modifier = [ - | `Control - | `Shift - | `Lock - | `Button1 - | `Button2 - | `Button3 - | `Button4 - | `Button5 - | `Double - | `Triple - | `Mod1 - | `Mod2 - | `Mod3 - | `Mod4 - | `Mod5 - | `Meta - | `Alt -] -;; -(* /type *) - -(* Event structure, passed to bounded functions *) - -(* type *) -type eventInfo = { - (* %# : event serial number is unsupported *) - mutable ev_Above : int; (* tk: %a *) - mutable ev_ButtonNumber : int; (* tk: %b *) - mutable ev_Count : int; (* tk: %c *) - mutable ev_Detail : string; (* tk: %d *) - mutable ev_Focus : bool; (* tk: %f *) - mutable ev_Height : int; (* tk: %h *) - mutable ev_KeyCode : int; (* tk: %k *) - mutable ev_Mode : string; (* tk: %m *) - mutable ev_OverrideRedirect : bool; (* tk: %o *) - mutable ev_Place : string; (* tk: %p *) - mutable ev_State : string; (* tk: %s *) - mutable ev_Time : int; (* tk: %t *) - mutable ev_Width : int; (* tk: %w *) - mutable ev_MouseX : int; (* tk: %x *) - mutable ev_MouseY : int; (* tk: %y *) - mutable ev_Char : string; (* tk: %A *) - mutable ev_BorderWidth : int; (* tk: %B *) - mutable ev_SendEvent : bool; (* tk: %E *) - mutable ev_KeySymString : string; (* tk: %K *) - mutable ev_KeySymInt : int; (* tk: %N *) - mutable ev_RootWindow : int; (* tk: %R *) - mutable ev_SubWindow : int; (* tk: %S *) - mutable ev_Type : int; (* tk: %T *) - mutable ev_Widget : any widget; (* tk: %W *) - mutable ev_RootX : int; (* tk: %X *) - mutable ev_RootY : int (* tk: %Y *) - } -;; -(* /type *) - - -(* To avoid collision with other constructors (Width, State), - use Ev_ prefix *) -(* type *) -type eventField = [ - | `Above - | `ButtonNumber - | `Count - | `Detail - | `Focus - | `Height - | `KeyCode - | `Mode - | `OverrideRedirect - | `Place - | `State - | `Time - | `Width - | `MouseX - | `MouseY - | `Char - | `BorderWidth - | `SendEvent - | `KeySymString - | `KeySymInt - | `RootWindow - | `SubWindow - | `Type - | `Widget - | `RootX - | `RootY -] -;; -(* /type *) - -let filleventInfo ev v : eventField -> unit = function - | `Above -> ev.ev_Above <- int_of_string v - | `ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v - | `Count -> ev.ev_Count <- int_of_string v - | `Detail -> ev.ev_Detail <- v - | `Focus -> ev.ev_Focus <- v = "1" - | `Height -> ev.ev_Height <- int_of_string v - | `KeyCode -> ev.ev_KeyCode <- int_of_string v - | `Mode -> ev.ev_Mode <- v - | `OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1" - | `Place -> ev.ev_Place <- v - | `State -> ev.ev_State <- v - | `Time -> ev.ev_Time <- int_of_string v - | `Width -> ev.ev_Width <- int_of_string v - | `MouseX -> ev.ev_MouseX <- int_of_string v - | `MouseY -> ev.ev_MouseY <- int_of_string v - | `Char -> ev.ev_Char <- v - | `BorderWidth -> ev.ev_BorderWidth <- int_of_string v - | `SendEvent -> ev.ev_SendEvent <- v = "1" - | `KeySymString -> ev.ev_KeySymString <- v - | `KeySymInt -> ev.ev_KeySymInt <- int_of_string v - | `RootWindow -> ev.ev_RootWindow <- int_of_string v - | `SubWindow -> ev.ev_SubWindow <- int_of_string v - | `Type -> ev.ev_Type <- int_of_string v - | `Widget -> ev.ev_Widget <- cTKtoCAMLwidget v - | `RootX -> ev.ev_RootX <- int_of_string v - | `RootY -> ev.ev_RootY <- int_of_string v -;; - -let wrapeventInfo f (what : eventField list) = - let ev = { - ev_Above = 0; - ev_ButtonNumber = 0; - ev_Count = 0; - ev_Detail = ""; - ev_Focus = false; - ev_Height = 0; - ev_KeyCode = 0; - ev_Mode = ""; - ev_OverrideRedirect = false; - ev_Place = ""; - ev_State = ""; - ev_Time = 0; - ev_Width = 0; - ev_MouseX = 0; - ev_MouseY = 0; - ev_Char = ""; - ev_BorderWidth = 0; - ev_SendEvent = false; - ev_KeySymString = ""; - ev_KeySymInt = 0; - ev_RootWindow = 0; - ev_SubWindow = 0; - ev_Type = 0; - ev_Widget = forget_type default_toplevel; - ev_RootX = 0; - ev_RootY = 0 } in - function args -> - let l = ref args in - List.iter what ~f: - begin fun field -> - match !l with - | [] -> () - | v :: rest -> filleventInfo ev v field; l := rest - end; - f ev -;; - -let rec writeeventField : eventField list -> string = function - | [] -> "" - | field :: rest -> - begin - match field with - | `Above -> " %a" - | `ButtonNumber ->" %b" - | `Count -> " %c" - | `Detail -> " %d" - | `Focus -> " %f" - | `Height -> " %h" - | `KeyCode -> " %k" - | `Mode -> " %m" - | `OverrideRedirect -> " %o" - | `Place -> " %p" - | `State -> " %s" - | `Time -> " %t" - | `Width -> " %w" - | `MouseX -> " %x" - | `MouseY -> " %y" - (* Quoting is done by Tk *) - | `Char -> " %A" - | `BorderWidth -> " %B" - | `SendEvent -> " %E" - | `KeySymString -> " %K" - | `KeySymInt -> " %N" - | `RootWindow ->" %R" - | `SubWindow -> " %S" - | `Type -> " %T" - | `Widget -> " %W" - | `RootX -> " %X" - | `RootY -> " %Y" - end - ^ writeeventField rest -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtin_bindtags.ml b/otherlibs/labltk/builtin/builtin_bindtags.ml deleted file mode 100644 index 35b82b9ddce6..000000000000 --- a/otherlibs/labltk/builtin/builtin_bindtags.ml +++ /dev/null @@ -1,20 +0,0 @@ -##ifdef CAMLTK - -(* type *) -type bindings = - | TagBindings of string (* tk option: *) - | WidgetBindings of widget (* tk option: *) -;; -(* /type *) - -##else - -(* type *) -type bindings = [ - | `Tag of string (* tk option: *) - | `Widget of any widget (* tk option: *) -] -;; -(* /type *) - -##endif diff --git a/otherlibs/labltk/builtin/builtin_font.ml b/otherlibs/labltk/builtin/builtin_font.ml deleted file mode 100644 index b865cda18dc1..000000000000 --- a/otherlibs/labltk/builtin/builtin_font.ml +++ /dev/null @@ -1,3 +0,0 @@ -(* type *) -type font = string -(* /type *) diff --git a/otherlibs/labltk/builtin/builtin_grab.ml b/otherlibs/labltk/builtin/builtin_grab.ml deleted file mode 100644 index 256926821dbd..000000000000 --- a/otherlibs/labltk/builtin/builtin_grab.ml +++ /dev/null @@ -1,3 +0,0 @@ -(* type *) -type grabGlobal = bool -(* /type *) diff --git a/otherlibs/labltk/builtin/builtin_index.ml b/otherlibs/labltk/builtin/builtin_index.ml deleted file mode 100644 index a42af5539065..000000000000 --- a/otherlibs/labltk/builtin/builtin_index.ml +++ /dev/null @@ -1,92 +0,0 @@ -(* Various indexes - canvas - entry - listbox -*) - -##ifdef CAMLTK - -(* A large type for all indices in all widgets *) -(* a bit overkill though *) - -(* type *) -type index = - | Number of int (* no keyword *) - | ActiveElement (* tk keyword: active *) - | End (* tk keyword: end *) - | Last (* tk keyword: last *) - | NoIndex (* tk keyword: none *) - | Insert (* tk keyword: insert *) - | SelFirst (* tk keyword: sel.first *) - | SelLast (* tk keyword: sel.last *) - | At of int (* tk keyword: @n *) - | AtXY of int * int (* tk keyword: @x,y *) - | AnchorPoint (* tk keyword: anchor *) - | Pattern of string (* no keyword *) - | LineChar of int * int (* tk keyword: l.c *) - | Mark of string (* no keyword *) - | TagFirst of string (* tk keyword: tag.first *) - | TagLast of string (* tk keyword: tag.last *) - | Embedded of widget (* no keyword *) -;; -(* /type *) - -##else - -type canvas_index = [ - | `Num of int - | `End - | `Insert - | `Selfirst - | `Sellast - | `Atxy of int * int -] -;; - -type entry_index = [ - | `Num of int - | `End - | `Insert - | `Selfirst - | `Sellast - | `At of int - | `Anchor -] -;; - -type listbox_index = [ - | `Num of int - | `Active - | `Anchor - | `End - | `Atxy of int * int -] -;; - -type menu_index = [ - | `Num of int - | `Active - | `End - | `Last - | `None - | `At of int - | `Pattern of string -] -;; - -type text_index = [ - | `Linechar of int * int - | `Atxy of int * int - | `End - | `Mark of string - | `Tagfirst of string - | `Taglast of string - | `Window of any widget - | `Image of string -] -;; - -type linechar_index = int * int;; -type num_index = int;; - -##endif diff --git a/otherlibs/labltk/builtin/builtin_palette.ml b/otherlibs/labltk/builtin/builtin_palette.ml deleted file mode 100644 index 4eab69a0f976..000000000000 --- a/otherlibs/labltk/builtin/builtin_palette.ml +++ /dev/null @@ -1,20 +0,0 @@ -##ifdef CAMLTK - -(* type *) -type paletteType = - | GrayShades of int - | RGBShades of int * int * int -;; -(* /type *) - -##else - -(* type *) -type paletteType = [ - | `Gray of int - | `Rgb of int * int * int -] -;; -(* /type *) - -##endif diff --git a/otherlibs/labltk/builtin/builtin_text.ml b/otherlibs/labltk/builtin/builtin_text.ml deleted file mode 100644 index b2d69589ba83..000000000000 --- a/otherlibs/labltk/builtin/builtin_text.ml +++ /dev/null @@ -1,50 +0,0 @@ -(* Not a string as such, more like a symbol *) - -(* type *) -type textMark = string;; -(* /type *) - -(* type *) -type textTag = string;; -(* /type *) - -##ifdef CAMLTK - -(* type *) -type textModifier = - | CharOffset of int (* tk keyword: +/- Xchars *) - | LineOffset of int (* tk keyword: +/- Xlines *) - | LineStart (* tk keyword: linestart *) - | LineEnd (* tk keyword: lineend *) - | WordStart (* tk keyword: wordstart *) - | WordEnd (* tk keyword: wordend *) -;; -(* /type *) - -(* type *) -type textIndex = - | TextIndex of index * textModifier list - | TextIndexNone -;; -(* /type *) - -##else - -(* type *) -type textModifier = [ - | `Char of int (* tk keyword: +/- Xchars *) - | `Line of int (* tk keyword: +/- Xlines *) - | `Linestart (* tk keyword: linestart *) - | `Lineend (* tk keyword: lineend *) - | `Wordstart (* tk keyword: wordstart *) - | `Wordend (* tk keyword: wordend *) -] -;; -(* /type *) - -(* type *) -type textIndex = text_index * textModifier list -;; -(* /type *) - -##endif diff --git a/otherlibs/labltk/builtin/builtina_empty.ml b/otherlibs/labltk/builtin/builtina_empty.ml deleted file mode 100644 index e69de29bb2d1..000000000000 diff --git a/otherlibs/labltk/builtin/builtinf_GetPixel.ml b/otherlibs/labltk/builtin/builtinf_GetPixel.ml deleted file mode 100644 index 45294d58c1be..000000000000 --- a/otherlibs/labltk/builtin/builtinf_GetPixel.ml +++ /dev/null @@ -1,23 +0,0 @@ -##ifdef CAMLTK - -let pixels units = - let res = - tkEval - [|TkToken"winfo"; - TkToken"pixels"; - cCAMLtoTKwidget widget_any_table default_toplevel; - cCAMLtoTKunits units|] in - int_of_string res - -##else - -let pixels units = - let res = - tkEval - [|TkToken"winfo"; - TkToken"pixels"; - cCAMLtoTKwidget default_toplevel; - cCAMLtoTKunits units|] in - int_of_string res - -##endif diff --git a/otherlibs/labltk/builtin/builtinf_bind.ml b/otherlibs/labltk/builtin/builtinf_bind.ml deleted file mode 100644 index 500fd6d32b8c..000000000000 --- a/otherlibs/labltk/builtin/builtinf_bind.ml +++ /dev/null @@ -1,133 +0,0 @@ -##ifdef CAMLTK - -(* type *) -type bindAction = - | BindSet of eventField list * (eventInfo -> unit) - | BindSetBreakable of eventField list * (eventInfo -> unit) - | BindRemove - | BindExtend of eventField list * (eventInfo -> unit) -(* /type *) - -(* -FUNCTION - val bind: - widget -> (modifier list * xEvent) list -> bindAction -> unit -/FUNCTION -*) -let bind widget eventsequence action = - tkCommand [| TkToken "bind"; - TkToken (Widget.name widget); - cCAMLtoTKeventSequence eventsequence; - begin match action with - BindRemove -> TkToken "" - | BindSet (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) - in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | BindSetBreakable (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) - in - TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0") - | BindExtend (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) - in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - end |] -;; - -(* FUNCTION -(* unsafe *) - val bind_class : - string -> (modifier list * xEvent) list -> bindAction -> unit -(* /unsafe *) -/FUNCTION class arg is not constrained *) - -let bind_class clas eventsequence action = - tkCommand [| TkToken "bind"; - TkToken clas; - cCAMLtoTKeventSequence eventsequence; - begin match action with - BindRemove -> TkToken "" - | BindSet (what, f) -> - let cbId = register_callback Widget.dummy - (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | BindSetBreakable (what, f) -> - let cbId = register_callback Widget.dummy - (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" ) - | BindExtend (what, f) -> - let cbId = register_callback Widget.dummy - (wrapeventInfo f what) in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - end |] -;; - -(* FUNCTION -(* unsafe *) - val bind_tag : - string -> (modifier list * xEvent) list -> bindAction -> unit -(* /unsafe *) -/FUNCTION *) - -let bind_tag = bind_class -;; - -(* -FUNCTION - val break : unit -> unit -/FUNCTION -*) -let break = function () -> - Textvariable.set (Textvariable.coerce "BreakBindingsSequence") "1" -;; - -(* Legacy functions *) -let tag_bind = bind_tag;; -let class_bind = bind_class;; - -##else - -let bind_class ~events ?(extend = false) ?(breakable = false) ?(fields = []) - ?action ?on:widget name = - let widget = match widget with None -> Widget.dummy | Some w -> coe w in - tkCommand - [| TkToken "bind"; - TkToken name; - cCAMLtoTKeventSequence events; - begin match action with None -> TkToken "" - | Some f -> - let cbId = - register_callback widget ~callback: (wrapeventInfo f fields) in - let cb = if extend then "+camlcb " else "camlcb " in - let cb = cb ^ cbId ^ writeeventField fields in - let cb = - if breakable then - cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" - ^ " ; set BreakBindingsSequence 0" - else cb in - TkToken cb - end - |] -;; - -let bind ~events ?extend ?breakable ?fields ?action widget = - bind_class ~events ?extend ?breakable ?fields ?action ~on:widget - (Widget.name widget) -;; - -let bind_tag = bind_class -;; - -(* -FUNCTION - val break : unit -> unit -/FUNCTION -*) -let break = function () -> - tkCommand [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |] -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_GetBitmap.ml b/otherlibs/labltk/builtin/builtini_GetBitmap.ml deleted file mode 100644 index 0c82a921d9fa..000000000000 --- a/otherlibs/labltk/builtin/builtini_GetBitmap.ml +++ /dev/null @@ -1,28 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKbitmap = function - BitmapFile s -> TkToken ("@" ^ s) -| Predefined s -> TkToken s -;; - -let cTKtoCAMLbitmap s = - if s = "" then Predefined "" - else if String.get s 0 = '@' - then BitmapFile (String.sub s 1 (String.length s - 1)) - else Predefined s -;; - -##else - -let cCAMLtoTKbitmap : bitmap -> tkArgs = function - | `File s -> TkToken ("@" ^ s) - | `Predefined s -> TkToken s -;; - -let cTKtoCAMLbitmap s = - if String.get s 0 = '@' - then `File (String.sub s ~pos:1 ~len:(String.length s - 1)) - else `Predefined s -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_GetCursor.ml b/otherlibs/labltk/builtin/builtini_GetCursor.ml deleted file mode 100644 index 4bbab73b8297..000000000000 --- a/otherlibs/labltk/builtin/builtini_GetCursor.ml +++ /dev/null @@ -1,55 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKcolor = function - NamedColor x -> TkToken x - | Black -> TkToken "black" - | White -> TkToken "white" - | Red -> TkToken "red" - | Green -> TkToken "green" - | Blue -> TkToken "blue" - | Yellow -> TkToken "yellow" -;; - -let cTKtoCAMLcolor = function s -> NamedColor s -;; - -let cCAMLtoTKcursor = function - XCursor s -> TkToken s - | XCursorFg (s,fg) -> - TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg]) - | XCursortFgBg (s,fg,bg) -> - TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) - | CursorFileFg (s,fg) -> - TkQuote(TkTokenList [TkToken ("@"^s); cCAMLtoTKcolor fg]) - | CursorMaskFile (s,m,fg,bg) -> - TkQuote(TkTokenList [TkToken ("@"^s); TkToken m; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) -;; - -##else - -let cCAMLtoTKcolor : color -> tkArgs = function - | `Color x -> TkToken x - | `Black -> TkToken "black" - | `White -> TkToken "white" - | `Red -> TkToken "red" - | `Green -> TkToken "green" - | `Blue -> TkToken "blue" - | `Yellow -> TkToken "yellow" -;; - -let cTKtoCAMLcolor = function s -> `Color s -;; - -let cCAMLtoTKcursor : cursor -> tkArgs = function - | `Xcursor s -> TkToken s - | `Xcursorfg (s,fg) -> - TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg]) - | `Xcursorfgbg (s,fg,bg) -> - TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) - | `Cursorfilefg (s,fg) -> - TkQuote(TkTokenList [TkToken ("@"^s); cCAMLtoTKcolor fg]) - | `Cursormaskfile (s,m,fg,bg) -> - TkQuote(TkTokenList [TkToken ("@"^s); TkToken m; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_GetPixel.ml b/otherlibs/labltk/builtin/builtini_GetPixel.ml deleted file mode 100644 index a4709748e331..000000000000 --- a/otherlibs/labltk/builtin/builtini_GetPixel.ml +++ /dev/null @@ -1,43 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKunits = function - Pixels (foo) -> TkToken (string_of_int foo) - | Millimeters (foo) -> TkToken(Printf.sprintf "%gm" foo) - | Inches (foo) -> TkToken(Printf.sprintf "%gi" foo) - | PrinterPoint (foo) -> TkToken(Printf.sprintf "%gp" foo) - | Centimeters (foo) -> TkToken(Printf.sprintf "%gc" foo) -;; - -let cTKtoCAMLunits str = - let len = String.length str in - let num_part str = String.sub str 0 (len - 1) in - match String.get str (pred len) with - 'c' -> Centimeters (float_of_string (num_part str)) - | 'i' -> Inches (float_of_string (num_part str)) - | 'm' -> Millimeters (float_of_string (num_part str)) - | 'p' -> PrinterPoint (float_of_string (num_part str)) - | _ -> Pixels(int_of_string str) -;; - -##else - -let cCAMLtoTKunits : units -> tkArgs = function - | `Pix (foo) -> TkToken (string_of_int foo) - | `Mm (foo) -> TkToken(Printf.sprintf "%gm" foo) - | `In (foo) -> TkToken(Printf.sprintf "%gi" foo) - | `Pt (foo) -> TkToken(Printf.sprintf "%gp" foo) - | `Cm (foo) -> TkToken(Printf.sprintf "%gc" foo) -;; - -let cTKtoCAMLunits str = - let len = String.length str in - let num_part str = String.sub str ~pos:0 ~len:(len - 1) in - match String.get str (pred len) with - | 'c' -> `Cm (float_of_string (num_part str)) - | 'i' -> `In (float_of_string (num_part str)) - | 'm' -> `Mm (float_of_string (num_part str)) - | 'p' -> `Pt (float_of_string (num_part str)) - | _ -> `Pix(int_of_string str) -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_ScrollValue.ml b/otherlibs/labltk/builtin/builtini_ScrollValue.ml deleted file mode 100644 index 7cdce1e02ddc..000000000000 --- a/otherlibs/labltk/builtin/builtini_ScrollValue.ml +++ /dev/null @@ -1,45 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKscrollValue = function - ScrollPage v1 -> - TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"pages"] - | ScrollUnit v1 -> - TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"units"] - | MoveTo v1 -> - TkTokenList [TkToken"moveto"; TkToken (Printf.sprintf "%g" v1)] -;; - -(* str l -> scrllv -> str l *) -let cTKtoCAMLscrollValue = function - "scroll"::n::("pages"|"page")::l -> - ScrollPage (int_of_string n), l - | "scroll"::n::"units"::l -> - ScrollUnit (int_of_string n), l - | "moveto"::f::l -> - MoveTo (float_of_string f), l - | l -> raise (Invalid_argument (String.concat " " ("TKtoCAMLscrollValue"::l))) -;; - -##else - -let cCAMLtoTKscrollValue : scrollValue -> tkArgs = function - | `Page v1 -> - TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"pages"] - | `Unit v1 -> - TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"units"] - | `Moveto v1 -> - TkTokenList [TkToken"moveto"; TkToken (Printf.sprintf "%g" v1)] -;; - -(* str l -> scrllv -> str l *) -let cTKtoCAMLscrollValue = function - | "scroll" :: n :: ("pages"|"page") :: 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 - | l -> raise (Invalid_argument (String.concat " " ("TKtoCAMLscrollValue"::l))) -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_bind.ml b/otherlibs/labltk/builtin/builtini_bind.ml deleted file mode 100644 index e7f9a0bb7527..000000000000 --- a/otherlibs/labltk/builtin/builtini_bind.ml +++ /dev/null @@ -1,136 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKxEvent = function - | Activate -> "Activate" - | ButtonPress -> "ButtonPress" - | ButtonPressDetail n -> "ButtonPress-"^string_of_int n - | ButtonRelease -> "ButtonRelease" - | ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n - | Circulate -> "Circulate" - | ColorMap -> "Colormap" - | Configure -> "Configure" - | Deactivate -> "Deactivate" - | Destroy -> "Destroy" - | Enter -> "Enter" - | Expose -> "Expose" - | FocusIn -> "FocusIn" - | FocusOut -> "FocusOut" - | Gravity -> "Gravity" - | KeyPress -> "KeyPress" - | KeyPressDetail s -> "KeyPress-"^s - | KeyRelease -> "KeyRelease" - | KeyReleaseDetail s -> "KeyRelease-"^s - | Leave -> "Leave" - | Map -> "Map" - | Motion -> "Motion" - | Property -> "Property" - | Reparent -> "Reparent" - | Unmap -> "Unmap" - | Visibility -> "Visibility" - | Virtual s -> "<"^s^">" -;; - -let cCAMLtoTKmodifier = function - | Control -> "Control-" - | Shift -> "Shift-" - | Lock -> "Lock-" - | Button1 -> "Button1-" - | Button2 -> "Button2-" - | Button3 -> "Button3-" - | Button4 -> "Button4-" - | Button5 -> "Button5-" - | Double -> "Double-" - | Triple -> "Triple-" - | Mod1 -> "Mod1-" - | Mod2 -> "Mod2-" - | Mod3 -> "Mod3-" - | Mod4 -> "Mod4-" - | Mod5 -> "Mod5-" - | Meta -> "Meta-" - | Alt -> "Alt-" -;; - -exception IllegalVirtualEvent - -(* type event = modifier list * xEvent *) -let cCAMLtoTKevent (ml, xe) = - match xe with - | Virtual s -> - if ml = [] then "<<"^s^">>" - else raise IllegalVirtualEvent - | _ -> - "<" ^ (String.concat " " (List.map cCAMLtoTKmodifier ml)) - ^ (cCAMLtoTKxEvent xe) ^ ">" -;; - -(* type eventSequence == (modifier list * xEvent) list *) -let cCAMLtoTKeventSequence l = - TkToken(List.fold_left (^) "" (List.map cCAMLtoTKevent l)) - -##else - -let cCAMLtoTKmodifier : modifier -> string = function - | `Control -> "Control-" - | `Shift -> "Shift-" - | `Lock -> "Lock-" - | `Button1 -> "Button1-" - | `Button2 -> "Button2-" - | `Button3 -> "Button3-" - | `Button4 -> "Button4-" - | `Button5 -> "Button5-" - | `Double -> "Double-" - | `Triple -> "Triple-" - | `Mod1 -> "Mod1-" - | `Mod2 -> "Mod2-" - | `Mod3 -> "Mod3-" - | `Mod4 -> "Mod4-" - | `Mod5 -> "Mod5-" - | `Meta -> "Meta-" - | `Alt -> "Alt-" -;; - -exception IllegalVirtualEvent - -let cCAMLtoTKevent (ev : event) = - let modified = ref false in - let rec convert = function - | `Activate -> "Activate" - | `ButtonPress -> "ButtonPress" - | `ButtonPressDetail n -> "ButtonPress-"^string_of_int n - | `ButtonRelease -> "ButtonRelease" - | `ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n - | `Circulate -> "Circulate" - | `Colormap -> "Colormap" - | `Configure -> "Configure" - | `Deactivate -> "Deactivate" - | `Destroy -> "Destroy" - | `Enter -> "Enter" - | `Expose -> "Expose" - | `FocusIn -> "FocusIn" - | `FocusOut -> "FocusOut" - | `Gravity -> "Gravity" - | `KeyPress -> "KeyPress" - | `KeyPressDetail s -> "KeyPress-"^s - | `KeyRelease -> "KeyRelease" - | `KeyReleaseDetail s -> "KeyRelease-"^s - | `Leave -> "Leave" - | `Map -> "Map" - | `Motion -> "Motion" - | `Property -> "Property" - | `Reparent -> "Reparent" - | `Unmap -> "Unmap" - | `Visibility -> "Visibility" - | `Virtual s -> - if !modified then raise IllegalVirtualEvent else "<"^s^">" - | `Modified(ml, ev) -> - modified := true; - String.concat ~sep:"" (List.map ~f:cCAMLtoTKmodifier ml) - ^ convert ev - in "<" ^ convert ev ^ ">" -;; - -let cCAMLtoTKeventSequence (l : event list) = - TkToken(String.concat ~sep:"" (List.map ~f:cCAMLtoTKevent l)) -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_bindtags.ml b/otherlibs/labltk/builtin/builtini_bindtags.ml deleted file mode 100644 index e09734870cbc..000000000000 --- a/otherlibs/labltk/builtin/builtini_bindtags.ml +++ /dev/null @@ -1,29 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKbindings = function - | WidgetBindings v1 -> cCAMLtoTKwidget widget_any_table v1 - | TagBindings v1 -> TkToken v1 -;; - -(* this doesn't really belong here *) -let cTKtoCAMLbindings s = - if String.length s > 0 && s.[0] = '.' then - WidgetBindings (cTKtoCAMLwidget s) - else TagBindings s -;; - -##else - -let cCAMLtoTKbindings = function -| `Widget v1 -> cCAMLtoTKwidget v1 -| `Tag v1 -> TkToken v1 -;; - -(* this doesn't really belong here *) -let cTKtoCAMLbindings s = - if String.length s > 0 && s.[0] = '.' then - `Widget (cTKtoCAMLwidget s) - else `Tag s -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_font.ml b/otherlibs/labltk/builtin/builtini_font.ml deleted file mode 100644 index 27a17501e147..000000000000 --- a/otherlibs/labltk/builtin/builtini_font.ml +++ /dev/null @@ -1,2 +0,0 @@ -let cCAMLtoTKfont (s : font) = TkToken s -let cTKtoCAMLfont (s : font) = s diff --git a/otherlibs/labltk/builtin/builtini_grab.ml b/otherlibs/labltk/builtin/builtini_grab.ml deleted file mode 100644 index 9007d04fa703..000000000000 --- a/otherlibs/labltk/builtin/builtini_grab.ml +++ /dev/null @@ -1,2 +0,0 @@ -let cCAMLtoTKgrabGlobal x = - if x then TkToken "-global" else TkTokenList [] diff --git a/otherlibs/labltk/builtin/builtini_index.ml b/otherlibs/labltk/builtin/builtini_index.ml deleted file mode 100644 index 3baa448f42fe..000000000000 --- a/otherlibs/labltk/builtin/builtini_index.ml +++ /dev/null @@ -1,140 +0,0 @@ -##ifdef CAMLTK - -(* sp to avoid being picked up by doc scripts *) - type index_constrs = - CNumber - | CActiveElement - | CEnd - | CLast - | CNoIndex - | CInsert - | CSelFirst - | CSelLast - | CAt - | CAtXY - | CAnchorPoint - | CPattern - | CLineChar - | CMark - | CTagFirst - | CTagLast - | CEmbedded -;; - -let index_any_table = - [CNumber; CActiveElement; CEnd; CLast; CNoIndex; CInsert; CSelFirst; - CSelLast; CAt; CAtXY; CAnchorPoint; CPattern; CLineChar; - CMark; CTagFirst; CTagLast; CEmbedded] -;; - -let index_canvas_table = - [CNumber; CEnd; CInsert; CSelFirst; CSelLast; CAtXY] -;; -let index_entry_table = - [CNumber; CAnchorPoint; CEnd; CInsert; CSelFirst; CSelLast; CAt] -;; -let index_listbox_table = - [CNumber; CActiveElement; CAnchorPoint; CEnd; CAtXY] -;; -let index_menu_table = - [CNumber; CActiveElement; CEnd; CLast; CNoIndex; CAt; CPattern] -;; -let index_text_table = - [CLineChar; CAtXY; CEnd; CMark; CTagFirst; CTagLast; CEmbedded] -;; - -let cCAMLtoTKindex table = function - Number x -> chk_sub "Number" table CNumber; TkToken (string_of_int x) - | ActiveElement -> chk_sub "ActiveElement" table CActiveElement; TkToken "active" - | End -> chk_sub "End" table CEnd; TkToken "end" - | Last -> chk_sub "Last" table CLast; TkToken "last" - | NoIndex -> chk_sub "NoIndex" table CNoIndex; TkToken "none" - | Insert -> chk_sub "Insert" table CInsert; TkToken "insert" - | SelFirst -> chk_sub "SelFirst" table CSelFirst; TkToken "sel.first" - | SelLast -> chk_sub "SelLast" table CSelLast; TkToken "sel.last" - | At n -> chk_sub "At" table CAt; TkToken ("@"^string_of_int n) - | AtXY (x,y) -> chk_sub "AtXY" table CAtXY; - TkToken ("@"^string_of_int x^","^string_of_int y) - | AnchorPoint -> chk_sub "AnchorPoint" table CAnchorPoint; TkToken "anchor" - | Pattern s -> chk_sub "Pattern" table CPattern; TkToken s - | LineChar (l,c) -> chk_sub "LineChar" table CLineChar; - TkToken (string_of_int l^"."^string_of_int c) - | Mark s -> chk_sub "Mark" table CMark; TkToken s - | TagFirst t -> chk_sub "TagFirst" table CTagFirst; - TkToken (t^".first") - | TagLast t -> chk_sub "TagLast" table CTagLast; - TkToken (t^".last") - | Embedded w -> chk_sub "Embedded" table CEmbedded; - cCAMLtoTKwidget widget_any_table w -;; - -let char_index c s = - let rec find i = - if i >= String.length s - then raise Not_found - else if String.get s i = c then i - else find (i+1) in - find 0 -;; - -(* Assume returned values are only numerical and l.c *) -(* .menu index returns none if arg is none, but blast it *) -let cTKtoCAMLindex s = - try - let p = char_index '.' s in - LineChar(int_of_string (String.sub s 0 p), - int_of_string (String.sub s (p+1) (String.length s - p - 1))) - with - Not_found -> - try Number (int_of_string s) - with _ -> raise (Invalid_argument ("TKtoCAMLindex: "^s)) -;; - -##else - -let cCAMLtoTKindex (* Don't put explicit typing *) = function - | `Num x -> TkToken (string_of_int x) - | `Active -> TkToken "active" - | `End -> TkToken "end" - | `Last -> TkToken "last" - | `None -> TkToken "none" - | `Insert -> TkToken "insert" - | `Selfirst -> TkToken "sel.first" - | `Sellast -> TkToken "sel.last" - | `At n -> TkToken ("@" ^ string_of_int n) - | `Atxy (x,y) -> TkToken ("@" ^ string_of_int x ^ "," ^ string_of_int y) - | `Anchor -> TkToken "anchor" - | `Pattern s -> TkToken s - | `Linechar (l,c) -> TkToken (string_of_int l ^ "." ^ string_of_int c) - | `Mark s -> TkToken s - | `Tagfirst t -> TkToken (t ^ ".first") - | `Taglast t -> TkToken (t ^ ".last") - | `Window (w : any widget) -> cCAMLtoTKwidget w - | `Image s -> TkToken s -;; - -let cCAMLtoTKcanvas_index = (cCAMLtoTKindex : canvas_index -> tkArgs);; -let cCAMLtoTKentry_index = (cCAMLtoTKindex : entry_index -> tkArgs);; -let cCAMLtoTKlistbox_index = (cCAMLtoTKindex : listbox_index -> tkArgs);; -let cCAMLtoTKmenu_index = (cCAMLtoTKindex : menu_index -> tkArgs);; -let cCAMLtoTKtext_index = (cCAMLtoTKindex : text_index -> tkArgs);; - -(* Assume returned values are only numerical and l.c *) - -let cTKtoCAMLtext_index s = - try - let p = String.index s '.' in - `Linechar (int_of_string (String.sub s ~pos:0 ~len:p), - int_of_string (String.sub s ~pos:(p + 1) - ~len:(String.length s - p - 1))) - with - Not_found -> - raise (Invalid_argument ("TKtoCAMLtext_index: " ^ s)) -;; - -let cTKtoCAMLlistbox_index s = - try `Num (int_of_string s) - with _ -> raise (Invalid_argument ("TKtoCAMLlistbox_index: " ^ s)) -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_palette.ml b/otherlibs/labltk/builtin/builtini_palette.ml deleted file mode 100644 index e1fe37dbe400..000000000000 --- a/otherlibs/labltk/builtin/builtini_palette.ml +++ /dev/null @@ -1,19 +0,0 @@ -##ifdef CAMLTK - -let cCAMLtoTKpaletteType = function - GrayShades (foo) -> TkToken (string_of_int foo) - | RGBShades (r,v,b) -> TkToken (string_of_int r^"/"^ - string_of_int v^"/"^ - string_of_int b) -;; - -##else - -let cCAMLtoTKpaletteType : paletteType -> tkArgs = function - | `Gray (foo) -> TkToken (string_of_int foo) - | `Rgb (r,v,b) -> TkToken (string_of_int r ^ "/" ^ - string_of_int v ^ "/" ^ - string_of_int b) -;; - -##endif diff --git a/otherlibs/labltk/builtin/builtini_text.ml b/otherlibs/labltk/builtin/builtini_text.ml deleted file mode 100644 index 4db49c05e9da..000000000000 --- a/otherlibs/labltk/builtin/builtini_text.ml +++ /dev/null @@ -1,64 +0,0 @@ -let cCAMLtoTKtextMark x = TkToken x;; -let cTKtoCAMLtextMark x = x;; - -let cCAMLtoTKtextTag x = TkToken x;; -let cTKtoCAMLtextTag x = x;; - -##ifdef CAMLTK - -(* TextModifiers are never returned by Tk *) -let ppTextModifier = function - CharOffset n -> - if n > 0 then "+" ^ (string_of_int n) ^ "chars" - else if n = 0 then "" - else (string_of_int n) ^ "chars" - | LineOffset n -> - if n > 0 then "+" ^ (string_of_int n) ^ "lines" - else if n = 0 then "" - else (string_of_int n) ^ "lines" - | LineStart -> " linestart" - | LineEnd -> " lineend" - | WordStart -> " wordstart" - | WordEnd -> " wordend" -;; - -let ppTextIndex = function - | TextIndexNone -> "" - | TextIndex (base, ml) -> - match cCAMLtoTKindex index_text_table base with - | TkToken ppbase -> List.fold_left (^) ppbase (List.map ppTextModifier ml) - | _ -> assert false -;; - -let cCAMLtoTKtextIndex i = - TkToken (ppTextIndex i) -;; - -##else - -(* TextModifiers are never returned by Tk *) -let cCAMLtoTKtextIndex (i : textIndex) = - let ppTextModifier = function - | `Char n -> - if n > 0 then "+" ^ (string_of_int n) ^ "chars" - else if n = 0 then "" - else (string_of_int n) ^ "chars" - | `Line n -> - if n > 0 then "+" ^ (string_of_int n) ^ "lines" - else if n = 0 then "" - else (string_of_int n) ^ "lines" - | `Linestart -> " linestart" - | `Lineend -> " lineend" - | `Wordstart -> " wordstart" - | `Wordend -> " wordend" - in - let ppTextIndex (base, ml : textIndex) = - match cCAMLtoTKtext_index base with - TkToken ppbase -> - String.concat ~sep:"" (ppbase :: List.map ~f:ppTextModifier ml) - | _ -> assert false - in - TkToken (ppTextIndex i) -;; - -##endif diff --git a/otherlibs/labltk/builtin/canvas_bind.ml b/otherlibs/labltk/builtin/canvas_bind.ml deleted file mode 100644 index 9256a74c00e0..000000000000 --- a/otherlibs/labltk/builtin/canvas_bind.ml +++ /dev/null @@ -1,52 +0,0 @@ -##ifdef CAMLTK - -let bind widget tag eventsequence action = - tkCommand [| - cCAMLtoTKwidget widget_canvas_table widget; - TkToken "bind"; - cCAMLtoTKtagOrId tag; - cCAMLtoTKeventSequence eventsequence; - begin match action with - | BindRemove -> TkToken "" - | BindSet (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | BindSetBreakable (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \ - set BreakBindingsSequence 0") - | BindExtend (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - end - |] -;; - -##else - -let bind ~events - ?(extend = false) ?(breakable = false) ?(fields = []) - ?action widget tag = - tkCommand - [| cCAMLtoTKwidget widget; - TkToken "bind"; - cCAMLtoTKtagOrId tag; - cCAMLtoTKeventSequence events; - begin match action with None -> TkToken "" - | Some f -> - let cbId = - register_callback widget ~callback: (wrapeventInfo f fields) in - let cb = if extend then "+camlcb " else "camlcb " in - let cb = cb ^ cbId ^ writeeventField fields in - let cb = - if breakable then - cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" - ^ " ; set BreakBindingsSequence 0" - else cb in - TkToken cb - end - |] -;; - -##endif diff --git a/otherlibs/labltk/builtin/canvas_bind.mli b/otherlibs/labltk/builtin/canvas_bind.mli deleted file mode 100644 index 0c6c58373df3..000000000000 --- a/otherlibs/labltk/builtin/canvas_bind.mli +++ /dev/null @@ -1,16 +0,0 @@ -##ifdef CAMLTK - -val bind : widget -> tagOrId -> - (modifier list * xEvent) list -> bindAction -> unit - -##else - -val bind : - events: event list -> - ?extend: bool -> - ?breakable: bool -> - ?fields: eventField list -> - ?action: (eventInfo -> unit) -> - canvas widget -> tagOrId -> unit - -##endif diff --git a/otherlibs/labltk/builtin/dialog.ml b/otherlibs/labltk/builtin/dialog.ml deleted file mode 100644 index e6654d8c4680..000000000000 --- a/otherlibs/labltk/builtin/dialog.ml +++ /dev/null @@ -1,45 +0,0 @@ -##ifdef CAMLTK - -let create ?name parent title mesg bitmap def buttons = - let w = Widget.new_atom "toplevel" ~parent ?name in - let res = tkEval [|TkToken"tk_dialog"; - cCAMLtoTKwidget widget_any_table w; - TkToken title; - TkToken mesg; - cCAMLtoTKbitmap bitmap; - TkToken (string_of_int def); - TkTokenList (List.map (function x -> TkToken x) buttons)|] - in - int_of_string res -;; - -let create_named parent name title mesg bitmap def buttons = - let w = Widget.new_atom "toplevel" ~parent ~name in - let res = tkEval [|TkToken"tk_dialog"; - cCAMLtoTKwidget widget_any_table w; - TkToken title; - TkToken mesg; - cCAMLtoTKbitmap bitmap; - TkToken (string_of_int def); - TkTokenList (List.map (function x -> TkToken x) buttons)|] - in - int_of_string res -;; - -##else - -let create ~parent ~title ~message ~buttons ?name - ?(bitmap = `Predefined "") ?(default = -1) () = - let w = Widget.new_atom "toplevel" ?name ~parent in - let res = tkEval [|TkToken"tk_dialog"; - cCAMLtoTKwidget w; - TkToken title; - TkToken message; - cCAMLtoTKbitmap bitmap; - TkToken (string_of_int default); - TkTokenList (List.map ~f:(fun x -> TkToken x) buttons)|] - in - int_of_string res -;; - -##endif diff --git a/otherlibs/labltk/builtin/dialog.mli b/otherlibs/labltk/builtin/dialog.mli deleted file mode 100644 index 532045cb2ba7..000000000000 --- a/otherlibs/labltk/builtin/dialog.mli +++ /dev/null @@ -1,24 +0,0 @@ -##ifdef CAMLTK - -val create : ?name: string -> - widget -> string -> string -> bitmap -> int -> string list -> int - (* [create ~name parent title message bitmap default button_names] - cf. tk_dialog *) - -val create_named : - widget -> string -> string -> string -> bitmap -> int -> string list -> int - (* [create_named parent name title message bitmap default button_names] - cf. tk_dialog *) - -##else - -val create : - parent: 'a widget -> - title: string -> - message: string -> - buttons: string list -> - ?name: string -> ?bitmap: bitmap -> ?default: int -> unit ->int - (* [create title message bitmap default button_names parent] - cf. tk_dialog *) - -##endif diff --git a/otherlibs/labltk/builtin/image.ml b/otherlibs/labltk/builtin/image.ml deleted file mode 100644 index a1fd2eab864d..000000000000 --- a/otherlibs/labltk/builtin/image.ml +++ /dev/null @@ -1,33 +0,0 @@ -##ifdef CAMLTK - -let cTKtoCAMLimage s = - let res = tkEval [|TkToken "image"; TkToken "type"; TkToken s|] in - match res with - | "bitmap" -> ImageBitmap (BitmapImage s) - | "photo" -> ImagePhoto (PhotoImage s) - | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\"")) -;; - -let names () = - let res = tkEval [|TkToken "image"; TkToken "names"|] in - let names = splitlist res in - List.map cTKtoCAMLimage names -;; - -##else - -let cTKtoCAMLimage s = - let res = tkEval [|TkToken "image"; TkToken "type"; TkToken s|] in - match res with - | "bitmap" -> `Bitmap s - | "photo" -> `Photo s - | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\"")) -;; - -let names () = - let res = tkEval [|TkToken "image"; TkToken "names"|] in - let names = splitlist res in - List.map cTKtoCAMLimage names -;; - -##endif diff --git a/otherlibs/labltk/builtin/image.mli b/otherlibs/labltk/builtin/image.mli deleted file mode 100644 index a92a9f8c70c2..000000000000 --- a/otherlibs/labltk/builtin/image.mli +++ /dev/null @@ -1,9 +0,0 @@ -##ifdef CAMLTK - -val names : unit -> options list - -##else - -val names : unit -> image list - -##endif diff --git a/otherlibs/labltk/builtin/optionmenu.ml b/otherlibs/labltk/builtin/optionmenu.ml deleted file mode 100644 index 5a17e3ffd735..000000000000 --- a/otherlibs/labltk/builtin/optionmenu.ml +++ /dev/null @@ -1,54 +0,0 @@ -##ifdef CAMLTK - -open Protocol;; -(* Implementation of the tk_optionMenu *) - -let create ?name parent variable values = - let w = Widget.new_atom "menubutton" ~parent ?name in - let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in - let res = - tkEval [|TkToken "tk_optionMenu"; - TkToken (Widget.name w); - cCAMLtoTKtextVariable variable; - TkTokenList (List.map (function x -> TkToken x) values)|] in - if res <> Widget.name mw then - raise (TkError "internal error in Optionmenu.create") - else - w,mw -;; - -let create_named parent name variable values = - let w = Widget.new_atom "menubutton" ~parent ~name in - let mw = Widget.new_atom "menu" ~parent:w ~name: "menu" in - let res = - tkEval [|TkToken "tk_optionMenu"; - TkToken (Widget.name w); - cCAMLtoTKtextVariable variable; - TkTokenList (List.map (function x -> TkToken x) values)|] in - if res <> Widget.name mw then - raise (TkError "internal error in Optionmenu.create") - else - w,mw -;; - -##else - -open Protocol;; -(* Implementation of the tk_optionMenu *) - -let create ~parent ~variable ?name values = - let w = Widget.new_atom "menubutton" ~parent ?name in - let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in - (* assumes .menu naming *) - let res = - tkEval [|TkToken "tk_optionMenu"; - TkToken (Widget.name w); - cCAMLtoTKtextVariable variable; - TkTokenList (List.map ~f:(fun x -> TkToken x) values)|] in - if res <> Widget.name mw then - raise (TkError "internal error in Optionmenu.create") - else - w, mw -;; - -##endif diff --git a/otherlibs/labltk/builtin/optionmenu.mli b/otherlibs/labltk/builtin/optionmenu.mli deleted file mode 100644 index c58795796a36..000000000000 --- a/otherlibs/labltk/builtin/optionmenu.mli +++ /dev/null @@ -1,21 +0,0 @@ -##ifdef CAMLTK - -(* Support for tk_optionMenu *) -val create: ?name: string -> - widget -> textVariable -> string list -> widget * widget -(** [create ?name parent var options] creates a multi-option menubutton and - its associated menu. The option is also stored in the variable. - Both widgets (menubutton and menu) are returned. *) - -##else - -(* Support for tk_optionMenu *) -val create: - parent:'a widget -> - variable:textVariable -> - ?name: string -> string list -> menubutton widget * menu widget -(** [create ~parent ~var ~name options] creates a multi-option menubutton - and its associated menu. The option is also stored in the variable. - Both widgets (menubutton and menu) are returned *) - -##endif diff --git a/otherlibs/labltk/builtin/rawimg.ml b/otherlibs/labltk/builtin/rawimg.ml deleted file mode 100644 index 6bd0ad283878..000000000000 --- a/otherlibs/labltk/builtin/rawimg.ml +++ /dev/null @@ -1,142 +0,0 @@ -external rawget : string -> string - = "camltk_getimgdata" -external rawset : string -> string -> int -> int -> int -> int -> unit - = "camltk_setimgdata_bytecode" (* all int parameters MUST be positive *) - "camltk_setimgdata_native" - -type t = { - pixmap_width : int; - pixmap_height: int; - pixmap_data: string -} - -type pixel = string (* 3 chars *) - -(* pixmap will be an abstract type *) -let width pix = pix.pixmap_width -let height pix = pix.pixmap_height - - -(* note: invalid size would have been caught by String.create, but we put - * it here for documentation purpose *) -let create w h = - if w < 0 || h < 0 then invalid_arg "invalid size" - else { - pixmap_width = w; - pixmap_height = h; - pixmap_data = String.create (w * h * 3); - } - -(* - * operations on pixmaps - *) -let unsafe_copy pix_from pix_to = - String.unsafe_blit pix_from.pixmap_data 0 - pix_to.pixmap_data 0 - (String.length pix_from.pixmap_data) - -(* We check only the length. w,h might be different... *) -let copy pix_from pix_to = - let l = String.length pix_from.pixmap_data in - if l <> String.length pix_to.pixmap_data then - raise (Invalid_argument "copy: incompatible length") - else unsafe_copy pix_from pix_to - - -(* Pixel operations *) -let unsafe_get_pixel pixmap x y = - let pos = (y * pixmap.pixmap_width + x) * 3 in - let r = String.create 3 in - String.unsafe_blit pixmap.pixmap_data pos r 0 3; - r - -let unsafe_set_pixel pixmap x y pixel = - let pos = (y * pixmap.pixmap_width + x) * 3 in - String.unsafe_blit pixel 0 pixmap.pixmap_data pos 3 - -(* To get safe operations, we can either check x,y wrt [0,w[ and [0,h[ - or rely on blit checking. We choose the first for clarity. - *) -let get_pixel pix x y = - if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height - then invalid_arg "invalid pixel" - else unsafe_get_pixel pix x y - -(* same check (pixel being abstract, it must be of good size *) -let set_pixel pix x y pixel = - if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height - then invalid_arg "invalid pixel" - else unsafe_set_pixel pix x y pixel - -(* black as default_color, if at all needed *) -let default_color = "\000\000\000" - -(* Char.chr does range checking *) -let pixel r g b = - let s = String.create 3 in - s.[0] <- Char.chr r; - s.[1] <- Char.chr g; - s.[2] <- Char.chr b; - s - -##ifdef CAMLTK - -(* create pixmap from an existing image *) -let get photo = - match photo with - | PhotoImage s -> { - pixmap_width = CImagephoto.width photo; - pixmap_height = CImagephoto.height photo; - pixmap_data = rawget s; - } - -(* copy a full pixmap into an image *) -let set photo pix = - match photo with - | PhotoImage s -> - rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height - -(* general blit of pixmap into image *) -let blit photo pix x y w h = - if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument" - else match photo with - | PhotoImage s -> - rawset s pix.pixmap_data x y w h - -(* get from a file *) -let from_file filename = - let img = CImagephoto.create [File filename] in - let pix = get img in - CImagephoto.delete img; - pix - -##else - -(* create pixmap from an existing image *) -let get photo = - match photo with - | `Photo s -> { - pixmap_width = Imagephoto.width photo; - pixmap_height = Imagephoto.height photo; - pixmap_data = rawget s; - } - -(* copy a full pixmap into an image *) -let set photo pix = - match photo with - | `Photo s -> rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height - -(* general blit of pixmap into image *) -let blit photo pix x y w h = - if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument" - else match photo with - | `Photo s -> rawset s pix.pixmap_data x y w h - -(* get from a file *) -let from_file filename = - let img = Imagephoto.create ~file: filename () in - let pix = get img in - Imagephoto.delete img; - pix - -##endif diff --git a/otherlibs/labltk/builtin/rawimg.mli b/otherlibs/labltk/builtin/rawimg.mli deleted file mode 100644 index 1bb120f6489f..000000000000 --- a/otherlibs/labltk/builtin/rawimg.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* - * Minimal pixmap support - *) - -type t -type pixel - -val width : t -> int - (* [width pixmap] *) -val height : t -> int - (* [height pixmap] *) - -val create : int -> int -> t - (* [create width height] *) -val get : imagePhoto -> t - (* [get img] *) -val set : imagePhoto -> t -> unit - (* [set img pixmap] *) -val blit : imagePhoto -> t -> int -> int -> int -> int -> unit - (* [blit img pixmap x y w h] (all ints must be non-negative) *) -val from_file : string -> t - (* [from_file filename] *) - -val copy : t -> t -> unit - (* [copy src dst] *) - -(* - * Pixel operations - *) -val get_pixel : t -> int -> int -> pixel - (* [get_pixel pixmap x y] *) -val set_pixel : t -> int -> int -> pixel -> unit - (* [set_pixel pixmap x y pixel] *) -val default_color : pixel - -val pixel : int -> int -> int -> pixel - (* [pixel r g b] (r,g,b must be in [0..255]) *) - -(*-*) -(* unsafe *) -val unsafe_copy : t -> t -> unit -val unsafe_get_pixel : t -> int -> int -> pixel -val unsafe_set_pixel : t -> int -> int -> pixel -> unit -(* /unsafe *) diff --git a/otherlibs/labltk/builtin/report.ml b/otherlibs/labltk/builtin/report.ml deleted file mode 100644 index 852b4c141cf2..000000000000 --- a/otherlibs/labltk/builtin/report.ml +++ /dev/null @@ -1,17 +0,0 @@ -(* Report globals from protocol *) -let opentk = Protocol.opentk -let keywords = Protocol.keywords -let opentk_with_args = Protocol.opentk_with_args -let openTk = Protocol.openTk -let openTkClass = Protocol.openTkClass -let openTkDisplayClass = Protocol.openTkDisplayClass -let closeTk = Protocol.closeTk -let mainLoop = Protocol.mainLoop -let register = Protocol.register - -(* From support *) -let may = Support.may -let maycons = Support.maycons - -(* From widget *) -let coe = Widget.coe diff --git a/otherlibs/labltk/builtin/selection_handle_set.ml b/otherlibs/labltk/builtin/selection_handle_set.ml deleted file mode 100644 index 2dfc5763f7ec..000000000000 --- a/otherlibs/labltk/builtin/selection_handle_set.ml +++ /dev/null @@ -1,41 +0,0 @@ -##ifdef CAMLTK - -(* The function *must* use tkreturn *) -let handle_set opts w cmd = - tkCommand [| - TkToken"selection"; - TkToken"handle"; - TkTokenList - (List.map - (function x -> cCAMLtoTKicccm w icccm_selection_handle_table x) - opts); - cCAMLtoTKwidget widget_any_table w; - let id = register_callback w (function args -> - let (a1,args) = int_of_string (List.hd args), List.tl args in - let (a2,args) = int_of_string (List.hd args), List.tl args in - cmd a1 a2) in - TkToken ("camlcb "^id) - |] -;; - -##else - -(* The function *must* use tkreturn *) -let handle_set ~command = -selection_handle_icccm_optionals (fun opts w -> - tkCommand [| - TkToken"selection"; - TkToken"handle"; - TkTokenList opts; - cCAMLtoTKwidget w; - let id = register_callback w ~callback: - begin fun args -> - let pos = int_of_string (List.hd args) in - let len = int_of_string (List.nth args 1) in - tkreturn (command ~pos ~len) - end - in TkToken ("camlcb " ^ id) - |]) -;; - -##endif diff --git a/otherlibs/labltk/builtin/selection_handle_set.mli b/otherlibs/labltk/builtin/selection_handle_set.mli deleted file mode 100644 index 3778e274bc39..000000000000 --- a/otherlibs/labltk/builtin/selection_handle_set.mli +++ /dev/null @@ -1,13 +0,0 @@ -##ifdef CAMLTK - -val handle_set : icccm list -> widget -> (int -> int -> unit) -> unit -(** tk invocation: selection handle *) - -##else - -val handle_set : - command: (pos:int -> len:int -> string) -> - ?format: string -> ?selection:string -> ?typ: string -> 'a widget -> unit -(** tk invocation: selection handle *) - -##endif diff --git a/otherlibs/labltk/builtin/selection_own_set.ml b/otherlibs/labltk/builtin/selection_own_set.ml deleted file mode 100644 index 9a4b1f16bb32..000000000000 --- a/otherlibs/labltk/builtin/selection_own_set.ml +++ /dev/null @@ -1,29 +0,0 @@ -##ifdef CAMLTK - -(* builtin to handle callback association to widget *) -let own_set v1 v2 = - tkCommand [| - TkToken"selection"; - TkToken"own"; - TkTokenList - (List.map - (function x -> cCAMLtoTKicccm v2 icccm_selection_ownset_table x) - v1); - cCAMLtoTKwidget widget_any_table v2 - |] -;; - -##else - -(* builtin to handle callback association to widget *) -let own_set ?command = - selection_ownset_icccm_optionals ?command (fun opts w -> - tkCommand [| - TkToken"selection"; - TkToken"own"; - TkTokenList opts; - cCAMLtoTKwidget w - |]) -;; - -##endif diff --git a/otherlibs/labltk/builtin/selection_own_set.mli b/otherlibs/labltk/builtin/selection_own_set.mli deleted file mode 100644 index 868a8248be11..000000000000 --- a/otherlibs/labltk/builtin/selection_own_set.mli +++ /dev/null @@ -1,12 +0,0 @@ -##ifdef CAMLTK - -val own_set : icccm list -> widget -> unit -(** tk invocation: selection own *) - -##else - -val own_set : - ?command:(unit->unit) -> ?selection:string -> 'a widget -> unit -(** tk invocation: selection own *) - -##endif diff --git a/otherlibs/labltk/builtin/text_tag_bind.ml b/otherlibs/labltk/builtin/text_tag_bind.ml deleted file mode 100644 index 72e9f0463659..000000000000 --- a/otherlibs/labltk/builtin/text_tag_bind.ml +++ /dev/null @@ -1,55 +0,0 @@ -##ifdef CAMLTK - -let tag_bind widget tag eventsequence action = - check_class widget widget_text_table; - tkCommand [| - cCAMLtoTKwidget widget_text_table widget; - TkToken "tag"; - TkToken "bind"; - cCAMLtoTKtextTag tag; - cCAMLtoTKeventSequence eventsequence; - begin match action with - | BindRemove -> TkToken "" - | BindSet (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | BindSetBreakable (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \ - set BreakBindingsSequence 0") - | BindExtend (what, f) -> - let cbId = register_callback widget (wrapeventInfo f what) in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - end - |] -;; - -##else - -let tag_bind ~tag ~events ?(extend = false) ?(breakable = false) - ?(fields = []) ?action widget = - tkCommand [| - cCAMLtoTKwidget widget; - TkToken "tag"; - TkToken "bind"; - cCAMLtoTKtextTag tag; - cCAMLtoTKeventSequence events; - begin match action with - | None -> TkToken "" - | Some f -> - let cbId = - register_callback widget ~callback: (wrapeventInfo f fields) in - let cb = if extend then "+camlcb " else "camlcb " in - let cb = cb ^ cbId ^ writeeventField fields in - let cb = - if breakable then - cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" - ^ " ; set BreakBindingsSequence 0" - else cb in - TkToken cb - end - |] -;; - -##endif diff --git a/otherlibs/labltk/builtin/text_tag_bind.mli b/otherlibs/labltk/builtin/text_tag_bind.mli deleted file mode 100644 index 6778e4ff1110..000000000000 --- a/otherlibs/labltk/builtin/text_tag_bind.mli +++ /dev/null @@ -1,13 +0,0 @@ -##ifdef CAMLTK - -val tag_bind: - widget -> textTag -> (modifier list * xEvent) list -> bindAction -> unit - -##else - -val tag_bind : - tag: string -> events: event list -> - ?extend: bool -> ?breakable: bool -> ?fields: eventField list -> - ?action: (eventInfo -> unit) -> text widget -> unit - -##endif diff --git a/otherlibs/labltk/builtin/winfo_contained.ml b/otherlibs/labltk/builtin/winfo_contained.ml deleted file mode 100644 index f1fb3735ca43..000000000000 --- a/otherlibs/labltk/builtin/winfo_contained.ml +++ /dev/null @@ -1,13 +0,0 @@ -##ifdef CAMLTK - -let contained x y w = - w = containing x y -;; - -##else - -let contained ~x ~y w = - forget_type w = containing ~x ~y () -;; - -##endif diff --git a/otherlibs/labltk/builtin/winfo_contained.mli b/otherlibs/labltk/builtin/winfo_contained.mli deleted file mode 100644 index 41cc57c0f180..000000000000 --- a/otherlibs/labltk/builtin/winfo_contained.mli +++ /dev/null @@ -1,11 +0,0 @@ -##ifdef CAMLTK - -val contained : int -> int -> widget -> bool -(** [contained x y w] returns true if (x,y) is in w *) - -##else - -val contained : x:int -> y:int -> 'a widget -> bool -(** [contained x y w] returns true if (x,y) is in w *) - -##endif diff --git a/otherlibs/labltk/camltk/.ignore b/otherlibs/labltk/camltk/.ignore deleted file mode 100644 index 81bd183eb8dc..000000000000 --- a/otherlibs/labltk/camltk/.ignore +++ /dev/null @@ -1,4 +0,0 @@ -*.ml -*.mli -labltktop -labltk diff --git a/otherlibs/labltk/camltk/Makefile b/otherlibs/labltk/camltk/Makefile deleted file mode 100644 index 4b108caeb9f8..000000000000 --- a/otherlibs/labltk/camltk/Makefile +++ /dev/null @@ -1,61 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 2002 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -include ../support/Makefile.common - -COMPFLAGS= -I ../support - -TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo - -all: camltkobjs - -opt: camltkobjsx - -include ./modules - -CAMLTKOBJS= $(CWIDGETOBJS) cTk.cmo camltk.cmo -CAMLTKOBJSX = $(CAMLTKOBJS:.cmo=.cmx) - -camltkobjs: $(CAMLTKOBJS) - -camltkobjsx: $(CAMLTKOBJSX) - -clean: - $(MAKE) -f Makefile.gen clean - -install: $(CAMLTKOBJS) - if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(CAMLTKOBJS:.cmo=.cmi) $(CWIDGETOBJS:.cmo=.mli) $(INSTALLDIR) - chmod 644 $(INSTALLDIR)/*.cmi - -installopt: $(CAMLTKOBJSX) - @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(CAMLTKOBJSX) $(INSTALLDIR) - chmod 644 $(INSTALLDIR)/*.cmx - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -nojoin -c $(COMPFLAGS) $< - -include .depend diff --git a/otherlibs/labltk/camltk/Makefile.gen b/otherlibs/labltk/camltk/Makefile.gen deleted file mode 100644 index 78152505a016..000000000000 --- a/otherlibs/labltk/camltk/Makefile.gen +++ /dev/null @@ -1,62 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 2002 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -include ../support/Makefile.common - -all: cTk.ml camltk.ml .depend - -_tkgen.ml: ../Widgets.src ../compiler/tkcompiler - cd ..; $(CAMLRUNGEN) compiler/tkcompiler -camltk -outdir camltk - -cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../builtin/builtin_*.ml - (echo '##define CAMLTK'; \ - echo 'include Camltkwrap'; \ - echo 'open Widget'; \ - echo 'open Protocol'; \ - echo 'open Textvariable'; \ - echo ; \ - cat ../builtin/report.ml; \ - echo ; \ - cat ../builtin/builtin_*.ml; \ - echo ; \ - cat _tkgen.ml; \ - echo ; \ - echo ; \ - echo 'module Tkintf = struct'; \ - cat ../builtin/builtini_*.ml; \ - cat _tkigen.ml; \ - echo 'end (* module Tkintf *)'; \ - echo ; \ - echo ; \ - echo 'open Tkintf' ;\ - echo ; \ - echo ; \ - cat ../builtin/builtinf_*.ml; \ - cat _tkfgen.ml; \ - echo ; \ - ) > _cTk.ml - $(CAMLRUN) ../compiler/pp < _cTk.ml > cTk.ml - rm -f _cTk.ml - $(CAMLDEP) -I ../support [a-z]*.mli [a-z]*.ml > .depend - -../compiler/pp: - cd ../compiler; $(MAKE) pp - -# All .{ml,mli} files are generated in this directory -clean: - rm -f *.cm* *.ml *.mli *.o *.a .depend - -# rm -f modules diff --git a/otherlibs/labltk/camltk/Makefile.gen.nt b/otherlibs/labltk/camltk/Makefile.gen.nt deleted file mode 100644 index 4fdba7713f6a..000000000000 --- a/otherlibs/labltk/camltk/Makefile.gen.nt +++ /dev/null @@ -1,46 +0,0 @@ -include ../support/Makefile.common.nt - -all: cTk.ml camltk.ml .depend - -_tkgen.ml: ../Widgets.src ../compiler/tkcompiler.exe - cd .. ; $(CAMLRUNGEN) compiler/tkcompiler.exe -camltk -outdir camltk - -# dependencies are broken: wouldn't work with gmake 3.77 - -cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp.exe #../builtin/builtin_*.ml - (echo '##define CAMLTK'; \ - echo 'include Camltkwrap'; \ - echo 'open Widget'; \ - echo 'open Protocol'; \ - echo 'open Textvariable'; \ - echo ; \ - cat ../builtin/report.ml; \ - echo ; \ - cat ../builtin/builtin_*.ml; \ - echo ; \ - cat _tkgen.ml; \ - echo ; \ - echo ; \ - echo 'module Tkintf = struct'; \ - cat ../builtin/builtini_*.ml; \ - cat _tkigen.ml; \ - echo 'end (* module Tkintf *)'; \ - echo ; \ - echo ; \ - echo 'open Tkintf' ;\ - echo ; \ - echo ; \ - cat ../builtin/builtinf_*.ml; \ - cat _tkfgen.ml; \ - echo ; \ - ) > _cTk.ml - $(CAMLRUN) ../compiler/pp < _cTk.ml > cTk.ml - rm -f _cTk.ml - $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend - -../compiler/pp.exe: - cd ../compiler; $(MAKEREC) pp.exe - -clean: - rm -f *.cm* *.ml *.mli *.$(O) *.$(A) -# rm -f modules .depend diff --git a/otherlibs/labltk/camltk/Makefile.nt b/otherlibs/labltk/camltk/Makefile.nt deleted file mode 100644 index 6c81dbc494af..000000000000 --- a/otherlibs/labltk/camltk/Makefile.nt +++ /dev/null @@ -1,43 +0,0 @@ -include ../support/Makefile.common.nt - -COMPFLAGS= -I ../support - -all: camltkobjs - -opt: camltkobjsx - -# All .{ml,mli} files are generated in this directory -clean : - rm -f *.cm* *.ml *.mli *.$(A) *.$(O) - $(MAKE) -f Makefile.gen.nt clean - -include ./modules - -CAMLTKOBJS = $(WIDGETOBJS) cTk.cmo camltk.cmo -CAMLTKOBJSX = $(CAMLTKOBJS:.cmo=.cmx) - -camltkobjs: $(CAMLTKOBJS) - -camltkobjsx: $(CAMLTKOBJSX) - -install: $(CAMLTKOBJS) - mkdir -p $(INSTALLDIR) - cp *.cmi [a-z]*.mli $(INSTALLDIR) - -installopt: $(CAMLTKOBJSX) - mkdir -p $(INSTALLDIR) - cp $(CAMLTKOBJSX) $(INSTALLDIR) - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -include .depend diff --git a/otherlibs/labltk/camltk/modules b/otherlibs/labltk/camltk/modules deleted file mode 100644 index 723783aa728b..000000000000 --- a/otherlibs/labltk/camltk/modules +++ /dev/null @@ -1,80 +0,0 @@ -CWIDGETOBJS=cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo -cBell.ml cScale.ml cWinfo.ml cScrollbar.ml cEntry.ml cListbox.ml cWm.ml cTkwait.ml cGrab.ml cFont.ml cCanvas.ml cImage.ml cClipboard.ml cLabel.ml cResource.ml cMessage.ml cText.ml cImagephoto.ml cOption.ml cFrame.ml cSelection.ml cDialog.ml cPlace.ml cPixmap.ml cMenubutton.ml cRadiobutton.ml cFocus.ml cPack.ml cImagebitmap.ml cEncoding.ml cOptionmenu.ml cCheckbutton.ml cTkvars.ml cPalette.ml cMenu.ml cButton.ml cToplevel.ml cGrid.ml : _tkgen.ml - -cBell.cmo : cBell.ml -cBell.cmi : cBell.mli -cScale.cmo : cScale.ml -cScale.cmi : cScale.mli -cWinfo.cmo : cWinfo.ml -cWinfo.cmi : cWinfo.mli -cScrollbar.cmo : cScrollbar.ml -cScrollbar.cmi : cScrollbar.mli -cEntry.cmo : cEntry.ml -cEntry.cmi : cEntry.mli -cListbox.cmo : cListbox.ml -cListbox.cmi : cListbox.mli -cWm.cmo : cWm.ml -cWm.cmi : cWm.mli -cTkwait.cmo : cTkwait.ml -cTkwait.cmi : cTkwait.mli -cGrab.cmo : cGrab.ml -cGrab.cmi : cGrab.mli -cFont.cmo : cFont.ml -cFont.cmi : cFont.mli -cCanvas.cmo : cCanvas.ml -cCanvas.cmi : cCanvas.mli -cImage.cmo : cImage.ml -cImage.cmi : cImage.mli -cClipboard.cmo : cClipboard.ml -cClipboard.cmi : cClipboard.mli -cLabel.cmo : cLabel.ml -cLabel.cmi : cLabel.mli -cResource.cmo : cResource.ml -cResource.cmi : cResource.mli -cMessage.cmo : cMessage.ml -cMessage.cmi : cMessage.mli -cText.cmo : cText.ml -cText.cmi : cText.mli -cImagephoto.cmo : cImagephoto.ml -cImagephoto.cmi : cImagephoto.mli -cOption.cmo : cOption.ml -cOption.cmi : cOption.mli -cFrame.cmo : cFrame.ml -cFrame.cmi : cFrame.mli -cSelection.cmo : cSelection.ml -cSelection.cmi : cSelection.mli -cDialog.cmo : cDialog.ml -cDialog.cmi : cDialog.mli -cPlace.cmo : cPlace.ml -cPlace.cmi : cPlace.mli -cPixmap.cmo : cPixmap.ml -cPixmap.cmi : cPixmap.mli -cMenubutton.cmo : cMenubutton.ml -cMenubutton.cmi : cMenubutton.mli -cRadiobutton.cmo : cRadiobutton.ml -cRadiobutton.cmi : cRadiobutton.mli -cFocus.cmo : cFocus.ml -cFocus.cmi : cFocus.mli -cPack.cmo : cPack.ml -cPack.cmi : cPack.mli -cImagebitmap.cmo : cImagebitmap.ml -cImagebitmap.cmi : cImagebitmap.mli -cEncoding.cmo : cEncoding.ml -cEncoding.cmi : cEncoding.mli -cOptionmenu.cmo : cOptionmenu.ml -cOptionmenu.cmi : cOptionmenu.mli -cCheckbutton.cmo : cCheckbutton.ml -cCheckbutton.cmi : cCheckbutton.mli -cTkvars.cmo : cTkvars.ml -cTkvars.cmi : cTkvars.mli -cPalette.cmo : cPalette.ml -cPalette.cmi : cPalette.mli -cMenu.cmo : cMenu.ml -cMenu.cmi : cMenu.mli -cButton.cmo : cButton.ml -cButton.cmi : cButton.mli -cToplevel.cmo : cToplevel.ml -cToplevel.cmi : cToplevel.mli -cGrid.cmo : cGrid.ml -cGrid.cmi : cGrid.mli -camltk.cmo : cTk.cmo cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo diff --git a/otherlibs/labltk/compiler/.depend b/otherlibs/labltk/compiler/.depend deleted file mode 100644 index 91ee430407c5..000000000000 --- a/otherlibs/labltk/compiler/.depend +++ /dev/null @@ -1,28 +0,0 @@ -pplex.cmi: ppyac.cmi -ppyac.cmi: code.cmi -compile.cmo: code.cmi flags.cmo ppexec.cmo ppparse.cmo tables.cmo -compile.cmx: code.cmi flags.cmx ppexec.cmx ppparse.cmx tables.cmx -intf.cmo: code.cmi compile.cmo flags.cmo ppexec.cmo ppparse.cmo tables.cmo -intf.cmx: code.cmi compile.cmx flags.cmx ppexec.cmx ppparse.cmx tables.cmx -lexer.cmo: parser.cmi -lexer.cmx: parser.cmx -maincompile.cmo: code.cmi compile.cmo flags.cmo intf.cmo lexer.cmo parser.cmi \ - ppexec.cmo ppparse.cmo printer.cmo tables.cmo tsort.cmo -maincompile.cmx: code.cmi compile.cmx flags.cmx intf.cmx lexer.cmx parser.cmx \ - ppexec.cmx ppparse.cmx printer.cmx tables.cmx tsort.cmx -parser.cmo: flags.cmo tables.cmo parser.cmi -parser.cmx: flags.cmx tables.cmx parser.cmi -pp.cmo: ppexec.cmo ppparse.cmo -pp.cmx: ppexec.cmx ppparse.cmx -ppexec.cmo: code.cmi -ppexec.cmx: code.cmi -pplex.cmo: ppyac.cmi pplex.cmi -pplex.cmx: ppyac.cmx pplex.cmi -ppparse.cmo: pplex.cmi ppyac.cmi -ppparse.cmx: pplex.cmx ppyac.cmx -ppyac.cmo: code.cmi ppyac.cmi -ppyac.cmx: code.cmi ppyac.cmi -printer.cmo: tables.cmo -printer.cmx: tables.cmx -tables.cmo: tsort.cmo -tables.cmx: tsort.cmx diff --git a/otherlibs/labltk/compiler/.ignore b/otherlibs/labltk/compiler/.ignore deleted file mode 100644 index 060114e6245f..000000000000 --- a/otherlibs/labltk/compiler/.ignore +++ /dev/null @@ -1,11 +0,0 @@ -lexer.ml -parser.output -parser.ml -parser.mli -tkcompiler -pp -copyright.ml -pplex.ml -ppyac.ml -ppyac.output -ppyac.mli diff --git a/otherlibs/labltk/compiler/Makefile b/otherlibs/labltk/compiler/Makefile deleted file mode 100644 index d8c47eb49cdd..000000000000 --- a/otherlibs/labltk/compiler/Makefile +++ /dev/null @@ -1,79 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -include ../support/Makefile.common - -OBJS= ../support/support.cmo flags.cmo copyright.cmo \ - tsort.cmo tables.cmo printer.cmo lexer.cmo \ - pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo \ - parser.cmo compile.cmo intf.cmo maincompile.cmo - -PPOBJS= pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo pp.cmo - -all: tkcompiler$(EXE) pp$(EXE) - -tkcompiler$(EXE) : $(OBJS) - $(CAMLC) -nojoin -g $(LINKFLAGS) -o tkcompiler$(EXE) $(OBJS) - -pp$(EXE): $(PPOBJS) - $(CAMLC) -nojoin -g $(LINKFLAGS) -o pp$(EXE) $(PPOBJS) - -lexer.ml: lexer.mll - $(CAMLLEX) lexer.mll - -parser.ml parser.mli: parser.mly - $(CAMLYACC) -v parser.mly - -pplex.ml: pplex.mll - $(CAMLLEX) pplex.mll - -pplex.mli: ppyac.cmi - -ppyac.ml ppyac.mli: ppyac.mly - $(CAMLYACC) -v ppyac.mly - -copyright.ml: copyright - (echo "let copyright=\"\\"; \ - sed -e 's/$$/\\n\\/' copyright; \ - echo "\""; \ - echo "let write ~w = w copyright;;") > copyright.ml - -clean : - rm -f *.cm* parser.ml parser.mli lexer.ml copyright.ml - rm -f pplex.ml ppyac.ml ppyac.mli ppyac.output - rm -f tkcompiler$(EXE) pp$(EXE) parser.output - -scratch : - rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler$(EXE) - rm -f *.cm* pplex.ml ppyac.ml ppyac.mli pp$(EXE) - -install: - cp tkcompiler$(EXE) $(INSTALLDIR) - cp pp$(EXE) $(INSTALLDIR) - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .mlp - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) -I ../support $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) -I ../support $< - -depend: parser.ml parser.mli lexer.ml pplex.ml ppyac.ml ppyac.mli - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/labltk/compiler/Makefile.nt b/otherlibs/labltk/compiler/Makefile.nt deleted file mode 100644 index 3c936ba4c6c7..000000000000 --- a/otherlibs/labltk/compiler/Makefile.nt +++ /dev/null @@ -1,63 +0,0 @@ -include ../support/Makefile.common.nt - -OBJS= ../support/support.cmo flags.cmo copyright.cmo \ - tsort.cmo tables.cmo printer.cmo lexer.cmo \ - pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo \ - parser.cmo compile.cmo intf.cmo maincompile.cmo - -PPOBJS= pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo pp.cmo - -all: tkcompiler.exe pp.exe - -tkcompiler.exe : $(OBJS) - $(CAMLC) $(LINKFLAGS) -o tkcompiler.exe $(OBJS) - -pp.exe : $(PPOBJS) - $(CAMLC) $(LINKFLAGS) -o pp.exe $(PPOBJS) - -lexer.ml: lexer.mll - $(CAMLLEX) lexer.mll - -parser.ml parser.mli: parser.mly - $(CAMLYACC) -v parser.mly - -pplex.ml: pplex.mll - $(CAMLLEX) pplex.mll - -pplex.mli: ppyac.cmi - -ppyac.ml ppyac.mli: ppyac.mly - $(CAMLYACC) -v ppyac.mly - -copyright.ml: copyright - (echo "let copyright=\"\\"; \ - cat copyright; \ - echo "\""; \ - echo "let write ~w = w copyright;;") > copyright.ml - -clean : - rm -f *.cm* parser.ml parser.mli lexer.ml copyright.ml - rm -f pplex.ml ppyac.ml ppyac.mli ppyac.output - rm -f tkcompiler.exe pp.exe parser.output - -scratch : - rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler.exe - rm -f *.cm* pplex.ml ppyac.ml ppyac.mli pp.exe - -install: - cp tkcompiler.exe $(INSTALLDIR) - cp pp.exe $(INSTALLDIR) - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .mlp - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) -I ../support $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) -I ../support $< - -depend: parser.ml parser.mli lexer.ml pplex.ml ppyac.ml ppyac.mli - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/labltk/compiler/code.mli b/otherlibs/labltk/compiler/code.mli deleted file mode 100644 index bde9c44554b0..000000000000 --- a/otherlibs/labltk/compiler/code.mli +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -type code = - | Line of string - | Ifdef of bool * string * code list * code list option - | Define of string - | Undef of string -;; diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml deleted file mode 100644 index 029cce70fb92..000000000000 --- a/otherlibs/labltk/compiler/compile.ml +++ /dev/null @@ -1,1074 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open StdLabels -open Tables - -(* CONFIGURE *) -(* if you set it true, ImagePhoto and ImageBitmap will annoy you... *) -let safetype = true - -let labeloff ~at l = match l with - "", t -> t -| l, t -> raise (Failure ("labeloff: " ^ l ^ " at " ^ at)) - -let labltk_labelstring l = - if l = "" then l else - if l.[0] = '?' then l ^ ":" else - "~" ^ l ^ ":" - -let camltk_labelstring l = - if l = "" then l else - if l.[0] = '?' then l ^ ":" else "" - -let labelstring l = - if !Flags.camltk then camltk_labelstring l - else labltk_labelstring l - -let labltk_typelabel l = - if l = "" then l else l ^ ":" - -let camltk_typelabel l = - if l = "" then l - else if l.[0] = '?' then l ^ ":" else "" - -let typelabel l = - if !Flags.camltk then camltk_typelabel l - else labltk_typelabel l - -let forbidden = [ "class"; "type"; "in"; "from"; "to" ] -let nicknames = - [ "class", "clas"; - "type", "typ" ] - -let small = String.lowercase - -let gettklabel fc = - match fc.template with - ListArg( StringArg s :: _ ) -> - let s = small s in - if s = "" then s else - let s = - if s.[0] = '-' - then String.sub s ~pos:1 ~len:(String.length s - 1) - else s - in begin - if List.mem s forbidden then - try List.assoc s nicknames - with Not_found -> small fc.var_name - else s - end - | _ -> raise (Failure "gettklabel") - -let count ~item:x l = - let count = ref 0 in - List.iter ~f:(fun y -> if x = y then incr count) l; - !count - -(* Extract all types from a template *) -let rec types_of_template = function - StringArg _ -> [] - | TypeArg (l, t) -> [l, t] - | ListArg l -> List.flatten (List.map ~f:types_of_template l) - | OptionalArgs (l, tl, _) -> - begin - match List.flatten (List.map ~f:types_of_template tl) with - ["", t] -> ["?" ^ l, t] - | [_, _] -> raise (Failure "0 label required") - | _ -> raise (Failure "0 or more than 1 args in for optionals") - end - -(* - * Pretty print a type - * used to write ML type definitions - *) -let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = - let rec ppMLtype = - function - Unit -> "unit" - | Int -> "int" - | Float -> "float" - | Bool -> "bool" - | Char -> "char" - | String -> "string" -(* new *) - | List (Subtype (sup, sub)) -> - if !Flags.camltk then "(* " ^ sub ^ " *) " ^ sup ^ " list" - else begin - if return then - sub ^ "_" ^ sup ^ " list" - else begin - try - let typdef = Hashtbl.find types_table sup in - let fcl = List.assoc sub typdef.subtypes in - let tklabels = List.map ~f:gettklabel fcl in - let l = List.map fcl ~f: - begin fun fc -> - "?" ^ begin let p = gettklabel fc in - if count ~item:p tklabels > 1 then small fc.var_name else p - end - ^ ":" ^ - let l = types_of_template fc.template in - match l with - [] -> "unit" - | [lt] -> ppMLtype (labeloff lt ~at:"ppMLtype") - | l -> - "(" ^ String.concat ~sep:"*" - (List.map l - ~f:(fun lt -> ppMLtype (labeloff lt ~at:"ppMLtype"))) - ^ ")" - end in - String.concat ~sep:" ->\n" l - with - Not_found -> Printf.eprintf "ppMLtype %s/%s\n" sup sub; exit (-1) - end - end - | List ty -> (ppMLtype ty) ^ " list" - | Product tyl -> - "(" ^ String.concat ~sep:" * " (List.map ~f:ppMLtype tyl) ^ ")" - | Record tyl -> - String.concat ~sep:" * " - (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t)) - | Subtype ("widget", sub) -> - if !Flags.camltk then "(* " ^ sub ^" *) widget" else sub ^ " widget" - | UserDefined "widget" -> - if !Flags.camltk then "widget" - else begin - if any then "any widget" else - let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in - incr counter; - "'" ^ c ^ " widget" - end - | UserDefined s -> - if !Flags.camltk then s - else begin - (* a bit dirty hack for ImageBitmap and ImagePhoto *) - try - let typdef = Hashtbl.find types_table s in - if typdef.variant then - if return then try - "[>" ^ - String.concat ~sep:"|" - (List.map typdef.constructors ~f: - begin - fun c -> - "`" ^ c.var_name ^ - (match types_of_template c.template with - [] -> "" - | l -> " of " ^ ppMLtype (Product (List.map l - ~f:(labeloff ~at:"ppMLtype UserDefined")))) - end) ^ "]" - with - Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s - else if not def && List.length typdef.constructors > 1 then - "[< " ^ s ^ "]" - else s - else s - with Not_found -> s - end - | Subtype (s, s') -> - if !Flags.camltk then "(* " ^ s' ^ " *) " ^ s else s' ^ "_" ^ s - | Function (Product tyl) -> - raise (Failure "Function (Product tyl) ? ppMLtype") - | Function (Record tyl) -> - "(" ^ String.concat ~sep:" -> " - (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t)) - ^ " -> unit)" - | Function ty -> - "(" ^ (ppMLtype ty) ^ " -> unit)" - | As (t, s) -> - if !Flags.camltk then ppMLtype t - else s - in - ppMLtype - -(* Produce a documentation version of a template *) -let rec ppTemplate = function - StringArg s -> s - | TypeArg (l, t) -> "<" ^ ppMLtype t ^ ">" - | ListArg l -> "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate l) ^ "}" - | OptionalArgs (l, tl, d) -> - "?" ^ l ^ "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate tl) - ^ "}[<" ^ String.concat ~sep:" " (List.map ~f:ppTemplate d) ^ ">]" - -let doc_of_template = function - ListArg l -> String.concat ~sep:" " (List.map ~f:ppTemplate l) - | t -> ppTemplate t - -(* - * Type definitions - *) - -(* Write an ML constructor *) -let write_constructor ~w {ml_name = mlconstr; template = t} = - w mlconstr; - begin match types_of_template t with - [] -> () - | l -> w " of "; - w (ppMLtype ~any:true (Product (List.map l - ~f:(labeloff ~at:"write_constructor")))) - end; - w " (* tk option: "; w (doc_of_template t); w " *)" - -(* Write a rhs type decl *) -let write_constructors ~w = function - [] -> fatal_error "empty type" - | x :: l -> - write_constructor ~w x; - List.iter l ~f: - begin fun x -> - w "\n | "; - write_constructor ~w x - end - -(* Write an ML variant *) -let write_variant ~w {var_name = varname; template = t} = - w "`"; - w varname; - begin match types_of_template t with - [] -> () - | l -> - w " of "; - w (ppMLtype ~any:true ~def:true - (Product (List.map l ~f:(labeloff ~at:"write_variant")))) - end; - w " (* tk option: "; w (doc_of_template t); w " *)" - -let write_variants ~w = function - [] -> fatal_error "empty variants" - | l -> - List.iter l ~f: - begin fun x -> - w "\n | "; - write_variant ~w x - end - -(* Definition of a type *) -let labltk_write_type ~intf:w ~impl:w' name ~def:typdef = - (* Only needed if no subtypes, otherwise use optionals *) - if typdef.subtypes = [] then begin - w "(* Variant type *)\n"; - w ("type " ^ name ^ " = ["); - write_variants ~w (sort_components typdef.constructors); - w "\n]\n\n" - end - -(* CamlTk: List of constructors, for runtime subtyping *) -let write_constructor_set ~w ~sep = function - | [] -> fatal_error "empty type" - | x::l -> - w ("C" ^ x.ml_name); - List.iter l ~f: (function x -> - w sep; - w ("C" ^ x.ml_name)) - -(* CamlTk: Definition of a type *) -let camltk_write_type ~intf:w ~impl:w' name ~def:typdef = - (* Put markers for extraction *) - w "(* type *)\n"; - w ("type " ^ name ^ " =\n"); - w " | "; - write_constructors ~w (sort_components typdef.constructors); - w "\n(* /type *)\n\n"; - (* Dynamic Subtyping *) - if typdef.subtypes <> [] then begin - (* The set of its constructors *) - if name = "options" then begin - w "(* type *)\n"; - w ("type "^name^"_constrs =\n\t") - end else begin - (* added some prefix to avoid being picked up in documentation *) - w ("(* no doc *) type "^name^"_constrs =\n") - end; - w " | "; - write_constructor_set ~w:w ~sep: "\n | " - (sort_components typdef.constructors); - w "\n\n"; - (* The set of all constructors *) - w' ("let "^name^"_any_table = ["); - write_constructor_set ~w:w' ~sep:"; " - (sort_components typdef.constructors); - w' ("]\n\n"); - (* The subset of constructors for each subtype *) - List.iter ~f:(function (s,l) -> - w' ("let "^name^"_"^s^"_table = ["); - write_constructor_set ~w:w' ~sep:"; " (sort_components l); - w' ("]\n\n")) - typdef.subtypes - end - -let write_type ~intf:w ~impl:w' name ~def:typdef = - (if !Flags.camltk then camltk_write_type else labltk_write_type) - ~intf:w ~impl:w' name ~def:typdef - -(************************************************************) -(* Converters *) -(************************************************************) - -let rec converterTKtoCAML ~arg = function - | Int -> "int_of_string " ^ arg - | Float -> "float_of_string " ^ arg - | Bool -> "(match " ^ arg ^ " with\n\ - | \"1\" -> true\n\ - | \"0\" -> false\n\ - | s -> Pervasives.raise (Invalid_argument (\"cTKtoCAMLbool\" ^ s)))" - | Char -> "String.get " ^ arg ^ " 0" - | String -> arg - | UserDefined s -> "cTKtoCAML" ^ s ^ " " ^ arg - | Subtype ("widget", s') when not !Flags.camltk -> - String.concat ~sep:" " - ["(Obj.magic (cTKtoCAMLwidget "; arg; ") :"; s'; "widget)"] - | Subtype (s, s') -> - if !Flags.camltk then - "cTKtoCAML" ^ s ^ " " ^ arg - else - "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg - | List ty -> - begin match type_parser_arity ty with - OneToken -> - String.concat ~sep:" " - ["(List.map (function x ->"; - converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"] - | MultipleToken -> - String.concat ~sep:" " - ["iterate_converter (function x ->"; - converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"] - end - | As (ty, _) -> converterTKtoCAML ~arg ty - | t -> - prerr_endline ("ERROR with " ^ arg ^ " " ^ ppMLtype t); - fatal_error "converterTKtoCAML" - - -(*******************************) -(* Wrappers *) -(*******************************) -let varnames ~prefix n = - let rec var i = - if i > n then [] - else (prefix ^ string_of_int i) :: var (succ i) - in var 1 - -(* - * generate wrapper source for callbacks - * transform a function ... -> unit in a function : unit -> unit - * using primitives arg_ ... from the protocol - * Warning: sequentiality is important in generated code - * TODO: remove arg_ stuff and process lists directly ? - *) - -let rec wrapper_code ~name ty = - match ty with - Unit -> "(fun _ -> " ^ name ^ " ())" - | As (ty, _) -> wrapper_code ~name ty - | ty -> - "(fun args ->\n " ^ - begin match ty with - Product tyl -> raise (Failure "Product -> record was done. ???") - | Record tyl -> - (* variables for each component of the product *) - let vnames = varnames ~prefix:"a" (List.length tyl) in - (* getting the arguments *) - let readarg = - List.map2 vnames tyl ~f: - begin fun v (l, ty) -> - match type_parser_arity ty with - OneToken -> - "let (" ^ v ^ ", args) = " ^ - converterTKtoCAML ~arg:"(List.hd args)" ty ^ - ", List.tl args in\n " - | MultipleToken -> - "let (" ^ v ^ ", args) = " ^ - converterTKtoCAML ~arg:"args" ty ^ - " in\n " - end in - String.concat ~sep:"" readarg ^ name ^ " " ^ - String.concat ~sep:" " - (List.map2 ~f:(fun v (l, _) -> - if !Flags.camltk then v - else labelstring l ^ v) vnames tyl) - - (* all other types are read in one operation *) - | List ty -> - name ^ "(" ^ converterTKtoCAML ~arg:"args" ty ^ ")" - | String -> - name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")" - | ty -> - begin match type_parser_arity ty with - OneToken -> - name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")" - | MultipleToken -> - "let (v, _) = " ^ converterTKtoCAML ~arg:"args" ty ^ - " in\n " ^ name ^ " v" - end - end ^ ")" - -(*************************************************************) -(* Parsers *) -(* are required only for values returned by commands and *) -(* functions (table is computed by the parser) *) - -(* Tuples/Lists are Ok if they don't contain strings *) -(* they will be returned as list of strings *) - -(* Can we generate a "parser" ? - -> all constructors are unit and at most one int and one string, with null constr -*) -type parser_pieces = - { mutable zeroary : (string * string) list ; (* kw string, ml name *) - mutable intpar : string list; (* one at most, mlname *) - mutable stringpar : string list (* idem *) - } - -type mini_parser = - NoParser - | ParserPieces of parser_pieces - -let can_generate_parser constructors = - let pp = {zeroary = []; intpar = []; stringpar = []} in - if List.for_all constructors ~f: - begin fun c -> - let vname = if !Flags.camltk then c.ml_name else c.var_name in - match c.template with - ListArg [StringArg s] -> - pp.zeroary <- (s, vname) :: - pp.zeroary; true - | ListArg [TypeArg(_, Int)] | ListArg[TypeArg(_, Float)] -> - if pp.intpar <> [] then false - else (pp.intpar <- [vname]; true) - | ListArg [TypeArg(_, String)] -> - if pp.stringpar <> [] then false - else (pp.stringpar <- [vname]; true) - | _ -> false - end - then ParserPieces pp - else NoParser - - -(* We can generate parsers only for simple types *) -(* we should avoid multiple walks *) -let labltk_write_TKtoCAML ~w name ~def:typdef = - if typdef.parser_arity = MultipleToken then - prerr_string ("You must write cTKtoCAML" ^ name ^ - " : string list ->" ^ name ^ " * string list\n") - else - let write ~consts ~name = - match can_generate_parser consts with - NoParser -> - prerr_string - ("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n") - | ParserPieces pp -> - w ("let cTKtoCAML" ^ name ^ " n =\n"); - (* First check integer *) - if pp.intpar <> [] then - begin - w (" try `" ^ List.hd pp.intpar ^ " (int_of_string n)\n"); - w (" with _ ->\n") - end; - w (" match n with\n"); - List.iter pp.zeroary ~f: - begin fun (tk, ml) -> - w " | \""; w tk; w "\" -> `"; w ml; w "\n" - end; - let final = if pp.stringpar <> [] then - "n -> `" ^ List.hd pp.stringpar ^ " n" - else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML" - ^ name ^ ": \" ^ s))" - in - w " | "; - w final; - w "\n\n" - in - begin - write ~name ~consts:typdef.constructors; - List.iter typdef.subtypes ~f: begin - fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts - end - end - -let camltk_write_TKtoCAML ~w name ~def:typdef = - if typdef.parser_arity = MultipleToken then - prerr_string ("You must write cTKtoCAML" ^ name ^ - " : string list ->" ^ name ^ " * string list\n") - else - let write ~consts ~name = - match can_generate_parser consts with - NoParser -> - prerr_string - ("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n") - | ParserPieces pp -> - w ("let cTKtoCAML" ^ name ^ " n =\n"); - (* First check integer *) - if pp.intpar <> [] then - begin - w (" try " ^ List.hd pp.intpar ^ " (int_of_string n)\n"); - w (" with _ ->\n") - end; - w (" match n with\n"); - List.iter pp.zeroary ~f: - begin fun (tk, ml) -> - w " | \""; w tk; w "\" -> "; w ml; w "\n" - end; - let final = if pp.stringpar <> [] then - "n -> " ^ List.hd pp.stringpar ^ " n" - else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML" - ^ name ^ ": \" ^ s))" - in - w " | "; - w final; - w "\n\n" - in - begin - write ~name ~consts:typdef.constructors; - List.iter typdef.subtypes ~f: begin - fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts - end - end - -let write_TKtoCAML ~w name ~def:typdef = - (if !Flags.camltk then camltk_write_TKtoCAML else labltk_write_TKtoCAML) - ~w name ~def: typdef - -(******************************) -(* Converters *) -(******************************) - -(* Produce an in-lined converter OCaml -> Tk for simple types *) -(* the converter is a function of type: -> string *) -let rec converterCAMLtoTK ~context_widget argname ty = - match ty with - Int -> "TkToken (string_of_int " ^ argname ^ ")" - | Float -> "TkToken (Printf.sprintf \"%g\" " ^ argname ^ ")" - | Bool -> "if " ^ argname ^ " then TkToken \"1\" else TkToken \"0\"" - | Char -> "TkToken (Char.escaped " ^ argname ^ ")" - | String -> "TkToken " ^ argname - | As (ty, _) -> converterCAMLtoTK ~context_widget argname ty - | UserDefined s -> - let name = "cCAMLtoTK" ^ s ^ " " in - let args = argname in - let args = - if !Flags.camltk then begin - if is_subtyped s then (* unconstraint subtype *) - s ^ "_any_table " ^ args - else args - end else args - in - let args = - if requires_widget_context s then - context_widget ^ " " ^ args - else args in - name ^ args - | Subtype ("widget", s') -> - if !Flags.camltk then - let name = "cCAMLtoTKwidget " in - let args = "widget_"^s'^"_table "^argname in - let args = - if requires_widget_context "widget" then - context_widget^" "^args - else args in - name^args - else begin - let name = "cCAMLtoTKwidget " in - let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in - name ^ args - end - | Subtype (s, s') -> - let name = - if !Flags.camltk then "cCAMLtoTK" ^ s ^ " " - else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " " - in - let args = - if !Flags.camltk then begin - s^"_"^s'^"_table "^argname - end else begin - if safetype then "(" ^ argname ^ " : [< " ^ s' ^ "_" ^ s ^ "])" - else argname - end - in - let args = - if requires_widget_context s then context_widget ^ " " ^ args - else args in - name ^ args - | Product tyl -> - let vars = varnames ~prefix:"z" (List.length tyl) in - String.concat ~sep:" " - ("let" :: String.concat ~sep:"," vars :: "=" :: argname :: - "in TkTokenList [" :: - String.concat ~sep:"; " - (List.map2 vars tyl ~f:(converterCAMLtoTK ~context_widget)) :: - ["]"]) - | List ty -> (* Just added for Imagephoto.put *) - String.concat ~sep:" " - [(if !Flags.camltk then - "TkQuote (TkTokenList (List.map (fun y -> " - else - "TkQuote (TkTokenList (List.map ~f:(fun y -> "); - converterCAMLtoTK ~context_widget "y" ty; - ")"; - argname; - "))"] - | Function _ -> fatal_error "unexpected function type in converterCAMLtoTK" - | Unit -> fatal_error "unexpected unit type in converterCAMLtoTK" - | Record _ -> fatal_error "unexpected product type in converterCAMLtoTK" - -(* - * Produce a list of arguments from a template - * The idea here is to avoid allocation as much as possible - * - *) - -let code_of_template ~context_widget ?func:(funtemplate=false) template = - let catch_opts = ref ("", "") in (* class name and first option *) - let variables = ref [] in - let variables2 = ref [] in - let varcnter = ref 0 in - let optionvar = ref None in - let newvar1 l = - match !optionvar with - Some v -> optionvar := None; v - | None -> - incr varcnter; - let v = "v" ^ (string_of_int !varcnter) in - variables := (l, v) :: !variables; v in - let newvar2 l = - match !optionvar with - Some v -> optionvar := None; v - | None -> - incr varcnter; - let v = "v" ^ (string_of_int !varcnter) in - variables2 := (l, v) :: !variables2; v in - let newvar = ref newvar1 in - let rec coderec = function - StringArg s -> "TkToken \"" ^ s ^ "\"" - | TypeArg (_, List (Subtype (sup, sub))) when not !Flags.camltk -> - begin try - let typdef = Hashtbl.find types_table sup in - let classdef = List.assoc sub typdef.subtypes in - let lbl = gettklabel (List.hd classdef) in - catch_opts := (sub ^ "_" ^ sup, lbl); - newvar := newvar2; - "TkTokenList opts" - with Not_found -> - raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub)); - end - | TypeArg (l, List ty) -> - (if !Flags.camltk then - "TkTokenList (List.map (function x -> " - else - "TkTokenList (List.map ~f:(function x -> ") - ^ converterCAMLtoTK ~context_widget "x" ty - ^ ") " ^ !newvar l ^ ")" - | TypeArg (l, Function tyarg) -> - "let id = register_callback " ^ context_widget - ^ " ~callback: " ^ wrapper_code ~name:(!newvar l) tyarg - ^ " in TkToken (\"camlcb \" ^ id)" - | TypeArg (l, ty) -> converterCAMLtoTK ~context_widget (!newvar l) ty - | ListArg l -> - "TkQuote (TkTokenList [" - ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "])" - | OptionalArgs (l, tl, d) -> - let nv = !newvar ("?" ^ l) in - optionvar := Some nv; (* Store *) - let argstr = String.concat ~sep:"; " (List.map ~f:coderec tl) in - let defstr = String.concat ~sep:"; " (List.map ~f:coderec d) in - "TkTokenList (match " ^ nv ^ " with\n" - ^ " | Some " ^ nv ^ " -> [" ^ argstr ^ "]\n" - ^ " | None -> [" ^ defstr ^ "])" - in - let code = - if funtemplate then - match template with - ListArg l -> - "[|" ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "|]" - | _ -> "[|" ^ coderec template ^ "|]" - else - match template with - ListArg [x] -> coderec x - | ListArg l -> - "TkTokenList [" ^ - String.concat ~sep:";\n " (List.map ~f:coderec l) ^ - "]" - | _ -> coderec template - in - code, List.rev !variables, List.rev !variables2, !catch_opts - -(* - * Converters for user defined types - *) - -(* For each case of a concrete type *) -let labltk_write_clause ~w ~context_widget comp = - let warrow () = w " -> " in - w "`"; - w comp.var_name; - - let code, variables, variables2, (co, _) = - code_of_template ~context_widget comp.template in - - (* no subtype I think ... *) - if co <> "" then raise (Failure "write_clause subtype ?"); - begin match variables with - | [] -> warrow() - | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow() - | l -> - w " ( "; - w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l)); - w ")"; - warrow() - end; - w code - -let camltk_write_clause ~w ~context_widget ~subtype comp = - let warrow () = - w " -> "; - if subtype then - w ("chk_sub \""^comp.ml_name^"\" table C" ^ comp.ml_name ^ "; ") - in - - w comp.ml_name; (* we use ml_name, not var_name, specialized for labltk *) - - let code, variables, variables2, (co, _) = - code_of_template ~context_widget comp.template in - - (* no subtype I think ... *) - if co <> "" then raise (Failure "write_clause subtype ?"); - begin match variables with - | [] -> warrow() - | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow() - | l -> - w " ( "; - w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l)); - w ")"; - warrow() - end; - w code - -let write_clause ~w ~context_widget ~subtype comp = - if !Flags.camltk then camltk_write_clause ~w ~context_widget ~subtype comp - else labltk_write_clause ~w ~context_widget comp - -(* The full converter *) -let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name = - let write_one name constrs = - let subtype = typdef.subtypes <> [] in - w ("let cCAMLtoTK" ^ name); - let context_widget = - if typdef.requires_widget_context then begin - w " w"; "w" - end - else - "dummy" in - if !Flags.camltk && subtype then w " table"; - if st then begin - w " : "; - if typdef.variant then w ("[< " ^ name ^ "]") else w name; - w " -> tkArgs " - end; - w (" = function"); - List.iter constrs - ~f:(fun c -> w "\n | "; write_clause ~w ~context_widget ~subtype c); - w "\n\n\n" - in - - let constrs = typdef.constructors in - if !Flags.camltk then write_one name constrs - else begin - (* Only needed if no subtypes, otherwise use optionals *) - if typdef.subtypes == [] then - write_one name constrs - else - List.iter constrs ~f: - begin fun fc -> - let code, vars, _, (co, _) = - code_of_template ~context_widget:"dummy" fc.template in - if co <> "" then fatal_error "optionals in optionals"; - let vars = List.map ~f:snd vars in - w "let ccCAMLtoTK"; w name; w "_"; w (small fc.ml_name); - w " ("; w (String.concat ~sep:", " vars); w ") =\n "; - w code; w "\n\n" - end - end - -(* Tcl does not really return "lists". It returns sp separated tokens *) -let rec write_result_parsing ~w = function - List String -> - w "(splitlist res)" - | List ty -> - if !Flags.camltk then - w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) - else - w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) - | Product tyl -> raise (Failure "Product -> record was done. ???") - | Record tyl -> (* of course all the labels are "" *) - let rnames = varnames ~prefix:"r" (List.length tyl) in - w " let l = splitlist res in"; - w ("\n if List.length l <> " ^ string_of_int (List.length tyl)); - w ("\n then Pervasives.raise (TkError (\"unexpected result: \" ^ res))"); - w ("\n else "); - List.iter2 rnames tyl ~f: - begin fun r (l, ty) -> - if l <> "" then raise (Failure "lables in return type!!!"); - w (" let " ^ r ^ ", l = "); - begin match type_parser_arity ty with - OneToken -> - w (converterTKtoCAML ~arg:"(List.hd l)" ty); w (", List.tl l") - | MultipleToken -> - w (converterTKtoCAML ~arg:"l" ty) - end; - w (" in\n") - end; - w (String.concat ~sep:", " rnames) - | String -> - w (converterTKtoCAML ~arg:"res" String) - | As (ty, _) -> write_result_parsing ~w ty - | ty -> - match type_parser_arity ty with - OneToken -> w (converterTKtoCAML ~arg:"res" ty) - | MultipleToken -> w (converterTKtoCAML ~arg:"(splitlist res)" ty) - -let labltk_write_function ~w def = - w ("let " ^ def.ml_name); - (* a bit approximative *) - let context_widget = match def.template with - ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" - | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" - | _ -> "dummy" in - - let code, variables, variables2, (co, lbl) = - code_of_template ~func:true ~context_widget def.template in - (* Arguments *) - let uv, lv, ov = - let rec replace_args ~u ~l ~o = function - [] -> u, l, o - | ("", x) :: ls -> - replace_args ~u:(x :: u) ~l ~o ls - | (p, _ as x) :: ls when p.[0] = '?' -> - replace_args ~u ~l ~o:(x :: o) ls - | x :: ls -> - replace_args ~u ~l:(x :: l) ~o ls - in - replace_args ~u:[] ~l:[] ~o:[] (List.rev (variables @ variables2)) - in - let has_opts = (ov <> [] || co <> "") in - if not has_opts then List.iter uv ~f:(fun x -> w " "; w x); - List.iter (lv@ov) ~f:(fun (l, v) -> w " "; w (labelstring l); w v); - if co <> "" then begin - if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta"); - w " =\n"; - w (co ^ "_optionals"); - if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta"); - w " (fun opts"; - if uv = [] then w " ()" else - if has_opts then List.iter uv ~f:(fun x -> w " "; w x); - w " ->\n" - end else begin - if (ov <> [] || lv = []) && uv = [] then w " ()" else - if has_opts then List.iter uv ~f:(fun x -> w " "; w x); - w " =\n" - end; - begin match def.result with - | Unit | As (Unit, _) -> w "tkCommand "; w code - | ty -> - w "let res = tkEval "; w code ; w " in \n"; - write_result_parsing ~w ty - end; - if co <> "" then w ")"; - w "\n\n" - -let camltk_write_function ~w def = - w ("let " ^ def.ml_name); - (* a bit approximative *) - let context_widget = match def.template with - ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" - | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" - | _ -> "dummy" in - - let code, variables, variables2, (co, lbl) = - code_of_template ~func:true ~context_widget def.template in - (* Arguments *) - let uv, ov = - let rec replace_args ~u ~o = function - [] -> u, o - | ("", x) :: ls -> - replace_args ~u:(x :: u) ~o ls - | (p, _ as x) :: ls when p.[0] = '?' -> - replace_args ~u ~o:(x :: o) ls - | (_,x) :: ls -> - replace_args ~u:(x::u) ~o ls - in - replace_args ~u:[] ~o:[] (List.rev (variables @ variables2)) - in - let has_opts = ov <> [] (* (ov <> [] || co <> "") *) in - if not has_opts then List.iter uv ~f:(fun x -> w " "; w x); - List.iter ov ~f:(fun (l, v) -> w " "; w (labelstring l); w v); - begin - if uv = [] then w " ()" else - if has_opts then List.iter uv ~f:(fun x -> w " "; w x); - w " =\n" - end; - begin match def.result with - | Unit | As (Unit, _) -> w "tkCommand "; w code - | ty -> - w "let res = tkEval "; w code ; w " in \n"; - write_result_parsing ~w ty - end; - w "\n\n" - -(* - w ("let " ^ def.ml_name); - (* a bit approximative *) - let context_widget = match def.template with - ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" - | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" - | _ -> "dummy" in - - let code, variables, variables2, (co, lbl) = - code_of_template ~func:true ~context_widget def.template in - let variables = variables @ variables2 in - (* Arguments *) - begin match variables with - [] -> w " () =\n" - | l -> - let has_normal_argument = ref false in - List.iter (fun (l,x) -> - w " "; - if l <> "" then - if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true - else has_normal_argument := true; - w x) l; - if not !has_normal_argument then w " ()"; - w " =\n" - end; - begin match def.result with - | Unit | As (Unit, _) -> w "tkCommand "; w code - | ty -> - w "let res = tkEval "; w code ; w " in \n"; - write_result_parsing ~w ty - end; - w "\n\n" -*) - -let write_function ~w def = - if !Flags.camltk then camltk_write_function ~w def - else labltk_write_function ~w def -;; - -let labltk_write_create ~w clas = - w ("let create ?name =\n"); - w (" " ^ clas ^ "_options_optionals (fun opts parent ->\n"); - w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n"); - w " tkCommand [|"; - w ("TkToken \"" ^ clas ^ "\";\n"); - w (" TkToken (Widget.name w);\n"); - w (" TkTokenList opts |];\n"); - w (" w)\n\n\n") - -let camltk_write_create ~w clas = - w ("let create ?name parent options =\n"); - w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n"); - w " tkCommand [|"; - w ("TkToken \"" ^ clas ^ "\";\n"); - w (" TkToken (Widget.name w);\n"); - w (" TkTokenList (List.map (function x -> "^ - converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n"); - w (" |];\n"); - w (" w\n\n") - -let camltk_write_named_create ~w clas = - w ("let create_named parent name options =\n"); - w (" let w = new_atom \"" ^ clas ^ "\" ~parent ~name in\n"); - w " tkCommand [|"; - w ("TkToken \"" ^ clas ^ "\";\n"); - w (" TkToken (Widget.name w);\n"); - w (" TkTokenList (List.map (function x -> "^ - converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n"); - w (" |];\n"); - w (" w\n\n") - -(* Search Path. *) -let search_path = ref ["."] - -(* taken from utils/misc.ml *) -let find_in_path path name = - if not (Filename.is_implicit name) then - if Sys.file_exists name then name else raise Not_found - else begin - let rec try_dir = function - [] -> raise Not_found - | dir :: rem -> - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then fullname else try_dir rem - in try_dir path - end - -(* builtin-code: the file (without suffix) is in .template... *) -(* not efficient, but hell *) -let write_external ~w def = - match def.template with - | StringArg fname -> - begin try - let realname = find_in_path !search_path (fname ^ ".ml") in - let ic = open_in_bin realname in - try - let code_list = Ppparse.parse_channel ic in - close_in ic; - List.iter (Ppexec.exec (fun _ -> ()) w) - (if !Flags.camltk then - Code.Define "CAMLTK" :: code_list else code_list ); - with - | Ppparse.Error s -> - close_in ic; - raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) - with - | Not_found -> - raise (Compiler_Error ("can't find external file: " ^ fname)) - end - | _ -> raise (Compiler_Error "invalid external definition") - -let write_catch_optionals ~w clas ~def:typdef = - if typdef.subtypes = [] then () else - List.iter typdef.subtypes ~f: - begin fun (subclass, classdefs) -> - w ("let " ^ subclass ^ "_" ^ clas ^ "_optionals f = fun\n"); - let tklabels = List.map ~f:gettklabel classdefs in - let l = - List.map classdefs ~f: - begin fun fc -> - (* - let code, vars, _, (co, _) = - code_of_template ~context_widget:"dummy" fc.template in - if co <> "" then fatal_error "optionals in optionals"; - *) - let p = gettklabel fc in - (if count ~item:p tklabels > 1 then small fc.var_name else p), - small fc.ml_name - end in - let p = List.map l ~f:(fun (si, _) -> " ?" ^ si) in - let v = - List.map l ~f: - begin fun (si, s) -> - "(maycons ccCAMLtoTK" ^ clas ^ "_" ^ s ^ " " ^ si - end in - w (String.concat ~sep:"\n" p); - w " ->\n"; - w " f "; - w (String.concat ~sep:"\n " v); - w "\n []"; - w (String.make (List.length v) ')'); - w "\n\n" - end diff --git a/otherlibs/labltk/compiler/copyright b/otherlibs/labltk/compiler/copyright deleted file mode 100644 index 87ab0d30b0ff..000000000000 --- a/otherlibs/labltk/compiler/copyright +++ /dev/null @@ -1,15 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) diff --git a/otherlibs/labltk/compiler/flags.ml b/otherlibs/labltk/compiler/flags.ml deleted file mode 100644 index d832b4947c8d..000000000000 --- a/otherlibs/labltk/compiler/flags.ml +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -let camltk = ref false;; diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml deleted file mode 100644 index 42ad1b38da4f..000000000000 --- a/otherlibs/labltk/compiler/intf.ml +++ /dev/null @@ -1,191 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open StdLabels - -(* Write .mli for widgets *) - -open Tables -open Compile - -let labltk_write_create_p ~w wname = - w "val create :\n ?name:string ->\n"; - begin - try - let option = Hashtbl.find types_table "options" in - let classdefs = List.assoc wname option.subtypes in - let tklabels = List.map ~f:gettklabel classdefs in - let l = List.map classdefs ~f: - begin fun fc -> - begin let p = gettklabel fc in - if count ~item:p tklabels > 1 then small fc.var_name else p - end, - fc.template - end in - w (String.concat ~sep:" ->\n" - (List.map l ~f: - begin fun (s, t) -> - " ?" ^ s ^ ":" - ^(ppMLtype - (match types_of_template t with - | [t] -> labeloff t ~at:"write_create_p" - | [] -> fatal_error "multiple" - | l -> Product (List.map ~f:(labeloff ~at:"write_create_p") l))) - end)) - with Not_found -> fatal_error "in write_create_p" - end; - w (" ->\n 'a widget -> " ^ wname ^ " widget\n"); - w "(** [create ?name parent options...] creates a new widget with\n"; - w " parent [parent] and new patch component [name], if specified. *)\n\n" -;; - -let camltk_write_create_p ~w wname = - w "val create : ?name: string -> widget -> options list -> widget \n"; - w "(** [create ?name parent options] creates a new widget with\n"; - w " parent [parent] and new patch component [name] if specified.\n"; - w " Options are restricted to the widget class subset, and checked\n"; - w " dynamically. *)\n\n" -;; - -let camltk_write_named_create_p ~w wname = - w "val create_named : widget -> string -> options list -> widget \n"; - w "(** [create_named parent name options] creates a new widget with\n"; - w " parent [parent] and new patch component [name].\n"; - w " This function is now obsolete and unified with [create]. *)\n\n"; -;; - -(* Unsafe: write special comment *) -let labltk_write_function_type ~w def = - if not def.safe then w "(* unsafe *)\n"; - w "val "; w def.ml_name; w " : "; - let us, ls, os = - let tys = types_of_template def.template in - let rec replace_args ~u ~l ~o = function - [] -> u, l, o - | (_, List(Subtype _) as x)::ls -> - replace_args ~u ~l ~o:(x::o) ls - | ("", _ as x)::ls -> - replace_args ~u:(x::u) ~l ~o ls - | (p, _ as x)::ls when p.[0] = '?' -> - replace_args ~u ~l ~o:(x::o) ls - | x::ls -> - replace_args ~u ~l:(x::l) ~o ls - in - replace_args ~u:[] ~l:[] ~o:[] (List.rev tys) - in - let counter = ref 0 in - let params = - if os = [] then us @ ls else ls @ os @ us in - List.iter params ~f: - begin fun (l, t) -> - if l <> "" then w (l ^ ":"); - w (ppMLtype t ~counter); - w " -> " - end; - if (os <> [] || ls = []) && us = [] then w "unit -> "; - w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) - w " \n"; -(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *) - if def.safe then w "\n" - else w "\n(* /unsafe *)\n" - -let camltk_write_function_type ~w def = - if not def.safe then w "(* unsafe *)\n"; - w "val "; w def.ml_name; w " : "; - let us, os = - let tys = types_of_template def.template in - let rec replace_args ~u ~o = function - [] -> u, o - | ("", _ as x)::ls -> - replace_args ~u:(x::u) ~o ls - | (p, _ as x)::ls when p.[0] = '?' -> - replace_args ~u ~o:(x::o) ls - | x::ls -> - replace_args ~u:(x::u) ~o ls - in - replace_args ~u:[] ~o:[] (List.rev tys) - in - let counter = ref 0 in - let params = - if os = [] then us else os @ us in - List.iter params ~f: - begin fun (l, t) -> - if l <> "" then if l.[0] = '?' then w (l ^ ":"); - w (ppMLtype t ~counter); - w " -> " - end; - if us = [] then w "unit -> "; - w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) - w " \n"; -(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *) - if def.safe then w "\n" - else w "\n(* /unsafe *)\n" - -(* - if not def.safe then w "(* unsafe *)\n"; - w "val "; w def.ml_name; w " : "; - let tys = types_of_template def.template in - let counter = ref 0 in - let have_normal_arg = ref false in - List.iter tys ~f: - begin fun (l, t) -> - if l <> "" then - if l.[0] = '?' then w (l^":") - else begin - have_normal_arg := true; - w (" (* " ^ l ^ ":*)") - end - else have_normal_arg := true; - w (ppMLtype t ~counter); - w " -> " - end; - if not !have_normal_arg then w "unit -> "; - w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) - w " \n"; - if def.safe then w "\n" - else w "\n(* /unsafe *)\n" -*) - -let write_function_type ~w def = - if !Flags.camltk then camltk_write_function_type ~w def - else labltk_write_function_type ~w def - -let write_external_type ~w def = - match def.template with - | StringArg fname -> - begin try - let realname = find_in_path !search_path (fname ^ ".mli") in - let ic = open_in_bin realname in - try - let code_list = Ppparse.parse_channel ic in - close_in ic; - if not def.safe then w "(* unsafe *)\n"; - List.iter (Ppexec.exec (fun _ -> ()) w) - (if !Flags.camltk then - Code.Define "CAMLTK" :: code_list else code_list ); - if def.safe then w "\n\n" - else w "\n(* /unsafe *)\n\n" - with - | Ppparse.Error s -> - close_in ic; - raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) - with - | Not_found -> - raise (Compiler_Error ("can't find external file: " ^ fname)) - end - | _ -> raise (Compiler_Error "invalid external definition") diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll deleted file mode 100644 index 2fc2376e2707..000000000000 --- a/otherlibs/labltk/compiler/lexer.mll +++ /dev/null @@ -1,170 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -{ -open StdLabels -open Lexing -open Parser -open Support - -exception Lexical_error of string -let current_line = ref 1 - - -(* The table of keywords *) - -let keyword_table = (Hashtbl.create 149 : (string, token) Hashtbl.t) - -let _ = List.iter - ~f:(fun (str,tok) -> Hashtbl.add keyword_table str tok) - [ - "int", TYINT; - "float", TYFLOAT; - "bool", TYBOOL; - "char", TYCHAR; - "string", TYSTRING; - "list", LIST; - "as", AS; - "variant", VARIANT; - "widget", WIDGET; - "option", OPTION; - "type", TYPE; - "subtype", SUBTYPE; - "function", FUNCTION; - "module", MODULE; - "external", EXTERNAL; - "sequence", SEQUENCE; - "unsafe", UNSAFE -] - - -(* To buffer string literals *) - -let initial_string_buffer = String.create 256 -let string_buff = ref initial_string_buffer -let string_index = ref 0 - -let reset_string_buffer () = - string_buff := initial_string_buffer; - string_index := 0; - () - -let store_string_char c = - if !string_index >= String.length (!string_buff) then begin - let new_buff = String.create (String.length (!string_buff) * 2) in - String.blit ~src:(!string_buff) ~src_pos:0 ~dst:new_buff ~dst_pos:0 - ~len:(String.length (!string_buff)); - string_buff := new_buff - end; - String.set (!string_buff) (!string_index) c; - incr string_index - -let get_stored_string () = - let s = String.sub (!string_buff) ~pos:0 ~len:(!string_index) in - string_buff := initial_string_buffer; - s -(* To translate escape sequences *) - -let char_for_backslash = function - 'n' -> '\010' - | 'r' -> '\013' - | 'b' -> '\008' - | 't' -> '\009' - | c -> c - -let char_for_decimal_code lexbuf i = - Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + - 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + - (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48)) - -let saved_string_start = ref 0 - -} - -rule main = parse - '\010' { incr current_line; main lexbuf } - | [' ' '\013' '\009' '\026' '\012'] + - { main lexbuf } - | ['A'-'Z' 'a'-'z' '\192'-'\214' '\216'-'\246' '\248'-'\255' ] - ( '_' ? ['A'-'Z' 'a'-'z' '\192'-'\214' '\216'-'\246' '\248'-'\255' (*'*) '0'-'9' ] ) * - { let s = Lexing.lexeme lexbuf in - try - Hashtbl.find keyword_table s - with Not_found -> - IDENT s } - - | "\"" - { reset_string_buffer(); - (* Start of token is start of string. *) - saved_string_start := lexbuf.lex_start_pos; - string lexbuf; - lexbuf.lex_start_pos <- !saved_string_start; - STRING (get_stored_string()) } - | "(" { LPAREN } - | ")" { RPAREN } - | "[" { LBRACKET } - | "]" { RBRACKET } - | "{" { LBRACE } - | "}" { RBRACE } - | "," { COMMA } - | ";" { SEMICOLON } - | ":" {COLON} - | "?" {QUESTION} - | "/" {SLASH} - | "%" { comment lexbuf; main lexbuf } - | "##line" { line lexbuf; main lexbuf } - | eof { EOF } - | _ - { raise (Lexical_error("illegal character")) } - - -and string = parse - '"' - { () } - | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] + - { string lexbuf } - | '\\' ['\\' '"' 'n' 't' 'b' 'r'] - { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); - string lexbuf } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] - { store_string_char(char_for_decimal_code lexbuf 1); - string lexbuf } - | eof - { raise (Lexical_error("string not terminated")) } - | '\010' - { incr current_line; - store_string_char(Lexing.lexeme_char lexbuf 0); - string lexbuf } - | _ - { store_string_char(Lexing.lexeme_char lexbuf 0); - string lexbuf } - -and comment = parse - '\010' { incr current_line } - | eof { () } - | _ { comment lexbuf } - -and linenum = parse - | ['0'-'9']+ { - let next_line = int_of_string (Lexing.lexeme lexbuf) in - current_line := next_line - 1 - } - | _ { raise (Lexical_error("illegal ##line directive: no line number"))} - -and line = parse - | [' ' '\t']* { linenum lexbuf } diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml deleted file mode 100644 index 91b6bcdffb69..000000000000 --- a/otherlibs/labltk/compiler/maincompile.ml +++ /dev/null @@ -1,418 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open StdLabels -open Support -open Tables -open Printer -open Compile -open Intf - -let flag_verbose = ref false -let verbose_string s = - if !flag_verbose then prerr_string s -let verbose_endline s = - if !flag_verbose then prerr_endline s - -let input_name = ref "Widgets.src" -let output_dir = ref "" -let destfile f = Filename.concat !output_dir f - -let usage () = - prerr_string "Usage: tkcompiler input.src\n"; - flush stderr; - exit 1 - - -let prerr_error_header () = - prerr_string "File \""; prerr_string !input_name; - prerr_string "\", line "; - prerr_string (string_of_int !Lexer.current_line); - prerr_string ": " - -(* parse Widget.src config file *) -let parse_file filename = - let ic = open_in_bin filename in - let lexbuf = - try - let code_list = Ppparse.parse_channel ic in - close_in ic; - let buf = Buffer.create 50000 in - List.iter (Ppexec.exec - (fun l -> Buffer.add_string buf - (Printf.sprintf "##line %d\n" l)) - (Buffer.add_string buf)) - (if !Flags.camltk then Code.Define "CAMLTK" :: code_list - else code_list); - Lexing.from_string (Buffer.contents buf) - with - | Ppparse.Error s -> - close_in ic; - raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) - in - try - while true do - Parser.entry Lexer.main lexbuf - done - with - | Parsing.Parse_error -> - prerr_error_header(); - prerr_string "Syntax error \n"; - exit 1 - | Lexer.Lexical_error s -> - prerr_error_header(); - prerr_string "Lexical error ("; - prerr_string s; - prerr_string ")\n"; - exit 1 - | Duplicate_Definition (s,s') -> - prerr_error_header(); - prerr_string s; prerr_string " "; prerr_string s'; - prerr_string " is defined twice.\n"; - exit 1 - | Compiler_Error s -> - prerr_error_header(); - prerr_string "Internal error: "; prerr_string s; prerr_string "\n"; - prerr_string "Please report bug\n"; - exit 1 - | End_of_file -> - () - -(* The hack to provoke the production of cCAMLtoTKoptions_constrs *) - -(* Auxiliary function: the list of all the elements associated to keys - in an hash table. *) -let elements t = - let elems = ref [] in - Hashtbl.iter (fun _ d -> elems := d :: !elems) t; - !elems;; - -(* Verifies that duplicated clauses are semantically equivalent and - returns a unique set of clauses. *) -let uniq_clauses = function - | [] -> [] - | l -> - let check_constr constr1 constr2 = - if constr1.template <> constr2.template then - begin - let code1, vars11, vars12, opts1 = - code_of_template ~context_widget:"dummy" constr1.template in - let code2, vars12, vars22, opts2 = - code_of_template ~context_widget:"dummy" constr2.template in - let err = - Printf.sprintf - "uncompatible redondant clauses for variant %s:\n %s\n and\n %s" - constr1.var_name code1 code2 in - Format.print_newline(); - print_fullcomponent constr1; - Format.print_newline(); - print_fullcomponent constr2; - Format.print_newline(); - prerr_endline err; - fatal_error err - end in - let t = Hashtbl.create 11 in - List.iter l - ~f:(fun constr -> - let c = constr.var_name in - if Hashtbl.mem t c - then (check_constr constr (Hashtbl.find t c)) - else Hashtbl.add t c constr); - elements t;; - -let option_hack oc = - if Hashtbl.mem types_table "options" then - let typdef = Hashtbl.find types_table "options" in - let hack = - { parser_arity = OneToken; - constructors = begin - let constrs = - List.map typdef.constructors ~f: - begin fun c -> - { component = Constructor; - ml_name = (if !Flags.camltk then "C" ^ c.ml_name - else c.ml_name); - var_name = c.var_name; (* as variants *) - template = - begin match c.template with - ListArg (x :: _) -> x - | _ -> fatal_error "bogus hack" - end; - result = UserDefined "options_constrs"; - safe = true } - end in - if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *) - end; - subtypes = []; - requires_widget_context = false; - variant = false } - in - write_CAMLtoTK - ~w:(output_string oc) ~def:hack ~safetype:false "options_constrs" - -let realname name = - (* module name fix for camltk *) - if !Flags.camltk then "c" ^ String.capitalize name - else name -;; - -(* analize the parsed Widget.src and output source files *) -let compile () = - verbose_endline "Creating _tkgen.ml ..."; - let oc = open_out_bin (destfile "_tkgen.ml") in - let oc' = open_out_bin (destfile "_tkigen.ml") in - let oc'' = open_out_bin (destfile "_tkfgen.ml") in - let sorted_types = Tsort.sort types_order in - verbose_endline " writing types ..."; - List.iter sorted_types ~f: - begin fun typname -> - verbose_string (" " ^ typname ^ " "); - try - let typdef = Hashtbl.find types_table typname in - verbose_string "type "; - write_type ~intf:(output_string oc) - ~impl:(output_string oc') - typname ~def:typdef; - verbose_string "C2T "; - write_CAMLtoTK ~w:(output_string oc') typname ~def:typdef; - verbose_string "T2C "; - if List.mem typname !types_returned then - write_TKtoCAML ~w:(output_string oc') typname ~def:typdef; - verbose_string "CO "; - if not !Flags.camltk then (* only for LablTk *) - write_catch_optionals ~w:(output_string oc') typname ~def:typdef; - verbose_endline "." - with Not_found -> - if not (List.mem_assoc typname !types_external) then - begin - verbose_string "Type "; - verbose_string typname; - verbose_string " is undeclared external or undefined\n" - end - else verbose_endline "." - end; - verbose_endline " option hacking ..."; - option_hack oc'; - verbose_endline " writing functions ..."; - List.iter ~f:(write_function ~w:(output_string oc'')) !function_table; - close_out oc; - close_out oc'; - close_out oc''; - (* Write the interface for public functions *) - (* this interface is used only for documentation *) - verbose_endline "Creating _tkgen.mli ..."; - let oc = open_out_bin (destfile "_tkgen.mli") in - List.iter (sort_components !function_table) - ~f:(write_function_type ~w:(output_string oc)); - close_out oc; - verbose_endline "Creating other ml, mli ..."; - let write_module wname wdef = - verbose_endline (" "^wname); - let modname = realname wname in - let oc = open_out_bin (destfile (modname ^ ".ml")) - and oc' = open_out_bin (destfile (modname ^ ".mli")) in - Copyright.write ~w:(output_string oc); - Copyright.write ~w:(output_string oc'); - begin match wdef.module_type with - Widget -> output_string oc' ("(* The "^wname^" widget *)\n") - | Family -> output_string oc' ("(* The "^wname^" commands *)\n") - end; - List.iter ~f:(fun s -> output_string oc s; output_string oc' s) - begin - if !Flags.camltk then - [ "open CTk\n"; - "open Tkintf\n"; - "open Widget\n"; - "open Textvariable\n\n" ] - else - [ "open StdLabels\n"; - "open Tk\n"; - "open Tkintf\n"; - "open Widget\n"; - "open Textvariable\n\n" ] - end; - output_string oc "open Protocol\n"; - begin match wdef.module_type with - Widget -> - if !Flags.camltk then begin - camltk_write_create ~w:(output_string oc) wname; - camltk_write_named_create ~w:(output_string oc) wname; - camltk_write_create_p ~w:(output_string oc') wname; - camltk_write_named_create_p ~w:(output_string oc') wname; - end else begin - labltk_write_create ~w:(output_string oc) wname; - labltk_write_create_p ~w:(output_string oc') wname - end - | Family -> () - end; - List.iter ~f:(write_function ~w:(output_string oc)) - (sort_components wdef.commands); - List.iter ~f:(write_function_type ~w:(output_string oc')) - (sort_components wdef.commands); - List.iter ~f:(write_external ~w:(output_string oc)) - (sort_components wdef.externals); - List.iter ~f:(write_external_type ~w:(output_string oc')) - (sort_components wdef.externals); - close_out oc; - close_out oc' - in Hashtbl.iter write_module module_table; - - (* wrapper code camltk.ml and labltk.ml *) - if !Flags.camltk then begin - let oc = open_out_bin (destfile "camltk.ml") in - Copyright.write ~w:(output_string oc); - output_string oc -"(** This module Camltk provides the module name spaces of the CamlTk API.\n\ -\n\ - The users of the CamlTk API should open this module first to access\n\ - the types, functions and modules of the CamlTk API easier.\n\ - For the documentation of each sub modules such as [Button] and [Toplevel],\n\ - refer to its defintion file, [cButton.mli], [cToplevel.mli], etc.\n\ - *)\n\ -\n\ -"; - output_string oc "include CTk\n"; - output_string oc "module Tk = CTk\n"; - Hashtbl.iter (fun name _ -> - let cname = realname name in - output_string oc (Printf.sprintf "module %s = %s;;\n" - (String.capitalize name) - (String.capitalize cname))) module_table; - close_out oc - end else begin - let oc = open_out_bin (destfile "labltk.ml") in - Copyright.write ~w:(output_string oc); - output_string oc -"(** This module Labltk provides the module name spaces of the LablTk API,\n\ - useful to call LablTk functions inside CamlTk programs. 100% LablTk users\n\ - do not need to use this. *)\n\ -\n\ -"; - output_string oc "module Widget = Widget;;\n\ -module Protocol = Protocol;;\n\ -module Textvariable = Textvariable;;\n\ -module Fileevent = Fileevent;;\n\ -module Timer = Timer;;\n\ -"; - Hashtbl.iter (fun name _ -> - let cname = realname name in - output_string oc (Printf.sprintf "module %s = %s;;\n" - (String.capitalize name) - (String.capitalize cname))) module_table; - (* widget typer *) - output_string oc "\n(** Widget typers *)\n\nopen Widget\n\n"; - Hashtbl.iter (fun name def -> - match def.module_type with - | Widget -> - output_string oc (Printf.sprintf - "let %s (w : any widget) =\n" name); - output_string oc (Printf.sprintf - " Rawwidget.check_class w widget_%s_table;\n" name); - output_string oc (Printf.sprintf - " (Obj.magic w : %s widget);;\n\n" name); - | _ -> () ) module_table; - close_out oc - end; - - (* write the module list for the Makefile *) - (* and hack to death until it works *) - let oc = open_out_bin (destfile "modules") in - if !Flags.camltk then output_string oc "CWIDGETOBJS=" - else output_string oc "WIDGETOBJS="; - Hashtbl.iter - (fun name _ -> - let name = realname name in - output_string oc name; - output_string oc ".cmo ") - module_table; - output_string oc "\n"; - Hashtbl.iter - (fun name _ -> - let name = realname name in - output_string oc name; - output_string oc ".ml ") - module_table; - output_string oc ": _tkgen.ml\n\n"; - Hashtbl.iter - (fun name _ -> - let name = realname name in - output_string oc name; - output_string oc ".cmo : "; - output_string oc name; - output_string oc ".ml\n"; - output_string oc name; - output_string oc ".cmi : "; - output_string oc name; - output_string oc ".mli\n") - module_table; - - (* for camltk.ml wrapper *) - if !Flags.camltk then begin - output_string oc "camltk.cmo : cTk.cmo "; - Hashtbl.iter - (fun name _ -> - let name = realname name in - output_string oc name; - output_string oc ".cmo ") module_table; - output_string oc "\n" - end; - close_out oc - -let main () = - Arg.parse - [ "-verbose", Arg.Unit (fun () -> flag_verbose := true), - "Make output verbose"; - "-camltk", Arg.Unit (fun () -> Flags.camltk := true), - "Make CamlTk interface"; - "-outdir", Arg.String (fun s -> output_dir := s), - "output directory"; - "-debugpp", Arg.Unit (fun () -> Ppexec.debug := true), - "debug preprocessor" - ] - (fun filename -> input_name := filename) - "Usage: tkcompiler " ; - if !output_dir = "" then begin - prerr_endline "specify -outdir option"; - exit 1 - end; - try - verbose_endline "Parsing..."; - parse_file !input_name; - verbose_endline "Compiling..."; - compile (); - verbose_endline "Finished"; - exit 0 - with - | Lexer.Lexical_error s -> - prerr_string "Invalid lexical character: "; - prerr_endline s; - exit 1 - | Duplicate_Definition (s, s') -> - prerr_string s; prerr_string " "; prerr_string s'; - prerr_endline " is redefined illegally"; - exit 1 - | Invalid_implicit_constructor c -> - prerr_string "Constructor "; - prerr_string c; - prerr_endline " is used implicitly before defined"; - exit 1 - | Tsort.Cyclic -> - prerr_endline "Cyclic dependency of types"; - exit 1 - -let () = Printexc.catch main () diff --git a/otherlibs/labltk/compiler/parser.mly b/otherlibs/labltk/compiler/parser.mly deleted file mode 100644 index 6dc7aff32907..000000000000 --- a/otherlibs/labltk/compiler/parser.mly +++ /dev/null @@ -1,330 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of OCaml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file ../../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -%{ - -open Tables - -%} - -/* Tokens */ -%token IDENT -%token STRING -%token EOF - -%token LPAREN /* "(" */ -%token RPAREN /* ")" */ -%token COMMA /* "," */ -%token SEMICOLON /* ";" */ -%token COLON /* ":" */ -%token QUESTION /* "?" */ -%token LBRACKET /* "[" */ -%token RBRACKET /* "]" */ -%token LBRACE /* "{" */ -%token RBRACE /* "}" */ -%token SLASH /* "/" */ - -%token TYINT /* "int" */ -%token TYFLOAT /* "float" */ -%token TYBOOL /* "bool" */ -%token TYCHAR /* "char" */ -%token TYSTRING /* "string" */ -%token LIST /* "list" */ - -%token AS /* "as" */ -%token VARIANT /* "variant" */ -%token WIDGET /* "widget" */ -%token OPTION /* "option" */ -%token TYPE /* "type" */ -%token SEQUENCE /* "sequence" */ -%token SUBTYPE /* "subtype" */ -%token FUNCTION /* "function" */ -%token MODULE /* "module" */ -%token EXTERNAL /* "external" */ -%token UNSAFE /* "unsafe" */ -/* Entry points */ -%start entry -%type entry - -%% -TypeName: - IDENT { String.uncapitalize $1 } - | WIDGET { "widget" } -; - -/* Atomic types */ -Type0 : - TYINT - { Int } - | TYFLOAT - { Float } - | TYBOOL - { Bool } - | TYCHAR - { Char } - | TYSTRING - { String } - | TypeName - { UserDefined $1 } -; - -/* Camltk/Labltk types */ -Type0_5: - | Type0 SLASH Type0 { if !Flags.camltk then $1 else $3 } - | Type0 { $1 } -; - -/* with subtypes */ -Type1 : - Type0_5 - { $1 } - | TypeName LPAREN IDENT RPAREN - { Subtype ($1, $3) } - | WIDGET LPAREN IDENT RPAREN - { Subtype ("widget", $3) } - | OPTION LPAREN IDENT RPAREN - { Subtype ("options", $3) } - | Type1 AS STRING - { As ($1, $3) } - | LBRACE Type_list RBRACE - { Product $2 } -; - -/* with list constructors */ -Type2 : - Type1 - { $1 } - | Type2 LIST - { List $1 } -; - -Labeled_type2 : - Type2 - { "", $1 } - | IDENT COLON Type2 - { $1, $3 } -; - -/* products */ -Type_list : - Type2 COMMA Type_list - { $1 :: $3 } - | Type2 - { [$1] } -; - -/* records */ -Type_record : - Labeled_type2 COMMA Type_record - { $1 :: $3 } - | Labeled_type2 - { [$1] } -; - -/* callback arguments or function results*/ -FType : - LPAREN RPAREN - { Unit } - | LPAREN Type2 RPAREN - { $2 } - | LPAREN Type_record RPAREN - { Record $2 } -; - -Type : - Type2 - { $1 } - | FUNCTION FType - { Function $2 } -; - - - -SimpleArg: - STRING - {StringArg $1} - | Type - {TypeArg ("", $1) } -; - -Arg: - STRING - {StringArg $1} - | Type - {TypeArg ("", $1) } - | IDENT COLON Type - {TypeArg ($1, $3)} - | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET DefaultList - {OptionalArgs ( $2, $5, $7 )} - | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET DefaultList - {OptionalArgs ( "widget", $5, $7 )} - | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET - {OptionalArgs ( $2, $5, [] )} - | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET - {OptionalArgs ( "widget", $5, [] )} - | WIDGET COLON Type - {TypeArg ("widget", $3)} - | Template - { $1 } -; - -SimpleArgList: - SimpleArg SEMICOLON SimpleArgList - { $1 :: $3} - | SimpleArg - { [$1] } -; - -ArgList: - Arg SEMICOLON ArgList - { $1 :: $3} - | Arg - { [$1] } -; - -/* DefaultList Only one TypeArg in ArgList and it must be unlabeled */ -DefaultList : - LBRACKET LBRACE ArgList RBRACE RBRACKET - {$3} - -/* Template */ -Template : - LBRACKET ArgList RBRACKET - { ListArg $2 } -; - - -/* Constructors for type declarations */ -Constructor : - IDENT Template - {{ component = Constructor; - ml_name = $1; - var_name = getvarname $1 $2; - template = $2; - result = Unit; - safe = true }} - | IDENT LPAREN IDENT RPAREN Template - {{ component = Constructor; - ml_name = $1; - var_name = $3; - template = $5; - result = Unit; - safe = true }} -; - -AbbrevConstructor : - Constructor - { Full $1 } - | IDENT - { Abbrev $1 } -; - -Constructors : - Constructor Constructors - { $1 :: $2 } -| Constructor - { [$1] } -; - -AbbrevConstructors : - AbbrevConstructor AbbrevConstructors - { $1 :: $2 } -| AbbrevConstructor - { [$1] } -; - -Safe: - /* */ - { true } - | UNSAFE - { false } - -Command : - Safe FUNCTION FType IDENT Template - {{component = Command; ml_name = $4; var_name = ""; - template = $5; result = $3; safe = $1 }} -; - -External : - Safe EXTERNAL IDENT STRING - {{component = External; ml_name = $3; var_name = ""; - template = StringArg $4; result = Unit; safe = $1}} -; - -Option : - OPTION IDENT Template - {{component = Constructor; ml_name = $2; var_name = getvarname $2 $3; - template = $3; result = Unit; safe = true }} - /* Abbreviated */ -| OPTION IDENT LPAREN IDENT RPAREN Template - {{component = Constructor; ml_name = $2; var_name = $4; - template = $6; result = Unit; safe = true }} - /* Abbreviated */ -| OPTION IDENT - { retrieve_option $2 } -; - -WidgetComponents : - /* */ - { [] } - | Command WidgetComponents - { $1 :: $2 } - | Option WidgetComponents - { $1 :: $2 } - | External WidgetComponents - { $1 :: $2 } -; - -ModuleComponents : - /* */ - { [] } - | Command ModuleComponents - { $1 :: $2 } - | External ModuleComponents - { $1 :: $2 } -; - -ParserArity : - /* */ - { OneToken } - | SEQUENCE - { MultipleToken } -; - - - -entry : - TYPE ParserArity TypeName LBRACE Constructors RBRACE - { enter_type $3 $2 $5 } -| VARIANT TYPE ParserArity TypeName LBRACE Constructors RBRACE - { enter_type $4 $3 $6 ~variant: true } -| TYPE ParserArity TypeName EXTERNAL - { enter_external_type $3 $2 } -| SUBTYPE ParserArity OPTION LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE - { enter_subtype "options" $2 $5 $8 } -| SUBTYPE ParserArity TypeName LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE - { enter_subtype $3 $2 $5 $8 } -| Command - { enter_function $1 } -| WIDGET IDENT LBRACE WidgetComponents RBRACE - { enter_widget $2 $4 } -| MODULE IDENT LBRACE ModuleComponents RBRACE - { enter_module (String.uncapitalize $2) $4 } -| EOF - { raise End_of_file } -; diff --git a/otherlibs/labltk/compiler/pp.ml b/otherlibs/labltk/compiler/pp.ml deleted file mode 100644 index c6d4f798730f..000000000000 --- a/otherlibs/labltk/compiler/pp.ml +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -let _ = - try - let code_list = Ppparse.parse_channel stdin in - List.iter (Ppexec.exec (fun _ -> ()) print_string) code_list - with - | Ppparse.Error s -> prerr_endline s; exit 2 -;; diff --git a/otherlibs/labltk/compiler/ppexec.ml b/otherlibs/labltk/compiler/ppexec.ml deleted file mode 100644 index dd66928c74ff..000000000000 --- a/otherlibs/labltk/compiler/ppexec.ml +++ /dev/null @@ -1,60 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -open Code - -let debug = ref false -let defined = ref [] -let linenum = ref 1 - -let rec nop = function - | Line _ -> incr linenum - | Ifdef (_, _, c1, c2o) -> - List.iter nop c1; - begin match c2o with - | Some c2 -> List.iter nop c2 - | None -> () - end - | _ -> () -;; - -let rec exec lp f = function - | Line line -> - if !debug then - prerr_endline (Printf.sprintf "%03d: %s" !linenum - (String.sub line 0 ((String.length line) - 1))); - f line; incr linenum - | Ifdef (sw, k, c1, c2o) -> - if List.mem k !defined = sw then begin - List.iter (exec lp f) c1; - begin match c2o with - | Some c2 -> List.iter nop c2 - | None -> () - end; - lp !linenum - end else begin - List.iter nop c1; - match c2o with - | Some c2 -> - lp !linenum; - List.iter (exec lp f) c2 - | None -> () - end - | Define k -> defined := k :: !defined - | Undef k -> - defined := List.fold_right (fun k' s -> - if k = k' then s else k' :: s) [] !defined -;; diff --git a/otherlibs/labltk/compiler/pplex.mli b/otherlibs/labltk/compiler/pplex.mli deleted file mode 100644 index 0502fc9019a9..000000000000 --- a/otherlibs/labltk/compiler/pplex.mli +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -exception Error of string -val token : Lexing.lexbuf -> Ppyac.token diff --git a/otherlibs/labltk/compiler/pplex.mll b/otherlibs/labltk/compiler/pplex.mll deleted file mode 100644 index 6559d8e94e2e..000000000000 --- a/otherlibs/labltk/compiler/pplex.mll +++ /dev/null @@ -1,56 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file ../../../LICENSE. *) -(* *) -(***********************************************************************) - -{ -open Ppyac -exception Error of string -let linenum = ref 1 -} - -let blank = [' ' '\013' '\009' '\012'] -let identchar = - ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] -let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] -let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] - -rule token = parse - blank + { token lexbuf } -| "##" [' ' '\t']* { directive lexbuf } -| ("#")? [^ '#' '\n']* '\n'? { - begin - let str = Lexing.lexeme lexbuf in - if String.length str <> 0 && str.[String.length str - 1] = '\n' then - begin - incr linenum - end; - OTHER (str) - end - } -| eof { EOF } - -and directive = parse -| "ifdef" [' ' '\t']+ { IFDEF (ident lexbuf)} -| "ifndef" [' ' '\t']+ { IFNDEF (ident lexbuf)} -| "else" { ELSE } -| "endif" { ENDIF } -| "define" [' ' '\t']+* { DEFINE (ident lexbuf)} -| "undef" [' ' '\t']+ { UNDEF (ident lexbuf)} -| _ { raise (Error (Printf.sprintf "unknown directive at line %d" !linenum))} - -and ident = parse -| lowercase identchar* | uppercase identchar* - { Lexing.lexeme lexbuf } -| _ { raise (Error (Printf.sprintf "illegal identifier at line %d" !linenum)) } diff --git a/otherlibs/labltk/compiler/ppparse.ml b/otherlibs/labltk/compiler/ppparse.ml deleted file mode 100644 index 2b0fdbf8ca37..000000000000 --- a/otherlibs/labltk/compiler/ppparse.ml +++ /dev/null @@ -1,36 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -exception Error of string - -let parse_channel ic = - let lexbuf = Lexing.from_channel ic in - try - Ppyac.code_list Pplex.token lexbuf - with - | Pplex.Error s -> - let loc_start = Lexing.lexeme_start lexbuf - and loc_end = Lexing.lexeme_end lexbuf - in - raise (Error (Printf.sprintf "parse error at char %d, %d: %s" - loc_start loc_end s)) - | Parsing.Parse_error -> - let loc_start = Lexing.lexeme_start lexbuf - and loc_end = Lexing.lexeme_end lexbuf - in - raise (Error (Printf.sprintf "parse error at char %d, %d" - loc_start loc_end)) -;; diff --git a/otherlibs/labltk/compiler/ppyac.mly b/otherlibs/labltk/compiler/ppyac.mly deleted file mode 100644 index f92ef966481d..000000000000 --- a/otherlibs/labltk/compiler/ppyac.mly +++ /dev/null @@ -1,52 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of OCaml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file ../../../LICENSE. */ -/* */ -/***********************************************************************/ - -%{ -open Code -%} - -%token IFDEF -%token IFNDEF -%token ELSE -%token ENDIF -%token DEFINE -%token UNDEF -%token OTHER -%token EOF - -/* entry */ - -%start code_list -%type code_list - -%% - -code_list: - /* empty */ { [] } - | code code_list { $1 :: $2 } -; - -code: - | DEFINE { Define $1 } - | UNDEF { Undef $1 } - | IFDEF code_list ELSE code_list ENDIF { Ifdef (true, $1, $2, Some ($4)) } - | IFNDEF code_list ELSE code_list ENDIF { Ifdef (false, $1, $2, Some ($4)) } - | IFDEF code_list ENDIF { Ifdef (true, $1, $2, None) } - | IFNDEF code_list ENDIF { Ifdef (false, $1, $2, None) } - | OTHER { Line $1 } -; - -%% diff --git a/otherlibs/labltk/compiler/printer.ml b/otherlibs/labltk/compiler/printer.ml deleted file mode 100644 index fe33ada36758..000000000000 --- a/otherlibs/labltk/compiler/printer.ml +++ /dev/null @@ -1,173 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -open Tables;; - -open Format;; - -let escape_string s = - let more = ref 0 in - for i = 0 to String.length s - 1 do - match s.[i] with - | '\\' | '"' -> incr more - | _ -> () - done; - if !more = 0 then s else - let res = String.create (String.length s + !more) in - let j = ref 0 in - for i = 0 to String.length s - 1 do - let c = s.[i] in - match c with - | '\\' | '"' -> res.[!j] <- '\\'; incr j; res.[!j] <- c; incr j - | _ -> res.[!j] <- c; incr j - done; - res;; - -let escape_char c = if c = '\'' then "\\'" else String.make 1 c;; - -let print_quoted_string s = printf "\"%s\"" (escape_string s);; -let print_quoted_char c = printf "'%s'" (escape_char c);; -let print_quoted_int i = - if i < 0 then printf "(%d)" i else printf "%d" i;; -let print_quoted_float f = - if f <= 0.0 then printf "(%f)" f else printf "%f" f;; - -(* Iterators *) -let print_list f l = - printf "@[<1>["; - let rec pl = function - | [] -> printf "@;<0 -1>]@]" - | [x] -> f x; pl [] - | x :: xs -> f x; printf ";@ "; pl xs in - pl l;; - -let print_array f v = - printf "@[<2>[|"; - let l = Array.length v in - if l >= 1 then f v.(0); - if l >= 2 then - for i = 1 to l - 1 do - printf ";@ "; f v.(i) - done; - printf "@;<0 -1>|]@]";; - -let print_option f = function - | None -> print_string "None" - | Some x -> printf "@[<1>Some@ "; f x; printf "@]";; - -let print_bool = function - | true -> print_string "true" | _ -> print_string "false";; - -let print_poly x = print_string "";; - -(* Types of the description language *) -let rec print_mltype = function - | Unit -> printf "Unit" | Int -> printf "Int" | Float -> printf "Float" - | Bool -> printf "Bool" | Char -> printf "Char" | String -> printf "String" - | List m -> printf "@[<1>(%s@ " "List"; print_mltype m; printf ")@]" - | Product l_m -> - printf "@[<1>(%s@ " "Product"; print_list print_mltype l_m; printf ")@]" - | Record l_t_s_m -> - printf "@[<1>(%s@ " "Record"; - print_list - (function (s, m) -> - printf "@[<1>("; print_quoted_string s; printf ",@ "; print_mltype m; - printf ")@]") - l_t_s_m; - printf ")@]" - | UserDefined s -> - printf "@[<1>(%s@ " "UserDefined"; print_quoted_string s; printf ")@]" - | Subtype (s, s0) -> - printf "@[<1>(%s@ " "Subtype"; printf "@[<1>("; print_quoted_string s; - printf ",@ "; print_quoted_string s0; printf ")@]"; printf ")@]" - | Function m -> - printf "@[<1>(%s@ " "Function"; print_mltype m; printf ")@]" - | As (m, s) -> - printf "@[<1>(%s@ " "As"; printf "@[<1>("; print_mltype m; printf ",@ "; - print_quoted_string s; printf ")@]"; printf ")@]";; - -let rec print_template = function - | StringArg s -> - printf "@[<1>(%s@ " "StringArg"; print_quoted_string s; printf ")@]" - | TypeArg (s, m) -> - printf "@[<1>(%s@ " "TypeArg"; printf "@[<1>("; print_quoted_string s; - printf ",@ "; print_mltype m; printf ")@]"; printf ")@]" - | ListArg l_t -> - printf "@[<1>(%s@ " "ListArg"; print_list print_template l_t; - printf ")@]" - | OptionalArgs (s, l_t, l_t0) -> - printf "@[<1>(%s@ " "OptionalArgs"; printf "@[<1>("; - print_quoted_string s; printf ",@ "; print_list print_template l_t; - printf ",@ "; print_list print_template l_t0; printf ")@]"; printf ")@]";; - -(* Sorts of components *) -let rec print_component_type = function - | Constructor -> printf "Constructor" | Command -> printf "Command" - | External -> printf "External";; - -(* Full definition of a component *) -let rec print_fullcomponent = function - {component = c; ml_name = s; var_name = s0; template = t; result = m; - safe = b; - } -> - printf "@[<1>{"; printf "@[<1>component =@ "; print_component_type c; - printf ";@]@ "; printf "@[<1>ml_name =@ "; print_quoted_string s; - printf ";@]@ "; printf "@[<1>var_name =@ "; print_quoted_string s0; - printf ";@]@ "; printf "@[<1>template =@ "; print_template t; - printf ";@]@ "; printf "@[<1>result =@ "; print_mltype m; printf ";@]@ "; - printf "@[<1>safe =@ "; print_bool b; printf ";@]@ "; printf "@,}@]";; - -(* components are given either in full or abbreviated *) -let rec print_component = function - | Full f -> printf "@[<1>(%s@ " "Full"; print_fullcomponent f; printf ")@]" - | Abbrev s -> - printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]";; - -(* A type definition *) -(* - requires_widget_context: the converter of the type MUST be passed - an additional argument of type Widget. -*) -let rec print_parser_arity = function - | OneToken -> printf "OneToken" | MultipleToken -> printf "MultipleToken";; - -let rec print_type_def = function - {parser_arity = p; constructors = l_f; subtypes = l_t_s_l_f; - requires_widget_context = b; variant = b0; - } -> - printf "@[<1>{"; printf "@[<1>parser_arity =@ "; print_parser_arity p; - printf ";@]@ "; printf "@[<1>constructors =@ "; - print_list print_fullcomponent l_f; printf ";@]@ "; - printf "@[<1>subtypes =@ "; - print_list - (function (s, l_f0) -> - printf "@[<1>("; print_quoted_string s; printf ",@ "; - print_list print_fullcomponent l_f0; printf ")@]") - l_t_s_l_f; - printf ";@]@ "; printf "@[<1>requires_widget_context =@ "; print_bool b; - printf ";@]@ "; printf "@[<1>variant =@ "; print_bool b0; printf ";@]@ "; - printf "@,}@]";; - -let rec print_module_type = function - | Widget -> printf "Widget" | Family -> printf "Family";; - -let rec print_module_def = function - {module_type = m; commands = l_f; externals = l_f0; } -> - printf "@[<1>{"; printf "@[<1>module_type =@ "; print_module_type m; - printf ";@]@ "; printf "@[<1>commands =@ "; - print_list print_fullcomponent l_f; printf ";@]@ "; - printf "@[<1>externals =@ "; print_list print_fullcomponent l_f0; - printf ";@]@ "; printf "@,}@]";; diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml deleted file mode 100644 index a86b4af508f5..000000000000 --- a/otherlibs/labltk/compiler/tables.ml +++ /dev/null @@ -1,427 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open StdLabels -open Support - -(* Internal compiler errors *) - -exception Compiler_Error of string -let fatal_error s = raise (Compiler_Error s) - - -(* Types of the description language *) -type mltype = - Unit - | Int - | Float - | Bool - | Char - | String - | List of mltype - | Product of mltype list - | Record of (string * mltype) list - | UserDefined of string - | Subtype of string * string - | Function of mltype (* arg type only *) - | As of mltype * string - -type template = - StringArg of string - | TypeArg of string * mltype - | ListArg of template list - | OptionalArgs of string * template list * template list - -(* Sorts of components *) -type component_type = - Constructor - | Command - | External - -(* Full definition of a component *) -type fullcomponent = { - component : component_type; - ml_name : string; (* used for camltk *) - var_name : string; (* used just for labltk *) - template : template; - result : mltype; - safe : bool - } - -let sort_components = - List.sort ~cmp:(fun c1 c2 -> compare c1.ml_name c2.ml_name) - - -(* components are given either in full or abbreviated *) -type component = - Full of fullcomponent - | Abbrev of string - -(* A type definition *) -(* - requires_widget_context: the converter of the type MUST be passed - an additional argument of type Widget. -*) - -type parser_arity = - OneToken -| MultipleToken - -type type_def = { - parser_arity : parser_arity; - mutable constructors : fullcomponent list; - mutable subtypes : (string * fullcomponent list) list; - mutable requires_widget_context : bool; - mutable variant : bool -} - -type module_type = - Widget - | Family - -type module_def = { - module_type : module_type; - commands : fullcomponent list; - externals : fullcomponent list -} - -(******************** The tables ********************) - -(* the table of all explicitly defined types *) -let types_table = (Hashtbl.create 37 : (string, type_def) Hashtbl.t) -(* "builtin" types *) -let types_external = ref ([] : (string * parser_arity) list) -(* dependancy order *) -let types_order = (Tsort.create () : string Tsort.porder) -(* Types of atomic values returned by Tk functions *) -let types_returned = ref ([] : string list) -(* Function table *) -let function_table = ref ([] : fullcomponent list) -(* Widget/Module table *) -let module_table = (Hashtbl.create 37 : (string, module_def) Hashtbl.t) - - -(* variant name *) -let rec getvarname ml_name temp = - let offhypben s = - let s = String.copy s in - if (try String.sub s ~pos:0 ~len:1 with _ -> "") = "-" then - String.sub s ~pos:1 ~len:(String.length s - 1) - else s - and makecapital s = - begin - try - let cd = s.[0] in - if cd >= 'a' && cd <= 'z' then - s.[0] <- Char.chr (Char.code cd + (Char.code 'A' - Char.code 'a')) - with - _ -> () - end; - s - in - let head = makecapital (offhypben begin - match temp with - StringArg s -> s - | TypeArg (s,t) -> s - | ListArg (h::_) -> getvarname ml_name h - | OptionalArgs (s,_,_) -> s - | ListArg [] -> "" - end) - in - let varname = if head = "" then ml_name - else if head.[0] >= 'A' && head.[0] <= 'Z' then head - else ml_name - in varname - -(***** Some utilities on the various tables *****) -(* Enter a new empty type *) -let new_type typname arity = - Tsort.add_element types_order typname; - let typdef = {parser_arity = arity; - constructors = []; - subtypes = []; - requires_widget_context = false; - variant = false} in - Hashtbl.add types_table typname typdef; - typdef - - -(* Assume that types not yet defined are not subtyped *) -(* Widget is builtin and implicitly subtyped *) -let is_subtyped s = - s = "widget" || - try - let typdef = Hashtbl.find types_table s in - typdef.subtypes <> [] - with - Not_found -> false - -let requires_widget_context s = - try - (Hashtbl.find types_table s).requires_widget_context - with - Not_found -> false - -let declared_type_parser_arity s = - try - (Hashtbl.find types_table s).parser_arity - with - Not_found -> - try List.assoc s !types_external - with - Not_found -> - prerr_string "Type "; prerr_string s; - prerr_string " is undeclared external or undefined\n"; - prerr_string ("Assuming cTKtoCAML"^s^" : string -> "^s^"\n"); - OneToken - -let rec type_parser_arity = function - Unit -> OneToken - | Int -> OneToken - | Float -> OneToken - | Bool -> OneToken - | Char -> OneToken - | String -> OneToken - | List _ -> MultipleToken - | Product _ -> MultipleToken - | Record _ -> MultipleToken - | UserDefined s -> declared_type_parser_arity s - | Subtype (s,_) -> declared_type_parser_arity s - | Function _ -> OneToken - | As (ty, _) -> type_parser_arity ty - -let enter_external_type s v = - types_external := (s,v)::!types_external - -(*** Stuff for topological Sort.list of types ***) -(* Make sure all types used in commands and functions are in *) -(* the table *) -let rec enter_argtype = function - Unit | Int | Float | Bool | Char | String -> () - | List ty -> enter_argtype ty - | Product tyl -> List.iter ~f:enter_argtype tyl - | Record tyl -> List.iter tyl ~f:(fun (l,t) -> enter_argtype t) - | UserDefined s -> Tsort.add_element types_order s - | Subtype (s,_) -> Tsort.add_element types_order s - | Function ty -> enter_argtype ty - | As (ty, _) -> enter_argtype ty - -let rec enter_template_types = function - StringArg _ -> () - | TypeArg (l,t) -> enter_argtype t - | ListArg l -> List.iter ~f:enter_template_types l - | OptionalArgs (_,tl,_) -> List.iter ~f:enter_template_types tl - -(* Find type dependancies on s *) -let rec add_dependancies s = - function - List ty -> add_dependancies s ty - | Product tyl -> List.iter ~f:(add_dependancies s) tyl - | Subtype(s',_) -> if s <> s' then Tsort.add_relation types_order (s', s) - | UserDefined s' -> if s <> s' then Tsort.add_relation types_order (s', s) - | Function ty -> add_dependancies s ty - | As (ty, _) -> add_dependancies s ty - | _ -> () - -let rec add_template_dependancies s = function - StringArg _ -> () - | TypeArg (l,t) -> add_dependancies s t - | ListArg l -> List.iter ~f:(add_template_dependancies s) l - | OptionalArgs (_,tl,_) -> List.iter ~f:(add_template_dependancies s) tl - -(* Assumes functions are not nested in products, which is reasonable due to syntax*) -let rec has_callback = function - StringArg _ -> false - | TypeArg (l,Function _ ) -> true - | TypeArg _ -> false - | ListArg l -> List.exists ~f:has_callback l - | OptionalArgs (_,tl,_) -> List.exists ~f:has_callback tl - -(*** Returned types ***) -let really_add ty = - if List.mem ty !types_returned then () - else types_returned := ty :: !types_returned - -let rec add_return_type = function - Unit -> () - | Int -> () - | Float -> () - | Bool -> () - | Char -> () - | String -> () - | List ty -> add_return_type ty - | Product tyl -> List.iter ~f:add_return_type tyl - | Record tyl -> List.iter tyl ~f:(fun (l,t) -> add_return_type t) - | UserDefined s -> really_add s - | Subtype (s,_) -> really_add s - | Function _ -> fatal_error "unexpected return type (function)" (* whoah *) - | As (ty, _) -> add_return_type ty - -(*** Update tables for a component ***) -let enter_component_types {template = t; result = r} = - add_return_type r; - enter_argtype r; - enter_template_types t - - -(******************** Types and subtypes ********************) -exception Duplicate_Definition of string * string -exception Invalid_implicit_constructor of string - -(* Checking duplicate definition of constructor in subtypes *) -let rec check_duplicate_constr allowed c = - function - [] -> false (* not defined *) - | c'::rest -> - if c.ml_name = c'.ml_name then (* defined *) - if allowed then - if c.template = c'.template then true (* same arg *) - else raise (Duplicate_Definition ("constructor",c.ml_name)) - else raise (Duplicate_Definition ("constructor", c.ml_name)) - else check_duplicate_constr allowed c rest - -(* Retrieve constructor *) -let rec find_constructor cname = function - [] -> raise (Invalid_implicit_constructor cname) - | c::l -> if c.ml_name = cname then c - else find_constructor cname l - -(* Enter a type, must not be previously defined *) -let enter_type typname ?(variant = false) arity constructors = - if Hashtbl.mem types_table typname then - raise (Duplicate_Definition ("type", typname)) else - let typdef = new_type typname arity in - if variant then typdef.variant <- true; - List.iter constructors ~f: - begin fun c -> - if not (check_duplicate_constr false c typdef.constructors) - then begin - typdef.constructors <- c :: typdef.constructors; - add_template_dependancies typname c.template - end; - (* Callbacks require widget context *) - typdef.requires_widget_context <- - typdef.requires_widget_context || - has_callback c.template - end - -(* Enter a subtype *) -let enter_subtype typ arity subtyp constructors = - (* Retrieve the type if already defined, else add a new one *) - let typdef = - try Hashtbl.find types_table typ - with Not_found -> new_type typ arity - in - if List.mem_assoc subtyp typdef.subtypes - then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp)) - else begin - let real_constructors = - List.map constructors ~f: - begin function - Full c -> - if not (check_duplicate_constr true c typdef.constructors) - then begin - add_template_dependancies typ c.template; - typdef.constructors <- c :: typdef.constructors - end; - typdef.requires_widget_context <- - typdef.requires_widget_context || - has_callback c.template; - c - | Abbrev name -> find_constructor name typdef.constructors - end - in - (* TODO: duplicate def in subtype are not checked *) - typdef.subtypes <- - (subtyp , List.sort real_constructors - ~cmp:(fun c1 c2 -> compare c1.var_name c2.var_name)) :: - typdef.subtypes - end - -(******************** Widgets ********************) -(* used by the parser; when enter_widget is called, - all components are assumed to be in Full form *) -let retrieve_option optname = - let optiontyp = - try Hashtbl.find types_table "options" - with - Not_found -> raise (Invalid_implicit_constructor optname) - in find_constructor optname optiontyp.constructors - -(* Sort components by type *) -let rec add_sort l obj = - match l with - [] -> [obj.component ,[obj]] - | (s',l)::rest -> - if obj.component = s' then - (s',obj::l)::rest - else - (s',l)::(add_sort rest obj) - -let separate_components = List.fold_left ~f:add_sort ~init:[] - -let enter_widget name components = - if Hashtbl.mem module_table name then - raise (Duplicate_Definition ("widget/module", name)) else - let sorted_components = separate_components components in - List.iter sorted_components ~f: - begin function - Constructor, l -> - enter_subtype "options" MultipleToken - name (List.map ~f:(fun c -> Full c) l) - | Command, l -> - List.iter ~f:enter_component_types l - | External, _ -> () - end; - let commands = - try List.assoc Command sorted_components - with Not_found -> [] - and externals = - try List.assoc External sorted_components - with Not_found -> [] - in - Hashtbl.add module_table name - {module_type = Widget; commands = commands; externals = externals} - -(******************** Functions ********************) - -let enter_function comp = - enter_component_types comp; - function_table := comp :: !function_table - - -(******************** Modules ********************) -let enter_module name components = - if Hashtbl.mem module_table name then - raise (Duplicate_Definition ("widget/module", name)) else - let sorted_components = separate_components components in - List.iter sorted_components ~f: - begin function - Constructor, l -> fatal_error "unexpected Constructor" - | Command, l -> List.iter ~f:enter_component_types l - | External, _ -> () - end; - let commands = - try List.assoc Command sorted_components - with Not_found -> [] - and externals = - try List.assoc External sorted_components - with Not_found -> [] - in - Hashtbl.add module_table name - {module_type = Family; commands = commands; externals = externals} diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml deleted file mode 100644 index 6768d0d7fc16..000000000000 --- a/otherlibs/labltk/compiler/tsort.ml +++ /dev/null @@ -1,87 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open StdLabels - -(* Topological Sort.list *) -(* d'apres More Programming Pearls *) - -(* node * pred count * successors *) - -type 'a entry = - {node : 'a; - mutable pred_count : int; - mutable successors : 'a entry list - } - -type 'a porder = 'a entry list ref - -exception Cyclic - -let find_entry order node = - let rec search_entry = - function - [] -> raise Not_found - | x::l -> if x.node = node then x else search_entry l - in - try - search_entry !order - with - Not_found -> let entry = {node = node; - pred_count = 0; - successors = []} in - order := entry::!order; - entry - -let create () = ref [] - -(* Inverted args because Sort.list builds list in reverse order *) -let add_relation order (succ,pred) = - let pred_entry = find_entry order pred - and succ_entry = find_entry order succ in - succ_entry.pred_count <- succ_entry.pred_count + 1; - pred_entry.successors <- succ_entry::pred_entry.successors - -(* Just add it *) -let add_element order e = - ignore (find_entry order e) - -let sort order = - let q = Queue.create () - and result = ref [] in - List.iter !order - ~f:(function {pred_count = n} as node -> - if n = 0 then Queue.add node q); - begin try - while true do - let t = Queue.take q in - result := t.node :: !result; - List.iter t.successors ~f: - begin fun s -> - let n = s.pred_count - 1 in - s.pred_count <- n; - if n = 0 then Queue.add s q - end - done - with - Queue.Empty -> - List.iter !order - ~f:(fun node -> if node.pred_count <> 0 - then raise Cyclic) - end; - !result diff --git a/otherlibs/labltk/examples_camltk/.ignore b/otherlibs/labltk/examples_camltk/.ignore deleted file mode 100644 index 801812fd3821..000000000000 --- a/otherlibs/labltk/examples_camltk/.ignore +++ /dev/null @@ -1,8 +0,0 @@ -addition -eyes -fileinput -fileopen -helloworld -tetris -winskel -mytext diff --git a/otherlibs/labltk/examples_camltk/Makefile b/otherlibs/labltk/examples_camltk/Makefile deleted file mode 100644 index 128b3c21d659..000000000000 --- a/otherlibs/labltk/examples_camltk/Makefile +++ /dev/null @@ -1,60 +0,0 @@ -include ../support/Makefile.common - -# We are using the non-installed library ! -COMPFLAGS=-I ../lib -I ../camltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support - - -all: addition$(EXE) helloworld$(EXE) winskel$(EXE) fileinput$(EXE) \ - eyes$(EXE) tetris$(EXE) mytext$(EXE) fileopen$(EXE) - -addition$(EXE): addition.cmo -<<<<<<< .courant - $(CAMLC) -nojoin $(COMPFLAGS) -o $@ $(LIBNAME).cma addition.cmo -======= - $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma addition.cmo ->>>>>>> .fusion-droit.r10497 - -helloworld$(EXE): helloworld.cmo -<<<<<<< .courant - $(CAMLC) -nojoin $(COMPFLAGS) -o $@ $(LIBNAME).cma helloworld.cmo -======= - $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma helloworld.cmo ->>>>>>> .fusion-droit.r10497 - -winskel$(EXE): winskel.cmo - $(CAMLC) -nojoin $(COMPFLAGS) -o $@ $(LIBNAME).cma winskel.cmo - -fileinput$(EXE): fileinput.cmo - $(CAMLC) -nojoin $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma fileinput.cmo - -socketinput$(EXE): socketinput.cmo - $(CAMLC) -nojoin $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma socketinput.cmo - -eyes$(EXE): eyes.cmo - $(CAMLC) -nojoin $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma eyes.cmo - -tetris$(EXE): tetris.cmo - $(CAMLC) -nojoin $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma tetris.cmo - -mytext$(EXE): mytext.cmo - $(CAMLC) -nojoin $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma mytext.cmo - -# graph$(EXE): graphics.cmo graphics_test.cmo -# $(CAMLC) -nojoin -o $@ graphics.cmo graphics_test.cmo -# -# graphics_test.cmo: graphics.cmo - -fileopen$(EXE): fileopen.cmo - $(CAMLC) -nojoin $(COMPFLAGS) -o $@ $(LIBNAME).cma fileopen.cmo - -clean : - rm -f *.cm? $(EXECS) addition eyes fileinput fileopen helloworld jptest mytext tetris winskel - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< diff --git a/otherlibs/labltk/examples_camltk/Makefile.nt b/otherlibs/labltk/examples_camltk/Makefile.nt deleted file mode 100644 index 717361429095..000000000000 --- a/otherlibs/labltk/examples_camltk/Makefile.nt +++ /dev/null @@ -1,38 +0,0 @@ -include ../support/Makefile.common.nt - -# We are using the non-installed library ! -COMPFLAGS= -I ../lib -I ../camltk -I ../support -LINKFLAGS= -I ../lib -I ../camltk -I ../support - -# Use pieces of Makefile.config -TKLINKOPT=$(LIBNAME).cma $(TKLIBS) - -all: addition.exe helloworld.exe winskel.exe socketinput.exe - -addition.exe: addition.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ addition.cmo - -helloworld.exe: helloworld.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ helloworld.cmo - -winskel.exe: winskel.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ - -o $@ winskel.cmo - -socketinput.exe: socketinput.cmo - $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \ - -o $@ socketinput.cmo - -clean : - rm -f *.cm? *.exe - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< diff --git a/otherlibs/labltk/examples_camltk/addition.ml b/otherlibs/labltk/examples_camltk/addition.ml deleted file mode 100644 index 44988370c2d4..000000000000 --- a/otherlibs/labltk/examples_camltk/addition.ml +++ /dev/null @@ -1,53 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let main () = - let top = opentk () in - (* The widgets. They all have "top" as parent widget. *) - let en1 = Entry.create top [TextWidth 6; Relief Sunken] in - let lab1 = Label.create top [Text "plus"] in - let en2 = Entry.create top [TextWidth 6 ; Relief Sunken] in - let lab2 = Label.create top [Text "="] in - let result_display = Label.create top [] in - (* References holding values of entry widgets *) - let n1 = ref 0 - and n2 = ref 0 in - (* Refresh result *) - let refresh () = - Label.configure result_display [Text (string_of_int (!n1 + !n2))] in - (* Electric *) - let get_and_refresh (w,r) = - fun _ _ -> - try - r := int_of_string (Entry.get w); - refresh () - with - Failure "int_of_string" -> - Label.configure result_display [Text "error"] - in - (* Set the callbacks *) - Entry.configure en1 [XScrollCommand (get_and_refresh (en1,n1)) ]; - Entry.configure en2 [XScrollCommand (get_and_refresh (en2,n2)) ]; - (* Map the widgets *) - pack [en1;lab1;en2;lab2;result_display] []; - (* Make the window resizable *) - Wm.minsize_set top 1 1; - (* Start interaction (event-driven program) *) - mainLoop () -;; - -let _ = Printexc.catch main () ;; diff --git a/otherlibs/labltk/examples_camltk/eyes.ml b/otherlibs/labltk/examples_camltk/eyes.ml deleted file mode 100644 index b7636de42d84..000000000000 --- a/otherlibs/labltk/examples_camltk/eyes.ml +++ /dev/null @@ -1,63 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* The eyes of OCaml (CamlTk) *) - -open Camltk;; - -let _ = - let top = opentk () in - - let fw = Frame.create top [] in - pack [fw] []; - let c = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in - let create_eye cx cy wx wy ewx ewy bnd = - let _o2 = - Canvas.create_oval c - (Pixels (cx - wx)) (Pixels (cy - wy)) - (Pixels (cx + wx)) (Pixels (cy + wy)) - [Outline (NamedColor "black"); Width (Pixels 7); - FillColor (NamedColor "white")] - and o = - Canvas.create_oval c - (Pixels (cx - ewx)) (Pixels (cy - ewy)) - (Pixels (cx + ewx)) (Pixels (cy + ewy)) - [FillColor (NamedColor "black")] in - let curx = ref cx - and cury = ref cy in - bind c [[], Motion] - (BindExtend ([Ev_MouseX; Ev_MouseY], - (fun e -> - let nx, ny = - let xdiff = e.ev_MouseX - cx - and ydiff = e.ev_MouseY - cy in - let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. - (float ydiff /. (float wy *. bnd)) ** 2.0) in - if diff > 1.0 then - truncate ((float xdiff) *. (1.0 /. diff)) + cx, - truncate ((float ydiff) *. (1.0 /. diff)) + cy - else - e.ev_MouseX, e.ev_MouseY - in - Canvas.move c o (Pixels (nx - !curx)) (Pixels (ny - !cury)); - curx := nx; - cury := ny))) - in - create_eye 60 100 30 40 5 6 0.6; - create_eye 140 100 30 40 5 6 0.6; - pack [c] [] - -let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_camltk/fileinput.ml b/otherlibs/labltk/examples_camltk/fileinput.ml deleted file mode 100644 index 70bc675bf378..000000000000 --- a/otherlibs/labltk/examples_camltk/fileinput.ml +++ /dev/null @@ -1,35 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk ;; - -let top_w = opentk () ;; -let buffer = String.create 256 ;; -let (fd_in, fd_out) = Unix.pipe () ;; -let text0_w = Text.create top_w [] ;; -let entry0_w = Entry.create top_w [] ;; -let button0_w = Button.create top_w [Text "Quit"; Command (fun _ -> exit 0)] ;; -Fileevent.add_fileinput fd_in (fun _ -> - let n = Unix.read fd_in buffer 0 (String.length buffer) in - let txt = String.sub buffer 0 n in - Text.insert text0_w (TextIndex (End, [])) txt []) ;; -let send _ = - let txt = Entry.get entry0_w ^ "\n" in - Entry.delete_range entry0_w (At 0) End ; - ignore (Unix.write fd_out txt 0 (String.length txt));; - -bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send)) ; -pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true] ;; -mainLoop () ;; diff --git a/otherlibs/labltk/examples_camltk/fileopen.ml b/otherlibs/labltk/examples_camltk/fileopen.ml deleted file mode 100644 index 2ac296742f84..000000000000 --- a/otherlibs/labltk/examples_camltk/fileopen.ml +++ /dev/null @@ -1,56 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk;; - -let win = opentk();; - -let cvs = Canvas.create win [];; - -let t = Label.create cvs [Text "File name"];; - -let b = - Button.create cvs - [Text "Save"; - Command - (function _ -> - let s = - getSaveFile - [Title "SAVE FILE TEST"; - DefaultExtension ".foo"; - FileTypes [ { typename= "just test"; - extensions= [".foo"; ".test"]; - mactypes= ["FOOO"; "BARR"] } ]; - InitialDir "/tmp"; - InitialFile "hogehoge" ] in - Label.configure t [Text s])];; - -let bb = - Button.create cvs - [Text "Open"; - Command - (function _ -> - let s = getOpenFile [] in - Label.configure t [Text s])];; - -let q = - Button.create cvs - [Text "Quit"; - Command - (function _ -> closeTk (); exit 0)];; - -pack [cvs; q; bb; b; t] [];; - -mainLoop ();; diff --git a/otherlibs/labltk/examples_camltk/helloworld.ml b/otherlibs/labltk/examples_camltk/helloworld.ml deleted file mode 100644 index 9829fca84bf8..000000000000 --- a/otherlibs/labltk/examples_camltk/helloworld.ml +++ /dev/null @@ -1,37 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk;; (* Make interface functions available *) - -let top = opentk ();; (* Initialisation of the interface *) -(* top is now the toplevel widget *) - -(* Widget initialisation *) -let b = Button.create top - [Text "foobar"; - Command (function () -> - print_string "foobar"; - print_newline(); - flush stdout)];; -(* b exists but is not yet visible *) - -let q = Button.create top - [Text "quit"; - Command closeTk];; -(* q exists but is not yet visible *) - -pack [b; q][] ;; (* Make b visible *) -mainLoop() ;; (* User interaction*) -(* You can quit this program by deleting its main window *) diff --git a/otherlibs/labltk/examples_camltk/images/CamlBook.gif b/otherlibs/labltk/examples_camltk/images/CamlBook.gif deleted file mode 100644 index fb7e52b1007f2f9e50c00ee51cf7ba6177f0182b..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 15167 zcmWlgi8s{W8^=Ghk1=OvEHSc;eb?B>62sVAY$ZgEHG8(omWHvfV@+9-rI1RI6l$#5 z82_PTaO<%}&bSeW$A^is{I*CW`$&v^Wb-&Qt<9aj zLX=}4(f2}ID~lReLPLw)@o8yk(%%H8GendRj@?U3>K#_r-_JOKE*6-C8Y%@T3!sJe}!#&}0tBO@bsLzQ$3qeue( z-b@wysHoM@V%Eaw&=7FK6C8;odR=8BmcNzA-)5mbV@P6?RQ9xOb|Y<;a}5E2&>Dhm z&Bcz_<*igb9mHi5^_}qznFWAd z0P*6*i^kTWJYT1(5Wi(ZAUD#jiXJ-NjsMt9{J634^XJdK)~LOYQFQ>&0{~Tq+LeYj zvqgCuX=&YVY2!{s%Z_OqM1W1ger)uesf-*4h|2&Wt+lbJuCcYdb$GbPmmc}Et>*Yg43)=;js`6%|RR=N45KRaRC#u1ZhOlM@p=+y&T22;_g@ zaLYqO8$;bjmX=1gwkrRjtzDd#UR<1q$Kwh7{CjM69RksaK*-67$;rtr6MPkefMe0rYP|B(X#K=Ho?{QoW> zkZgeM^LgB=L@`Kfq3_>r-TlraoP=fGUb;9X0Rg*_SJOm0;{0 z;@KA@f0bE$XLQLd3ooD}Ns&JNo;Xr|`0r)F#aDjjp2B*_Cp8})p31k(&wt|k5y@5e zfa0X=^6DwIGgbJMrsAuREALa!Uu+7PL>@NEE7jD`zb8@5oPkK< zrT5+*@^(i~)+Kfitmtg}PetKx7uRwWWRCuZzYTf!;m!4Ep&!2*4(E(+JlSyC{`4vG z0vjfC-sSb`a5kNjf1~;B1K6j59n{&9w@Y)VS%wDpv|8C3Eo4G(XONO<03KF*uZgnt zBFLindgtOyh9Iu7D9vVSA}`-p*Cdg|<_t|q%sICdN>%kjs$x^&ZL+ej+L$Id+rd3m z^{4?0hy}{JWuX(z#~2hPF3AM8qTv!lWO%~EMs!6`5`yXsR8&1p@Jo}{BwQ*lX$-7kCJ z1||RfK{?9zLDesB_qpu5qZ2+kVN>$!55?EMJ$Q8cO==a{TGeO$iQQf8%8bMZcik&Q zEfqY<=4v0fGSD5be3Gu)7b+)T15ZicJ0)wmc<;%Yz%u!1M{QjSaaZ?Sq3rm+YqP`y zCt}{xQUCp<$UB@KHakXo--;+h5z=k@`jfJ6X773j6f|J&`n>?JoT`6Z+jD0=UQB0N zwMHM)CD&0RQXG6oLf%pCQIpa4hC=kisf`yTyQ1eQBnk8m)2!70XXQXn)Dq)r=|N?c z`HkZb+8!2|6G!)Fqc(GUN?WO(g7z-{Wxj6(U-bWq5%#`xC3C30A$`qvEz9)^+fVuq zR;{kK_U`!Uhkda3g)8a4KlA-Z#TJ`o8y`xGXwNP^AZfp28U5Lth9>odGzY!;yOCVB z&y%Gk@ARYAV0N$~a_vjl?CWLEBM3^p?hzzo*|p%VmQ7VHkEvdmM8IB^T$FicM{wrs z{Z1P;1O)_>0Wt{~i}{-Rxk-Q%V0A&rdUNad7f`@{#h(Q=Fu*ieZ1Aqq{@HB4s0JVx z%a53X4)jtpff@mfGrR2F!4ZfSZA=knCnu^O1w*d(E=sbIkV}bR3@}X<1bVRsvV~dY z)^yoXBt4^JOZRvU1jwp~+eji)Z#hV4vydp5`~6HS@}dCGX#&9B9DP7Mh>P2*??D}L zA?}kQC&o9;npyTt=HrZWb!!N~Z42YN(<$_xM$=ee#*qMW`gT;Jc3nF-oQVW1p-lZi zrtUU~ECK*9pxQMf2xk%#>Lw1vmsgmDVS!oXJBgfZ^wnZ4aFDxb{RBiK+@)X=)kQg< zJnXsQZ6(;TY4(d%MVL{~2q?8BXdLvC{b*d^bw`4@021X|pK1DMf`WIbPckFf;{OD_ zGuS0!k?SC^J*rdnZ#URiF$g=bdP%4ngu2!R;?BaEDvGp|mtNEeQH1(M#B6j!4=U&a zU8R3(T~$#DiDytb$Db@{i=l=?2y`e-yOoQb<$Xj+;~A3?PFl)RQVoh(Ohc$o>}6av zhU6IckL+TO!?E_<@xM+j?sjZ;M59w~W+lJV9h^7x?lmenI0c8)a3OMSf@vd=5m3<* z%J1N;;G9FEXpJGtTF+hdm-RdS)+-sF4i=^(L89so92vgh5Z=+%B-I%$S%Kf~0z3O= zdgZ7LQSqyyG12ArHCye(>Fr{d^X0!SWzX;VP(yWDB6M{6mKOI1?AeV5N|^EVL^ z6@*d-&rSF9)zaQQY7|I5W32;0V{ow$_QY<}i^o4e!$F^C|L(qIqBgEd&0SoWEokO8 z-vFhzI4{ZbzZyF8B<$g-nKkK`Q0{#$4-Rt^F4Vjbn3NO_BVXDog$S=ApGI^l(8QuY zwf@w28vUN@%b(O6$W;?W%(qjQ!;-b$?rNNfTq(K?@J}$0goEOEqA>==dqPAUmq%8- zX1LpUXc*X}WIX=i*91-ziL~)Mno*CUzy7w}k>vKt?oyM<#yE3cw4*y;HyL1cIzR3I z;PK=3<9WI7jb<*>^Skg0>)_#wUu+*&2g!(sqiU`}FY?72c~zd4Q(zQ3W!J^DeoeiZ z8YJJtn|7r6!LTjOYCKehZ;!j(LvMjCtdwynYwk|F2S9^$E!w>nI`*_EU+JpVk;+|# z-AZeel#n9hi@@UAQdyr|D1&iX@$>~UO0G9Db@@TnvtAj$UaOnIA^1!M^$H9-*?J>{ zdu!^Ld}o1g^u*`dgIz=38ML`pL5O|jGc&yi@FQ|(-j`m!O4+bJ^O(S{u@$7BgUE$% zw;JR>TkjGK#!(5k{uJ4+bk)5Ie9J21-Wc&j?qG8ggB;(V;v&^S%jvaYvSrA3u582e z_AzUsYt5i|%c>SZ>tlBHzmgL6e`H-Hvm9ahmur$HM{hCQuN^#~7TF_yUKz7~wC$I4 z%3w#YH}7K19Pm+#=driJll8K2c0pqK*A+80FjF`+aG!D^^Q6+6U5sJ+Qvb(2l&`{6 zH=C7oupp$Q)%Sk-&!WiCmuG(TyV&Wb*+iY%eL{%P&a|OUwf66_&A~pas|Nw7LI;ANMsWu=Z7hyaBs?M({eEmX5x6{+eC|pJY;x8;F&4ie1-e>0UzHI6@5mj<`N9 zI`%X7!awjM(Dp-js~A>t8#{AJCOY(-!7Y3HR~=T@yiKwwBU2N_HgdL_xZ2v-55DYrhBZ?8gAIJ@@vKy)kp-Y>gcqu=gW09Y!fgd-~ zq-&>M+lI(@fECMb-1-!?y%(UW9(qI#&Gm{F1)mhX5y;-eXzhhiTunto{E18EIhEdU zB)}lXi0uS0D}$Ua(3fspGeQ7=2{-5VZm_uxQ|)y%Ut+h-;07|cIAkbmTBtAf(PCi7 zs=V`O!oxOSMy5*hzBRf|ue_mvz)s5;aL5>_swN?-QMqQJs@!L^u3!SdN#1*!>g8by zd+~|QA;U5#WqzYnwrQNyLwTq-`STpsUQIH4W8o#-Uvf5=9@ek`KLQpo~+?Dp$5IAS)P-aZ0-GY7A9z zC|~)sO~itXtZqF} znc+77G^%yugJ;pAr0K65@dtS({MjN9O}B5PZI4`azTCJ4O`%1NTLmiDw$)R%6&an5 zVRl5F(7XrvjOt~z%eG4O;)RB8mhUNK=%S|YbFn>5$2VTuJ#o5ui#Zn;RWfpJ6Ru0# zu(;p?Q80%T=9Tl;AG4dY^?Y(I2f_}UtZ~=n`Dnx3|!e< zn|wAgtAm?vzM!i7%iT6a_Op@PgPc1a+lnpX1-5a-5eqk2AL2bbVrz(Hv#on@oQ&Hr^$e(4{B}&#lJY5Ci;pE8v^1w z9d#u%D{GXeQ_AI?bUt*di%1uqH&uq>v zjb16z6Z3xZZh1t8Vnc!IdBp(k6ZSqDwd0CY*R^cja?GVm62PQuYE}6Q8mzw3t82>t zyp`?Pf4nd9o$&Ro_`BeGsiw@5UJ_%Gm#=mYlqzodM{7scp;Ag*nXat$iimTUaZ4rV zF3P`J&J>p~Kj*6}Sffzbe}d{(Fl2X+*G-P1bA|c5WYbZHx^_h;m-OIkjc)B-sYON! zM3a{Cz~V#h=wt!!-$I`c>VB$PJX4ZEs=hbrcTT@PQ6){nODi@1&6jk1lE+hU(!z_p zR(4v=J1tI9!Pax{b?)}Q`#)5`;oqm-;Tdmph!DEw5<`d+i~?_SAQ#e=%u$~J$UGT^ z=DteA)td8QP64RHvU(9g3Sso`%qO7XoeJC%nAIYeXEKE#uh}$N-mW2u? zfB`ZG(Hcw@Y~lo(5LC`S9Os8J>_=07MKY z!j=Gue1!cwhxyCEo@0XJfF@2VIOB7(G!-mG=1?SnKj09(YHs%Lq?2DYuDM;CLI9zU zunP=`{zLD+O?c8K+?0yJF(5&LO|F71QbE9NfWwIZe#XFN0vwkww%j0q2kO!P2&mz* zm%Wd?^EcsF0fYw&sg3}-)?>Q{;D3P@DZ;DgEp0kfPH_U_1v^ySCZhb;U+fn~>%&Lh zmdsW=2AV{@=pp#_^Tief0}@K+$fI&LMghT_oPX=FLAP7MbyiW-Kn1h5aVFL&2tj?+ zHmT5(^Qf&!mqRQ`eCGTG9xnm)kT;Mz@8wN+XV7&WT#KaQ+n|=WZRcC007yRT?Pyty zup$#)=Z(Xm!dqas$t~CeCPt`fD(ab*Th72_%#6Q0dd7+k1 zRUOx&fr2??XH<8jZl_u+><1G*#ANCU_2>$U(vg2a=q@IyBg+ zrQQdBZ5J0LmRmxWX|OmNOo3n!Nb6IhVhX6335EYQw4kIRwuyf zV?Y+D7&~$Ynd*G)pbtTV17(Pxo0vZ4DMbS6AE6m21KF>?Q)9MXr9$4~Q0>f%dDa{r zo2YnPiw+g?V!dnXJM22pB+ibK_mI6}c=wu+KL$(dBcMkI{ou=G=qGxJ%bbw$b+iYK z^4pR1nnycsS zAwBK~6gC%DliET-VT)ZxN(oaF4AdSKrF8>DMs)xu(GF!+3~T7eq1L>5cpL5Wld{iz zz{`X=6nOT_?k4KB3;J>pP`EkDN$$x9quL!wvb8-UkF5w96Jr4}=}@2`2+*912SaYN zakIA>GfOD!)FAk0J))un^>P!gPxIe9oE=QVY=1zj4I|SSpY;N(eb_V(FahL# zAXOBV6*p5&Bz{@OvBnNRsMW(tJx*);bFA!^o&kSKgJRoABRnN&9_yLTxo-fA<67X# z4ftr<+{(?P6{Wdh8g(@>5DN|Bh-ESRQS1GI9>hARt(1NDps_ z!S_;iajX=;fh+rgWBtGp&`~tZp78iG6{>!;whb9Q`DWwQ5G<$!^7ip}V|}DI@F@es z&~mB$(FjE_5r5So{g@85GFagb(y0t9#r%5eT=mpkgSrtMF^3KTIEH6`FbL>P;^JdJ zjQ-6Ha=`rHMeO03?|K`ks`^nV>kIhOD&z& zs|=R4i44Xeh8Yl}EPgkP6#u`5`5?5BD8i799GXKrkyprvh-CtY@YNN<42S4oYdUj7 z3cGrPh*UI~yTV2}2ch52u5L{9-UWY+Cy8ANS^*gA1u^p*EX-IL=pz9fhU28K=uOq{ zxIaN@5;0>e%#S$?<=&Zm>lJ(JZ-b}MgnCYyAn-mDL!Nm}7T$F;Sb7?S$R+$tyadW6 z{t|0aEw`{L;RXe50^QSF1%VTu)Hb#*>INA;O4DCr^?od6ERZ?=P*J{uoEvi(CmQOS zJ_NIm05MSal@7n11hrVtEVBS|8xqQX^7&*bT-zG`z-lQl2=QWiP8W6X&%BoS53*in zr7#BpT^)BUHhLDs!K+y7ZYS1rwIu=dl{=KH zfp;K)>qJLY=SDA*2R?N|P;>XNrRIzR`mqb!q;u))-Nu^(LTCOo5a;h50{{;SNacw! zFL#63G=w>1WO~BvN#hlB%S=lV7me^q?q{bILjChe^^YHE;&nrvhVKYmc_sQi(W1uK z|69=mjwEAo$Pd%EL0ZkW1$qLB?4?^o@so5u>8UrS>VBi49T>q)@B+qbqg zpXB_xF(WM$(Tk+t)1}#Y7cR)w`n9J%_c2m>@j%U(n~xEqKnWeRc>t$0*FP*Rxb&^N zrPs~wr%cJY!EdeihH0G**JeAD)dj!M=*d^hB1}aDOH)=19zVZZ_b7(hj=I}8M_mF- z7;PGIpi~87!3r`)ndPa;*~I&t_7g;k$~)fBtmEXym3;0u1N{bNiofL42A3TdXcVtP z!yagnjz`J)GSEsovOi@`z=wS#_gvvgbN^MrTY+Rxh{v0K@uX9H%rMYTOCT1p7wDe0X| zyyRrJk>+Cy7Dj_-(FF0}m;wFuJvtId~qCD8i1!qaU?5;}-VA{Sio9&K9m zLiZw0=ED1pGI4-sC({8vn zgR@<|!sp^7G|MU`knH3t|K|t2ghc^2!6P#f4?TDb6uiq=yq{c%l+5sddh%hs;-$ok zE;03~`St_rkIz>JFjH0>D%gpJeEK=7lw7WTYd0vt_n%BU#obR`1HbJzF>!0zyvnKG zKw0dVYpuDoIHpeO{vw1x=C3(sPlBa2^*Vog{O+^l(@Q0>{Wn(Xj+TWtKbSFPcx^Up zXa#Pr^>E(9CNakIeubaMkCD~CIEPy9;9qgztCeP;+?MaG2RA_z?bv{8o78C4D+t_h zbU@o}nSjWLY}%~@3**?RjrJ?hBSkD-Z|VLEKcSxy&i~%2@HE*JB8-G+c=QVJ?Ue4RHi9jf^G-7@1d%he^mB$b3Iht*;c#*D;`1ZY zUs($%S7xF;lL5+8aF@*bofS0J5j%A}7rNmchrq=`Z*5YVc1Zmsr|(!d{AGMO>1pX| zo&ClsD?T2MX7_b5t`pPU$O49F9m74uEZ3uRw+!Zg{weh708Ywsvu#L8B{QPceeZ~t zAY;m27kw^kr9gKx8uE89Xr+UM!{^Xm(-hu8Dp~$)aH>5%FeHX9({uc~I&w(@fl+K1 z1{nM*?b%R2JMoF)Kc_eHnMgOCybJzuFN=6>PtGVh9i~eWE859i`}K5qYcD!;VKGg} zrCm!rB|ot*j)lMCrE#RwD;Mz3vp+xd4SpjiJ?GE^FaoM z5z%5{@-;#cwc`q1lywp>ybqO;bq)VIeNWqFF44`{Jtuv@3hHZ}j^5{nb9u*#tp~jy zdIpH#%uQ8ynO49OAz7oX>|I#x;|&X@64_+TU_;HkIOxO8qHF-|Pv$^c$6?sERGKtN z2OKdBe)R8`w|zuApfFa!n;^?4;Gd0FwKl@5%bHv+LqZ}O%V54^_D#Su*cCGHBm{L& z7h?^c-6(iK8hUhwV+}MZr(keMuo}k8_YNw8+_iCu$an%8wG=1N*_i|`zYY+c3vTVL zcH--($O~f?CkCp|)aJCqNO%b_8wuuiDxc{c1f|LHNm{!U}3&1 zQN2qb-J0@gJvJU1<{waqGgK7fLL7|S3pAg}*N(%#1K+s%(pZ^ogj?5wQCAT*CT)W8 zez$X{oF|<8a+uN~*^c_SAD#brx`Ed$&a5#y-kF?=JmOkHTZs33C0iV)Mk(naU4=eY zC+dbDAYI9Th@$l|$%2%}oEN?W+TQ-$rvQLY9RhGj&0B93sI_^ThPJwpIV9(Rx>O^c z0$RK9_3ZP}-W|u%_It%y>wK!lkU(}>lFB$WHp}HZ+Ffkm1hV{!_CEeWbx4ousU*6t z`XXi|nXXCS11F}uGTdb%4L>nXy- zeA8j>sZO|+S*oZFxY)3Gs$pj8;vYUbF+B%rXvD^j7JCQCD+2=f1_{E_v`$=S##Uxs zF@KU>Mv+@@Pk7&XzuHJCMx!Z%lT5@h+xdlGds8FmmC--?X$eFnOnLMyR^yY{{eXQo~$x;+qH zEhm8puuk%!!34>#xmj-xT@&T-F#F~@m)BVEIxsB@VduS3P zEgoB)q(O}Lmy5M1qai2Y?JbFZ`)?;(Vy8M!g2mFVGju~`>An$yd=p9DEX28##I|2x zrJy8VZ^Tt(ofildIUuTrdH48rKrmu;C?>7Z$YOU){gLBD(Z*U@B z|EaizL%jU}z9?J5J%R8sN2yvPmK#z^+nMp5908jM;iyjEY+wNL?0dhm;zXP}73wAn zMQ7iJ|H88I#4d?*d0t{|1lfdy<^=y_a1M8tL(TD&n)HBugVPQmUpd6Yg)FX~0A~Durvos8uIE>@v@GUF#;fzAbDe-Li6 z$HMj@Vf!*X3>rF@w#i5j2}ij<6TmZQpIQYXn~M(18r!2}%bc;!g9rx_owJjdJ^MQT z1UX^eIN<~n+A9mv>Bar`5b1`Ug-s-=C1*&qQ02xPvoaD`#>iI9l^dI3UmBa{7qIkI6~Opn}6f)Q)0K9W6G-(1zqd zqorHXx`h85LEd*x^rXQcZB5+!U{W<#0yEBt^78spb-V{0Lspiac+LT9KpCPe9FSqi z-re}oO+xJEIZjfq`GjoW?)Ow!nXQl`Fu+2!9hiMv%(};d2L(ade)Wl--cVoCSqdE< z@12UmK{@K5`;H(Ek~>q}6I~_}s-P;N9f+-0g9b#KlsjmiRojGmTfp&@v6M{!DM|Uf z%^)k0&SRJGLHH&p=@=_6dJgeE6zafAx)~mCXpWP*8Fz|!T(~}dZ!}S=8QS|#nLCd~ zJ`^t)!KqQtnZ2+qBGF9FB;#hRchbiqkmK?$fW!Tgz4-^|^f%O!SdXB1&w9AaKbRN| z@iZEeQK(QkmnZ|!O2#+>>YrHmDiYOXZ2yTz?0u5s5NS&C9NX{{+1 z=j|t>-_w7YB|uV$2cIx#QQcf&tlpv1wK0ac6EGO@n$+_1 z$w8z&baLeQA4n(-s=eB9BfOC>pgN>1$;I;ZAa{bUq#=yBkA30wpXiCj5&Aj1!$&d)`4o5veSpbgPtafp5 z8CZ;WDZh<5M1)U3Tmg(4>-N>@REbJ{wgu{az3_XO!zs^sR2a+Y#1Q)KtLcW576GJ* z5oWTm1{gW_?4&#BtK5vwG_&sJtg8d!dUL`>GCqvNCH@ByL_?U-vQYbQV?(Q1RBz1W z^p;|NC<(z$yz~cVb7CedrgbP#N0Eb?s)C1zGObO$6P1FXQ4LzIctl;HDMc|!N){v^ zkXoEEo3G?}L=!rQ!>UmsyJ>S1!mT_RS%1!q{P8>&7StDi@lq)s+x9J`u{)bTh>op~ zlbHaYq`_3elCCEwT&Dra5$`(`lD@p)nnPYx$RE5#OC*`Q>EPfF(=Htq{E;lU$@zID z_{b4s&@wmo&5pESaN>pJOtuLj5sQn9CLr}5B|3!1C*SEQX+FK*Ox-7-NF)U2W1>xc z9P|~PL~AU<>3x>-2r!>KIlnOU7#^_F8}>BKKu4BM zJAnEfp^HU~1X~a!+B@l_L&rD=opHAN$ zv$3;JTNSqN%ST6TT^N-G#PDgPRS0r(s5XAL7cZdEL;k z^dvm~j(;Jb^J*$(^7O7>y;0-3#e*XA*;PM$ESv~FKAd?Geza|Es*WK+D{>dhD%_y%ol)U%rO;8{vxZq2p zn6S$ZbXyi^ApBgo%}~=(Mkr}$ujbAs<1#lc0AhudmV}+ay9Z1-s0Heop_GaL{Qs0kxzMnBfgjM^H3h$J#66J*L*)91A zR^D+zDajm+L6a0bx5ksLm@nee7DL`u7Iw{7d*fViP$F_G3YkzX7-t#AlU9s=zvI7> z05RC7-eH-xqq+}^6@&iG;dD}T)5kP!3itq05ZYT z70f?n$tH{mjVza@$2HmZc4xcNKrf|Nih&=S@$|{wtnBv0*JMlz8KT97)qdIUc5Fm5 zrSNl}`We*dX}BB?s*f*qE(BeWg%KuPDo;Ar{ou#X`J3j`8VQpw$}<77tFHO9TdRN@ zI}aX4sG*hf zHZKF0ifH-T`fe`>i5HOxJcLa6J!DEDjboK&+CKV1a^ULGdDB0Ln+|ViJ6R+jDa#_& z;<@(_X6>b7P?qdAe)xjPq`w=N=+1$kH5-O>dj*r!9EgBKNHveUs5lGMT8Ap?v&@%?%z!3btxh00c&QGeU%!8VMw=_vX1vg*aZTTI zZU){@!EFoaWF*uQ6tCSJJM$nSGJHr0u^xJaP)&vaYDsJ*M!XFEieACx5j}`%JxH_$ zb)qn0%3L1gfKXx4FHa!+%HXQeOKpns2@3v-&xyUHhy2GyY&I34o8XZ;Ic|KMZas5n z93EPbE`?99nW!2vC-6Z4ZkkU!;*#l2h+_wyqaK7*PWms(7M4st*xxcm3&wny?f&=j zjG(dg=cb`Yq^#+#h|k2c>(xJ8wRxm1^Xff@r&IMUjZ2zYoGCB^Nw4A7%^#Ov1$+%L zIw1Z0VxW3?ugSjwwffHc z@()2V5mLsa>eGx67ACr)xgmGk{wl}dqAnHd7)pk!ragfWJ`jM82p-`p}h{f zwT$KGNtI)&nJ^kbQ`V!Cp3$P+O<=iC)p>@dj~^i-i12*q=nNx4^I z%jiDw2Pxj8iKtGXa1-LoEV&={hPdAG&)1$Uz7-s{Vlw-z`O3o;5DTVKH74<%f9n_x zEpMW}CfgwCPfVq->z5r0+IDMBOO_uodYybh^DvAd75T8v|LZx0l2;*JZl$eG7bO5^ zoO{-Zc=f0g4KYF#)Y%Q|e@|Xy0TMkrkMcVCE`AgfQs{Ud6JL0J(WY{N`tpbe%iP>> zwK^HVn|7kN@{U-h#6QVg6?Xq}5HhX^)pGE>1}B!dVaoG3>dMgPX3ot(Wkt6vLC->5 zNUv=e<&6I5dT?om?A3@I!l0Dvy98A3zmO_bzuXe4lI_yMC*kadh8LRh6=;>;V-2y# z!AJ%f+goVZn8Q%7u+kr2T@0J7Ti@ylc{CV8A!#pB5g&;~k-*KVgHDYSo(qbzrXFuw z;smy84?_h5pkR!4WwW7{PrJ2hg8o}1PtgNAH#+Fc896#9;64`o30qqY1{>DWY=k?J zJb$dST|T3?s2UeH9=Yqb-cQnoD%!q3?u&TcEAT}f5+YE|An?eDciAK=eIOf2X*S#^ zgT5?>{W7(S1cs;CA@2{%QU;!NkXsi+$1VIOkQFlezkOhLo8OIwNu-*D83tgYsd8g1 ztIo^tFD43}o$QpbB_}AYw)1?S=vTV_OH1SC zDsH%Dpr2%2qFq17)lLPeCqlE?AJJA*DH8^PtUTgr%732%+GXyvqh;O%ACNdkz=n1O8tNn}bJ#|G%bKo89;!1cITxua^KR_cAZ8FL;n zzh;c!5%UZ;K%On&N-K(n%CZ&Q!qJdt&$i?+|5#>f7-9}L5hA+BOpw0o*6%z>&G+kd zQ@A;jtbVq`NxYiI0VTwFDoTi+Db;XwJb^qc--2q_0Lhmne@ftp;%Um_vtvcn?(3)(7P-m){JgQ5LFveML|{LY z$UuDXIm(;yWLTt&eD+r5x#EbpN17d6X@7?KOV(PiatJZ)LIKiA+KY!LBV9pU$$&_& zgVW^Te4{l>$cB`uInMaaWiNAAtn~&jcN7q7 zMrsnMx4=nySfg%kQZPg7a3Nf9a$H^H$1tC3c5|C_or5`Ca^We%z%9C@x2up`FG6ES zY@O8QK*T#3V8Nd(x`S0fD$79O`%ny#*|rzp06{`SMX?}g3wJ?D4H7}tm; zRc@tsE<&>U_tl2K&J20q7n+`F+;0V){U!Fzf29uA-}|{myzsl=%#2uM>E9nA8H%5$ z|8AIP`Y|s)(}=cP!y8#b&LPI=tg(|D!P)$BOBa$J&Dg}; zc#>A4Zj0v)rFRs5H7aV7@>1oLYt%~1-ZW8s?`8ih{h#ec zGdrE%Ia;uyKfX51{;bQupE8WO_JktRlwE=EYsk_&<`VOt?1aCQN(sA{d-6xDL1ag^ zXaLjy@~_rUF{Js|JA&_;ekoO{eP|KcNlVh5*O0ND|0aafz-&htv!zPj+?n1;v750O z)!Xm1d?oxKRICByXP`$Yx}$m@B5 zlK9R}R=R)R%(YhM$U~8duR`0gMKfHYT}t)@@HRilr0F9{som!eiZF0g9{&jZ@f>}@;9~Hq1X-Lk80=! z)s%tzgm1CJnHeHPU+2}T%WJ<0?=oB_g)2Bp%O-t>cDF zXO6z55IZhzbzf8!aT!sPnClk&e!u*Egz)$?Vd2;8%OvLoR2M~P&|SzIVn;Kf)ZNdW za4EGBrm`I0cDsE2DAuv%ya@U-2rDP(OAfV(G-?Z?YN@B5EofRx$P!_Iv5{RgU7Iv4 z0RYmw5a^q7e*G^$^F_zo<|z*<@#PD+<7Hn;%C!0JnJmoAWXEakbQ+8;jP5U?%psBh zQ@=}$I|yJ_YqlNV5=XaF>I ze+uvDy!_uHk#WhHZ_cW!RV|)NI<{X=L>5m83+>(Q0Y0 z%-mW4_{xpsJw!*V_E0XkkeTk_cm6YMrp{|Y^{%*Fk5RSwSc-Y)CdgUp+2!Ff&I|hS zI_hpDb(ooEg1$Ayt_ys!xU&1%m!>mbaMOXMA77eKOA{IQHc!Us9MJU{ULiUiXC!5; z2@i)3jqtLmT8!A^nP-G_;?Yx1^KXD>#l3_pHJk7%k9qZ-xO=(O7_{H>qgTx6+0!2J0;BN zI(l)MU4|O*An0ideyLN!fr8)h!KYIs<3XhL|2!YvhtKtp!$V;Wt&th0lMd$nORvt6 zlVvXJt(O1W5>8LNq_rz7$0rkPE2T|(U`(>OmU$+^Ye7rsv*t7)YwjkU2+`hws7uOF z!!B|~T$*_0>490&vK9Gc;o_oP+%fO@VqEH-&7&q;Kcr>Vm$r`zqm#V8T_AC+X>XsY zwP1Mq94{YSn^ZYL*Uaprotf1))KgS&dJJd)KS7|cU;nr9Z*F}3Km6|> zzV=RU{2L_FG_jXRB=zEny`TO1ex2?mZhYc?y8biY!NK7l?ez3NhJV!28()crnufik zfASDrOI=+_-4K#1vDekr(sHgdo%l~HNte{C+q>aPnhx36_~*nw6Lg9AkpE|$q@*rd z5{>>BGD}O#um2;3xVoYdlA!+|5c|Kg|92N4>T4_r1jHu9B_-nG;(@gIlvF}`c2;&? zenDYDZbo`iNj4aqgHKDw)z+4gvhd9<35~5UIua@H6g{Axu2+3;$^HE=Usk_pZ%@n^ zdNb?S{;$*!9&l}!~gC#mL> z9!`cFv5!<+z#WET_bzR98Uk*NJm98@;*6Z$mB`eO7P(>5vTKGvdOvkS^`Du1Fse$u z+U~evDLf$=&-HuKins3JTxC6{|Lt?t!&gGBKY#_E>#dbx**B3Cuqp1USY7Tvw_ zjqiR9h5i&{?eJRg_`3}bWptU_==|H`ZF^Pdvka~3d{oTIJ-*fVVn;>P&hs?p*}(@I zw)S5WuJbRLRXiUkhLP)DPELn~ss_evoMqhV>+$)Wb7Xk2f&Iv)`zZ?Q*Y(hi(kqWA z>i2FUhe_8Agf)Spz4JjLCo0=6VC73*dF-FuFbCD$t9>IpE1ZGHxo&H|!nvgT#%Agi z>(XY54o;C5*X`4>ExHGb*h(p{xwf%48`?79Qw2J$?HqY651pUgaw}xb7T|*N#lP%k zUCz4`y1Sb_SAyg8vWhjR&GVNZzmaT{Si9{zVtXav%!zz4=V~g=;F0FHz*-+6=@;e_ ztM1kFA&$=Kk~?#0MZfr&wV!QywO1(q@F|~@l3Vflnb3YTGv2Gr_JP%rKy5y;@HjeK z{ottSm+!HFe`NZqXv6Aox63nw!fte8ZC=EU4C7xSg3U8_RxVLeU~k{YDZlIl>x=RE zVnw3?h7UV-J98i6TAu#)R;QGW6z^`^rs8SWO|*VUO6n&aKc8-ALDam{n6T(!G3`En z1yxz)Xyk6VU6AUq#nx&KzGm>@FCqyvp1IR}TRDyTUu2kjSJ0}`ZXwwEPif7W-^uw1 z+o$;0qN$NG5n}6$Z ze7|-oWv`1xyJiT@FZ76gQe01+6IZg0_+OX8O2xqMi*%32=^shon%CX8Q&EVXomy@6 ztK*fn)t+(gbT@|r#DJ)G5rZ3h_)2Z${hBZD-&_AsBUSlD9ybbRgb}_pGD*%?9YrV% zCjW0$Y|S?1s%<1qg6?Yldi2R#j`fNBjP4WUy%Ty2Rh_DET$Gil;3@u7WAx9E$+DVD ztNS0>E=f;{U-7!XsmvAAmn+iSJNaJX3BT*(t8LcuROaO`3sEyx^O^6lRJ31z+{EsB z+e=c7^?#sj!LqAnc?5>G+rlSf4QbMT&*rr-W%)^R7<2FJTJ<5$Ps4fsa3d%U$ZHjZ zz`yX~)~5$Ndla7HJxA&B19LKl5k7%R)oVvuLIYb@ElGnrPRNY0Hi7gz3C5hoO*X@_ zD^m4$D_(6f-N@H%^!<>sl~RPz9J?ibZQ#}NY7T{~)&WN!1_}3V{fXKiMdAtJoLk#` zamk~4c}AuqzZ^K2u7zKle-TL&Tc;Hg?`Z?BTb?-f5n0DsM&_H&lipsI@fjNOe)^km zUt_RrP-sD%`9^JYhnS=2tEGNqq^V9g?IY1RCEgP`WWi{}&Wos#PJ@r{5~F1JOlL0@ zL;}qs9*GH@-#yYE{gRoxq2fv{iW~4>3@rNiZce|zm3RynFMY@OPWn#IU36`BZua+$ zSL;g5$Pk!)<-7%xdDU%?(5cd|$0cn7@IK}J>|`xYXKn{!lZp_E67^zNF(s1e?vca; zSc%)(vEkdnsemHgIqvOjb?v_oSIP=_@C@k-jF4vf<5_@Djlr%A4dB4iN7N1q4 zoNktMl3GojsdPO%dL~=X_0hv3&Uy9>xj=HBKT>>qIFTA?k>{^nRcmjl_|dgF?@uqw zYd>3sg2jx8=0MLo=E@ySdG8Ab%kiyzz$aqx2ON`0j1WjXx$W7*H3`u}lNsq9!SwlFXE zd{%3^T=zD+UL5()$Np7gLh#Q;p9i1aZ~Hv=y;C3we#S&zSM$rLk2DVyV6I~gdHf1q zSiQWJZi})PA$_lT=w0*q(a+a6-9rt`&frTOzb#wbKM)-c<@5WkzJGijXnfzpOWsPf zQHmMqV!@>y_-wd|q-_3s_*z=A>6MI)eT}h_U!_Uc<;!;cB}4L~bJ^Fm{DKvQC^$X(gsuz0<`X4$Y`X^;8%Qr|lMuuX9gcX#^Q zc&H}b`%;j@s&aj?^;4!&X2Bdh z{bgoXB)Q<)lFcRezi(}8SMD0w@{_NA`s=fZop_1>Fs=QAu?Qw}%FfLa4Ta_#x*ecWf zpWAQCTo&ph8-}$#Zn*!xSZd|>;0JScb6uH3w1N2PU*;rgmQ@jIapgFhP3P5~jfY>~ z37vWVeA9CMrwXEe{x3jO;3_l&CWj+GWuGUx_3VXw@c4!cLVyKO-fv)bK$nVEly*dc<^Um z?`m%h|m?r>wOZP`EGiPqQ=kD0jJME0#~kncRnJ zOp6a9W~l7GFGl-W`*y!{x|L=8I|=))Bj%th2F(1lCkzV+dZ)~}+^gkcKaAmIHJ%)H zwa+#7x*oNsy~LhdxrYk)aMpPh9Iy=z#n2>$4m@&H&3jCshzto0m|gNzDTw`};OsyV zza*$6)*Tq*7WOMN-pk!Durod(%p!!s-Jkk_evY2^#4)zCu$`io^5DftY-%JFX zKzID1219WoHqO~Oq232r?Y(DzhHt$(NO+a+ac3kL9p>?;R`o)3Uxn77O zRH=CVdL)fOrUOgabq< zKx74&&|o5K8oMO0A(URT41%EPD>p$j{+SHrAgCjVZWH9Am>EU=c(+D>i#cIjU#IZE zm1!&`!!?N2CWHC{9&!F)KSPOG8 z{)FI&T$>dFgCv;MF~_13}^G z2M6hUq1Xh)u>3F&PfuU(9*1fH6!ThWR*H zdTL>Qh7ypeRG6z|qIc*@^bEgQkfn1`Seq}ASLn^6NSlTRr8E#!RD2{t{Y&kJ)| zMADv(R~R(_mbkL7R|NKJa_ZMYT+JA+xI2>y3mR2SXK4WSuROc2XLqtxp0xb*wNN#3 zsW`<$UbX?mga&v_N`!ieHdh2g9I(n(6N)Rcji@ZU1eIL^JQ_LL4Zwm&&R4c7Gzjb- znLA@pRXm0-2?u0JAgUQ2YOiXgWy{3mI-#(CUQ|T>WT`mq*Y>Pzfayd>js>3VQJghPXEh3ZOG0d#4_`k!T zClhtX1{skao{fu%mHw&M2Kme34etwZ%!pE!%^W5Kcf={0nGX#mrS)+Qa5mXm4=!)v{W^=vd?@-dF;sBWEy&py{p@GO=Ei1 zRzvQGCgYE;vSEm}l3$fmcCErB;4Mw1BCLs9vT0BRoT1XFGYOW~Xk;e$8FBzpAc!Ox zybUYbBoZ%r8XFC(?ka(EXsR~v_e>ddNNDtXvI7zzF!Z{oK*XMu(_6rFii4Az!IGJu zpA1?EYKIP6PiA{5b+uG>gNnxpMfH`9<9HUrtItQ3Oawr0t#s)a*u)b&CkAwWgLOH; z)!ltEWD z#fB${i=+pUKw#`(B5lT0e6^%Gl#YyB_54TC^ChBVYYdD(PQyob(0|U*Pw6HucdtJu z(5GZGOF|s}fF%+A>nS5rGku$@eeVx}aS}1&sF3fp zqlwygeGRmb=d|FaVsfiJ&~D$_p$hKoOY3gL^{x*@A5Bs!z4)d0E)!QW%Gox4lKAfA z-PF6@Px2C}tfs;Qu%caagleCG%7CX`kF94d!RNyu2jovm?vyft@9%_7<7l!sAny;U zjhYZMfyj~j=xCc6Il&6JBDdb04TBPy&oyNQ6)7ue7vrz>VH0N0Yu|f}WGXdUJ}D`p z0UE||vZ=lBJ1t`O>1%pGIJ?$z`_@N&1?rzuCuo|JRu^ENa~Uc1b1S6=G+;#-Y0Gfr zztjoIR&ri9c=U6Zz+bR@`Sqx*I7FT!jY%bc_<2b-yuej$UINkf_qeo7tdyy5K>2FC z^m9Il?PY}r9y8hOYp`Gme{L-frNK5KTY+)KCW+IghPnIDd_lH0%v-1&*+_%oG@F$SUqu+ z{Y^+j=~_wKC2Y`02`@`3gZqPa&Q>}i7rM$9f*Z24Ir~|k0Aic17*gu@skOmZgxtx# zv62o(`&Kp+$X_GEl1&NBA1tT=Ua%!3^b%UuCn!Y0R=r*HYfbCVn`I(#zio0lKDSnr zatgx{o%el|oTX#p)L~fFqdS5o}TjSs6Q8tk1q70{+Um zl)|<-QSc)Bq%`q0A&<3m=W|VCMB|t7)c=&yK5)&xhpr9V_sDXcaDsaAo~3(Va$88B zgcJ_1W$Lx3;tyv?hvX()I(M6OL`jxJQ_gi-9$m8(;mFXtqt>sY=JKdQ{kZ1Sa@~WH z|J5H)O&&8jw6cOe^E?4wl0zr^x!qDgMT#_o+-maf)<`8SQ3yCTv1Vfdh>y!dlkq6?})jo1UC>>ie5~O;Tb?_bL03`hx~|>*PlGz4M~i=ECJ4h zU(vU=(U0TKlmPH1=#Oxosr4Ch=~=42`c3CU2|lO{4&+>v`sX=LK8^70V_H|*b;m|Y zEu%d-sG+j|P9sMvKo0`Tf!b7X*<~It=;#2|(+qZUnVNrEdh=zu;w4;tvEKgRu4heo zZW3T*5XxhedW8wQ3(f3c-Zs+SabbMSMI%9inIzhNHd{d^9uIdG%(l~RQ zz8lmTxG|fK^{~Gs1}BXzeiv_g`TF&o7g=|*p62$yU=!efaI7Yfa-%gml_u5Z;kR)7 zG92J4&puKDxK44E$q;J47oRpBw2b+qDaDR={ z`v@^rV|$;d)MC{?lk3JNAlfggYFx(Re`(Y1Onvfy!*#$q!)L z{R7;*yj#$%L!s>e4j5M@oaK{lGLlb69r~L$%8}J+=}j~{tDj?iKgA#?46T7*CT!_I zX)t<@07MT;bIBWiY(4vE$U%k)BNFf7#%uLTFQ%KkJxqgOwjV-!Iia4LG8y@LumD;@ zHuNTPzPd+RHE;={l@a?7GLGRxPN7;#9&5MHG&W?-3N9hjv#{Fyg9=N;>Sa=tJQ3ve zS}E_`Y?7LTHO3*ARw=LEV)h>S;})K4OpF`6{`T#?D^ zOWj*qK`3S~=r8BJJw&1XU2a!G85Mo6x)@QzplrTA6aL_mOyJ^d_B zwQe*M1!?jjM8Dpm1)Nlq4f@a7aZ_XU>U&1hOM$fJwXR=36y`!%9z>p5PM{CF`B_C0 zbYlygnIuP69#I?V6)NXB<;}X4M2{2(zSK2Y^+Z&6+EFyU4yAK%*VQfZ?LKm=P<|uF zvd%Z;>A222j*}l#C#&g~1QRW+=|fke7r8K-HPYN>VoI^xG{_x_UFt-~8GnGQzq^RnOC zkrIqmkx>hW2Xs~|8u(HOBy<+@conTUuNlP+hUNN z;uh}d(8my&YQ`LqRnKi4HMdQB3gxSl*#}QD3@9|gPfIR1!zfE!N|dV%JT$53UC>%; z@5PxupdY#tG;cH+NZ)>vY)saGT*IM=_w8CY=WcYYvxv!J zc9{3WMOz=03(&k*`KVklkBEay&Ig4;_fxglDX1d$e^#O2@R`B5qaC$;d3%^=DR|_5 z#&}RCo_cH|`yAs;Zjuot${0xrMgg%C9F52;3*9*(9(3RtgtKpm>sHN49CsPBO@54+ zC1zwmU@@dfO8f^|9Y!tlF?Ng}CR+{y--4)h8JX_xtNK$+cP?V=_*3^W{+E31Q_p9zJp#`OjvZ+xCoLie7ESS?&O?aZ9 zWn($|OHUF-D3bMnQ|K;ABT21Zk2P$5-}oTNf+?loX55WqIVMLao&TmnMl!!5sM;=x zB8fwt@`g~U#|jNUA2(&1s7U#8!p55glIe1s@apzVeXOOPRqh1y@0o%?+6u;dk~P9s z4F+v=6`%ty`diX2R`6TnHv&?362J%xilGE}(uwG!l~rTtz-Y!vy*6_WS%>R$I2sW@ z;!V%43%}H?zdkyviiQhQvMzWuWcs+JaxM4M(V?@D^ZOVcc1j9Wf4rg99bM++bh=;= zqwqrJz0v|M(O@Z9^VAT6WpFuk;EMB3GOc2kcS*gxHvD#Ky4OYgteMR~Y)}?HYhYj) z!b%2F%Az?+WT}LBB3Vq~*qmA&*C*<&6Cy9Ocv}AGi^*tCP6i+6^{n48@B4XsCSH$c zF!kYKx^1S5AEOSf=e|sp($ojp1L8`Dxpw!_9sgSQ;%x7g-S;r~c(HTIQ*U<>Bj8^4 z)C=?ve#%?-7W2#SJ~HxiMw1lmVvQD*NT{WdHV270ne>uviiTS0&31aVK**hz;GybP z7=8G4AEfAfH))8oKsmj4C;9L+KGaUS#h1>UhX$y^%fHYMS2X}9BXD=_`D5#`N&E?0 zK2DvAaQc%u`**OqqD52s(A>wN*;Q;)Hk&b8Vp>RsWtIbCCEY;Iwt+fEm)5ScF4#jW zy*IL&L$e$Hy>Z}fNS2AY#HbRARwKv#%kJ5t(cr!kJn~;+1gr>>px@MHmQ~VE-+oD8 z?!fXlMY2AIbHIJtzwpSKo5T>o4sMH;api+8{Ym}@h zU`-*}Hd;#?bY~xEkw~@#N`*B51}w&|B}KJ%&vo3$?Hry>y$6!INh$0|2Dn?XM)R3m ztW`V)bhNm+<#1FWY1`5f!ghCTP9&S4OZASC^OOCEeei9|KDTvs_UFkaLaY1tMs138 zqRaVO`hDJ@+ikTa`2pBr-68%G$%Byy_+j$U^krhq1Ef1;5NTXO&r!|5r>2Z1mTb1o z_Wq=if+E@JKQh*~?Nc|B_d#2+Aw`?k*HhZWaWiI_Qcl;Cr`kC*HX6AmrWOeX#-$t@ zUs<&M+vr>4ThilF1$ILwtRpL@L=_kM{+OztX*fqwULD1#N(&pmL|voqxr7;?a~el@ zp`XqCIg((8kM0WLi}~ijK*yngfDB5Vo93&Og#v{c;KJ;%G+o zt-xWhz}GxB^MrfGOWi6m9eJkkF!c=!EK~!G3f{%h$8c!R#GJ!V_i`fsvfk1;1&6YR zIA^QmQcJetmEp0@PkoLtc*`1J>Uh1=cCQ-n&Mn;t`}^0wgfwC76+*SCbiEAktgDRQ zL3K|30JtJ(s*VE$3O74=xcwSFDn$pPbp)tu*aR1cC35CLEmREfr3x;5lLz(#imY?2 z@d4laDg5(jPC;=ewQ=6N@%t}(447Ut`}sUh^};^f5mkY-L>!>`Gdk{2pFgJtif;cH|Db_egO)&xG#9)BK@zI}CF8nMbZksO4 zAO19$rpf;A^rL7Uql(B9 zR1}a&Yd+Lw6dr(&*U-$nN3&)}bIZwpJn+BXq-NhvlKX1%l)nPePk}rRQ)#B~{qF!c zO+udQKg)A|cG(pMZ+n&-NOv9P4Jr@^hsz6_VtEs=mHtt*HcBk!dbP9M3D0GG=droqoU>Bx&NYv909TUVrFCY-D4st7xzZouie{LXg5d{%t5;HB5C^15B>V z>fEuYljVNG%P76+e>0T+Gg|7|9zAy}I5C0#;Dv8sHGGf~EL+aHxDOq|*ty60q5L&z zO<{3WsW{#6SqSeUzkjl{KaW3Bk#Gyd?D4?UDeoLml}!ICNfGZVcff4SV3P-qwi5G z!rrltiQ0~VeL+bKW!km!J@_~PR^Nm;2hsDIK-RWUuFeQ@z@x((LXTYF2O937xgkN{ zSahpl*IgnMGQ14{lB)mlLm6S33f}acy(PENGm(V{gDh=_+VV^6JepUKJA{MELSGveQK+GA z?tc4vAtJ>q2r2aglO1AoYZn#G#JSvQ*78%nVhQOMfn*U9;@DJ|?L_lP^G51NzubaM z4iQ|E=pHNNwX`KnXDZHOASKd}NYumswE}$DK+dAv(Kt4~uhen%rnT_$+x z9Av;Q)xQ@$v_<~}4DK@Lcty6}ix-@<(*Muo?gU#St78<|s}KW<5QxvoiwI?{$T4k@ zx0Jnk1v3`YdQ@R;eid{pHZbj#Bb~>uu&WvC5-EV6kQa(~Dmtr@y}@9~XzXEh9a?;b z_)Z4nvNJO0q|r0JIE!2VnTVvH>wnvoE<$rxqwlE)V4*1GbVj6PvQ#=7vSc+}Zbxp# zOr*!epy~>W&l5?WsbttBjqi{om5UUVgWl}OK(Wtze?9M!%Q>TL9Dr9RxLPd6G_L(b zPZH^nn~gKe90aMRuKAolo-K#_uvL7m-K7sZxS5N$`AcEmK0D{(1luDE$uI0oU)ft8 zceI$Vq@m(ljz~{AW?FuLT4m9#E2ga#Nv$X+PN+5wy>%J zIM>9vMMXM7l@c%Pm%*sC!1fJOF@sK3anCAwb`Wr?3daIvlr(JDr@1P&0u`s~e^0@y zg}&xX(sGVA5tR~ME*8?U6}(u0+a$Augz`E^v$$wsX6nR1uQo3fOik-f*gfoVYESn& z&-qa9@sRxsx#*X9as+8Z-563B0jYml5{vNg+Zxxm2E zZ&#AWyRWD#f%t)D%SVo%U2Qo5q;8*$h@A0t4PuE8xc0pW;33@ly!^CFFP$@l&i_EK zEarh(KUkq$(eeU$q9Mn9mi+zx14dIhXi)Hrz|u?Cx8nsR`qG&PPH<)wks8VHgDs7C z6;>bV5rMH-e5g2L)8P@Oe<}#f5CVdeWun*VY(Avu8gim5f!rC1+g*Ln@{0#mLiAt* z;z9JH*x-&e3H}AUH<$EGg1K4zQZ<`Hr{x0sTd5!5Sc0i;+>+0#qW{hW(m!8_B>?>* zAgw>9mQ~;;Zw2%Tbz(|_+CH{fS#AWhEB{vrqA6Kj_d;z!r=qeP;47#9GOxs(b;W zh0>|T(A)J3q!fAfZbEC3Zn0?MH-5fXl}rvzwX3mrf1NH=VIyPF9Vic(Xj*0!b7FXE zR{U>z5fhHekhaO^2qwaOT{Tz)!Rj&+!f*U)by3_k%YUnVLV@sxRPI%ZhA3>p7VYoi zma^4pIAP-Um_JJ?ZPjehNB6Gn^bR6Q-YLS?No8VYw-^ZQo=QjxnKv$7eK#;RuQb?w z1WQxh^0GD`m$cos`gZG)ar)8mEtn&F)}Ua&*Q8J)tj+@VQp1p-;)imA@rGcn&rCBX zOx;kc?emN)n%$)_u+l5@hfbA(1uAuOZccflOR@@cm%7MIp<8gha^D<{&%ND@ITz(A z%io>02RWp*`b_OYCW(R?j!}`k5~7>g4P*%tXjcE=`M8L_ec1b*S!t#jKju=mPe!W| zmh8Nlpl=EutjI{TY5RM{o7I-9GNDZ$525hJmOPZFUk4e=(8=H?oV+S^%o-BYLsRw9 zH199d8yMor4Y5bRS*{nw7ybxHR}%8sc}4EPtcRI^>NTigf}Go5xM4pc%|uM0-z=*C z)3n>9D(A-j0OI>=xgTWf>4uWELD=Nt25OcA_>=?rBu&K+p?WV3Rfoava-wH87bEBq z%_|?Jx0YaeZ(_D^k#Y&cTL+FbcFSR0eB1GzB9ReJOflOrBTb@rcd&Xlk)RzP5zU?3 z-BClPC-@!o1ElJw9rWo=`U{^0;f35y(>vAK-PqkAEm3Cj?$p+<$0(brgrNBwHY;u! z*C?h9({bGHo(TJXktw8<&fVS`s4Cfp_jhdn_)s3z&*)$=^joKkkV8C;LYhiz9x09r zLhPzG2fMF*MX`6ZVSedNf*xO%TXtWtYpWZE=x!2Gav;v>P$VwrU8|pC3-DecwxGE5 z2$kc`B8vP;Qs6xk;s^WU*vcac3zUzZwc3Yo6yygT2>tLck;8_zrG`h7Hd-_oUbu3` z8jn6QK<0f35S1HE3RcF%sl@9rr2Eknoo?Tu+^;1O{-X7NVqvqkI@+EREdC|;shp2A z`nH*t&5RBca*L@lKZr=d&;(Q)FGQUjV*YG`&BOvVcc38wJwjC;OGIE)F)g6RylmLJ z!xjZe!dy4N3Zhrs7P{wi9vBpzmHCPr@%>I%;+}4!Q(nOwlviA`@pkkGzW`DtuDAdC zQiq{!o+0KY@-b5Tb^87PO(tI|Qt9-u$MFvRV!u3p&o{^YhnX`b;QgX3RALjxTf@1$ zzHpJF^7ACKJ(r>SlTyek{dCtB;lbBi7B=?Q0#CVK>e~9YR+R+&(*0aXw{owVD5;oE zrn8KH#d-=6b)2Gi|GHs)clscO%G82iE@a|L%@+SBKs6Ei0+G51tPGr$Qk_LpK#@#H z6pEcYnH!Umh~VL2=i_6;B%`v35bO*{ z1d@ZJGXnt|;9^Ii(HInFR9af>{d7uPS2+_ZuA8B&v!kRw4!MQ?mkY*RGp8U~SeQmx zqka~jAX{AM?;@kaE5@U=O{ScZ|IWIyxItWSQ!kmtqalsf6 z+_^Cz;%M}{HEsr1Y8y+@r<|G z#%(6Pqj`la*;s6i5NBF0H3d`T=aSS_RBUx1-l7% z^@t|}>6+zz%wP)9`q-HpNZkS^z4ecC*}UAD+nQ9URL4w1M5=~^9LhKePkk5c0qFC3 zkW+3xgljWfa>cqB{c9-C>xcNcA|}P^bTsb!W+(YH2D0|Rh+(3!VmpC%lGosW+ z=OM9Ay4D%fb!A?!lFYLvHieC&%!EGhvN|EE!z_RXC{3cO-IDb^FWY1*S>+>B@tG0+ zfmBmpGcUz}lCdwCWQ$lRAz}U{n6JWL$X0Ga$8w4gUV{37+evf=yjsO-acDMU6D?S_ zv2=z$OF`hGO(#FPq&#^&FgDm7!+4IQG|O^WSNO%)mXUpde)UCMrImU6P0BhNdx5L+bt5P=k3UuiL9p4 zO%W}bSD)rY6E18-8+C@vSS8w_dm)S0;$F&6ro5jYCOExhbyAt`JXgiDDB+S-FakBD zfqv3Qp+b*e<#}cq6rS;C?O`rfv%h-(`9kRL}`TAp)Wja@&IYzLSKoGFltM6O*+M z_aaIDDFQycZNaW?60ysUrr~BW_jMBRE#-)yyJw)^Z7Do1$L1NyZqWEK(2bu$8MHZz zv@Ryo=F;7o2v$_=G(QM@k!cW-Q<-`Nx^1>|Kk+QDKkJtypOAVz^^#&`wcF(;3P1CH zfjOq+_e&VB(EJ$hgG2s>iptcNoA(=9HPg@Rv3}g$rFh8?Rr(2g5MsCKJ#23J<0$8+ zxOyr*iWu5`#Z$lF7sF@)epIuZke13HGC!kkk6|N7198bxlvM~vyJF)$3t3t5lU1~Q zZr^_U1g^tNkq(KyuCy^)fuCr#vPMC*qM8WrsRJu&I)_>x?amlMTL%eR^=Jw?P)wbV zhRG=>pDdF{VpL9ImX>0N{cc-7+|M6|aCCQ&inM9O z)AAFrbT*xDRqn-u1FPLmwGv##Rx#oG`yUQWD}AxX;!n%{vCZOMcw?_=JdF%8(+ z7*Xlc4)&Co9J1@j+?K|J^NWkkvT2l#*c#5uWK9L@1_rPc+@^@gMn}q9tdt>+?b%Yy z-q~!)`I#N3B97X(3!5gwy#2;gD=DwTO{l)gU~U~3e*s)uHY6sjQ* z+ywQt0cV5v!rsPhj*Lw zC%kzh&6o;V^(4#~`^`NpCH))-NR&r^yv;D8*p**ObnHk@n;`#sS({NGtSj~CJiAZR zo14n^9h~4~-dSS6*5=}9TIoDK0QdBVzc4Nety11>j~}v(B1z)|vmI5no@^R!-2)wn zIT&vuYm^=FoX1iIE3uE?po!63s4=n;nI*|%L27sK9?V3`zqg!5j6X}2IVhj~dW0CS zGy4eM4oczs>vI|z9N^+=P=(yY<7Q_Mk@boMMA#hphx{LI&4_BrJRv?E-ug^$kD7eC z=(2FL@q2nEg?U14%ilAqVZXZ)F-ZPije zLslk5lJL-47i)#H9##pd-ND!}*Z2z}l5VIKoQY+btfP_^SQRx|fN}0LV(7m}wP8Rm zP^c}p&fV|E={~wQ2D``aDYr4Ufmrvw9#oYp*foJrMFD31Y-Xr^(R9(#|Q=6 znp6kGsFjk-tGqYTSx#Sija#!{hsMZ3-zf^sww%joHa8f{;loIw*&Y9+G{G*xeu`~z zRsg(X%xuc-EV$3=BzyZb#$aHG6&#sE(K<)U4Hn0pRYaG-1Zu&;Oe@ zd@i*m`E0G2juyThw?8wi8Cv~O-?jSw?^s<&Jyd3B%5z6z<8{Jg#(weUM7JhPPx>93 zJ$1y`bE~wzY_l#t zvA{mBmDt$vO%hDhGaqC)d|Is5U9cZ}|lqUx&3i8pAQe{9& zNVfu9S&2dJCP4xW!8Vv^18&1|+R@E07y{rT@Nkj2kQyf17s5AB^~paizT8m1UBSZE z4^~G2rGa#!A@EpDCj2AG4YGC1=96kc;KmF9r-aBlQsi5Tf^?<%CBYWbU|kKcsv|u4 z6xeD5W6x-%D;RP84&1F~i3#x97zHfEf*<1=SrOwNAO2?#)w;{5e&%}tVfO<7T{0KE z4%yVsuJ{6)0}(gtC-Gt(Q!KybkC~TqO<3SKvY_z%wle0dzo`R)%tDe;hRAn3scO7EbM1e$5 zV66ZbF6W{*WnwKncJ&RpXa2Q`K(8`EH%#&h4I&cCg+!4Q!{@%Ykc?VqqUC%@AtzQ* z&6_%vHdINRdl;V5b4Gs)EhYp+svLE@%`V*pEL9DN6F}Bgrjj6|o04DxLEz$?JQasBx19$<5xMW&_9@K%sP#YV2 z9>PygpM%Ih494RM zNZ*gGsOO3u(zL5!*hbM03kEJZKb7j{|CmVu)(u9riHnBZ6wUS9!Ade|I27yHS?#Ke zEdcm!mk|%~N+j(-`AsD$xh7jE!wUFWIN$bG**GBwSON1~iQuZ$;;fLK#YHof z+p%sHi}XY_xuWppEZ=pr} zHskHl@O-w-__r&(^OTKjNjszaw6dd0&93o2Qz{Bwt?tjGi;upYSM9yWPQOr{IxDBA z=VOkCT6)D#VQc<YHTud5!YGh4ts!>7kaa>o-R!vpG%2=y0+4yniN2U{G32~^gxaE@04?=`lex}o6{ zgG6aBtUS^(@&lehlcCm5>?nqoG(noqLM_cS%b}lJn?L9Cf8HZPbJcH^UL*9DoqgaK z{$NX37JZ*?7{zgFF<$7A>a_K4hCVVdg5~5>+Y5TjOJOt|^ zOKuuA-{djORS1u8R_UjNRylM|qJU{CA#uP2njH&OpUGt-WFA#iW$psgzx1zaZt-F% z@*JO=CaB3_5jr06cQdipm5iTdJQ>WyvdBsepohN_XyLlWPDe~@))6u>NKFKw>)-Sc zU~Qa@TnxOwer92vW%Sb@!Wl+e;Q{2di|_}9gjC$ zrHI&r49)=ER`=mQ^)F6)9o^{bGF5p$sB$_DMMtK6KVy2Z1;1$or!A&fugIF&L*kO* z48Oo%e>~AhbTK%5eV7sgl4Ah&?%iV3=ao{GcD$xwY&ZK?|0_E*70@)uaS>-=x6xvL z<^2PwDS9}97XEw|4N8Cx?jY}CAa?=C&%Dsj0nh=o)SnJ}kI^m#NeXx-6g30PpLT{< zYqX--s05R@vY;a6LIDX#gBgtVpu@?q62mMDSEjhKVmEcC#L~e&TA7ueKnNLSe zgNyI$Gz!yfK_69gZG7NnJp-5jMs4f}_f)ovNa+)XvQ#IaZ%t@xq{nclk8lL;vOtqw zeTOati$>rxm+*=HRs>ZyBNyuJID#=@hUR}cMB#J$@Lj~_i^onzW)}UnI+8Q~-)nt4 zJj;WbJ@wUZh4FNZKyRZWL@}LY0Uqk>JQO87+_0yMEeBALgvgjc&R^JlS_g0W^N9N= zdmIgRjHDASB{rfg-||mB_rLQoV1j>0!7LG0l;foCB-WN>NGNaCXF)yUP+gQpJxJo- zs)+s{M9wi0pCEvQyO9<@)6!P96(us1ota=2C{*@M3_R$DJHWU@AH*zr-8A@lGNL4o zfeZ6c0}Ym$si;0+`z?y(`DLP%1iPC*eaQsAn@RZ1s2_ZLIWPheWt^0PjUN97meqi$ z@X4*Yx^+|rJoo^m`fQhZXev|@^tRKkAW#GTfvaqmHimjk$s*#OlyJr_+Yi35ka>*w zo;-cEZJgWcfRJ7FQtA%4=30g7#$nX6-y?{nWMmZEq%ObK!FUHJ(qv>#7S+0ds%iW0 zOho!}8NRB-dH#;?Of|SW;`Ru78Z>3VAD-Z^KV%2h)o65Xd$gQwN;eRUXa!tTplgEe z6JXURp_s->iKxHog;;edMPHbl@TDb`CZY@_`BLPDh$!acN5F&-%>B1xdQ$}2&|xTk z-tjMo^R5#Z&{(El;8H&Y&R^dPxik<#gePO^dMjn^{s8J%H~Fv>11X8?rjJjT$B&Mf z&i72j&xw%%u=FMc`dy7%r;uzNy%=|BSK;jp!TWEVLdja@uR3;Dq_sZv*}-y=w1$biKi`Yi%18e2cWnuz+GzY zQC7Ih$_f$p2v=D)&@@L@I7*ubM{2fQ+3q+in`oWZ>G=Km`}h6(z2573p7*)$hJyLZ zS<*i|#2GUBa5+|k=W9Kuy>@b~DZFZ6&MXb)dx$pmUB{3$509SDEjUDbc(RexVx{53 zj57R?x^*XWSi9xIwq%(oX#3yO(OqT0hL5A=3X2Khb7hrnlxvd!BI+wB`*&+voZH3fYp9fU82l6tT2IqUC!hpgYhXm;^|2a2~HEpr7g9h_27>Hg&OQUkJ${LJ>D5mWKzyNvgb^jkA?pZ;nFHS^?eaOLZ7bY}R5$?Oh? z-mSM;R#|4QT1$zc@%*vX%Jm}SY-K&^@%9iWxkmoprV9mvojvOdp5j;A;cj7UbjwTe z)}WZ<^L)=70^qy}&HFn)3-mRpS+h)e}c;_l-++ht2qFAa`@*iLIswujZH;D?9s1} zUs-u|LfTPRS#!wJ3FG}?c1n-fahanF@xyu*OW9GZX0vROY+^?P6y zNj95bs5Zx?(*n%B(I!Agfp)z;3K3~gR=Jg@^rVX~@t%e+R-uoV#7GcASi0tVUY=4(na)cgs z2~PqC!!$K}?kbAA1i(IQETT-si4}9J#;J> z4Qe(Ku9*+0KhBPS?DSqT8z2T{#Uo%2FL~}rYjppBIvHs_V6~Y1X z^k*ng)qg-l~IP{peGtmNb3$_zcr6H<`bN*l;X7gC22OJP5$-aEuQa|+b_18RP611xb?%uYoDKAuu~i}AC!~v>gHWz zO!du<7_SfgJwsuo7lWUte^}}bbs}%L_NMW|hO|%Z$_*P=O}xIS6}_xq`*K@+@y)%z zz^Djif4hRQ+Z=ggUKxmSXQU-)O#!qWGeyyP2&=M>nVXqU87~f(-;d2zsk>k7JN6*_ z4uCm;%Q$Y8a?~DqX7S}4#D%+;Z;z^3IC6Mbp2#TUEcXX#hGV55;)$^e~J7X1(u}&?+guvfe2V- zePbk`3bhccz5IdyePzIVl<>rMZ&wj42mpXZi3@^M^yZnyTFgL7Q1QpP^4Fid_UMk* za(Ni2p=ayn5AD%T(=FxyMJyiLav)bjTvxm?jqFxLG@2+NBQUUGN);MG7WUCDI;SQ~ zg(3fp7UDw8)yY4k?CR{jo@Nt;=XcOg3Wr(DzwayV}2Gc?O3}jH+RUgfovHMCs0Xl%x9_ zyrwT`?-46hJF;`5BNX-&UoInmRiuW7(4Y6$^(H1@Cf~8tK%B6Y)lM=u2(+KFL+AcX zZ&R*Lvb6Lm)l&5uGv=F5cpHrW@3b~2rYT8f%|hsB+6UbEo^2f2$&k4B=J#w}jQ4n@ z6rq9`a-wYkbs3Z!AX>_6i;knx8%Ri~=J4?Xku8%bMy&0Hr6qGrNv(>swVz;Uc^*@` z`r0iVF6;C8iZPp$ED%?6j}EC|+)E>!ZiYO*a4A*qFRZ)`);Y|rswJmNeVW?4$5=8Q5(72_`m$Qu9Mo)TO7=vXRaV74eG?d`Ta+>~cG>;r zs${y2wRg+1i$=&ok8Yphux$+bg=1HXZkTVIcQu*t^n4JTIMKC(VUc;?IFA;1ww^F? zBYqa{O7N>Xjj(Nb^aq_ftO>>><|FhJo_7Dkcbax>f^XGOI}~~vZlCkG%*#3UYG?Tf z3{M8swC1i}4J#8mCL@mZ%)*)*AJ;p_J<)tQ8|khtUUim(z42h|ae38)=zG}AKRX<6 z)770$bsNC(BpR)5Ejk)KaiU=31+6;S(1v5oSP&$RW#2RaYpZ1aue;O z17d4_GJeUwQ0R2uxko%)z9-^t>{~p`;uV#t90)uk2x@j9J=kVE)xJaeEEikDQrTQ5 zayr&1#`ZB>&J?G8@vQ1(gAR|PUt z>0b&~h}CNimmtTN4Q=s{dD|b^AoD)b37G#P5YcX()vurZCYx$YE`{IOdG^om4gFV7 zhrSCejmxOMFh_grq=Jzop%zRhL;QTkIw#{#tJ^)-g7(Ilx_XMXyfxS(mJD>&5hy zyFAZ@6>mvvI(XHy=#Tk`=xnHSoW?aL&JsOIa_{WGDdOm<`v2-Krn#j5HSlfdn)ANb zMfhtQ8z7FDeunmBuySWY^WC$zlXsgVwj&&#n+!(X1gE~%wETJMmM%8TTz+^ESrs|I z<)TKc_1dj;J)^)ZxP+CU4>Q0N&~5`MxQgRfH6lPjAna&kt^(4X zU~^s)g`3o8gQDQX{TsBA!;9PZO_1Z+aD(xnv1pB^MM$kI4buR0baK9f-10IFN*Ee) zxpRCB_%SghBgDT+q?!DWrn3aAB_t{VU~zFa%qJTK_LSR?pX;P4lHMC#`?6qEXGW5gqy_&Uy!}2w7tck?s4lz5gFp;Y90d{!sL zp46bQR~<&VcZSm@U@ceFwU+$e+0ls!&cBo@LrFEG@nIU&CWv5*c?&!C>RvBktv6GQMJ^9a~&^lF`KRZ&am`joAc)Sz!y55&+;~GUPUp(pqHn`49L!i5w=SVtd<3nr~7gjfn@G~yrQHD$4*%%k(h$8Gu zK?t=$=Y=pnpieir*}#5f&7BdGm^0{+@zZ565OKQ(W|W}eomkMONX}j{zsrXmSxi6c zT{$4%UKw3X6&;_-^@6hiD0ru?r+&(@z$z~oX9D7)^fheoQ4fUB8wx%ws2gZOJ;&X8 zy1Ak}8%AZpil|j^I8>8_n5itEpgMo|X%$s&Zamo5e6T@^eSkA_LnrLbCi+N? zm`MfgGCnd*|32C^M%&#`26d618fLnD0Kwog&;T{<%d5^THr1cg5eJ67&wQ2l0{C zpY!>U5tr{}F)D}p35hlsBf7BgB2_@Q2DXF%IMB8V1&5d9z9~0$5Tx(81lBD^ERW-K zes0+`cT%Y&o-KmTh%{CdJZV0npK9a1pRtj7+$bQ3cbETYibog@WM3-$g3nYmm6Q0KrN zGsr%LJv)nhn@H5-q1r;uLaHqu=93uF$!2D9^`}_8mTk+OoZ{$A*@5G0xN2zjHFd2E zus@>2R8=@;Hf{<)Ag4-FOfLKycS_xH!CZXdw=nL+;|qTsAlGAB?k$}eIk|i6t? z?`CV{k37#QgyYNsY85!6GaqjE_T=9u(Q_x^3+=$tbvjRcNi0TuxZeBe_a&&wWk3Gq zAJ_dcotM4FFHb_`_sDYNMuXVjjP12@JGoqMT<)xt?*s3|zQDQ#bsqVK(zzFA`=nD- z*@>of)%H6UIhdN?=n5rl@#pYbL18xk`r6&Y*73leG5D4%Fz20mt~X9vp?lIc_IR}P zT+0bk6xC z(dcMpZcD8$hKIgG9L9}pHFUF1UVfG)%qbb z=;@@>WhnEIbu~hj`to2RJ5VKuMFBPXfc`32lORUs4C1~!dC0d*_Uad^m|57eRqKp2 ztt|$-0Lx~?g?X?y(Y%!nb?1$J9S2vAYjhLW@sU%`Xz(!hUR$e%E4p-EYoJ~SDisv# zq|$vEcDFLnBLh+W4Q>||6m~ORSJ#lrh?wi7bgu{43Fi%@d|w$D zcyGLUS9q&*4;$^=jVW_ig4c?~NtW3iN@)@K8r(Y~u%8mbsarDzs$G=MQOIcV0|Obfn_zx|rT18138NwjLGib=y9^W%3h3d}oDydt zlp@j?h3Sr<>z`NVHi8l&Ln_c9b^b25tOb4-(mdNXd2$s@;2~2zcgW^Ba?itA@0ym9 z;5%mM(^Fui5{zgBkEO$Jk}qxU!8#cv>+WmI$}^a%)RWCR(q)K9zNh`n*@9MA5Ly3e zG*MzQhRBR(uzeV*iNV%!?~LW>PC{XHTX1nmgn=QPm3Lt>g6ITQl#^cR+pNkG!?n%1 z${VfoYwAzwhFs7?_Df(G{=`6@#LXD)YP~nB8eFYHe}bO8V&n6SYLhbogq4&CA3y>W zkhnu70Sc&Hi-!BG>1hd;$$;L&*Q+)0o#78NCIEVHa@Z-*92>Pfs!#NQX$l)ggJN{A z<1fr1wCCW%Utfrof{h%%y&q3$3L(9cT=>jEm^u({DPEE!6G*UqI^f-GkCY{RFed1v z`CrGb%rMWGXLoYre$m;+0P(Mh03XF<2G>$G|BkvpW01Uj{O9Y`RU7@{{g|%b5cNTc* z+ZUYjoBibCj~pvQf87>@oZItIUc7F&&83ihU& zQ_xA1l;EGNxQTVN5Nmv0&v@_z`sx!{E6XBn7)EZ^u(ZB@pY@dZm+Mv)I1!2^ zOTqPqz-8FU;;Y!pwfw@%2NV6&zh~Upe*)wsn)PAnU(184M2xPnxT{dj;3X(9li~<8DyidiHi}d2cnX%GI#R zRj(JTOSU`N4Y%YTHE<3vb~ZBda&|U0FmPEgencjF6mqFlHmyWv$2>)9VjlOgld(Nr z7Z2z!M_({xYI+;m(I(kGD6Fw7L8lR_--oEVzKOrR=d208Jj(4RIX;DBZm!QP7TLozf~#v74iA4k=V962*fi6sEF2t$UgTMO zsICM-9{lj zKdqr>5L9lvr5j-V@=p=h`DQk|>CUd#ibP&cEd7o3mdM&!Z3%-@rMai2ZnT zu{6uquJc-Q!;x$KSU=-PyDov<4BcKVJZc<>NV|&%Z?;;Yjt@2(NQEAosM&j=xY<^o zWWR0gEZcIXUvO^c9|BV{(z-o^5l@8O&?1e?32HezzR585iLAHbR|$Yl*G? zAP5$wPMVG*L2s&(`oq|n>5ppcZ#8!y$YvI!95b+m*g7hBwjX8CcMcr*xMC>}89Ub6 zu!!dB$7)^97VH>W zre-NUhZch;Td)Iz_qs#Jx%(9X2Z)K-E$4lwq8HE>>^-y`*7%Vi(p&YNPiE`` zF@-%MxVhf=km;$Lo%ZVPA*+JzkdHn+LiNuI8UFXjxr_%Q)Pl_-9`x# zBvCtx_Qq9+^3rmmAx5lW#yjg`)X)b?^_(Exf1)YP*d6X4J%G!W-dJ3GE4m^#a6c2* zx)dg~70;G#Q1!gnB_%Tmgi>U@Kv&Qd7dX&~=IMIgc*vcF=!PASC(Cm+bD$;Z{ByY;c?=omcvqPJOWVE$TeTz=G0ReeV@B)5|F zb;oq)PL*cZ)IkZfqtK-(_3}aN&(|geL{~DlF~@c>=y#?E;`=YJE%6qTKf?mI7+c_o z3mf{s-=X++s1gEMEFaa#mO%Hu--yg4+LN;-@DM4HFuhJGo54`4)LpMA_h5N5Be?Uz ze9QPz^#{g-Y2%B*?PIdr>2;+rrF4@U-UB_t@yOG+b}f-8uoh2-(DzkJ1Ro`Pmuds(0AS=F-*K~e_qYtY%5&;&mK`#&H<0yjtpCmttBR-C)PISlxP_({82#gE~;;mJ$`ogGsEz=&WlOa62huM4oaoxze^N&$0IT;?pdYNP)HOJ-cXp+Q zE*44reu_*6N>OIcBpBndiB93q-D`DMy?tJb2HeoUx-m3*;R^1cvSjb+N*XHJ57!{28Tf|#s6Kj3PkhMg3-D36IJAWUkYK$j69f5Cc}D%95;P z$MsIJwoo;;TRGCU_Oz4Uqr1!cY>j^U?QKvJ44hZAICbv;V;tq(S{|V2*O2kBkBmM1 zeua%#?hv}%u?_LJG8l0k?h(r#BcxXYwftU!C1dwxn5UrpG~EHtN&iOA{Aa4_snWo> zp{ARbL^k5YRIZ7c9QJaf?~)0701X}1#ou_c!`05SGD@`RBS zABV7OL^F@uWhqyy*{G=e3rh^J8qfPivy)t`mprd(Uv%(gIqR9RwMG_`As+MRwl8GM z&Ussk#UoXc+OS#`4{vWwh+OA?Yqs8qYK$$s6qYh za6|5my{w_Q36aYCmo7#{GEsfjef}2DyJ*|eB2rs-$zc^ZBoNAH=^@fv3;D>;2@0(N^W zTbD;sB?VhBAj`nUk!UljoO>xGoAeb%rZ`vHsarHazpO*I0<2CnVqOz^MM?{4*1s8O z*O`3VOl8%$!FzjF0byhXD`19?6Pa48Pz&2&10`fFwkn%yZG@Om-!IA2>hj}f-P`ieu056Na}BM!bLNx3%{H#|jx&+pg+#tVv z$UQKln(9XUdWa<3B7kx8`csho>wyfD>j)>Yit_8UioC0Y!$lQoC}*I!>M5+oQT>=B zsiU%ZSzdf98FB_z!X}oy%R)7q*;84Uet3?hmEBo_jQw0QBt4CPL?{H~^dAq^mjcD~1}j+JxegZWL2HhLA{%${_rl$?X6tpEKLktX z(QqxY@IRj3y%mU?y<2}Y&@_bqay1&qBnpbUR&zcu%^X z#x*K*6~qR>bqc?o!0iUn={$atEc{ xDn#K3MuS7eddpc_z2pT8DW% zL#`lN7JbvlOCXv`wEmNXcv!q@BQO#~>1DV(D=mycV2nF-RSVIVa)_9QEKq?|tq0eb zkTTr9XqEhsF?`2dOy(~v`yVM3vTt3AYoddwm4}bdo{YurYt-E5!y_K-N|(>s_40LF zyD7_Z$8R`%W}e?71Gp))ERpHQe$^>w)As#CBc^a=ylg3Y`)j@~bA)u6-$E4qTLm{GXgcIRGLU6$iLuC>P*JZr#XrN%@sCs zx|ovWE2#FQeIKV2g}PYJ;7IT8~QO1gt@ByCbzBK1U`%yF3p;} zPw3SgjKD@?T@CWnWegLNDDC8|`#?s##!1Vo?v@TfYdHhG;e^K2`NPAc3+ra)`dWHD z_Zanq-g`BjJ5|t}Rf{%Yzn2mgM9@HgJMKyF9$f{0nGdCWhjFCncn5Yhz|NQICNu-H z102mTpiv2={lL0ekghN`JaIs53nO^Rz=UZ8MZR~O!btwPhD$>P%0P$ ze8rGOI)X*~%LOC9#H}~6Tw58W105Eh=2ZC1G4yx!x)5z8ANrwAual@_6ay{w+xTaF z{h@QkOB|Q$v1zFVX_=yHJC3+(F26+dFmdOsER}t_UeY(W3a}NI?8xfrD z;Rb^G5lQfvy$OW@?P3@+EU!(V5i^2{BXuJS;IAmS-Yh5u&0Jt1RPrM`17RgRFe6UA z=m}0Y8b<|T3_y5;tLE4GHP_`WR_he{TE7c5%?4D8oHs&9GDsgbnDC^V% zW#dsB+gB-vn4ZuV)5gPcFNq9&Qw?790@>dcb=qQIV**tCCfKJ0YLdr1DCU`b)a&ZX zx;uj?91oOPS$51F`Y|tyh+&&m>MhT5Is3Rd6X~^s_|AS^Oj#KIrM8xH zhS4Cqr3!gr$ojo5;sbhM%|Q$|zUd{C3`lA`SnN$pO9PVGLn*q0_KZP0WQfD5L8wiK zbBC$x9}CtgeGXF4M%?8U0rO3b{<1=IRllQ2x^sqgEI1-5^b|B)-}cYf$Vhr!G(9gi z6%n60d|F82Gz`-e!@K>1?Y|*1{5M5M==6=ls0|}IFS$pMHjf-edwHXUH_w#NVP$_{ z6{$EW{q8&jH5~{&o?~;eg?LIog#FLms)iHr=*%=V;Xi7^Q$>@>fy~@Hk*{K!P4q6O z%q5zUA-&^K8P-tC;}0dqp|zwN)$R5UYUh*w!9+?n1U=_EUvs^g8&$#U>R{VWTp@t9 zylm&jR_pbXJ&&x+9c0* z06|n6!Axye-G&PqC1`w_Bz&osdet0h4S4b#YF8oQ;wu`LbnK?F*g*Ur4HYa7>9 z;>@&Zel<5c;EkRM#-Js7lj=-`Ntzy4p?%)cJ7JE83+#OJRS>0y0)O8>d`>^y9ng`Y zQ*klpWqcUI$XNuL$b}Kd`Me>QY6Y$?&=7oLFAlA3br)}y)?g$Gy%c$W8X@$?;4B>q ziSnXdtEda!hi|2+Lo7~%de?PQ)wxSe8!FPCE#_eVRDSfvaD24*YwUA*;KVF76 zloVcT`gam}ZglE(F48y-;>3z?$<>5_vP5iaUE3>PvLi zxd&PI(NC;&?};$C@xWoF3g0UCw_V)Wuj&I0R|7SpUud04sI^?va%UX6d2Npvad3xw znP6vkQb(P(k(h_GZ?LOgg=`2VSC+)sbXqO{NOH52`b{lK z&462+`khs$_^zVguM(;`z~|Ygq%a*1ZRjrFJd2nhi+!)Z@rKs7h_(~i|0p{lm9I~Y zi?0CqkAVcb5NXMHJ9HQO0=?UQ`pOqf`<^E7!3PNXziawOmC*aSVB>$TI(P{Z|H0nq ze6U3poR5yARO<>~<1|@8_jU;aKq?59d6`%0eoCxY=6SNzGah3#O@sKUT8Z}}CBl^= z`PZWSL|fkHT2`hJCT$&gDEXir0meQ0bZ+x)sc)yE|E^on=TL|A^XQ%YA%!Lm8|3zD zlEwi3OqKqzfidOR%G4m9|6M!L`Sx|D@i6*TiTgko_ODyh(1iSyd!)+08M_z1GvBkI z+XuV+tYJH9w7?yn`)9bU9p5&1EkidlncjG|Z;^`08mm0;>1B9N7mp)hO1?4SvKHC7~^*tlhAZ5*YR2or=G`VXRUvxvyHuIe_28QqVv{=he4oW-IU~J-^lg!^-TtzW( zh0z)%@Bl+^DeOcz+54y=_dty@x3!>h7cJW{cpy$9jq|P^MNij^+&A5lT@z;a6;{#d zbxJkHx+%YG7wPsdS-4Gq;Trl9hyT7`0+(Efb5nO>M;s%T>&?1P zU?#BZHtqyJ*m@=9N!P9q-z_7`#Y+#Hw-wfW>&^bknZEIMtC8CgkV=JZk#u&Tz`)S+ z)X!&R&vHA*1JI3oUU)&BrV|BQ)!NGyCwI#4UM+@Qd3Bz%yCB=#eGl=E36(NH z1s^p&b5|)w+`qd&FZeYf&fn5bF>}oR60vgt@mzlZMmG&O&flamF`tVpiVxLyH6?M{ zJdd|U>-aCW%G%i69HBSc`_*i6ntPF4a`-cJ;@#GI)@nQDxHne7U8->}#@1D&OTq#& z74DZq=BGKAZ&k^_&1^g$=%!}!ps0W#Gl`7-Ei=%3b0y$`4k^fj;%{9N=3!p#Z+Vb= zj4B!@AD;`G#sn0hQCK)S!F%6jH2ZE#=^vH`)!k(LqZ*ngZo5e>qinUsv**hbTh?n_ zs!PrqXeSkIthjI#{SR{sL)xQc2N=mFBR8BCf%;k9#07Ux=DOp-`IXJwz}LAJbupbTjqU>qwlj}38(f8cRu!`_hS$HzS+hjSw>&vpbrH< zpgnW#E%4v+nxrYQ*nQFEFT8o| z`yV2f8oN1W>D=Z0n%4j_s67wbvCvwJ#I{D$aGST(h&-Bm+tJY&isHF;bT5|d1Hf5| zxoR2=b1{?})CCK6`|_)u%ve`*ZqoGOb($FvvWhJtXak(Id_q@C>NS!47}RLZ7-B<> zdy6f0gZdP{vbH&LwCK1)jc1DEm296qt~Y9FKpW%IAnp30g_Qp_+&lAfpJDo9i|Gr> z3zFj!)2`N1$A=Ml`y*TPeXGLnn{4c_F%kez29ZE_pLC&ZuE*BiNq4S`Qaiw`HX&S~ zyAcM=ePz1(A<5Y^SddDv5|W5l*=orHVi&mp)*yF1HEWBuDj^S3=k?rwg5u=!z4bvw zYT__9Hkz~X&WZCjzUf0If<=cQe7g#jz&?6v6E=W0Z6PDRk)@&Kmq zHH{0cWxJc7Pq~2RPtTAB^dRhFwsVF}hvoYe75KJ>D(FxeY)Bu>=9nQ#lD3y3Scw42 zPJL6V)bs@|rko^?sU9_2*ZF!NUz;DuluetzF);|sM_(;=G^*@|xv_?5Vi3-}7RZ`? zPk=+g7I4{=*Q4Ji=godx-!|s~r+BNz>;~G?MnTyB5xhu>%1Zv?odhP@EOt8k)ZWuW z2DIm>yUuag9c0eFO{ACD{mPqF;8a6?eYskntqu8SG^e{}v!Dk95O@no9`D*5UiV6~ z`W_ux`+Db*cUI34{eO}f=!Xy9T`~A(9eXYx;nlXLF<0V#zd&%HT9iD-Zu8%b3XI`M zHV>|-_j=1tr_~qu>-{c%#QPe&ke!Q}Y21|jZ1F54c);o3^dSub8K%Ah+PH;uJaK5q z_wvqZ^hr{6R}KrlU^aj=0fl4*;W0~LVC+e=aWX-x!SR;@b$GV7q5bU4Q=AY z264JRL6l3A%m<~PLH3avu8krQ>;4uQLK(N8_g6GoAi zMG|uTpYzlI|b=Hm8te9EB3!V=2hEYe!<&($uu)1GHwx2Wr|c@ zjefiDp@31#%skkfx2@#^9=0hg+&3Zsw(e#g(imms>T-<<20XMHFgfa;%-Ek;>OF3vJrUX>v2CG3c60Yt- zg3ka`2AeKZ(N{)^M~jLWHn4s3>FMvOuIUK4?le8@Cm*een6^KlOo-9>4nu);FL)+j z(~yeJHonuuWh;9$7P)jboMcQ_p7?mI^v1Ja8L9HA#CO{xKwSsYksnge_~7BGqq&<5Ve_?iFeSI!V58=I=(|gN3)`DUvlc89O?K|S#&+A@QS|4iw z&gRR2TOP#;#5mkJml-Cr5F(DsyfIqz_h{`ooUTQdxVgZ1 z`;*NYDV_PMd5X-ffn#ef1^+Rh%KM0^t8LY3Qzp7*YHytF0naF0)}H%*n2PA9hGqHi zfS+tNLYy9IRBvUW=pzPJNvNli4iQ=DiVA8d9 z{i`C=eY3qZW$333L_p#VW~6Griin*3gdy)dYT3Aq$YrdH1>9y`wJ~rnp7!e)T{}~R zy&OG02@X`%xh_CRI}beIz%PJ2`lmRGNej)@J!fln+$TlopWC!7QvZwL_Tan21);mq z_{NQ@+o~0$H3-Q=%m6%laFdf;@+U0fCUU7VM*|!C>)dTzh4rTxK{221DAo3tdV3SG zBh}Ck82IIhz=n8RFNp7+d7Zzcq|2Q;OI*bJBQQN zTAGa97Iq|ZZTC&`R~+18@_gKt5PZDpxpat&aTLv+?XKxSXB_76_AV$9mnp!VDV$3jR5efC|C&F8mDxdd zIgHz8H4|IV30~Byu?s`MI^z;1D*QZvXFqc}qmZH};Epvcl+g#sJ7L#xn!YT6M?Ark zZ=^~wvc^EWS&YdOuWLLT$x`)lFvNRg`;8x{qm4fAp9Ip?d|1^`k{q2;gv^E_?#x#I zuc2y7sNI6x)X&!ce`JYOil(QCU_6T`Xhn|jG~5_b9FU6v z!`RpcaRLhV89%(<+5b0%6NCX4Ea=*{P=qZeJV2P#B$8M#j&HUGzZdE(*a9xZ6ZL~o z9Twb-3bC1m)Q8iK&Yx(m@p?f#*|dzH&l$M3A=QJejHve{*1LD38!8PB55cZ2 zo84H}2vl{bz@7@_o)R((M^ZN2-H*Jd13XxUJW8q3XCpcUr{4%QepQ|RY_k{sp7!@f z^&X+kApeZJ@XYe^p^wXFOj@|BzdX>Krt?-#lb%L429W<}^N zqEMq^G}xqu99d=GKknvK3mq_pe*H?eFh`fogMVCexj{62$ws6Tped zYVoW*G4`7n<_;=!7_YeoLNrL7e3g(r%~9!C4LS>bxi4(<1P;zi*+G)}<~qdJYKg}I zy>al?YoXk6H}(EaH@acRN1!fflkV_i627~{=3HNEd6co1s;QQXK;tMi_Jun$H(rKj zAq2xF+#0KV44wkI+$?oWNULS})D0})%VZJf+8sCd;ZPVS8Vjg;dhj#F_Fm2Ip$k<g~5NX%@ zFGfQc|G5{1aK-s@!3{oSHh$}^w`JVwvw?sy>7I{xb$%@Rlr zEd`36MXlICt8$Uyc!KA2^?O!;##5PHL)Ylu{kGN`wu-~#z1?u-7X5C<%Xklmv@g&fgU7LGDSUdhCcOv@jW7-~J-_d`Lz1%+dJ9nDc3sU_2DeZ*aehh;SOY~Q z$8N|8XCd<4+rW2)e*cU1x6!=xwY$Iz7vo~1-}ODjN|wKLCGx{tQOA;zq3B2%i@nxh z9^@H^jGZZ*;}y@22fdX0EBs7~X2X$Cn!w4g{g)ZQ4qewr=*)#Td1ySbE;F4tXoar+ z^foZ@eK2+-R(Ha!&&&4SJd}y%=abwMNL2h*-J?s@T^SI)ajTMkb1(tAY4Gr=N~x$UB$va{z_CenkI~KmpdNH}pU70sL34x=D%WoVM>9Jb|M;uqoH)};Y zOSNf3juFj%-^b3wJ$jAD&KoMW-{GUTJXzB{RA;QK#Tp+` zw+)GY{>!#X%gy#}0hZw>>C|H=^qcv*RZxm42^Dtd`q%aVY=MzYT6Q-YyxhEfga?O{ z4xCMfZtE>Q2%L`Juj4vkz3p1v)VNGFt(g5Ur9!)$ISE0C?MziQQwwCDM=fmAtPi~; zN80b{9oS|9q33m5{x{>HpY24Q!W}7M3&*F35Vx(kE$PRmq?qSCm|+myMTutQQvNoE>DD1gfVMsp>dU~FB6GLF zUDS8r&nqo&6m8aY9NW(anm*Q=+J~Q$T6IP;#d#2(T-!fd>K2&3G;nXRz4yo~)1BU~ zFM=emCb`?WqmrHufN}aa9{WPecku#dcK~|$Fs;q z_7+NKqgG{jeLoda(B)yrAED+XTiBon-xl3}|K6W)rQQi@yit8P zK0;`4SAkYPrH;`6G`!XMjv|XXbGw1;<JU!l-mmwZ@KSe9eJS1C>-y7G~O z=E8AXPT%Z8px!lpQ8{t&mh@c}EpdoE0Vc=#D}_6KvF(qHO;xbkcJkLYbmlk9ct2|| zg3WS&60sW@?W!pzdN(dbszkbH$mpRyb;eh97uuHG96Y-9OT$r&xR8aO@>!37I+F|S z7*4p0#-IBg-wa6?!9+}151$_$1-LbvBdrTe?3aZJ0+?^mr!RJ7LOEP4}2}2 zEWL?n_-ZFhL+*e%VIAm{P9108hgXJn#fhCXI374I78?Cs5TX40K& zDc1VN5@QOJ$+59<=1{yPLRY+TGqV$atkaw9EDXe-Vv+mtqzcX|$C8Es+PFnz48eSED=_4GK8jK?W1td>XDs!1ek+Y;-Bmoz$!R)#-E_NMrK z{o24Oab2zUD_hfLnIpCSHSa?UnWFlN@^3}5^t9ozT0e;kBfUM1R}UK1sVpNF#&J}G zuaCu8XfoRriwIIE{~5D0F?{-yq&M;>F4($iKslQ{u2!YBU*DZNH>?)u_XI_Lx+Vc1 zga$YBB80sXQ_x4086mn|f%B&Jq|Yt;Y2rQS^&N&DBIy+Lj^Dk5G-C(TTA|W8t+KT} zwKnc$Ttb`#r0VW{DKs2vJAst-L5<<{ zW!q5q4{*PbcOIppA06wD$VwkYQ<^w{dt9odM$Z-Vn7yg z^?cSIy>-7&CXBw9ZPV=4H$zRLJ#nTcgaMNY zKJ9#e{R?o}ZwuS)TWCbVzY%y%eHOlPx5s{|FZN$@0gGV1M=^;DTZ0yBhO|Zry_pk{ zAd1?kC?*AC={me|Iqyz7{daDf>G3|b&3jly=DK@Mi3(=7m5qx*f8!{Z4f&O%Y!3Dj zEhj#GA1(%ltklYDrF7nS1H;674sTD_U|IOD&Jqo}i2GzMa_I(Gl_#+y)QyQt!(3SDG7~_xQkjs3g$K=grh>7%D|6F&o#hQI zKg}K6o_WxE{3lwgCSL31j9)jur~XYhHPEvZBv;p~;KX8HHFBPlAtXr@);Wh<%rT;_ zpXN4sgNi#2%d3-l$ld*4N?3K)6Q)AYuEupllT*a?O(Yn`1Y-SaShXbo^;BPVcG{ZC z?Kr{19llq=7*Ss*AgON_=)JmQ#vEBIUoA5l8p7jtSxus0{^Er631UvkoeJI5ao2kn z7anrEg2p%F@YMc6go#YK!E|n%ujQ)RGM*+Nr|L-J-8`H8o8HF=_YC##YwasTKEOQ+J0e-G`_uW9fs5`l z&DARNlFpOtjF24t=`MfgQ}L7??Ad1?=HIZg%G%7W*Pzcfjk;Vq)4{FLAD#SI=GyYE zcDJ?a@EgGO@)qO=J~{G;SEj=4!wX2Zo%l$#<;j5_zD|1+#){Q#!g!Xi#?e2GrT z7tLId!um|LKV_C*+xBT!Qr6F-XyMzAIjw&Rm>lCzt=-^TBWU4N=do|HZm(d>5Yn|` zNJuNyX?dyUQG@c$1HP(j%j9ZngUX-3b;N$@r~S(7<$gunigwg?hwN05TCU>60Jd|B z?W}s?Gt-JG@Pvie&rJpYsf=9gxtrI{{_tqHBo z_p~z?s*J|DfGrLPiSDA{wnwRpRM&R>Y*2$;OZnJ8?txcSqgJZ6m3h-8s}rYSkXM6h z9D(Becsks~Qb-=m6IrZO_}uykIT%7IS-o7*v66z*;0Q`IX0vFQXrW|@D&)h9yC!DW z>M$%V6VXazU~}Bv^yZ<8`(`C=9jI~7-W)26_?~%df(8<7H6kk)11IG+Gh;b7tifNzsatNcyATh zqlAd6E^hah&v>4Dk`M-z#m@V{o< z$mJlZ8lhrGATO<>EBQQJUp#tV!~NhxbDpom5$z7;XvyMh7oO@+5}{SK!K{bDUd^0T zYm_Hk46Qe1BPYXT6{O26gf%?H(cOWvH6=}YE|8(McVD~C$LSx*;r*TD+;4}dRw>uV z75F56drL5G?%46<$doU1ryD)Oq9YB5e}&=lRu>#n6c+DwS3j@#sc?GAZ?e;!vZSnRyI%iqK9X2zhvTv9zee#W?r^guzC z14(TmM2c91loE~|s)FN5=KmCyF9z_0>A zr2lkseWSxMv^hMWW@e-I-0F@lRiST7lX#={owHR?*9y*9kPVfA|tw-lHt_x>v> zu-}5}wBS#s7KRE6J*9>JP8N1-!P9|~)&7zTKkP2IK(4x~kE!DSQ!A>~qSnRcNZ|UZ zI=X?e7N^KXU$V?Pp{sfC#=I42-d~ET5zdGQF!hc|i9e^1rv$9;9A7S20PxqGT93!DKX3Rck*?e#y)r_Z*Xqx&w4j*~I zmcOBv1l}(;5GtX5a!i*@u(dldgP>24pgj73mi}VjzTLTdwq!kq5=f?@TPeoUy^`#$ zMqEpOUT`Q5>&4$PNuZthk(lI<-@FvOnY`}VSB#$kjB@bU3bi{9#4edbS4dEr0B?ZZ zjpAW%@=eg;gc7k^O&%uCf{XFb$>!7!v-IQJr4m~~u~|9Stzv7W{@3(} zKO(DF6>&%htE0&}QgY}aXUu_;;%ZatkYOjytb;wn+9q5m85=v6hrBl?-bqmx#b9dq zwc}f(YgGV^f3TOPZ~6okVv2GN*g!6^TF=&i2@PTwlM45s9_AfW;ev?UI{QbEUl}1CWYjIbmZgrQ zNop*CSOs>l&Ie#e$Fwv1nj^22|20&K0Y7?Y#n zZfR|L(dh7$17A>JGv*oqpdFCU#`fFYb_t$SuT?^6Qb&@aa$-*Mc||`hoA8xpEsWr4 z&b7a0dHc4g9~i`>zp7vEtEiA0CoH0N=N$gZFkw=R&WbetgRJ6go{?5ly?xr9=F)bR zJCXB5&URdAv)oD8VZ&x*nLLK7iwMX3Vn0)zVL8pzzMRl1f}ILRE$;pu0oeKCy+~HY z{mo(V+Cy3!GJ2txhr20DTFLD(yev?Qbi#;dSl-@5X|h=2;oO>#)ll6gG4;$cVaPX! zCASXfk1fqow>xj6ACLT|a%rFQX@cdnD4{><-6n{7Gkv0Rm|n9yTUTE{G8B&mnEIp^! zj?H4S{ZnI!tlp~$lxpkZ`*cq0TZ&<6uB(T3ZF>)W!Dr9RM|W#EK3(p%Xbt}<$Ih&n zsdKWdc{@6^@QF*7k09tOHBt7c9k^uwZy9$n5PSYn;s7D@w3#WL9=GSppU^hzZB5n_ zP~O;fjIS8<9mQOu>j~buK6q<>f2HNaoJOTTddfOC?6$g8adJ!+8JbpCUV>rz>Uikb z1WD>%JA(H6vb~OHh`2GLc!`LCCi4?wBWw(mHpg(d(>Ne^{*c1l92f53EQNhwIr=y@ zt}Q<kIYl+A8Ln!i6hymQ2m#dn^6 zYW4dK#@i2995A)c)++XwX|KX2fdH%rffff$8uYCV{jCMeLDQ5;3c0VCumew3gsr(~ zD?0jb5B8TR`^#bH0pGyy3FlpH4z5?*K)3bV-(W|()v~*D;!7*n|EgU8u z6<^wCK%NC~f*o|B4Kmc}tVPLX#Mic3>3ToqWfkV7m2+tAh+$MU?z2FM%nh}XC; zcs#5Vcq;S!0@WxdfG*s?GbaEWNc0_2yz3feL`of%)^B`4czL~!c&KHJhh5cjWMW{~ zR#S|Er8YegH^xDY&H7>Mcme;3O)n?IE@kU2zV>UOxaMTxRK?h{^=@wp2oIlxhW>Kt z|3zF8+%8j8E)Xh|PPc0lb$^I4KkAVP7m@8x^e@?=4%MbhBs9$``_@nF{G?fi<*D2& zktJ}K%pB??p5o1@lR>)O{}2h^X*#&KJS|#aY@=P9nkRC8oe>wc)Lauv^0>LM(MSN( z!)kqY@zgLMLX4UksfQS=w6CyiXQedodylCbMHSvaMxR+;#m1`m&!QvFy z4Ti44eBF07$f%kCHL~mCC>D(~>tFL}$^r_Ct%?!oTT0mfuAA{%%^@!{R{ts1x#kP6 znEYecTOA8`9Z9bG<_ps(eY2;1DYzl$kPeH9!9in-f{z5?O>^#hKQK4qcrQ&8C#JF< z+x}UG&cBN-q=Swp@`IV0PkJ^Oi;Yg*!McAz&eu5GU3{RWgtg5OGuyeDeOY08SS$kn zlq!00W$Oz`c(yazV9EK;Y)RF8fkO*iF>`9s%RJ?=*o` z_pksmeGkX~wyID$rljZj2 zPaPL$6WELIJYJmf_H1%HT9NGsL7!=~7R=l)E<5JA#qFh`@nVP$gKxIy3hG|!gZXrw z&lQ;E_TH1ikmPE{I_QVPCDzPPm~+0~MKayK3@jKVCgUwKl22#NYe?sjvaw37-q+{0 zI|lUUOeJi-LVM!^1A6IC4_Yez2JaZ4bM~-{gO;>oqrG=`HU?6upG)_*y;cc6 z5zm|d>w2miGIc`<)8Ruu;=;OYfdfk}-R2JeYmfxq#O!c1dNPUWyNi6o%e&5_HSMWy zlns2VIQ?^nUg|#3g637*#CWhCC^h+X_%~~H8+t>W=t&kFpY>W7n1ue6YnSs(bL#C< zjW(36QrKBqOCyUlpDD@|V>@2n&209UPwRI43v=3#^Xpv!PX`ky`h7>^ov_0L=f=V1(xl)6yN1+zrd&*Qv$Kk(linV zP&(o|_v$X-x@PCe_=QJ-tmS8Wk*|7tvU4S5rd8^zSCdopAuGcF3g0g+g;QTZU;6n@ zO-4jDa`%6lBd^*1aesZ8dzF(Lm6Eo)5I*wzWq4OtRL6AIw1ZO=_{T`j=f9bOLeMmA z0Q=37RjqOV`$?7JRX{hXO%g(-yh2!21v`cR-eX!hPG!ce{Z!V1*(6^}V3Nuz)1hU+RM~Unr@Gy9iBp3z#F_W>h!-1rIt@?VzTt1B=RPRnCW%Y&_!UDjOZpv?DdDpl9@k zlkJw7B~N@ud$o>gd|pjmDQ?GW%@n@)ke_(R>yH2q&8mZ9a$Uo=D8%1mExw2gWPst5 zcP>mtP#m4}Y)u1SQG+FomhH3omOV}^l(_@6)|^^75NY*-!>&xAhZEVvy6`R&bJw)* z;pV}6=kJ8R=SG#NZGdN$paULbo1%`!m70+KKcl=*1AjG-zE{rfGb zgHF2j5KU8lB&gw`qKOhcUM>WwlcR*;=44DGLlZMtI#SPEgl)pktVNI0yfF@91byI< z&{MG*qBBDKpGtbf*+lfVMyCeUclfqc_ zI8H9`?A-e(_lStFs@IQg4EB!OlMjvaMzD>SHIgAbIyTP0dwBkJKnX z1VZ+6{jW(?VqOA|ANHg)`LX^;(7wt__1wFKIO%W5m#gV16@!AVh-&aWnyZDcqrO(# z?QRt2Mw|SuWh`0ex>6ctL9-2C9~J%-n-w~Cwz8w|YuUa>k#zB@~tvRg4xVuL( zQ#Lv?9HHB;6vj-K^>LglG=~ilbs);=ypW7}73G|+=7?7aiy07L`W@py84i1)R=M3; zfN*UTJF6J4kWVTD_)b0e^mK+`qV+Ihq^s9}*p5;&WmhRiS4rn;x^mv(QRhA7z;>ws zAf^v$#9%=*?cQ!Z@*y^nB{A4P66fl07k6-|vo~s9ceiz92}0ZHplxwLa8G5_0X#l_ zStB6Gy(${aBAcu=c=a$^EoQ0Ei6%dD*Z2ua2el&W20;AjaOm>yXpP|HU6c}v?zJx^ zXNk!yVnY^~`d8!mJ6MWgFmnjWlA9L(8-#Fd9b7CE7avdWfM37N`{t`?c}S&K`Lpiq z8=EY~)i5GvxWVWIDU?$43WmkrcIhDmkswU7e=VW#XzcCF z=@x}GGHz75QQdqAtqNZv+o9}d#~fF}A6_+dsVnyeJFo@}mduk)J-eba==64^Dwk3P z9-cpEp2x0A3ny$GVCr1k+s) zD0B-$%lL+K?pjbCEmjp9E(pMCN2sP1O@tU{z-P8Y)D>phowIVsFH^5DNe%(UNfb8e z=V2Tpb>NKCR^FCn^ZG`3IiwnE$zg4zgO{1-=y{?3J@mdm!NDdE? zlw?Whgn!7$S$^wyZL)ZFptgzkt(GWf|Iu1Z?<{GthO}h%%dS z`Tf}0b&HZ6wlY^RE$jqtb|KWw7fUm}AgJ>eKy*vg!jk-scY`u7TUuq&mh1{{X{SVC9j2}O4^{y_wjKr{T6#+khr&q%%vx^H2?E_0+r zI`R-tMv-|ZuZ|2;3W_;@O76_{nq7)K+dcVyPsNd)X?KO#+pLLKjlb^yfE_S;Bl9=@*om7`pGBe(?eL_G9q-488(ET4F}0J?_n>v&(#hHES^cy=vvd} znkU-9{R|~+nHVRUn%0fK+~ceLOUukf48<`R2+t^AM6Cy{~f(^0IUNo%i?9L~;YUYhwCJP+h}( zmeE%3TNp>I785KDO)XR%4&iQ83zFR+zn~gErMWl_Se<AkP3moc_l8b08tJSxoa0077p?I zddbA=JBmr$sGUr9--?TYTE2K>Kl(V`UxC}0oaX+WLQEmILUzs3whVH2bw}$wcBG>t zbsEXQd%oxOQb7nY;HIBChXh!^!2wR{wSb-)RPXF6R{sgi(0URiaG4vzy=)apmrS+% z7zQK=Y%C?6Lj&PBTmKc`?1-pa{ZPQIGH*{TlW$>+g?ne~;H7SV;4zL83PA8O=7Ddv zVV%XBvvOh9q+lQEj%8AM5Z7gbZ+$Nc6iZyJp*7DMExl;LOfi(B_@j>_#P@(ZyMb5J z8%{Li{I;Z>h3W@$Q|;ssb9pU>U-EZ)iMxQuc7bJYAusmtV>fdCm%P?W7>9aA@PcNo zpMw<-TZVU0-ZPvU6*?^{ecytFoF}XkV`g-6*H=_PCrcCCXtEnP$d^%;gia##q2b)12u|3I@Cp$%k*@CE90J5*PS zG00A@on)P2d1sr&j%nqdW<=}Bf!FD_PmVj|X#vx0aE_mj0n}T>95PMQlLj>jG&0O9 zW@EK#2PrdBu*}~mU9DzmZG#X4n$gx|a`<2?)S8?(qsUXFSAm?`7GCZChT7+|waS&+ z`OCmUdY#o&3~!*$f3mI{dC-`AknMNy`yzFv75tUH^IwirHI_^#i+%E}{IJ{9;wgtr zeO^q7tDyDXr26Mm#M~}jop*eFy(*(NJJL^*sTI^L9%j)dv3V-lifFh^YoKr&7PA}J z;s%eOtALjtc|JFdY1Js_r7xy5>IoWyuB47n17SbWT&pGq&Q`IfDgH{+Ka)*vs;1<< zwCi!rw*2P7p61MV&3vntT)j}U%Xnh=rY7vpeGR&G4jV-f=!y+Mh^&hDy)ksC0G0vdh-oUH(|jSgi5>seNc2OnFwrS2`#!=%Bmm>EgijcK)p| zI9Gzsji(m7>Ghr#jpt}b$KUODRR;Pg_e+;FjA+=1@;!8jsMFM8ox*Y;nsRRSDe8Y* z@Ci-Nl?HxMLHhtrVi}K$!)sjB*Ak;X1~e57lj59 z#6LSJ`xjXLi1u#_9*+6zy17aCVA3(V%yKnLcS(I+@~t$edCtunmPd^a2P!D?u&^%@2Q zRAU1quhnk`IX%sXjlF{%2r~MjGVzs4w&!RhIlHixG4Z6l7M#mwX+V*#U;_>ahJqZvi0q;eG2C~dPD0#Q8u(dsMXS1}brIN^iT1wBG zxH6GG&(k+SVWlbLz&_nyB~*`Oa9Mj`EW0dc4vEa)c#@}+Iq8totWC+;_>_KeP>}d_ z9*sT$hVtP_DsY36x`70jjluHwU7C@F#D4*;9fA>gy07O^eS)AbRrWE1`OOFzNs-|8y@l!C6!n*=Z3l%(e`Q!M1vm`~&`*^-Uzv|F%j(6FfzRGF z7kOoma;KgOU6sN-MTh2?7XMI$?Cu7}1*=~F4VhA*wYMnv_T=+wRlV!40pa1Wb+7V| z_HB$5xqpbGsCA;ozQBTLaCApy#YvN0meTiF>0KJ_*^I*xgvq!fx8z3$MX7C*VO4c&GyYg)x`}IV(dn6N-x8o(HG1 zE?I{A__z#A#vs=z4)*qP5_%0M>eHyFQf_07sI!2MpL&<~1dT>c>?kfPxi;q1Y2yL!{{opdqxF(~+f3lple=wbn z-?cSYK->-kzNFnJ-cWa~?(sqIGnp;8=E|c)+G_eLU{$yK_++hL+U)4y4JG{4l~)6Z znWIT}qO| z6Qp;~Vc=ZZ+VR3S@Zqt_O9?V~zWUjGb%bUSoJm5s^|8C%?ii?&{Iwn0+Jl--xbK&2 zrTl~)9@KEWzDbpgJG=!=>;f6G*3}B4(^_3vG3bA~Io9z$K|Shg1ZzJ9`aprYL)S>x zV@%_G-*#FL)3LJQJ~ZKjnZXWW#5D3bfc(3m$gKJ0nGafm-!NFMhE^#!9Q z@xmZ!@v5i1FS{uoCro%;NZWKxH+>1|ZkmJIdqW((JA^`mI%56{cgsdx+e7kl%4F7Sefo}Gq<%|l^XL1bCT*8J#HucMvT z$j2;q4kWXHf{|j-T3CEQg_wDf@RwZU(xBm8nuaxm^`X7*J70s%-SS6bw!)86$sa=0 zDo{5R@$K$g25=W(=9?Q$h&w0GE*tCJm^4btz+?+3W+Hv&R8R*$Qxr5PTYZ-De5&N% zDG~Nj?pM#C@J9*RkJ#cz<%0t2rAI%^r-h7Z|D)4E_ou_qkI}!u$fU=yM;~u|`FOL@ z6M>QbrV~E;Vp&EgYRCSJUA1Tx&U0-TRN{;Z&dk(L&geYX6xcNikNWH@gq7{od%&~4 zJvbYvoHYZU`jeh+%K@80XSyX%`!7GeH23tE;Ffoxv7SRP3qAm& zL5Q;G+AqWdB^w5(aPKMj$q^Upr?6$3(OsO@wQbrd*}JRcq*IG}YdT(ot%GhU`kp=q zol+Xx36AQndw|vry*s()ZQm7}Y>m_2Jr%{4J-+o@z7dOfcjisns^W3defU)j;?@gz z1olaq;H_rJy$BL~yZ5DCnc&)&YTZ1tbxX!#c830-`P~~nGOe_I1?Y&m3N}q|Sn7Oy zN~649^M+ruu$jWJjLjKJyrtAi>TwTLU@*-P&oR?}QgnGAAbKVmQ~|Sbtk!?)vv8Ut zETDY~I?mlMXxHW9fzi@{vkbtx?mS!?>*BTsNw*!mSDXIRx#5F;6x0Qc1lJpBZvD!$ z#Ld2p*bqhB33Ffn2OWKkL6sPCws9zBjrNQ0cpI?&t3&qVl1=G%imB-@V?H`trh}Ni zO$mHKSOR@t?esbCVc zyJhR9mj39~4A4M+WnJ3#85J;2#R#|VMV~;z0q~et+*&NdpcR^2RR?=vpkf9jWhcCG zSPLyc!*qc0>kRctsP=t~j~Ki#Odc0c8Y z`SAMFG8c>-i(!&@RlUC71f#xpZra^14GYwY%GmCH9+_sKQ6tYds5pwF6-AYzXLyko z4z75IEw{t1U}H(AkVvLb=>7lAwq$yR(4UH~uZK4_H9;ES?r3v!f{C7~o=q1s*wx$G z8bvVmArRP9PcwE<5W&vJI@r(8nrZFoGUCegCJTLCheuo{Tu8RIuB>%6!gY_0Y5xAR z-W(2{*d zYHAkJYPYeOzxvd-EToMVb+KTH0%G*6d9+Pn;FgJ2%e1k~E7|andUL&m9z66u0;BsN z^LoM3M>yK#Qxqe;ey#+g=PDuovutKd(1;Z-V<8mMM{oC7^E)fQqE^?PM*#1Emx@UL+LctcoJFSP(G{C{$@ z=>P=^bdBT8IAzGSNcA$_)H{tDNU4Y;Zu8oyAf>QGXbS7gUsC1-2XD%}en*FL)!|rTVc6uY^3v1{CMWd=1VS+f=vBSq?Fw)6*S|P01?|GxggX ztS^YOy$A)51qwp2b_2uH2?67d!Z4;tjDwha9!*RJnT1@wXM3DmxD`o^7& zFP;c`uP(hY;1A)p8D?*^n|YBldB*SPp4ki?Fn_o}?O4I;0zBEc@P5zjWBc+cj+^)Y zc>M$Y$11c!Bw%CHNrzDVZ($`Gz6DR#6B8=h%jo>Yl5$cNr=!yF_~lZzZQgQ9jpLJo zSD^dn*;faRQ1M{BKjmZ^cNp^x(-;|%Vb)AZZ-caK8uB~Yn)ZwL2Ays$eUq@$MZNoo zAJv?BG~d3X+h=^`3RLQi4C-mGD7={7`I#8y+hr7jt~owYb1DO&SHLaS)U9!C!Lj1h zqp|wCbVO816h#2xjE{i?+2=PR^sQ1lFiRjgWa6KpmWDMvFtR%{o4+bxSP|*V1b!4t z-ip2nGDVKge?k1BMxwI*a{PsxD=uvLMe|$5my_n-7F++OKPLaM9aXBaaP=asnA6xz zMZ(`5Be>1mNHGW_af%<&j#DgJE7)ub*9q}KfK!(h)C0KK+1f3l?C1Yw;H^dRb-;OcNp({Pg$dB zXNZO(gFqZPaK+XRcdrA}oX7oRjN5~W`h^hJ53W>Dd>1S1BO*jE6O+~4EQOfQP>}&gDe_bRx^RJa2(<$Zx(oDSh4#g4{Z_oT=l;dl9MGkiskkKbZzX$gH<1j)xwq{5DEz&bwU!jJ-z+^f2 zyLWk&*Sm-z#Vom_kwC772?FrBau7|bCDBPDOO>7FL*0ibHS}4tPRpy8)k6o@MKhts zhByceBFI&f38+1vbT_6U_CnISs9vVX?_WzbYZ~dd*bi*}c^AgfOa|FnP*gdoM4RIZ z9vV=(2|FZt%~-EBU<{h407AWG!hgyRdfi3e#h=}Vvsw9EA7xomEu_|eVCt%Wl_1lJ zKRoElYRr#cM=fsiOP}>enA`Vt)yNg4_MXKj?GFHP=U{lxStnN&-DBAV2WTphx(yl?v%f9RESdU-?>T>T^V zCApe%sZ{&+VNq(?TmHvyaO{vWl2$W_wv&zP?&?2yp2Q3YR-Ow!%LQqIIkb^wllX>2 zxy|!cy%E$5+ru?IR~Ah<@^O3VFuxT2;~C3t3eYZ8iCya&Ka3HWpSWp z`O2Y2lE0r=E-zgxEPE=Fa7JEAkESFdRgC<3eFKvQykI3aCXy&zX9UplOQ zVu!i3!i-E;wHiea{DKx#j06j zyZmhx<>PwMUy~ixIv*;ztH1K>-sZ;cj(C6e?61e?Z+<(wQTJntE0DG=&ueh^cC~1; zj%4yAJnL=1n(;P`pT8-ZQg}Pxaz0-$0|)~O%F1y&M>RLf3TodLh%dn<0ejzM?|m%Z zTULTTG6Nh_D?AVxGLc5D;ubyVVxD{pJ2g}2rz%`OsP~Ds?}7zzDL>xR-0YfK(Wh*r zdpy&tgbKWVmIw04ni4ULL1d}(v&Y%&Mu_X}Cg9p2EJTdLG{Hi+ z0NE9I?u*oKbnjKF&vV`LThVRj?e?`sCM>I0BIr%jo&WCf)L{}DX22K*;mDc*KxpO{gMeXcq2C1N2FT`n>fvubjLgz+M```Yx8#XMd8!KSd4h$@5 ztsn?Gl5e}q2}G`uT)2!i;IAoHo63L^A*dK?8M6_JfV0qo{cxFc5N{j037DQUdQ z5gpUu=n9zkt>#%Cjz`a3;-quWDJ0rR<9<8>9!rwibvs}0;Is4UK+H}15yXQVkqI%< z;74n&I7x~f36$k&#tv@Re*}+Rg3T*@69VDel>si{V1HaPp%1>D2WN=4N0IjULNxcE z1QNwNH*)cv3k4%@;6WtQ4r-7=A6#^@<-vEX)ntl?0^F>C$1742`338qrR@F|Ea=>@ zz}wVAGZ{^D16y>Ov$5_m;DcNTt{WpY3vNwf9-Y&h=NA21(HU1ltvhuw{h<>qGqrxA zK7Va7f&R%dJBEWsZUxalts!!lV>!fw!OF2_X=Sj9if#id11kkM*_PNV6?+Qc(_|nH zf+$3|T0mSMEIFg)px{~e>i$DVByv^{M4h8pdnKN~6&&c@#*Q}`KPzEw-26~%ko8gq zdoSEq@#k4{LV^O=4%OtSGN>z?)!TuDZm{NU-j~Oj$ue+r6TZ3|?j;8wd~Mhwh2NRY zw3`HN2V?TJT9P1eHdc5QOm)hFCqiOxj#T`h$8O@o>HTN8;`dMo_o0v>V^ zZmkG>-U$w!FQBC~ZrP)?Q3_gp-|nS=besVHJ6^-aBJ%dBvsGY(Y7c%r;jDH(HHKgw z4px~WF2o@oeb1n}!1MFH)Db(M`KLTK-)?7qHjx3Wd(vw}Mnsn4%JbnL(Qx}W#dhCQ zkcS{1GW5?b+uzz?T>wUGo+gy={pA6IF7OK<31q8Je6OK@0l5lLrSw{H(#0?6i6()e z9_IcI;F1b9zm!Jdg6o6B(KJ9VGuToL8cPA0SS*u@&1g_G@22DGy(2Bpx&hhw@zJvD z4)8Dm{FW0uQVOutT_tyqq9Jfqa5#lzs4LU?@(O+I2|i{NW^}^qIf0;X!5_<`?Y)-~ zs(_Z=Yvf0R_Qe;e&8NJSa4v0g3>Uy=;hp+G^Obz9@8!CUot9Rvx-w7o)J#KfxL{GT;BaJc&~Faru7*#`tL2p%*j z?{)RnX~>*kpFaf7ltD%E@cRqQ307RjQcNI?@PJ&adf!oQ4mk7m^ts?^zWP-MT{}o@ zEX}r=tnJ1}K_FLj%@Og6@et+st9>^Kyql|wr*0NiowV6l|Br#($--rM$1PvMtzXX} zzn|ZtqU2Cd2+R|JAHi}2@`FUL2b1!yucNq+aKgkHbl#wz;rQ6|!2`K)lI;*RbBHY% zij@v+kPjs*hc04=Z}|;x8_Zai5p2yc2{)_kZNiheuUqB8yE5dmna1;Ohlz9@uQYkyE^}L zZ~(OtnpT6Er;sDGEX|OK^)W^dI$3)ndBur}jS+jipyok7dR{wY;ae4+GXz4M0-hqP zA}x(t`ok0DFsDJ-4_`$3J-pp~vJp8b3=Q9diM`@@mJf&X{n||(z_lrvK|^FX0A@=6 zwLGXF1pd$g{pmHV^a}gc@sKBv*XRgmfBxu*?%uOwZp*tU5Nw196AxDbsa!q)sP^}tk_&?Ut;qGk;)ZEzffVA+3@c#?^4g>K7 zV!+(6Knv7KsXD#0(j@}U{vjKk^mZ;WS6&oUd4!B z@JMCQiX!fKg>5_-A+OMQSKIoG&{%C&02-td2Hugr10xwY`60sta z?tu3)5k6^*+I9t7fCL_95&pd*WB>#|G83#8B-v9|E8%#St|KPCt#jpK+p3IGAgja5 z&6TJE1>;9UAS2)NR$H(gS5Ulll# z`U(XcS?2&C<`*pnkwCO(umf{S0U%uhCH>|jP0|z4r@XxY3*ZF|bq2y63w{3Z3Z=zI z0I~{D!RFj{C$S>6C{+juVcgRKRsd~|w*+M11!e0Jl_+76Xmw2B5_ac`RRG2S#&}!6 zcj7D&Pc8lva1}fyx}U)w>I)dJ41Cs}M)Jl+1)5Dm5xHFeJTO<(YV|%M6PN3O3jq&s)dhQ)>3BuC zQ1B{9RNfbj1$4uk$K3=Kxw1>U3D`-}e_D~e{WVWObFkn9B>?f1UjQ?A0>w)c6Cbh+ z3`$y6pDa!0T1`eJXjuIRt)Db7@~o_~Pwbihzh zSU6As005+>hULV>lvr@KlXKaCnVHkj>3IoyNfCN-Vi@^ks9KmZG2v9QDmzPCYr9%n za01nIb#-J4z!MckMKwkR78Vvo7DhHURzwv>9c=}6OhpD=J;n+~){?y}RMow;rKD6O z#Jv@UJl53YrLqOqg@si%7N(W12{SVAmMJ4sY}>JP1)Fh67e<*CE5x?>1Cy-`nQ+{? zg((BFOtNp#o@^<`O$!w+U6jS!a-;)BYSqY8Ij3a|xo6w1XwcB2%NHqKib~6D-U8jVTHR$`h7No;)c!^h!D|WW{3SB8ZSGM2Z+Wf+Pt5r5&YmB?2%2 zz=<4n0fhPsYJjO*hH|)iWoyR{!iG!=)+CNsQAW^WeG7%x+TWA zsP1{J>NYSr{cWLA=H|I$SB#;I#%STVMR2Nx9&8E)~%3>66x zLxvC$9fOQ7M=W^67VHt<0S`R>{Wb9cC$+HP zNEBd1GD#(j6|xs#e+oc=EGcxN<6%Y2c*|sVDVCLDt3+}|6G~jM%+(rr40L6%owY|+CKOH`o|8OC&@1sO#Yp+pPPb+%rV5IM6F7ra@~#S^}O zxs?{6rK3_uV2~(Y8Ot~$omf;@At)F{OcljVB4M=5e@#%i4;lS{iH2&KVnjw4QTlQW z7q0#3A*RoW#7#8?r8mYCIAm1<74XEi1s6w=h|d!KT_FTWTX3TWqg|FNRy5Bw@kLf- za3NMaV_cB{C!rY9mLph90i#?1EH-0}IULXl1u7iCNdpHwcFO*5@D|X@1S2?Mi(O|h zVb>~)?NH{YMspedf`bTD zSgI>?UhoE$n)p?vW;9l@%hIa6$v}vNgaZEbQ~G6He5{7m$quR>EJhoRP(E zJ-!l4Eq0}lK^ke`vI`Vqw5^yFz9_}ym{$O6GLup|ss2(Cv1V=U$M^9qM0Pcy2B382 zZ~+7mr>zQ23n!-ow--Tpmh}$JvuArcOIhIsvF>olMHaZ5De1KWJu~Wj1x1uiI$}J% zCCIQHgC=eLz&%qm2*x88DqR5z3IIb6u5cyz5hD!l=m<29^$}u>!3$e}LMf6KCG8k4 z9oyJ~NwzSBEuo1UXkbPaDpiGOd~jE?%8-aQWUvA>U=;{ZfC)@c0v?BfRN9 zsCmL~b}&IGkVOipDN(N?(h_cArfB{uOrc5Wq2@z5BP1N3s6u&)huGlZHSB;&8Wf}%pe}{Y@vSBatb}Z zkdx75YM3GN#Q>o|E<+$d0}pt>1aJVPAclg71E9cO6az2IH6e677~KR)M~l+|AuFa3 zm^XbPyDLoOTE2LbSAs^HlP!TDzQ{>6ZbAkkz~>y$xWW*&Py{pX;AB?t#c;N;gi1c+ z96S(@AJ+&QlcmWu(%H}zf-nZ#SOaDL)Iya%AZC&=oZtwVi3%44wF)at3scupfti}2 z1Z=E{W8YB-cr3LgPh~7?A~V)D8Bzq$L}Uy-Py!SLg&L>!#u}DF2uRix3XWV0BI)?X z|H6Q#vt}$&WvJ9YoN$wsY~?u*Axjpr01z(B$1Bll!Vwx%01A}z0V6n(?c|{9f`&vH0_G++C zDC}Wrl-R{K_ObZ{i~!t8fllP$vQB^k04R_F^O0r?NOQ#qHY@6N zN>@1blamGsH;P@M1sm~SKSD~NQt{wq6KoU4sDJ~^P=hQY=*Akv^PglW<9St~&K8gm zjeDpd2q57?5S+m%cntM6SJ+QF+`*49(1Rb*=u^bt!6YRx4;nuw%2z*m@r7uCQw(4bf)Kz!Ae?GpN$h}=FOai9_z(nV_Rz^h zya0sqXkme2@PeFTg^VgpLBR2XW7pG-61M@PG=w0TgDZTKn7pH<{K^W9?PJSF)oO} z3~TUt5t>1UBizSJSU$#^3<k zG@XNkXi^ytoG>lvXbO3z)Utn^!-GmrZ5dPG#t?Mk%ktnCnrdo|Gt%UQE<}*gIuRDq z(IkfY>8cD<&x*mKr39Bf9h^Jpf)K7E1V!-=IG3#_&p{)S3p0CcpHW7DJ&Ceu+gRt&Q+U^CS2eJAd*8o00pZ<0ZH%^89)Msz!&{e0Edx*_muX5 zCGY`<;ft=|fF%G#`=Ud8K>_aMLmA*QOpt&|kQh6#DPuwwd80+%RCr_{9~gl%S70U_ z)dIy*S7?(a%>WWmH3o_jbQ1&wo*{-gw`A@(_mLfNJs`*<@d{LgI^-)?t}p`P)*IRDZ_i9lP8Nn3etI^^hzq!q zXZP*NU|wE(4b6^5^G0Hk=^+81UM6M4)P=ay*4Lk(BC0GA&?U zhrHg;W=GVq4T+OaT9;46tbe+7X0Y}5m3)GE#PGkv-Zia*WO9Dot^7PEZ?<=7Ub|Dx zJeG(Bkk~&J$FS=!oNqkiy?%nd-tS$}It&1I0r?^G!!-o+{ww*dh5hq?Ca$j!js_TJ z6xL;DXR~8&8G7eCIptrulK*M)$-n>pyZ&i%@Y$2~e@E9p4VF3?uCI??$`{erit*z;_-@pGI4T&4=|NB#6{`&f)Q~sZEe)(2hhWVMl|NeV@eI5A! zF7yA};s4G8P*MmuW(EXI0)ap;E5j7iF@&IE&ys3PfWf9HgMa``QYpq0(^P*<*lB=? z3cv-QFo;SxkSgx>n%*SE|~fSx!8NL-Ro~1 zvk2Qt@=5dCl&X_w{iYrtTTf5e7_p|=CpmTGNubW7c%#D5irTJ`XU6w*TO-4-elaLU z)h_K-%up{(!pfuSHwGB^ZMC>CNlkgA_t;hYowl*nSvD(bV^a{XYe0l&_TU1_(gFZCI-lzuZ96{Ar*Xgyug(evy?8{56H zzFk)BU$H^Y{npow%GvGc;M$=HpD;Op%A3Cu-CiBe2_BmFs)#mnqkgrvj!eT<1x8aM z2a=|PU8?Hl)98JY>)Co5CUYEmb2!o^^cCW8=FK>3HA6VdMH}uy$T?0e={_>SasNlr ztQvY^A`B5v0OR2c8Kk%AR*TPA4=!d+vSKPBd*q&{cC+I(`3R za2T#n5|BY$OxkLPo3ers3Vys|9Tvj8Z+f!YLzYwBUaa28?zV9Cp^g-I-ROvX9avs^ z`uJWcEr^|`6>x{k7#E0My|oIR^2EM3 z*Mp>0%?p{mjt^Aa&n6_W2X7OCVSOZ*02a7|@w%t*1umGgkaCU?Q845C=}|~RoWbb% ziNuE+0!20t#<0`G53IGr2uw7wgQ~@G=!Pbv+E?KI^F(6FM)UL#Ra()p)rAu~ z^PX?yiQOZtm~a}|CC$Z)jV>0m-JOckN_gx=y|x0?Gpkmkj%{sn52rHsDa-Gf8t~iV z!mDSt1OT@!OiT&I&AbM}3Ri2}h2N#p^szg%2iLnqB0+Cy`*dHMLpDh4;ld zk$Xy&r)N|NYH3#HiS=LS2H+RRCpT1g)ML4E`fkT7;@F>I6$^?ZPE>Y$?0-TpgM$mF zJ>nr0ih4#EtN(*Hfq| zOT>oNJ_|p4NPN4%d;p8s>vLX&s0=9YQ*TcrhzgSkxC>5u&vK%nf&M6t+taPPUB;ry z5n~-lX5w?JfExiQxy?!TUlPx#=ETnXU)YX5llu%_$51Az8bwK`oiVQ_{8x+hzH{SM zx{96--9Lp&T8f9Iyq0*T^k`SqgHe@ucY+>v$TGl?TWm+)cuHJ|(V4JIDtm+*k~F_k zp+bE2gM{G>q*HvliRQ;H#3_#o6~%x(mGY0Byi2k0t{}+k$44CXwzy=ojghD1@2#Kx zOYUy-f3v@`d+x2J*VF+l#A)nJ=@$%jv@NSVG9jEDn_zhjLwl=s*6Xg{_Bc4)=d)I4 zWjX0tiezha3aac!soS2&ewwJ@^jW)@_`_1Lby#We`Ww8-oBJxLI&oRhd?aPc-Zdfk zEZldRv&0#w+x_sGy>{A+)8d{EY9PgKMy@sG^h%&{|9#FcPBAu|3^R$QfOoe_)Q_1J zzk$HceDoroNVD;cb~4Q>eFgVl&#KLtg|B(v3Ca@(bKloJ{D&KGmUVJ2bm4aB)|>9l3mu*dPo({;DRkeG#qMxX0|M!2BF zMq2{lrH3KvknxZu#ttKM%9+g?(WSH8`zMHFy%u6_eNRC)DZx6ERvUZWG9yhB%C zG)UFx=p55h37Gh+Ks)Ov;>2AxW)~wZaK8hf@0E=SbWR}f$xxs0ey4|Pf;gvPJHL0u zp>E&m4fs<6;(odbqE@*|F|vxcywQ0wlUBQ;22311xQtwl#Tguc?L0Yp`LS4BMo0r4tywmwjvIT?2UH`pzO=b@ z=OT1iAQ*^xv#n^~BGK!@nJwb9ivNwy>mvoHld1|;Zp%<*h&01T1}qtHdrGOKI5E~i)$(NL;0LK?(uX(Fof4rnS`uiIzEO#3lQ$Ux3DKGUT7v z5>nKPrb{#EWsqpvHGI<(*zsjN1>C zN~G3?m}vM%J-VzoU#<06*fl0AKdkI})#@99x^7{7r9F%p$GX+Q*xhcPo5Uiz zr&y-2Mhvs>595;fB#T;KUBMRLAjI9zhAL#(G9`h6g`pYPBq4}Pia<>5(G|m;pYA%P zsP)W$0b|9}1UV&Zhtkey0PV)5`>*AQ8govSLeL!QxWsB*gmOz@F=zGS zzp8--8rJPBQ3}B#F8rZPkP{GeX9`y`O+W=CpWw0-I6RL9MYtlY$es> zaWP`top|2$(;5qhC|Bo$qX7T6?ckwebO+fVmu&N^P<4#y`rZbFmO?ZH5C<{aMFew@ zq@EfsmA}j(e9PexbIY#fyh$nb;2&%^&Uh16trnK6l9NFb!4x04n^oO6an~gLySsoM?0wK#_3gE{X(3=FuJaxyI!HrlO zik6IfiVVy4=6%g@@w;$fZvs!qg8PJTTTD{$W~QADd!QEBIvO{vL!-KMxo&OwVDWMt z>D$3Knz?J98DXyu7JsYymXhn-Qhi7%jV6Psipl30SXt0U{|;1=Jnt1PIe)@x6zj+_ z%$h^^H9p_*--?N3sQ&4z?aLOx5Drd}Kxh&GU_jvyKp#fg1_OLz7Ypcebc0ymlc(GY zqdZ+Oc&%oAEyZpBXW%eb-HTS38xgrH1JDpRD+wSW;kmbIEhLlH4VR7_yjJ!8WgQP$ z8c)oy_`#noE8!9|el>~ma-g7e|InJ+I2(?tN5{w^b6?ezym81}*axO6BM#}Lj+ej= z%eysqSmKX2=+(4gM~VgciaB*nmbMEEYR&?fERe$AA1Q*Fx&|cyaISZK>C)bd&DmxP zP2~b!WJ#0c6jD18v1nwSaS`uEZPK1{tRS7F2yzLBO3js9K7Y&kcDkkPVrhNEk?Xu8 zKOP*kNi9WtR@<_Gqd!t;fTG3QuikTB3#)rB~DL! z7R6Zr6O&B_CJ6*Scrgbg3BgJwP!o&SWkBQEs!fZ^|FmhBQj6B79J}DVi6q0~(n^+# z8^-|lqd8pxpGD%vGhY& zS0pi4(YqeyMNS*uHnfn%%(?1ik!q2?B58u&lj_A;JeCE4J zpczRHCmL;yTsoHs^L{`_yADwSB zTT+QF4=Sph^SWLiO8Z|t;sdURdI}rK+K8&vJlj;za^6qV>&ylo zYfdBEat-Kumc(2;`uHiJFM|b$fjZ3{sz5eQfY|1FT!d8Bm1&j*r)J&gAkQdv9q5Q0 z!yB5Apk7&u} z8sARd8%=`=($JcxlXEkAx*!dwn6cimXUXmRd$~PB-A{QD>98yVneN`<*3O_adOSj# zm+C*DJ4a&G;NUq-fEeyz?%l8PkT3i-n!fV7A|%Ktm-GncsUw?Lhj)lye0Z;;1 zc_j=b7>RsyB7_f|X)KMRwRSj;wvsY_d*{x+$*~teEl6EkTFw&rx%TC`zw^=}nxV&x zPurAcbp8NoK=3JR1Sc3x{YiLNR$~&!x-n}KDe$u##~F=XM753or?3!rr#Q&N4_D24 z*zb$bbb;z%0T(&Z3=3O~FxmaF`-^z1=g-;zDDP4c(juIuhH&y>L6tc0vK`>RKTdGQ zMwIx|A7AI((kewoi(<4|XDcoxo3`94J89)TlykbYEF~fKOvZ^9se8Z8oW1qGyLIWf z606)2kF(b{*eB@iqZBl)5pvgRl05dk(K=doUl~_-RQ^yom;smzkg3D_DY6Xp4%pr{ zl1sMlhV!Va&nhYeC)_Nf0=_uj_e6mWsxAyDNiZ0AY$RZ8gfrHOU9K}%mN=TV%#YRy zFXcGem$sE({o;EmY2WC+lw9WUeyhfWo6!k-#yVAUpgK~B;@cPB8ukFRouyqc9{B&aGQ-ZsER_j2^36zm)U!(n-_-$;pw8M<{OwsuL-*5%UHSWn?R^R zB~_u$_11?uDUl7H?dV@w*muErZs@4xtY7mo-0CN=NdiGg03SKTWLi1xwU&V#&}Han zKeeiNq4ifZ#ha)-YKc7d8M%0YZAG5`i>OF2cwHH;0&9O!l3I34V0-`2*_M-km&Ec8 zDxEoUvbT=roJM*%V@poh=nPUt5R??4a_6mdAGZDX;Al0U{$H1kRw}a8<0&uC7f;b? z4PsshlAk%`8|py+L_l@;`BNivag;l^toEA))PF~-Vj;@hn0w+=|70Ai%J7{U3NC{g z_S|%QSC0hSqQ_31@hybY(4d0^EQ^ApxL^f+l>-fYOopC?+ zYRSva8xK=E8xxrF!Ba8w?dgd2n0cz~fw2gJ7x1NifR7|EXbSgQ3!kzB9xUrQvs^Gh zH|cmuyv${F8knEsIy}7(Kdwj$GK~+%U{Cck0SEHEa4hRyDw^O}bCwbRx*gQlFw84n zK4YYXxEQxV0_e!4G~pEs`ITzNOP})3$Gw^T@?dss?0iCa%Y)n_hUvLCa)<1Nw_`;Q zIyT6htP!t1%FhDQ)AcX%SY2yoH0iU_|R9P5%<2hQ?AJOFN- zN%-vy{e5=+W(`ci6u_vA7uL>D8UU7_x00(XvtI6q9QL_#qum4NnEJQhD3_IZ=QQ=NBg*Ke+ZG z{`Vc|NnP1y>7;E}-{-Jg8)SCV%ClPYG&9RP-2pO(zF?@) z)*L{*u;c+Y-uqj1R1;z)!)#(eIe-b$W?yT@l;%^Ip(Ev<5_KeCN=%9AOG9*yd1P0lWBa7-RFUH(M*FnBgjm)B8Cp)4AuaSPY+x9qIdU zt#9ntn&aEL4LxhEN1vy6OX~lAPLcjNmH$F|Hv!L)*~I)n_|JcSqQFZ)yzIe`Eg<{U zJ^?3LUEO+b@De**16N|BZgIb0uayVUh-kg&o=dR4f59^J!9d_riB02(nnfuQNBt}m zDF}5q7wp6uLnCoWP4~;_5%m)=*RrTWsG=(BFP|+wN896;;^F=RA{5o@FGepPkh#pbXoDH~!AQ zFJGCg(sE2&wS!K;a85`&(n=4O;!$*yMYl?xs<*)1l)Pi`I0gYt?S`hzi5K@y92puK zb-R(&1kM%nWh`hIaud3bn`$*3Sd6J^$DR_Zyc&i~}Z| z!*2pmg>N@^yXNqpDCOu^jlFG3c(S<|#48~W$kz^OA5m?;T>ESWR*f=N_&s_Q0P{TD zaYy)pvJavJI%@=q3Gk$PWW?pE1OGvcXi8@L8fUXsUp5CO)%dxb>YOA7^KRCsUO>`Y zH^$J4y$awiW!)5rpL1^_Z23N~kJa{Lk!Zn;8g|}slv-$EA{`DcdIH%68qvlg>_pH% zO$ZI&A}1z?$J?Y}^I_s{qklhBSZnR&1MD*L`4(x?V zS(EUKUf2m{xZle4>KL~$6-$gAqa+-&bHy*>?`Chd^|XQ`sj{#N7o@2BaNA%G8ZVBB zHWz}hdrls1G-+G8?yBnMFW2`#LD=$()xYYRaE$J7Dg&#Kv6+< zoN_2`!K%b~v)W)`m6@L!{K!4sx|=)C{xS_#viq`h6ZNuTu$8780oZndhPz(Ep&oNCF0%YXSX49(R`M=6jeLk@$OO3Vb&L~ z(z^-OajXYdA#L-!;}wy~4-!E?8&@bbw+rH?Ug>4(p_lZiR@IqDn1jV4XWdPX*FR-x zZsOqz0{-f$bLo%l6HnmUSaE;z-S)~VH!1A?UX7-PTBYplvr5fiqk3<isEXlAaWu^j)qD!Axy9>XcgL0We^(1*J>wb%&@_R_d(rf46I>LJdaobX>t~te2?M$`ZD%Hd^KvTa7H(Q($zpXsPxE_9r>lcURaLK)W zqK=InJ5@M5-M4ROeSvZn)Ksd!@jln{an?^A?vlpO^Mn)s&?$D;^W5lCx#>5*O&jlV zJwCs(svh9Tb`Ee3|NB*qxJG}&TE%bwrYLCn*f6;JaD|E^jQ~L0`do|G%TDWM4osx) zY%+c5Re`aEDlpeOGB>yQ17R`)v+y{WMFq=*CPOzhQ0zHgnA$f;tCM9^yUJIhO~isy zwgXUeJ^-?ADJ)Q8RYSa~#W$nBH+&uO%)4QL{yaCSV&&(G%v@ppY%IHSpkt8X5zcXv zXkrT<$>N&Z{GOP9>i!>=3qie7`Stw}ZuT?xl=^Gl>gJyThFQT?F@DEp_<6@guXwFj zBFCks889yn7e*WKzT;xC)o2liDzj_!HI38j`)nNM{%}gkfN??Pj~fcRKTjwY3YM#O z;XP$^0+m(32QA>wsHMxr-2NfMXQirMzQ@E;DMa@TSI$3_^pzscwwh^!E3-OITyOfU zaDGL`mz1S2j6A9<1gE@&Wf%^Y?(L4^AE~R4y%}&H!7C2#xY>!c0~#$kpn9KN`OXll z+;_n^jC-bdcVv?x?bu7FyDO=X+6U#D%`Wy$WfG+mGXfZw4Ts6tN*>}uB`!PlFt(IK z#cs?$=#KORe8Vfizf$?xF&SxSv>n6EgW`1niGDIEkAp#AKD*U#`jwz84~I+)>Y>Mj zSA#``)rh^~6R+EH~JY{gwEgpXH_yn|F1j7)yHho-BbuoMeX5k1jR{ehHgcBZgmAM&cwc&zE^ z>x_*Tp;u|$kgk0#zKX4YGMoR9RNzn!xjSR*m~ofx;AG4lar5XpWpIQytYeT$ITlkU z2v8bO$IiS!9@sZ-cL-k!+gU)cI<@t6Xk3+&RM;EgyqtNfUFBfo;xUz=+c~HrFh^&o zzt+L}$xoM-G3S}KBbHuqI{3mnNS0yI`+`QtA{e1L=RU{n`c;K{+o6gUfQmx7n=qh8 zVp&K(q+gvkU(zQ}RGThPGlCF}v^SX8H+}EfdZ3tTe|Je?b8M19k%f0IU+)2!cD}F< z;f8JXg;?%fB6eS(3`Ks{942x zC$4A-pI_G%>Cl?LG?}bQ4P7i2Zz#ed4YKLmLqQ1Qd%>O9PnTMOdp5277gooaIxo2# z`vyC;d&3Y%SEjeO$OvBd`Mp|br*g5>P=HOwHau}BtN8F2(ZiO?uD_q+aKw=?p#|iN z1byx8K5*|lk3>)V>v|~2?s!Py#Y-kt2eKNJ@Tko0vY6TS=VSnZz4bh_o!neUEpxpV z_Aar=p4s&Ceyi$Hpfzo)(WUmSi$0;{p|3jB6*u$d_@VK4qyshH?%zr>`8Le{W9yH3 z0(j^aZegY9;oS`PJnP#O%O&+{JLNc-3wK-`kS`THO3?q=EX}dlOmwrp z-mkq0$<^_|{*E9({=1=a@ansp7V|8_){ibZzZBm;QKr^z4DV1Ea!O2J{jt9QS8J+3 z?V*Oj38^ImH28~>Rmau72(gl6$6d#%(3#AKs|FtI6z5rO0v7NQWa|qc;f4M_Vn{g4 zy6qX>K!g_tAAs9#n|Fopfmpv3F$yxsHPrlcBis8;u~l_6%;4td30SsGGDud#ilCU1 zgRhwsbSC!F3(~Pb-1vfSV26()07jme3ES5OwUFz}1P~nn5xW+gG9J$~(tbR#+qy(& zp%#T7L7wg8Zk)njQ`^^;fFI7Vc69{^0=TjOt=)sbPPp>VqWS;9w_W1VcVCL=O9j0&GQ>>d~D?Y}cTp6EEZys2({b@wk5ripca9~G5W0EVM zKhNLLMA8bx;qjJ7Euc&?UA1m!JsWt!!Wg807WPLp0L*U?F;|LkV?h6CH40A6Uv3&n z*0WU8VYKhNWa-d`-#5SF*MLQp+OYff6jTb;^#zFCu0SjcswNGlFyLqr?8PAR3^^(q zw=vB&=mQ1Dgl)PZH92aR_(M{Zdx)_M}R=h|1toIR6puF$_on#69fJdh!xrHiXs$;kU-6VXj+@+ zR7QFb*3)57N5o)xXQo$hc@eXg?$=P=(r8T<_*V{?ZwKYLT1RW@cT2TbI`*Uox_(@Z zo+2M-&Cv44HI=BUPoT6N4f(LOoX>Lbo(+hwfewdamFiUAzIKCW930U29~WWgAaFNj zKoQbry!>Es2J{JV`1f3Y+@%2f1ENeO!WfWxg*x1OUz2=4s9>ceUBq|?e zAT5@Z*)P>$GGKm9yHX4_sfVB$(7yAB=L-%`8+cF4P3JDT-U%b+oF*O&$oZ#*^IC@K zv9Xoi$Z1rw@3sIV_jT?07FwlFcXb1@E~MpTC!&q$ml)~@VO^{QDleg`CqalL`qu^@ zm|Akn8bwD45*A77wcu=56kSx-KyHAn`t8WF{$&R_&e5@XhBmV>w%(&`7lda8#_986 z=0*4uWHeJ)?gJbsT|yq`E6TRFMNeVD^n#FZca@cP7=lgtC8X6*Nvac}sQELR-Ch2-(oN;bmw6`rA7MA}ZY zpU;GcOCSR*l>v580;BCAO8IWRGRzMCpjn+>TXSfn>}rX16WItOM1IeW!f{fYfQ_b+ zfU-1#zl!dUheOxZRTQLgGJp6^E&tUp3_0O2BT48UjeaIGTCm zYfq0C>Bi6A+DWLd1K5(8q+r@CD&yQ)_&_PMwB3 zx{1#Mr~CpGLhXv&bju9n^|m32JlpTbF3Y-eAXfk4N523G1TO;y#f_I)=k z&fdslK&#{2w!SEuwcC5_C!E& z?Iaz`7%@d}Zz>4~#86<(la;LyoQ zJhxU`mmzuh6hAN+F}wnV1mYuwEroeYmC%dtrB)fU}O;XHs}KJ6$s^O=cU)Ddc?Q`QxyHw8wd|-ZSEE zpQe{ZX#K%t>iH2Sa9Vv9z;dSW<6!mvlm9we{0a(qW)`@53;eGjCT!A~kl3ZMzX8RG_wtT?10-o<-B>7Y z@A{G54@sY%?Ko~>G5@A>`*)jjRnz}7spJ@veoQA7x2ZzfDxN1*T2^k?;lm?9r|rw? zJoD1~Do%Idf^FF_Pqaph%+Ee3D%EALR@vDoEa)Qy+2Sr8A>_&t^}_;gJD{w}0YJ}~ zMNukTX5C_!m|+m+7fd@C?;}{*63eJlo$u}3N&hD*NhO2cw)4td&J^GPU@%^3c;r29aHuO(+ zTBF%}zS~Ff5mUPs6BPNV))KrPE%`+&k7Pog6^78tG)#^gpTrX^_LL!)G?W(Lq1?#x zacbNN$V2V2?Pb9$pa8O-y`v}kU3+R;%f>%3hY~(a`D6JEf?h>YWrh_qh5tj|1ovg2 zbJXonZ%AekkpDjE;L*_FSGAh!<@KQNP2HrAe3|@Gcv@YxER^Ew1pwtvPvsS3@x;Pu-9zBZ10v0-6~ya~hS zw|RixGR`-VGrxp{IW0rQ?+DUL>?$J#hEi;?H&>$qu+kT?x5?H{H&mzdvlmbF#SmdK zh>sXh6~ZDiWx+rB+wyG>>=HkArz>Y1#F9;3zc>B;P%lc3q^z3uTLuL)v^QptR&gY{ z@06b{pMXY)GDnIzNWaMnk!+=2(~$3py|r!+*b}O3C(H2_&_4uGY$5 z!u;p{PtJ%wbvrz3pR_v)j7zcH?C1ONj<%nVqCUp5C(gG4y9AH8qeBKEGUEHNno8e7b18# z^;AV?S_!+8!UqvR-;CTeoWIgjmYHQ{;UtK`dy=I4?o45W=HcbSGHzdw@rPnA_kVXH zGLVC7Y=5Cq;J_)XxXV70_m&?`U&P^g;_-W`D0A{~W1_5UfmRCoo;XR%f-d%WEaRF~ z&lanaq)>c;*2}!Le}$@qbaH9Sa`y9=MQk8Z4s0jG+yrnT4DQB7yYOtEL6Q1}FqjU) ziB1Seh=~bMV;UBNh4!{IEDB}nq*Gj|55p45aZv=E0ge#l5=77?FvIXJ2?0TvO*l`_ zpco9#lNX8$!0FRT6c~cyj|rGF_v!W=Q4QcEm=RRrbUNCF;6hhyfSZ@Qh=}$?4|@;! zr?vX8AhB@G-d@#E>8N#NeeX`k@a7rnfWA&Dv!ymG$zh!my^d(`vQ z^W&$N!rzvc(MSeRfcBP(@&qODR&~{WMz7*J?)&AFKrH5W6ekoMfO?f;&f` z7Uw?T0t@|~<(E)n{5KS{#3t1#2Z+h0Kx4A;+7c;D4(Emo3Lq zJ(QiP1#`iUCnDnGoi!yw2!TMGRnrQSVr%`z-01-xuo!n1BuXX3BPxKf_f}&PZ`O-I z*=cnGY1}Mr0#Wu{77VZnHhEGN*4DtEEZaTkKvhx!)THsxjif)~H}U&*Oj$L@ekY(;S6t1~-$ zx|UQiy_eFqZJ{`O2ha+42IE<3=72lQd;oxJxg-h--E_dWEnC&g3AI^4RRczx__T|i zduw=qPD7k40)M4bP@Lc#5XUSLhWUxCt3z_7it^#=Y~1?7efw*1Q&Gmt$L z(DTu&`_5kc?w-!2U^i;aABgFCOu(JN**RJrYpln(mmP4PF!45nDcA0&^~7HAKApQrU=FZ6OzG zqK{j%tuySo@HWMC=VK(_U7)$KBiaIrQl2t#x1N?gc(sw|#;Q5kn=7H))ff7-^}9iF zwW+&Gv|@jt3_;oA1rD^L_d9Qo)!HG)V>Y7&SQgXeGScIKAreaK1@z=Bm;(T(C|(I7 z@e!!S;E+x^;6_!9u#xo~fx&@ZC@Vm(StKgiP`!dos=ILnDJWJB|93NP-mTSGYQpTe z0hl(k5#7y@VqFTnW>WYg^n0UHJq0MYo6ryoAW%VodeWenEUO308tr;TIegv6Pq2l%;f+;`%cGJ)Icr<-AHz+p&!kYVTM!exI>p#3 z`K#n}FMO;Fa-~aL7R~A2xbzFK*J5tb5XGZ--$4zvjH+F3ipiiZpk>vvLxbW3?6J|V zJI9c*=5{9QDX}{?cYP++mGP;UltGl81e|N=$i6b}gH(}2x5a^IIwc8#j4LmzFHMHn zA0JrybWEo;5ut?kQ99V(`J8@^7Bd3OmL=C#^8pA%bV7NbL`dJedmGxD?WL~{DiyDp zZO&?*+$<@)DVG2Ufkgd{I?*?#0utROLHD_u^f;6zJ{KReZIIN4Jw2~yI3a*QW6|cg>pq#J*EFkhTqOjBg)j*?1A0oISHWJ1@i~DH4XS4Q7efQp4 zm)oMKIJMMejXk%f&9|Zb1^({6aA$}}q}aK${htR~96yYli`ZK?W8LjtU{J#f!g)<8 zk%a|^)C%BeFF-?uUqZeu3koorM)}u5GKuD{RD7ZR$U_`E%Q)m;$%^~y*Jp4Xj3C&`ea?QrUPFuDv^})|=9`S}I zcp|%5a>425u7qf}m2iV3qYDRFs`xi9w_JHU8es%hE6c(?p`BZzKoU_gxp4TwXIuaC z1GiK6AT%rqjTU1fHoQuQE)7^%jaLg-qr~*uG1cyfUWNU{>bisuwJ$fo4ATB%A;UO`6JPnU6%xpCBO@{fFY0I} z{nc1<`n|t(Qa=qscNhA1 z=CTs6Q0(^*ni74yWYq1iS-9skw=3}>RlVEk;G5MeHr z+#K_F-G7vDtLqofX4KM5%*~!;4}J8cu-+ppt{d4;=E3(Mg3Ni+`hSR_RtmBJ|JGx= zlwU}3;go0{ULj8W>I^9V2#*H3iPwmJTlTt4cOsqvbtR|Z9pqi5;n>NSg~gsdzf4&- z4HHp;*pwiJ@2qjl`xdkvPbHe|8W1KZK_d4@gz;zGf0?-?WV zpS%zCy+Px61{N5=x_d)5TV0f}O35H)q`UTcTc}9)b50Mm@v)t#a4=VZ=p2Kfi=_pZ z=S6iEhFWncc53zL4JpOdMoI{?vJ?*B7k%??qll5WB`5MV)b~$?2GS%{Fu*CB_dJa`P|~VaSZS&g!;+<4f3hk~y?W`mwIu&t5;!+r~jQ=2SXSNw!Z^jEJM9k6xKmpg|`zwrebfW81CS8h9kxS zHg@NK471-0eHq5 z>L&#igVWC*M*&aizvEEEAjZi+lY%Z3WuB5Of|)Iw*__utOI1~4_&2q&Pp_#ehP+Fy zu{$q#PphFEtx}^s0MZ|%LT;`q2mA&crJlJ&2`&KdqFsQ$EdhN1QrNP!nH#q(l4_5GRJ#_jCO1t3KnFB5{l$vXzraMkrxQGvP#Lh$($fCjW}u`q8TK(9sU z{s9wZU`IkI{k&G+Q)YD{&R|N#0}tEr0+_+4M70y6zn9eKq}v`!Z%)jdIOVO7fJ+8h zc(QKOT+ob6e_I#qg$>y0=^hWVvL-eka;2TkR#8^l^Pj8f{(5Bd%~!%Q+UFV9g(qEOA062kI(%oNSa*E($g}U(X|1891=?bOaEZOuKtAE~5aw z#zuupu&6bxyiv1hLLVasJQI1P{o&k4Q;k<>@NBN$eubB#`G}?3u>xO+viQnqkC6q{0H>O#+pL zAPEa|VNs}`)C)XN{|3}|a>-fo@INLyrU;cig)(eLV)%dVU5kB2fbnTnO>vGv5ggK@ zWuA@2*y0qw-I0I09B%DS)MKRH!s^{x@#Zifr|*O2jBs*6j*5i(XxgjXgySQ^m~ow` zokq-yMhjmnE6cg^2<|AYWh#^7{FM6^bp9yZH6jhVLRLxOY{rQJIt%Wew>hqj^1Tt| zuvn@9?IW*QRLD{9jDTRcEyaL+PELK5~61PDQto`DRENWhRBouI8mLNN6qu4 zb50U*iH=GFD$J-m!~}DMu@A5RVh^nRE2=nNWdvYZw^;ncD5#mSSPrLXQ56Xtbub-k z9E@*upct-ZV|zEk;8X^dnW?^qgkoBD=N827f4O7QAUB*}5n>5dmV`7%DAOb^Dgvl( zr`Ej|JX;34WJvHGErCu{ZW%|pja$1Bj58XW&py;>_yTNQ@!eu+ee^mGCO}zy(-izb z`W=77IH z?(CVbXpn3>p$^$dw{VdfYGmQ;#v!_5AbA4(^PeY<=M|D+sQ?i3TIaX>j%2Qr%PjKi zX>029TnvPLo!dVzqasL4q=T;fE+{;SiZP8}0#$rLcf*fw~ zu)mRrA^`9$tngSNBHB8)K>*)QKG#}&u8#mA0pzNHGx2JK@m&^@1aYv1EP0l`7hkQl%hp8wEHYJEr!C1{M8L{8C?~*dQAX&GEwC6M@ zWWQTs&+ASCD^@|Z-J%_I+(_+QJ$^%u0ik4wX}RGxBmAl%k|c3KFpxT|3p#Lb@c$Su zxIoFg)vneGyXPIr?e>wV$PO4&WH@yTs&HoSF}O7R;A_Xn$X;z9?6;p@)^Ug=KB_{4 zyjHN^^6$9Ab${u2fV(qbRnPQ^lc)p>$m~9qC=rDkO4Dr*LQMGgilQ;!&+jSH!*V!{ zECVOrkh+@zjXwlAFw|n_;#r4i$igw@a2X}nehLg?T|k1}<(^P~A-DDrSCuj5gM}S* zAJgeGJebiOq}4h4y}G{f5Bs=1yx`pIx;()WA)pf0_uw zpVi-lqHCFUrgM-N@@o7%9D{J&^skCOoIFT&KnfGIP2eBvvIR?ifx7zeOW zls*`VY))P64{r-41Bg&~1j3y+q|~0i@M%hpjZ0Aa|%Tsq{^Re7VWZ za|fP3FoIWdBRQs#@H`H~_t>PN*J) zC;IT_Bq$wY)P#t3QKTO%B@P&!9|#E<_<<_&xWr#UMTxJ-0L*j=92K{3wG9>~1a5|4 zvg|;v;#yu3;&$SJ(E-?AiH^kcZQVo>PDcm?F2O=~geQMYVhRykuqB!1zN*+WG1N2s zrP}%wg5R4C{6`CJhxpkbWb}EMx%isrS(pmfeCBIXI^4P93wUs)_a_duMw$8*r>npb zevWV6W@IV-sd1<5VlR2?sm$z}uPB)~*q`P8#Sw&um(&D!etagVG|@X=(!Sx_Eo(JN z=Qz<}O${JdRISyBHs9 zR%XGb+mPRzd;>)HHCDZjNDj|MB{MmUi!z>$4cysn>qQn^q;iGM7y&DGcgtxCU;Ev6 zkR$VvC}k24a|fFbSq^raEeJj0&w|P(AHj@ndpgeG%fW+>>nfB$nmo|_2R1du+#w6x zKNcUg52`6Fo7PRDPk!ymRrH2v41)Jv>+ogCGj{#mmQxB~c-r_|Jpi@l9ouicMc z_bSYRhI2&~a?RZ<_+=SmPCS_Z3Dt|0QqIHQ&7+?5_8u77Z@??7s|DJvZN0ECJq|F@ z>YLaG&7Uw%UJ>vi;H#UUgG~9yTjk28Qu0kGO$uDU4jRjq?X#dH*){bTEGPo?Sm9>R zx!wfB!zz$q?vpn^#J5kCjD`QN>rFFrxw-y1>^{OR)-@v0QsHzyEwS{%KW$j}m9j!c}HwI5Hcz(9G4sY>#`81D!*5Rl+l+^6>;9U{mhKA`W{S{5~L>H5D)*ZxIUa>Kr^wVyWD6GBn( z=_)&u-p5$s7d0+XI@%u^dp?XGHN`T{WzBP8(hT;Ho%*KsmPeY)ho-WFV^yyfz$v2G zdnd6qm%M&fB1as+&D>|*hdwHY?EG2zad@9P@(ivcS-mb5c~@wlCb@iR#p~59gu_Md7-Hd>{;LES3)(NYg<>%hk{#;je{lROM*@c3=FF*Gjq@#e{ zG}S8y|75H;TGlUgE71Qy%Sy0`aXMF5(*ko**lqOMo2LIWeDm!Ru3h%=_W-UV*ek%} zjV}#gtw)$iRO}Ln!+Wu{k-#IeyON8^9l09G3h()=Y_z+wN$=g(_0es5JzIB9t6IMN z6PJ1F@jD-s-nqq>8+WU(mA}8@N-~ndCmm9kt|@EU)o+WZOi9D&KBlBjgY|(T{YSe_ z%=)|)t=YyZ(8ht+D3AqD9ZS35E5a=u!x;!KV<}iW9L-(y1}8=IpN3BT54V{Yvz3ln z{Z<@P8Vm-@-Dt1Ob%%j4X~2hy`xCb7%z(by`=e?X`gY%9VlVWqQQP_>>aQm@Hy`0) zfkU_Sl3U56nPkV;7Es3c%0MzwAa*ZA75z8 zq}$nn1-6Bg9m@{mVEhc7PA9r7<~m;)|BTLBwP)sHW>po{xUFg%U9SS}6H8yhe_Pob__qe!wgE!pWpYAw_4L)@jU;K~W zrCJH-#H zNxGW*TMYQ7N)cn>PZdzacC2#!INN=`?>PJg)gcrJJcHJHDc>OiK zee~}K@4mHcdimk}*2hQEFp!$Y#mTv4<6{;Zn=OoS+P!1c?qaMdbLwI@?uDq(`p8=E zn)2O~Q~lVDIc-g6mZl%*!skZ>FzXzZs$ZuYgq=rt&ExFC zdt$zMl>1fpWw z7C*}IHZPH}X-$!cgZ_ws?2+|vG>$T@&($_?f&#!uE>kFGL=+I z^yd#QBDKUgqDR;|Hu={*U!y~D zix0kEkBebRCTRYmc@O(9JBX{>Ia_)pAOgb%ye?Qvg@PTI&Ohg?>;7zuAYr7uGNO5) zy>G7`W?Vq5JRg&Z^uYxrFh$DSyTpA3)RDn87}D(z0?uL=VsJN7WlyZp?1G9b?b8!; z5ralDuhsO4d%W{@m$H}sbDo}23~NxLDeK00JYAOZZ&?U$%Ko|ZC@FEw8G9`vSSxX| z>D=YTjmkzMl(Lzeuf)HiZ7wUIY+K^v+sasTpQ}Dqkx!DS6!1ENyxq66xPYI8?ae?} z9TE+rv4&8pCSnDb+W%6)gCyhB|65O>e)H;3K9e!~KkK2BYr6r{qjIQJ)1&>J-!($_ z*gX@oc-FFtWHsiSb1UAl2N^ql%VM)^+-?+DbKsOjYgsBFOj6a*D}00GvH;0HsRwsT zr?tW7B@VaoK7V<5qT{0(NR-1Nr6$0Bu2rzz@Q1*$R?P9Y1l0CMwU$0NH@Vm}p?L@x zqE{7gdUQOQ-rQoKX7U_#(YOyE&ddJbc{AIgt(d(-YL*UKJL05SG zGj-%+^y69e25<^vCN*%WR=~og1zspKI4+0oYt|a+YI!dIcsM0Zg0U%n9!x`~RWXZ# zUA>Wrr7=UTV>3(*)+}mmaM$!WoJ&<-^V0zKT_}L6Dp0LL^=x7HHC(I!7z@XOEQ+2D zPo#M^^{Q=(P)NcRYWZ_L;yT$rZvU)6-k^`m@Y+-EbxWQbdp9a&2_&A%3RnE9;=01!Mvn8>ecKd-z zv-j&J-x!K6+)#317DHusPnp>&lVf+o`U)E$D80h3`tvnE&IBRAz#CxlMghhf6o((M zr$2#z=tt$2jKI<>^%Csa35D#BJNJ zjHqajF!qDt#}}6uDl>Dh@I3yc=)%viTOSJc#T;dCycz5<)UNyIqPR zs9Fl_WE$~WxCDuE6GBijG>KygrV!U!vXs}qFa|=`FjmJobFw0rVk&g%V5Pd0+n^)j zD;e=#y1u-Vu(b1;Zu}rGQs+Kc5rV)HZ;m+KipN@2y{zrV-0}OT@DQyMX|g#*u_8kO zUqS!=-c5FozwoMsD^$P4*30)x*SMBWHSZ;_~h}8Y(L#j4V=?DD5YklBR@!1ud)2$udlXJ!A9a$%m9`hhEQKsXf){M(zJRk3?&eQ;J5q zIaa9^AmtHW9Xny%_xgr(O1t|OHYl&t&uq0Wo?vtge^Oa3LjM+O32)rXM@244l3Ql3 z`EU)uff*3HUPmkPdCN^96MTBips29$e4NVcQ9|q>1sxdwRy5%4plW>7HR0Ex!&8Zl z3&(f;Y4Es{+<7v3^zH1GMH8=d_pjAmLf_hcYcDA_s4M3QFX6>u#QjyAW^Pd}iNZ+3 zIixlpdTB_0v_NsX@X&APkuCSrLmg%l^Sp;Y3Cy>qqg2py87a~u?sm_HJL5{!%z#bk z#en_Ej6%eNo!C#uK39E37htCjq&ere=&aqD5qi`{QoNS?ZguBi*_#iz(u-$iUQ*TL zqNsI2&;i(oW_fe!0FE&9pM5w#*J~Af-s)^F1#K|Tn9e`zTAP(_q+C9W?skNkQhTI< z#|3_*Z9M$WbB7ANqbke8+9?1nBdirdObRF_LVvvM;u9P{%iM`HcqpvYG(*^tM@(Fx&(ON%UCG_ZUF0|v=pTtQ z!+XFReL)|t+xxA1=DOmRB9fvFh`$6Iqsz7oh5!*bh$;bv(|V*qyvr+K^)p_@E9#7g zey307a|2@V@H)mf!cXJeVlQTC7QuF&j_4r66lB{XkULB{`oeKe0*)Ql9EMf3Sd_np zp}O9P1c6P*s!_socHwgPnoO3@-@?L`j$JuO_3!jp0)Nj7rHuY1T(ZPITxdt56O1$V zjF#9BEfHKlYhjj=u3Vr)2r7JW^%2+ZEQ0#@?#dzDV~;IC-ci}bIvol4n>hp+^uNqx zKK_wZT^t$ngRmjTN>!4j$Jtwjhg4+(Aro=RFuZKo24!0q0w9I8hw=;=KRFr#umZgA zoDqdB@zh-6RrGQ+P&9krR5#yyI4UWTPDr6I+UGHu1E12{klNR}{C4Hq>B;;tqA+_I z(m)9GP2#n_*pc`swFrN4fewGSq3WR7@tTs#?sb8go8RoQ8(V=8Qc=cYVH3i|?qNePhYoFk2Z1LB7n5b*mxTFv0T*TcP@ z5@!%)-?Oy)I{a^%#2sb9Hlkb=hh&F^jrJxrFJ|#u!^yk}NSSM79*WCP6f7$CUzwq$ zH~UmJ_(=j@KCJq8Ue3Qjky%Q^@1{0NV;VD}+_Dco&;_$G{s#$(IyE?@dH9_Xno1Ha zOl7}6i!)+pB+B*e&$3D)s!Vf(U z4>cJY(OSRWEoow9R(yw6pYPY402Bkh6=T!y@GXTB@@q5a=m^h+D3qEI`aJKfXl0mj zfsB>v=3_xWJ<|#hMTgb*T)f-sIkss}4X|xB8D3kYQ|6-mD`9*5nWMi))~#ZU-cO%M zmiZ={xMsny>UdljA6AjaDQ6oxPOKNzLz6E{FuppX&$woPoU|k(>+8{ZGtSQ>Ka=>B z(*_>lzFRhYJE^ac;zsqDgmzowkqQ9Shteh~Ro(DequzUKp#@SZZ_VuNG(~OWC*?el z?aM#kd3;%;)DE!;r`^4B^kV_@W=Un-+{SgNB-O(QRlasAPJ2cZ{kD^}@ddCV>Oue6 z*iYyD?|E=Po`8tQFQoc5o1^ttO3aFMG(mrpML!jXgMYs8Zo}eRnoT9sMFGDy{BObA z5=VSUfOci?%DWSu$}ZC5c^7UItmcgb@v#vgGVOIsrwGNfoWshos*0%}10PTW)^iVFr)&d@HFq>(}*-cX$N4X;QqXt*Xo_3_CNdpl3;Q zJ3E|%DLHGvFY)yz=Z|VuWUxA|Oe3<8m%U+8ve@1h08W}e5y$DXD-izhmRfaE%NIwPrB@+bSX zeArb+v6AIU8wL#vwwO(~_!~8gx=KY<;`)0b^A0Ex6cx#jdp{gk@3*bp=kQ45>BnV$ z{cqCk8j~h#p<@5be#y^=`66Zl1OHBl-~R^LRD{zh zXFlrd*?au7iGaB*#CYSrPjUmn<7RzS15EjOm&laQlL@VVf*)Vf(4WPy?vm68M zs-|&phMkoNp(P>Py+FcJ*RhqzXZY#=MTta9c_F?%Gle>uQI**`3J2p*!;DSKof1hU zs`x_pj^`WHN|P!fLJA0DHT2E8{Zxv##Ib`fd<`Gft#~Dc152S`Hm~7v!})gu>L}i8 ziiO*MR~7Qp;f0MVWYMD2kns(Rp)$!C$EX2K|7+RWt9FUK-}D{srCK*3H}j!UF0iU3 z1hIfwI6H9@e;t2_ZKR=NeBszwJRzvi?{uqSahA5RJK^sN_A8b)dVXp!$BnX;u*<7^ zw;>G<+TNN37pSZ5jEVrCT{f}XG`pwQDsqkbz1FjVMeT`~Mc*`9{|j21T5NOUQitu3 z?=e5R$*>zK@z)b({fSw-lG|I}r&m0;I8p?!;lVg2;szhK=K@w@Uf=wBY;ua=haHq* z=Y0P_+1H|@`^PuN#ra>1dw4(D9yPu`ef03;Z0XyYkBfUBebtwLInHkId6bpYt)nsU z@LsgB@F!6s*^%~hX80Dj(#e_9_t<$lYkXJ4C8@;$^g6;tiB0Yao9_9k|JJP@jN{!p z?BD%yWrJD=QkQ1YApzIo32@fQ|Ck4Uz?J)R)8`bwgp-D&E9t{AN%+aWqdv^FlWeCL z-^tzDnaO*0k(0n;X7;o60>e1VCGeM^;%8Ia=Z;;kc=R=1m*;M5lEg{s{L^s8w9oI2 zqP#kj*}X^Xhjx**y{017oD%Q6Ze&@+-QhF;*3efgkgR%k``ueV;jakj;QcAR)Y-%{ z@OH?v-He+5Hr7Z#{u$HXu%q+z6~e~j@dr_rSN5FiADpsajb^IdAIqwRK7wOARFYKL z!#@&ziZXkvD^%+j^>d#W?%Ka};=-x^ch!IY)Np+~a$QN)`D;6MviQwv?3tD)xV(oJ z1A>eNUQqUexBao2)kqQ!$pL{N4@6t0wwiF7WifXy3?&-ElTG>V3+ap-8#P0= zj0q)S@i zgb2CP5caOOjNV>Xj@Ud9W>rW_hUJ85JF5!=xOm5m<;PPtuYmFM8Ap6_)#eYJxrbA$ zi8|%3jdg-JG*BwPdi&5wazx~wgjDqy%^G#d%+pQFG5fJWYgT)mDQ$mV`be2}$4);8 z(!SI0cZ77zX<_f1XIJh^oAc&RDt+Ieub_HlrUwYnJ?irY=LZajp&ziT`EDzc2((}^ z9ctK%SF0lax$|~Y@$GEFsA|AZN|>_Jz;DQkvR7q!gi+5C8oHM#8v_KH!DY^ zH9uj#DLkxO!%qC_X9lh`pKs>;Z4n-Wi^LuK_zs^)OH}r{H-CnG*1}X}`7SfXmsh;S zoPqqsO#63WL++`x!inllx@%m<78^~bqRG2nYVQef*b|_#+JyX+n0Np6FRN#}iceqE z$Z)#@vi=2Aaf$ssKZzfbt2dRiM4T{M6o0$=_dte+8al+tNY%$jwXBSUR}EJ+iVP!# zg{W5HeZs0kLLwuZ!otn*ZJY3MEpZ`XktEfYs?(M}0s-Efc`i800uvR*3=WG)W+x}> z&FWd|v14K^lW*zWlHR>;d2{x<-b~EY)YX}}*=KW>%QqIDKY2Q{i4!)`>yy|Q(sVTW zWMtcPP29Kayb$k*W^$s?!%veIf6OR3)rE66{y~#jF!OpDZ_u-zPC1_aTJUnI%um%! z*Kbi)P)H*6;c^dC;oSf?CPZ%%AJ;`P~Lmcf`UGmmRjR0OKxo9Ua5-RTw^ z&#N=b&a*_aS@N}>mUUM?*>w!^WJ_xO(4k^PX%jCBA@Yd58$Rqy$}Q z%)2YzqfvS5w~}mc=B%lPtrdgo(a5a_O0ZM=?67oZH~VpgesXHHU{#ZR6|dYthqw2M ze&E-d>5nD&RS@pIz~Xbc05&Rco(Ya*2`R=QqK>PH)909V)h*p$!W4hv$L<6q0zc=J zgV;J(P{!#oM26nRPbC1uB1d&9oUE_cs|?GcCQR^rf1*tgJTETIzo$R zkLNQAD~k`a{mmIe_sw~6!yNC~akTEe7x>bpQ+pa)5_`T^HOF6t#V$Lc>k}&K983WY z1p5O?>-J6hZTrK^9W_v1L%-dTI@T_&SkrMugun-vaY#hlA9#AtF?A2nP+MfK9F~QM zF0}NvgDm{c)!w$OyKmul$}#3ZOP}e9aLjBCXT<_GjKtdyG1P*-yzaXNSZ}^YS;%rq zn^M|L3W{0{d+D6;S^wYIU7Z(Nry_JZ#u zOhijelEz9L9uDTxTT~5rGM3-hdMtih!S;-pkjQZFbI;A=NGC1h9=L|{h_AO8gx;$T z{xJ(O(IA$6_t;BexI<&ot3@WieUW8A ziBQ28Rq&ApBdHU9!%mBn&(mtAUz4BY{$LS)X6fAo4QBr4fSfX_veM$S3wfVz1`sOL?->dK16C!$DP}(DJYN`$R-!(6hD(prSNwWi>GZS7 zcNf2i#G)z`6R>Hl=>)cy+{%#cHyEI00>cKx}= zLjLN&J|!h(>~O#1bAF~=@Ha&XcAh_>`Ml%GQawMbmI_Ie$&;MvEvh7ZN_BZnUN}=z8C1}cb7a5 z-Tf4qruqEwWTy}`kfMmbCnhPhnx~#Wi^AK>=%$AXTcQsY5!A{9vp*VWMNHmc9^s55 z(A<(5PH#ZlvXbSl^3K+>U;1*zmPht*I(JhlpCaKr1H7a#5V@Pt- z-dQtvLIbany_nHk-kS4zzQbA+s@?qejMr)?UuMOz20~pM()eyeX1jri`5?zPBG<#{N_qdAh`%%rpJ<<6H}?Mh z$Y_B{b-h`emh%^^ytK_zh$S1D34>QMboWo58u~hhUMpP@q=#Y~lq*v|yD|!ZUP^gD ze#ct6G!qIPWll&*4bc|Ex>Tl4iR8@<)S|YCS}IM8^ZdyDqqoi#zRI z>6v>|w$AD2jLWm=pupkB_HB>i8~0G4OVn{#6DLsSQJ%1*eBSlHubN$CTsR)0<)aCj zQO+NvI^WAGex9RQwhw9?OXPoPTm9!CGRO?NCCXSfTM4DKCq>n%%gm7(X&!g9snRU=HH{-pB+6GdkdMm$8ofIwhhlfGZhP97*(BCG+IRt>=Pv=MJSa#4*t7Z8TwuKq zqI49UM<-oa#Ez_*=xmwF8mo)095Q@DWHjImz>ttt3EN~I_7G_6)=)5Dj!#<+dXFs6ZW8W<=*YS|%hLeNfX z&16u~gSjK{Ul-^Q#&*a3PB$r_o_NLn&-cI75*1YjI8dCaA1e* z5U6j}bcHdMnc1pzwL^G=X};h(Zv8P|+t{f9pK&a0(Xjr9VV&H$uFl9YetQ6(YJW9( zd?nBxhZv6x?!GIG5GSW_bc~}h?jdmC1Voh9L;xT*T5lnQTNn*<`E)Hi&_Ybw;<2x(6B!|| ztT)~Gy?eKnANKwPq$@|*@?nY?biH4qA}!I9BPamm#zqYMM3@TKzkUU1)ArjgVIS2| z#X$HUL>kTmJC!S#mN~w=ho8aWCVF))lFH0i$dfhYzs1B;fcL{9s!QmWKbihQS+IE+ z>9-xE%jXtk1;464+>@<`lLGD(=)mj4?y@GL5RCbhaTj0d(~Gz;))dwYr2x9Z0(id? zNTeXErww$T{WWY{s|XqE%MrI$m%;8=&=DUfNQyjq4k2yo7%(q2Yyc$;7n}H~OP$_M zwmR!OVjI6XpU$utVdLPAxVk8dP60M=95XZ?kSq_R)?teH36t~KemVB^J&Ph)nzE@5 zeovYsIb3a07}^>9=6UyPbI4G9L=i7E5%$FNL3m74AP0^Kt#L(wkp;++-UGoN&4HgX zBKXIq_iQY8ipPtP863n0F$noWUDHTXK4>j(R+a;9V!*w;W1t*%b^#O;^+Yo9_dSb7 z3UNnK8n{xn-7hDR5w+`z-#$Boeg?5(f^?=v)0(M^^`tHi$6BOdMV~M{>XvdY@jeT! z|20(5y5$wMfxF(o@e!06zu-98i-53PR``_$Hernrwq?j^b`333TRbL)KYnFjjuH0 z?3kUpxDq7Gd4$xUA@ltqvb4l?I@7^#73sx5ZeY~0 zXahO^r^&ch6afBw1k1lMfM~OX{z1XeJgB7v#+4Vrh_1D`5Io|-#=-iouRNnZ+?H-2 zs54Xf(976=X7Mu}#A-3Alt(BPW1|`gR%b}Myl~~!dp<#Z!8l~iJ9B6~<$Rahc=$HR z`5NTbdj6R0VI~EY@c%41Dpd{?X&+^2j-1Us<>l6-D>)F>i&5r*r+?O&((?Da<_EFC z4M5ypDF53l7Nk)^aT3IdJw^e8=rgnUKLy$kqBaz#YX0EDFC5km_&eRW z>SWJ!>iuDOjBU#pA$>g#+mvmvP~UQ^lyp{V`$Y#znPTLmA5ret<32)Q`Qr|5!&BR! zsQey9G?l|Yeyaxa9%PgztPu)4O2Sit= zHPZVF0((9M&S2zlS=Ef13^DNl!qaB!+Gf~tNKFP_=&gz91b(>a8AVkp42n%FCHOfc zN(>H|BlKmE``L^3;ud!dlWLPUY2MjVFkbwwW}s;^-;?W`HmoNWg(z zsvd;$M+Um~wAlYfU{hPVeW1Ry;|{d^>DKjMLOX32K$?d@%b6%{S4K4N-?GZwV9AcN zeq@|XgSPG;PlU6AlY67#&3eO;7Pka} zJ#VL>gj44q%2Z(X(*!A0^$6U(b~a52m^7mV^V6U9jfcNMU}Zf74Cu?Q6kWAD%i&Ib z0^QFJYydjQZ}Q$+Oo}g#2GUBCWSJ&f1$8E8ogl4K6jyTq`r%S+8)|!8Ow{(J1P$wC zeK2+T1oU_|Au1RwIB>Quq{E+`ZY@z&*epY`iEvqxmu;?+^#A|oFwq&%QospIqC z7oo8h4sd#X`KZ3)IGsng0HQ;4w2xADRf-(~6F>t1W%ANYOr=o=FXb67nk$~Dy6xM- zF{tBvf0y03us9Z2qii9%uvsqMEDyL$C9fOaLzy1hG3BZ&yW3USvtIb7ai9ojN0Dd~ zcsXD}LBTvib)dp^pXfY-QkK-b`cQLn{qtG9@prEe%k+xZn4XHnLr5;y{qQ`B-4R5& zmNN%^cvIJ5+R?og_-SEx*24(jMBvbZ=i|A)Vp2tKoMmTBoBhrJP*}TAy|Ld&(+pz+ zB_CgZ=BdUDYZ|bI1_W&YLN|Ox@IV9wBv4krM*h_jwUWUqyZa~}v^n`E27Aw`^-V!E zkVbilFU#ZtDtFqu(%WaYC|oU?0!c)eA6dd*KJq?#sQ8x z76XDe{1<-tYs{{%vzxv~SAQk&T9PCH0{ERI0hM#fIn7)pV3_8%g1>cS9sg;nY~;dk zb5#k1utAZF&VPRb5*gqVcf|4a2%9Hw!rvTr+P+HKwYt1P;h@z?IS2?nslnY7Mc?hZ zK>cyLh6~)@a4~c2$a=nTk+eGKHTZ(DNNZqrgoj2X7j$>A;SA$D<>kVZn-Qo}o)BuOF8jwX*m=?3yv=XVf0 zoaZZE^%@1E{P|*pvV#<05cKT_$1z%p4?Cm?|)i%777q+A}zAk9x z`gRt!nay;2qAVs0VJt09BUQz^0|23rz;TRKll3+@X0U4YelWjPoj+rxF)dimr6PqI zHoUmR4*T8@Od^PUN0_+QJ79INuirNFMyOm=F*Z;~3WrvLCYv5=PyUSlUWjs!D=j0iqIrhF+F1)Ly-OfR!1I$NmciMNM z^n3qCWNCfT@oRhGb=wsD->=t%30ID+;z(Fv#|g5kS(9nOvr|i(N!)nVK?LlpA3;jl zv2qW%K@;0v*S%=9a9KE(rp8zR?j{X3B`wx=F+ zm-HtKZ0hbPN}0IHL1{A%cucC;$r-2aEvyDB7kG|%oM?3!d6_bSG`NTye;*;G)dfDB zW&IBZr;*jIkpA#1DnfH@AsH5*r?8U?ybVkCAWvIMckUP$tDX@hYtR*JN|w8ceAXDGUc@WTMS;Yq-luNSykZqGaMZu|cmsnWVa0GW_9IQy2V@|P z!QC>t09uSvj)Yx@ij?!i4ZaYWEE=?N(R}uu`tn@F0HGB6Vc=&fg=lwpr6cKlD8}zv z^iX(#x5_w@C25*&D@?bv_{YVBd5U_m4w8=vh`tMgu55*AjV6%H_$7%w{5E${qsA&q zR!oWAf%45IoSl3)X>z12*6sm=Fc%Kuav4hO-Urz8G*nQxNTqawsS(MzkL(t}`Q(Xz zRY!f_l8meAso_q#vU~Kn`xdQn1XP4Q4WRKb7inZD6okpGQBZG( zFPZO2Mf1_dO$_U+>_>zVM(J?>sT~lO>UsO+R7LWntVzgNW zUiZoaPi0K6LwcH`l`h7;J(wwRa?_eQA^X_!g2z`=1)cm0jKiR_VK zV$e0P8SeoeY3NcVQS|QwUO~*Ei&aVYF~OR6rEm#^#xWq>86fy5OXo=Q41Ht~K+j~E zAmrQ=Ke;SZ4!_s`7_;@y8;y70zDqQ}m{*U!4U;^2S=_xATW9oOLdotPy)s0k(sC`# z(mIj}oJc4tcBJD%F3dF@W#;6mNOH_kwxh1Ok*GZusMdV<` z%}y$*Fqd9*ER;823HHJbefX(V9zXVxqq#9oaPVvgqCQ=Mh=0U@0Wk=)ai8f>eqvO3 zg3*IBH%G#IdDDFtpYk(x{}l!+mksij6w1m5iyW=LK4c!Zrl2=xHWI8S^($prxmL_I z75(7|D|;oR1{>@;%jP>xOy;aT!9)!x&ONvwd2JJ@iEAn#tz)2Z)uL>17hf|8PU{~aWZXcPu{q%d?w{KTMJ!cc=9HU6^B&*!xEr}y4!GV1LxkyK5k$`ba8i?Q z8IsnqwQ4Jvn{;4*0F|Qs8l4kj6+?go8H=4el`z28LLooaL5lxT9OMtWLj1guhn`TL~+*iaeB-qI|{J zm@5#>v$A08AM-}gS%^<{&RSvwOPHrKh&NDNFC#-197cEC^)Q)Ctu|aGRr2VdEzIO8 z4~mfabv7yz;3*zb5!xJZw%I@_d4GR%`}d41<9VgIMB{nn`x)yXxiK|9Op)DV?_Ph` z+gg_|@aF|wk0?9mxnVN@dio7+yIh9aA=0#>l?Rifo%+wTU_ZGzYA+&rE zE?4u{Yx)ou!-!I$8XHNIu8Wlk7kc(~^zKbvm8x9&Y~VKTraKFyPi9?U8WVBIk4nHt zR@7M`WGUVlEUV2yf%@W&{yZ}@MKMbvza(yRi>INarUpC`hv&o*z*|H2q$)5-#ndAq zE4l?6UGzgbJSrz#p5fIKLV*9#_5bwhSp&i=i~ACmOK-)uI!HGYIC~Z_kg51kpjgi+ zgus2+s4F(a(N%fjo39XqEqL`G!;y{>pp}EPN^PR~dix3OPC^>i3}B7K?V?!oIU{qa zVLQ{;L|Zi`moMn(Ai83-d}|25|D*Mec$c$D6;xi z&FQ*j*HDJJIz*`I&;Om=yEoClL%?kMSLgNarU+Dtwr6(sP;nVGBRV&)^8cR zW&z&khW7hNV>-eG_HxJdK>6iMxE{o31dWTpMk8ZI?zA77=Sq#rGBgpgqgAhuS}j;U zWo|ZPIEJ(KYzjpsON&l$>lA^6jtFw@8Hl2|J4}ql$cez{fjF$TD0o6hS&E$Ed|3WSRr6E2#>FUZz>fe2+7?jm4BFMQ z?Mf-~r?Hs|&VWRVNia!aB5NKU_%;SU9S2n!u_F@9Us3cbas6?wOK5YOIkyjF5bgOy z6<({3Q#;e5{^7ZkjZy8X-?~c2Os)@tfixX9vesSUDg!%qbZ3Ry1B%OTt`7n#0OHmh zJjp!8P@-}q2D6eH4IJ=jn}x4DpWVGV4F*!C!F^e#mQqZN1a0L9=4}J*D zF~IG{bC5Ses<)nK9DTGonOV&|hyV6NS3_3uQfPS&kEBU}Kto7NRJzB+GKr4E$^)Hl12g$yL#lg+Bk#`>6fqoo3*qZ7=yw?eR#JfZfLX~XPX^|Oa z1gkj(S{d=NGJ9JA%*z{8a721t6h7rmjR7x^Vlm?sG?(=7k!T&>2$U> ztQn5_$RhnaZI;Yy*}fM97|^m4w`!ST0iw(RNSQ6(z^;F@7n)hAcBT{Fe%g@8Hz)DT z;(&%0sG-`nPumMjLL*)A&=$XZ=aBq3tpdwylE=r|8?Oy99_1-v%U?aqe?i!oB;QN} z5H^O65nkZE!$=PabSnlKDnu5UA3OIQVfxwNzyA!xf-Fg^s&h}!!Z;~XhDns9uIq=D zAdJ^wra>m`ibJ4;SbztrPFkDc5Oy8DXY!mz^P!D%05FT(6+*ZicwL8q>itX$dWZ>Q zkbU?bJ|Z&{5~V%D$Vj+~v@;@57on3g$hT$$9iSan>2{zX9>3hzA9HSW?xcEC`wpUG z!{By(+=LecrFmWFISuR{hy8@eP;K#7(KzySBHdeCl={)U%fl zT@HkdUUgSEql$RQU<|z?0T$yZq&l?m7leTvbOooaW$pGI1rJJw?wOaoxX$-@#DAZi zQukjM<#?WW-S%3KwImU=sY0-UJM%33-WKdpFU2mJjtG?_>Z~d>a99Jm#u~Bm?!oTj zc$EvQ65P~q{@@_2ToIM?2wZm&eihFmNuW4@>^%eGX_xE^^bFX9`vrX}Y}kNr%wm)| zFr3yb-nsd+A&9-rqY2#FGxnB1524*@dVUu1$$6h^U+fCeoZqLxUwHjrBXwN2f7|q@ zv1y}Cd$z$gmaWq_@q`Ja>hlV%kY~tG34l|B&ZFnTkA8?k`otCs*!8wREhoKq1=#e> z?H)x%3%ZipcS=P9UI<+$V*nf(kSK!Pen)C$!8Y>*D;fCBc#5}_ttN#tPi#;UU7~VH zJ1#mOiEC^wg>}T;|7baxbX+}XxmeM3UGIy&5YeUf>}pzpUoR~hFF9(4zrL!?$-kL* zx8VZ*lQW@r2f&O$L|73v-?*D>dqVeBvUxb`PIGC~&1?r9*_L=_cLTUwqir3|?`;M|R`|4V@DqQJ_isN6I?`Q#yL#(Os?- zWyE~=AJHa82O74ZsYDym+j-{l%YzgAf@K<1W|Hve_#F^z9sS*t??DF?&|WfbR$Ye0-@%^bTb&-u8B;ym;jP{_DY)(nv%-UUC-F zXG(|W4jGBT8k%`HAIg-(N$k;FC3=7b@5nLg0Rh7sFpck-#4meah+LtdAACTIwal%8 zvdf0HFS*bP;M(Cxa3Wf?Wl17c=fCswcFW7WaA1kHUWZVXp43_6H>R9qqCJy;KGa4x$#xe#7hTrfETd1wUF3 zId3iauZ7^`&$^|9m)XGYZ{s7_pzWr+>v>@L_`jlPlphnlFctIsi?^-nY=`QViDW3N z!;a)__W|x`G~2`^UNl&ShJTXi&-N_!Lm%_OTa`EvUjhyHcbcPfc3(y5A*`+pS67=7 zf@kGIz;jWhnN6KdRB@?|J;R2;Xk!p+c6rh&Yk(RS5^yBIF~T_npPIQS(=ufKEIt!& zlAbV$?M-ox*K4E`A zOk5)9blZ3nXQvdWjI1-6Jsql>#je1u;C3nBz@E5>Z>&~bg|I}PvoRpeHP}G$%$Pb*Q%;8V4Ddv!LsOQ=om$yjGG7=pl3qFwcf-A4(Lv^zGqgM{o{VCW`K? zX(nggyxU=I9?Ufzogt}WV~B^O>|m^LKc-GK#vvU!MQfAXNQ^!&!`Uj@xDgIrJ@E(- zt`B^TB8+u%GTw$COyoOB+T=Fo%xkjBu6=tfJVIvyR zLX0R$g(fWmWF>|spXXnTf){DFT40yRUsmp*#p$Sst9kB_9zw5tww(tz2+>q?k^t?s zehPpcY@}B9ih{p|6y}IJh@IpXBOuebZV#9Tv4dzzRG~zJu`E;zRB@HUrWC(R)K~;?5+MP(w2J=mn$y zt4PK^)XHA?EaCElh!N)~yDuaB>r3}6+vBEaapUw3U(v*a10cg#RpMl+D@Fwe2N&@X z2FcBl#7HyOd&rnrx~=_$cnBkL;~(j0*tPnA`1PYM&XPCDDHABd&^RK0jY8 zyou>}RED0y+G?pWi%QGE`T-p{;t)mb9P5EeCKU8v5Yxv>R8 zXa2MiPU`k(*CN#%zAn%R-~wm~{i# z=-Jq7#+jGtgD_yskHOI2C5#(khWJqM>ZwN~B9do1K=J=+vMD%9%NL>tLfR=yVrw*% zF6)B1*lp9af8AkB5f_LpDFif}T{S6aVAnb+3V9+wRN@df&~?M+w^cEFb{@(E-u*t; zBav+*9ruAuo}`1%T|#~lH&@M+$^S!TON9v=Sg@J6n&5u{Hkr54$iTv4Gvbp_s8kAD z_NyTCYyr}y^l@+v_X|fU3l*$OgAV556E0 z1C50j|jzh4&Mep|C6*{m>X$|6#G2nW@j5 z9r8}qX)uN|+@x4QJnB{qqFIoTE5mKR5WA&65A!m507S?NRE>m?GJ^_RSgvT41~;-s z!dP2~_IMQ&+7{Hp3LKWzryg2V`7P<+J%{Xw!9f0^N=+ws3%aEuw(vc8bKBA8M&hr$ zZNln?ouR^cy$4bQ@2njcMV(3^F zEYzUVp4iEm&U~zqE(NqC)-KcNPUn5H;_=>iws$WAPq z@Jqw^^(cZaJVzPv1in1Y3WQswa6E2EX3PR6*6k}Q=6wbo)BfEZ-s4D7i6w-<=-ssA z;*A~7zXRTNcg5yXD?`2r6P=;Y4iI2(!A&CXn=H!a zGN*xL5PEma^I|j#zNs2)iI%~boU-8q}zTl7tK=)V5@3za>HQFKG?Lt)O2$OAk z3c*&WR@7_m93S|9K1$euuzwdCuL;>*wAsD!LfLj|IG2}X)q5Wg$N^WT?2pHR9n0OG zqxS*pj(>!be)eo!sd1MvY^>$Dp7{>X(#)-RyAXNOx87hQ>4!--$Fo+_>QLT?jEZlV zu7iKl%?w3?W4$T`+bRI^IHw@SNq)pt0N?c+uTWs?W2_|Y;z4NLoo84XS|12D^B^uCIx+!NccPZ?2^MP0T_1tp=1|#0 z43Gs>PFUYrI*R!FRM>^LlXT4ea6*JYEK?%k)1cLON<(^P}{{lwJpHW@Ofi5++j zlck=sTqtmMClw$#4Wg1*FrE)u$WlV|nsYwL?6BsA@@-}jl1(*P3O*r%qju;e%5_3M z6d9AoxsI|rT*>i<>#WTW1*NrW$OD@-}-dTKkb~BFNLh ziPEAa(s}|Ph&a5Cc`oP9>oiAz>p_Gr_L56wOjjc6t0sg+++j0o+8n*~fw6l9)9JU5 z)Ps=YJ-KWPnY8*oB?i4@Glv>_Xyx8|)Yk5m)42}Knh?MiY3cST)8LGRJe)TYA|)Y- zNCpSD>tBawuhyfPM(CG@5oZIB4?skTXrbKLvJ@8ZC3y9k2o3CPPjFVDSy^ji)VTiB zCJ%Ku0RWS9aA-noM+uA;m*}sU`=?-ivDv)^!O-A&SOSUw@InT5O}__EhBnZEo?^q* z$?(wBdV4M!7ZwcQEbFw~xKg*(V|x}USJ=3D1nBScTug&IW;zY_P21?K@ZXz@ zYEh1%m=$XNO*_z8h6$F5`(@s;T*S2$`Aca+^s^SL(2#On=w?&>Jv!6}3O4|k0GJ4E z5uzzEl-MD27SB)N4yc#Yq9JN%sGBx!Ai-(345wBc_=R?~?#0>&EMh7ttM9{3Ov_j) z`jaQ>N-@QwxIBOawo&E@`f{%zC%gVz_DVNp^|c_K8#W3!u)5Bvol9TSPtV9+aD>Vj zf}J;PQ~sm1i2!V9d8UrG?fXC|S%v1R2)g=3NfMhtrTmuE87L4o#{JG%f zn|ii~VfZ&gk^bnE<>coq-7O+bVNieuJp8<27^Lx}7~>$P$(J4Cxx@n!()-~Zc<+#^ zkDT1i4$lgfSZkxM6z_U1cQE9~?DLEILITzwc5LEf;pe!kEgPg=^xR@<)f6?^EP?_Fy#zYu`wWI6>usYyZ$UlR{{nu=&|``oWL-3ZBo-=N)lN!2{A$qjYh3RMeH2j^#A zq%b>-G^m?re^+kWMv>bDRl4#9jX-N*39Ea-Ra-v$OmIqxQds$98Ed|Fsr<~U!A8% z=Iha=2ZuLZ3~xR0!`+s2b8YL3{O!~ELGJZ@`*u)f;?#M-B1Q_A#j;k zIu*gZ3EpfcZ3y2y{pyd$0$f9A*?CHWMX_6F{kiMC0cis0W(M_t!UHd2ud~|y}5pkr~m!C{!HLF3niK<3M}1ce-ospkpL;} z4F>hHd#McHof(RXo6ExbI6gmfc4G8O;W^7sFDXAyul$)X8joHQ=w>;)Y1cj>fXC1u z%TK*}b9w1pXwP8M`M#tzb*pe#z;zpl)?US*4?IFts1mh~8c@{iaR7aCp-+1ua`EkE6-EN6zCa}0S&CA{QwmR)FQm9UJj7Gigb()+{fMh*}Z9Kz!A9l%7Je4jb4Euj_ zSXB}#p?b>6^H(w^Xjj9X%9Nn`c+Nj+pW~VZgsm65M$-^=iHWMnQ4dB(PJS71eX4|$ z0i?Mxe0zh54Ie|(Kqj(@hmsNu5iPn6`DvhdaiyIEWARz= zAF>wtcCWJA4{+OlPj%qeLd zcp@_elE1`dQk@2UahTcMCeB3Vr!yOFo-n>#Il2dwaKp=n*7h~Sj$c#u7T~>9xCtBY zhADB|LP+QZ36$$P`hWM3R3@ELo-rG#YubCr{|H(PKfkqX9=zr92bhr(V2($+*-+BF zmpo~MhSZfWD*-KwVHGR6q>yB(|$?tC#kJDt+Kysk?!tFp)^O1i5FpG^QG0`|8+GQ)!G-P~dNyZG@`xV(GWESNSUor`R zTkh}=^&7HB_EJ~Oth<@^zfse#CVzP7zn2fRi%wZZ0Z!;66{}}RRg8XyIXIU^-FBPu ztF(N;jf##OexaPPf?aWdTY|p5ipldtv8W1u58bd4wzOq z^s6kAheE=B9bISf_%TBgZIz5xW`>_l$ktv6&76cf>NXky!Pr*>co`~-Nw(LK<$7`dyi|J&hMbsgE7&uv8>|z z-=LUJu|dhFATgvKD;OK%yPM`wJ>6-WKIawiUUKuQHuJpFvuGiLDIM3VlujePm0ob- z5uZOF4DKib#dZB-MS|x8Lul0>w{M)=nmmwnYHF%3+EAA}-+S58{hox)?qL5uZv9vO zg7J)li&*a2+8TVa5>X9EG^HRKgKilpt!`wK)>F?L&vn#RP|i!6xfx}9LG$cUak~&p zH9~!8DKz=Va#7LGZ^M*1^2*DY06Qv*Z=Ky`wMgapSRQUxXBq;?fGHNb$F9AZdye~R z1dGHLgtWMKCnTPTEz=uBvqBnA$7)h4wGZ^uOICB+tWJT3jQ(%ADYk8O+Zk4jT{pANcX^{)-#u!4l#M0_Q^gbI{bzVD&H2;2}|%S-_C(!#x)~Yx;W9$Uo`~tICVp~{Uxz0 z?Cqc2uk@N)_Ytvg%AUF5mlz(JOtI&=0XQO|zNMh`WrGplrK4~uM3Jh3@l>i-L4?J# zd?6ut4p_&SI#U-ClGHzj6Z|3$1sRdH=;H(&X#hpRk}Z}XGhMr@T9Lkce3n+K0EM)8 zoZTK?2dkA@8?Ai?{V9wS_*w0?Q(2(Hbj92iT%VLW1(6W zinb(hWyG9!d&cTQuI>4=cad7DA?Rl*saSLWw?j~(WMH6jcC`4>nHIs`7F^;7v>=m_ zNfgGJQ_oBpwQZPm0HT1N_YUt3#MTv4md`3R5VDs!hsCT5jwX$nQ&Hg_SP-KgO2ZMC*lF?`u&XrGrK3NK zT&$7#cag1f@J%=F_gLxn*a^SLeuGKayfJ!|`Z1bFhgaS{eE2WLTU?^^?_FFWgZl2` zKd!hkZEbXeWp@;ro`^+WdyeQtp4)y)uf?k>mP}$;sb%?5$Gdx4R(WkS8Aqo_s?bIl zkyeR@MEoF7Ur*K;Wone9zM#NbvkBE5 zm8wCca7=Z3A8`B;7TC8AHHb+F-#myR7;}aHRqPq|L8y^Scm7!E*uyR8e-0ry^2?qm1*rI2{Gg+u#l*H5TM2&Uw@U>klO(pg z-|Vg*ajRvE*Foqv(yFbdy;#Ick?x6&pq`Q7H`V>0ECmuT!S0fk(cPMzp1M%AEdR{O!gW= z?-t07RGh2CB6^+@WQAP{HFe{C3iU*~9^e*ke`7;EL@?@a^`l}Eko7DI>Y{u^FYwA=2_eE>R6UFtrR2YL~NNFnD| zeII~#*gq1SXL6cJuV(lA4tyHX$Z+#gBYWQV@J%abPPazNfWyZy;KZDT$LZIqg7w1m z$*%U>p6r7gKmVEd1rp`Q$dJ-{JZTW~LuH7abq zIbmVq(5jB(fe$$@+qD&c?#}7-|1hV)vSrU> zCxwAu+fmam+!YK>U7(s7n!H&somKS-gOEKl4SC|H zCB_Y`aw)nKcr-t9+su40Od$>;h0P^@rL_~p{HsQ7#9M~Je07mK* zRDJPB;K7Vi2-nGgI(?71r@Rku+(Lf*4sU-gPOe^;hTl;QSnXbx02;2rqf?T=+4ysz z7HRYNOVY*E3(A8A=(Oe^Lz6yUOmRc6(Tmex3d;yVp#`U{HZPo3)ZLf2Pqukl zHWpzom%<`jsP)e>gU60lBWT-;YuY^Pr@e4U?O9U;1nj*E2U40@E$*>RcQhJ^Uh)}B zD&+5opH-*66C0o6<J2U!Hs}`R{(BgbU zJgT}pKH3fbJo&{~g*wdqcJ!98ly*tR*y#4lcVo1g)Wyszy6y%~)cYVd=->JtB$54C z4~tI*WdQF}z2|pk&OyjqF7hhI#G&7%yOgqg(AMqaR%RWMtOPRmU^oc?V+MeA_6rr5 zb@WZyD&7KSaBe7u1SE^{{rlvS{$7bm8e}hHFYB}YsiSnD0DB-uuVw1Bquu74ly64S zt;5@ywA}{jUpJw`CDMZ6)ZdBV0yXMns1>#ZkA4AUM~7YH=dK(}U7L$XO0a)=i$hrp z)`humbrV083QnI{`xieHP%+kpLD~}ZvwRcpG27yKJ8O3~wkQF~thX!6{Le;{LIxG7D#&9bydzh8 zi<)yRRf}wtJMVLIn#E9592Bj?Los1VFXJx*`1Pcvya&kkFn$7!vFS7Iry@R1hyIXj zxVv05p=3-*SQ}o(RrZ3JJcl`J+{Xgj$EE+43HyT z8W&TcUxzjlV=R;aOoUH8T*;NeX)=uCFyH|s+hzffc(q5VbAPlAjSFxYfgMvD9;uLM zmY;K{C0-DK_CXiAA@fl>YKRJlmO@R}YAVS!6`zm<70s2tltW)ya?0wWE_Fz=Em@BL z`z##UZ@Hn#@E8ZleU8d%bYqMorR~ek!9X_@KFXja_PH!mlsno`hQNHXCxq6na{*vI z%D$>lZlOxj$MoqYV3r1DVY^tY2LAa3P||?9_?SgQK(f?-Kennr8nmkm@s9RXHnfR$QhpEBTcBB3z(rS~=-Do!1LLKC)efR<3oNyWOo z=R3Nb0`2mfyFHNR1_#qqxSBD`d=a$m5ONU6$rakYnNGxU0&kCnd!WG1(-gKkK**m* z@A6nl<)ghjV6hsd#~Ndm*1`IJ$&axuG6`9+C`tSfv z55ghttUt#LRcZ!LMZ^#h_Ta&^0^A~<7vmKD4>hfaYt^l?A83w0o=8s-_*|&qU>+{G zHA#ON4B~_UPe*9ZY@ARr&b(s&MiN($suNj$Hr%a=pz$_2(MAQ0Pm%rR5n zXKd95@Ji(#ePd1EvcePL2$gl_s`V>Z?X{oTzcKv4(?>yHFwpi;(kgb!_t}(+Xk7Ha z7I;sSJUGuHbeRqD;6doXJr83uDLPAnH{`=V6`T}ZYDRCyiTQ;1EIynR!rTa2IcU1k z^_&Ho`duBwz-C6Ky6V2f&&a(aCq(>{YX7N&aO|70#TqNX%!%KOu?{(R8h4SSqz z{a<#0p$r%c2QAbnXClW!n*Ir!oJ9nkxce8cIkq``W%O5w00cw_ncdw3iezXW5vkEI z7)0C@k!mkPbrRP`$rzS{Vj@}P$#g`<(cNlVR_}ryE$y$Au7K zztYd$UVz7GCg$fYZ}VAugllWP8_REOMrZq}eb}4ak$qIxg`P$_Hi{yJL%ksp*GW&% z7K<_bhhT&@OOJrCn1z?BD+WCld*@ltTLXut-*mCxcHw0Qw%wgb%=(D=O8Uy8NxWtDxZG5*&W%}DQa zaphrSMD zHwjnNkxY_X83l6|v}x=jO_6yhZHCAB=AMfQv)Ua*Kk2k@>&KSEzDtj&kc$$e>AXtr zj&YC@dcD|d8+$q>j1DEk_OM%J7oj^c|Bor2>cpGJA6#P8&@Co zfW?}h1tWCW=i)^fF;Mnd@OcUHGbR@`v8Xa{aHZVm&zn~N3E*4be0EqTNayS)Jnahl zkni@w_H;jsOxB~*$frSIGkD^^@Oo!IlY()y)qu&`w~p_;uoM83S-E>d3kIjPNdnG& zzkkKHX_bE*h9Lr-fyH_>Op-+L{o<9gk5^v38rV=DxNrJuKDMcG06^(*Ia|ojG35)PCMy^HblH@0I?2-7s_$Bk)_ZAj{7c z_|2rn_leqVJkz^fEL?Z^_k|)TUYGc2nUU8iipR(NLE;rzHB;Xm&f#BvhPyUjjE5J- z?037+6?}O$aB}p= zRl|A~l1ZlG|DXiYh{yb)b7Zif5hY-Pw%BX`JJxlg95&K&B$a#8mDVXTz=(-iCc9Fz zY+TZI%p71hyut22rn!;;-rWvbDcvovhqT8GqKHZV!XPWQM zM&Cs+Njg|_YDZrc2G%@umcn{r-fyj7=C%Df0LI6Cd|~>24=H?Z+qi?vwf@XYjRL4~ z+|q{6T74WLpCYC_c0;R*LqqbqnIglZ{dbKF4SA=hXDsc3Phwhq0Oy z4eUGVvhxGR5fK_v#y6`A9k!6fis;P8#JJBt8hhXDJCU_OPi}};c9sm=c96`2Go~R4 zaHwt?;y#VPm$ZWEqa23BTE0BJ;)DTeb@KSNR|9A)} z_Pdqh`G;lHEbYxvamzwoXZ z+FytE?+X%YRxMAB!E<-Nx9EFYJBC)FtIqeV4Fi5&1w%`R#t6Zy1 zpTh=pC;n%>{Fw6b;OskeIg;h6XCT;jsS&0@^{>6%d)etFORl0vfYYH5wy`$8&={BF zrc;ZJR09;|m|g<8e*y#VzJDcK3gg0ucdiAbYZIKA82k16wMUYa3x|7o6+`|9$nU%g z(oSvYBwo!7!cQ$Ue8PD4+0IHuIPLjY7IVotoe!1@4mZVrdp;oVL)FH-FN?uvvX&=~ zNC#vs@{e1#E&;n62!4E%mr{XYhnpD_+CJPD8Cu^k&~EKF^VQR?gj90kJh9O&D>*pO z@4`*{^!?#P0^{iws$?Ex{|&G{9kfX6)jbDW&Q{dfUU4D9O3&nVcV`zH!hxGFywwpk z?qnOcmly%>zB#I5Aj-7BA>H&s`>lBR;}*S&_M{Wz_(S;jr#^?f!^)QuJkHQwU-v0X zUkWv}C*ZLRhAYF822_{994@8`-oOr0&_#9t>tE7-Rf?I@h*kM=0c*3Ws*CCCOV&QR9QJC?ly^tdp9)EMMfkjogB_@Q3P$BG-i+m>b%58$7ULgMRpuFAF zXOo5Y#n2&26k&gbdwMlZNwK)3PWp%)aj=dIHJ)Qf?47z0t1M7<*xjtxwC-lMu=kQT zvkbpk^RKSavCwhI*`!pNkzQ?QtC@LEe#pjVV|i_!Mm#!Miz zh^sL`ClP}-yM4>xM+^11WxIMwF9`W;!al)Yt>s>$#})-gQ^Wl2_d^+tnZwu(@!@qM z%c$JoNVgDyfNNBuGBWs4Llp;S%|uS5Yc$?J&< z&_)f(oljI~4|aO=D}|=i9_|3;;ja*ZYvT@UlI!wI_Z8&C7fsbGEDBV^t|k?^QTpH) zDMQdPnnCFGi<^Vl7^x0k3ZdKYu7b>GjgWbI9H|&)rK%fkJlCmqlN%-g6m~I=T-O|{ zrI$uttCheoHELiyGClo`ZHQ0Z+hrnlDRpmwo3E0;^grrbBV?D2Tcusl`A{rSN!}#f z?jLdge!`NFy!e=)lR*`D7GHHUnXUQw7Yz~1ZqqzyUIf^MSbQzg;yC=)+wn!;18Dv2 zrfbF#x^V>sK8KWka{+*i#r(3drB|OGc4LZ9_~S2}_B~+MfyXQ$$?C5~p{INO#J@elv>W?r za%KWHjlhvwZm5)!)1O6+PhpWG)^Bk-(?l95h-rLLRuC-RSbW|AM#r%V@3owdJmsUL z^^8_xYBS7>IA5_R)nS&M0CHs{UlD{j%FTTyF$ASNWK7|FVg@v}({I&Md-%S~ZZ(IB zYYbBdKqu8xceVye{^3D(TvE9){e`Zsh2W<6C%!2>%Uj z06)(I8mC{+gV&rX#9?Y!sO72(nx@&7OA3p$&8;?eaJOg{SE8aju<-mVx|`=~a5PPT zb>?~+qIFPL8XfePA|E*&xXL{9APJ-%y1m+=(`N$Sr!A=*zDB}eEJ|i%VN<lp1t+;_`JdZC2q60Xr_7>z7_Txozz413I%7sT*HBffFRmSB+OHqLl*HVZ zXLCHdvpLajY)R*M;Z%?Ia}|iuunm*=()i{By~n#N2uZiAW*)HtyRGuQBP2WDBe*3? z+(YYncBiJZ!^=N>ZNqYp_w{bm7|C4XcuPG&;nVs2!!6`wzi{)CuyT)V!CzypwQOU@0Awj#p>kxIV zhPZg~5sAJ8iy~75FL5u(4(PJ6?2fcEk1Ce!`LCuFWh4by2P;bG zJNd*VHdD)<*5kI!J#44yZ1&%~u{!0c*M7##(w*)Oj3sBp7Vm!f9QD%@#$4|WmDf{f zk<8#}ua?F+&X=@u?F-zOx2uFb)9QJQW}_rPYmX^H)!C>`$;K}^$^4_4o2KyaDga}d z+KjTaOgAZz&}o-Y&W(Xh(@1 z>?K)8Bx;IWyVxep%AIqsX3(LoIs#_QMGHzaEQNX<3>*{Np38x7OU|;djL+1Z@1S}3 z3?db{T7p&xd+0P?c_F(NNcCdLMb$~}I=K405bdY~T-;wB+!49a%H8jA;0G2+k8;5v z9M}7w1%Tk22|9WH1W0PGH|3n}wOff8TKq*Px5+kbOzH@ad^}uNzmB!syIn?6Gfz7< zVr1V6%h9SMCdVAev>ySbw-*Q?Q({Dbng3Gq7k}(YvSKAo^ZRtF2CM*6AMSQph^7a8 ztUEkBcqLy*TP46_`GByuKWha+mP_J2qor5QjTr56`>)NnD*U2>!M?M9bl=F{?Iz>* zrOS>VNY!Y&MF@6>D)aL%{yJ{EeRHN_UH4x6OjS`{n`kNq)xSWqyzdTb*RN=z?0a^Aw_T_ES55AXdl#5BvjXRLtKK$ zXN$|jbe9Kx>(fG4%=Q)Bty@0rNxnVhl2c;(#T=yzlI&lXl?c z4kH5$^6voA$aZtBM>w$m+1NMMGI1x~Y~$VMD_HACM@u~)F?OHS## zoB&rzH6&$ow5EO{)aPF6|4#e%%JnExz@Q|lHJGa`rMAWiUNnj-6*w@=O{B5f^^g;w z0a4oQ+OWc3_9zOo?C0UqEbPw14n++lnc zIdqTX67Cl$%jJD9G|ng+6Vc680KzmC>5Rs%0uDmp=Jol!p+UBv6a<0PgJMe)CADof zmC40W(ri9VF26HHxAsv)*spluzOG`1ZqK5GD=kLSi}wj2(Y>NIE$p#r)V4!w2{|hR zDmb}=*yU+E4v!Emk3dnNpJ77Xfd)=NH}*wZJ>|QlA3(Qn%B`(;3t-aIX9{`Yen0KY zewXFid!|t|pqtVfh&NsAv4J(~zbenlInU?|H|l$+=y2GQQk|VodEm4=oR9!`v(UeI zVV^}SPF-)x&S*`(Vb1laj0^%e+D%XDcq^EVD`dRLOd~6<^?#BQzi-jIibVvXi$M^L zTFn0joAoFS4>pDeM}r5h5*xb0OY^X1^EZeU>Bx>4H>+TJ!;#Y6VJ-E(W%Wl;H?S?M zMR)@l+O6E#o89KGF3bBho2a-(v`DU>k>`J%4oz3l<^(M=4g5vdwka z=r>@^sk#!?>MvetsZ}kW=MUbVEW9l$+gG_Jr`=hkbRG@nnSYIRU|VBuWC+ykuu#ZK zX@r!nB*Mw~5=${^!CT6vkv$X^r(k5yI$v-FXU>bAn?mIm|IIw|$G=YQ9kl}HiLZdj zmFxMRY^^NQ_waS}3lQ3;!5-wfrEbDi5L-ifeam$A7A@j;d`RX_ePAk2`4p9qi!+Lc zX`vBKEr%{|Ye`STxIU_x$Kf0I(hq!Z8Gb2?p9RAk*`iZZ3J1cVZ`Tg^*dyxp19K*3L1{FM6cx9|t--$K`x_{b z-@<)#ES=P1pLLL;U1TdmcQN)&@8O9$D|tOz$BIvfy@F*nG2uT-8XIYNf!V5wcD5ia zfxb!7x8&T76KTA#1etsz1$LH#=*{eXubo=HwYB&hfmG10TMDbi zAd#JdF*5O=G?$QQs8oYX=&UMMAg4Gu)Pv34I^v(817@7MCdn)F>=#Yc zhOM64gD-zHEYTQsx_K_O&Ae}&`9n<$=~cHXvAxaM2EJ(VQQChPzxgWumNBPno+@OQ z_$VL_Cqzd##PXjXquqE2{C#m}cxua$btv1nh4U@v0syh^_&FHKcl@Y&KkKymCbW9n z0*(+GZ*2RguImVbG9VFOmMnc3vODPw{h?&%CE$= zFCOrCl1)LOcRJHHxg9p*i9^P=Un>{^3|&IQdLXy>G+oTL&|;rCB5)P>SX-uSDD2I^V`dO&CIY0Ey23vVvzK zg(ChH&$XF0G@8<+DSzi_Ue{A5zQ{-Y_e`6@Ax;;5bb=mvdnT63hOpH5G%P>1nRNxGj&UEjxOCe zWF~1!^CN9q=CFd9i{9|bJ3?7BuK{Nl?+d$aba(4U=Z{7P%x%{_NBFD2d47Dm%sz8F z=UFtgZg1DD|E>zak0yhO)ts6J4pht4mb#$#bJ5Esc~zpsd@CXm(x*v>Pi2Su_az}M z+W%QW5yQjrs4cYo_c~czDyqLIb8kCDoL3h8ylC`R3W~`=i(Ke=A zC5{LE%7|3pwYWzd(j(VTxrQheK2KlRo6X~DDQ0HPx# diff --git a/otherlibs/labltk/examples_camltk/jptest.ml b/otherlibs/labltk/examples_camltk/jptest.ml deleted file mode 100644 index 9ec06acaae38..000000000000 --- a/otherlibs/labltk/examples_camltk/jptest.ml +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Tk - -let win = opentk();; - -let b = Button.create win [ Text "¤³¤ó¤Á¤Ï" ];; -let _ = pack [b] [];; - -mainLoop();; diff --git a/otherlibs/labltk/examples_camltk/mytext.ml b/otherlibs/labltk/examples_camltk/mytext.ml deleted file mode 100644 index f3aadfbbec98..000000000000 --- a/otherlibs/labltk/examples_camltk/mytext.ml +++ /dev/null @@ -1,62 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let top = opentk () - -let scroll_link sb tx = - Text.configure tx [YScrollCommand (Scrollbar.set sb)]; - Scrollbar.configure sb [ScrollCommand (Text.yview tx)] - -let f = Frame.create top [] -let text = Text.create f [] -let scrollbar = Scrollbar.create f [] - -(* kill buffer *) -let buffer = ref "" - -(* Note: for the text widgets, the insertion cursor is - not TextIndex(Insert, []), - but TextIndex(Mark "insert", []) -*) -let insertMark = TextIndex(Mark "insert", []) -let eol_insertMark = TextIndex(Mark "insert", [LineEnd]) - -let kill () = - buffer := - Text.get text insertMark eol_insertMark; - prerr_endline ("Killed: " ^ !buffer); - Text.delete text insertMark eol_insertMark -;; - -let yank () = - Text.insert text insertMark !buffer []; - prerr_endline ("Yanked: " ^ !buffer) -;; - -let _ = - scroll_link scrollbar text; - - pack [text; scrollbar][Side Side_Left; Fill Fill_Y]; - pack [f][]; - - bind text [[Control], KeyPressDetail "y"] - (BindSet ([], fun _ -> yank () )); - bind text [[Control], KeyPressDetail "k"] - (BindSet ([], fun _ -> kill () )); - - mainLoop () -;; diff --git a/otherlibs/labltk/examples_camltk/socketinput.ml b/otherlibs/labltk/examples_camltk/socketinput.ml deleted file mode 100644 index 485c258648d6..000000000000 --- a/otherlibs/labltk/examples_camltk/socketinput.ml +++ /dev/null @@ -1,42 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let _ = - let top_w = opentk () in - let text0_w = Text.create top_w [] in - let entry0_w = Entry.create top_w [] in - let button0_w = Button.create top_w - [Text "Quit"; Command (fun _ -> exit 0)] in - let buffer = String.create 256 in - let master_socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - Unix.bind master_socket (Unix.ADDR_INET(Unix.inet_addr_any, 6789)); - Unix.listen master_socket 3; - print_string "Please connect to port 6789..."; print_newline(); - let (sock, _) = Unix.accept master_socket in - Fileevent.add_fileinput sock - (fun _ -> - let n = Unix.recv sock buffer 0 (String.length buffer) [] in - let txt = String.sub buffer 0 n in - Text.insert text0_w (TextIndex (End, [])) txt []); - let send _ = - let txt = Entry.get entry0_w ^ "\n" in - Entry.delete_range entry0_w (At 0) End ; - Unix.send sock txt 0 (String.length txt) []; - () in - bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send)); - pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true]; - mainLoop () diff --git a/otherlibs/labltk/examples_camltk/taddition.ml b/otherlibs/labltk/examples_camltk/taddition.ml deleted file mode 100644 index c186730303a6..000000000000 --- a/otherlibs/labltk/examples_camltk/taddition.ml +++ /dev/null @@ -1,53 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Tk - -let main () = - let top = opentk () in - (* The widgets. They all have "top" as parent widget. *) - let en1 = Entry.create top [TextWidth 6; Relief Sunken] in - let lab1 = Label.create top [Text "plus"] in - let en2 = Entry.create top [TextWidth 6 ; Relief Sunken] in - let lab2 = Label.create top [Text "="] in - let result_display = Label.create top [] in - (* References holding values of entry widgets *) - let n1 = ref 0 - and n2 = ref 0 in - (* Refresh result *) - let refresh () = - Label.configure result_display [Text (string_of_int (!n1 + !n2))] in - (* Electric *) - let get_and_refresh (w,r) = - fun _ _ -> - try - r := int_of_string (Entry.get w); - refresh () - with - Failure "int_of_string" -> - Label.configure result_display [Text "error"] - in - (* Set the callbacks *) - Entry.configure en1 [XScrollCommand (get_and_refresh (en1,n1)) ]; - Entry.configure en2 [XScrollCommand (get_and_refresh (en2,n2)) ]; - (* Map the widgets *) - pack [en1;lab1;en2;lab2;result_display] []; - (* Make the window resizable *) - Wm.minsize_set top 1 1; - (* Start interaction (event-driven program) *) - Threadtk.mainLoop () -;; - -let _ = Printexc.catch main () ;; diff --git a/otherlibs/labltk/examples_camltk/tetris.ml b/otherlibs/labltk/examples_camltk/tetris.ml deleted file mode 100644 index 14a9b648f33d..000000000000 --- a/otherlibs/labltk/examples_camltk/tetris.ml +++ /dev/null @@ -1,684 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* A Tetris game for CamlTk *) -(* written by Jun P. Furuse *) - -open Camltk - -exception Done - -type cell = {mutable color : int; - tag : tagOrId * tagOrId * tagOrId} - -type falling_block = { - mutable pattern: int array list; - mutable bcolor: int; - mutable x: int; - mutable y: int; - mutable d: int; - mutable alive: bool -} - -let stop_a_bit = 300 - -let colors = [| - NamedColor "red"; - NamedColor "yellow"; - - NamedColor "blue"; - NamedColor "orange"; - - NamedColor "magenta"; - NamedColor "green"; - - NamedColor "cyan" -|] - -let baseurl = "images/" - -let backgrounds = - List.map (fun s -> baseurl ^ s) - [ "dojoji.back.gif"; - "Lambda2back.gif"; - "CamlBook.gif"; - ] - -(* blocks *) -let block_size = 16 -let cell_border = 2 - -let blocks = [ - [ [|"0000"; - "0000"; - "1111"; - "0000" |]; - - [|"0010"; - "0010"; - "0010"; - "0010" |]; - - [|"0000"; - "0000"; - "1111"; - "0000" |]; - - [|"0010"; - "0010"; - "0010"; - "0010" |] ]; - - [ [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "0111"; - "0100"; - "0000" |]; - - [|"0000"; - "0110"; - "0010"; - "0010" |]; - - [|"0000"; - "0010"; - "1110"; - "0000" |]; - - [|"0100"; - "0100"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "0100"; - "0111"; - "0000" |]; - - [|"0000"; - "0110"; - "0100"; - "0100" |]; - - [|"0000"; - "1110"; - "0010"; - "0000" |]; - - [|"0010"; - "0010"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "1100"; - "0110"; - "0000" |]; - - [|"0010"; - "0110"; - "0100"; - "0000" |]; - - [|"0000"; - "1100"; - "0110"; - "0000" |]; - - [|"0010"; - "0110"; - "0100"; - "0000" |] ]; - - [ [|"0000"; - "0011"; - "0110"; - "0000" |]; - - [|"0100"; - "0110"; - "0010"; - "0000" |]; - - [|"0000"; - "0011"; - "0110"; - "0000" |]; - - [|"0000"; - "0100"; - "0110"; - "0010" |] ]; - - [ [|"0000"; - "0000"; - "1110"; - "0100" |]; - - [|"0000"; - "0100"; - "1100"; - "0100" |]; - - [|"0000"; - "0100"; - "1110"; - "0000" |]; - - [|"0000"; - "0100"; - "0110"; - "0100" |] ] - -] - -let line_empty = int_of_string "0b1110000000000111" -let line_full = int_of_string "0b1111111111111111" - -let decode_block dvec = - let btoi d = int_of_string ("0b"^d) in - Array.map btoi dvec - -let init fw = - let scorev = Textvariable.create () - and linev = Textvariable.create () - and levv = Textvariable.create () - in - let f = Frame.create fw [BorderWidth (Pixels 2)] in - let c = Canvas.create f [Width (Pixels (block_size * 10)); - Height (Pixels (block_size * 20)); - BorderWidth (Pixels cell_border); - Relief Sunken; - Background Black] - and r = Frame.create f [] - and r' = Frame.create f [] in - - let nl = Label.create r [Text "Next"; Font "variable"] in - let nc = Canvas.create r [Width (Pixels (block_size * 4)); - Height (Pixels (block_size * 4)); - BorderWidth (Pixels cell_border); - Relief Sunken; - Background Black] in - let scl = Label.create r [Text "Score"; Font "variable"] in - let sc = Label.create r [TextVariable scorev; Font "variable"] in - let lnl = Label.create r [Text "Lines"; Font "variable"] in - let ln = Label.create r [TextVariable linev; Font "variable"] in - let levl = Label.create r [Text "Level"; Font "variable"] in - let lev = Label.create r [TextVariable levv; Font "Variable"] in - let newg = Button.create r [Text "New Game"; Font "variable"] in - let exitg = Button.create r [Text "Quit"; Font "variable"] in - - pack [f] []; - pack [c; r; r'] [Side Side_Left; Fill Fill_Y]; - pack [nl; nc] [Side Side_Top]; - pack [scl; sc; lnl; ln; levl; lev; newg; exitg] [Side Side_Top]; - - let cells_src = Array.create 20 (Array.create 10 ()) in - let cells = Array.map (Array.map (fun () -> - {tag= - (let t1, t2, t3 = - Canvas.create_rectangle c - (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) - (Pixels (-9)) (Pixels (-9)) [], - Canvas.create_rectangle c - (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) - (Pixels (-11)) (Pixels (-11)) [], - Canvas.create_rectangle c - (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) - (Pixels (-13)) (Pixels (-13)) [] - in - Canvas.raise_top c t1; - Canvas.raise_top c t2; - Canvas.lower_bot c t3; - t1,t2,t3); - color= 0})) cells_src - in - let nexts_src = Array.create 4 (Array.create 4 ()) in - let nexts = - Array.map (Array.map (fun () -> - {tag= - (let t1, t2, t3 = - Canvas.create_rectangle nc - (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) - (Pixels (-9)) (Pixels (-9)) [], - Canvas.create_rectangle nc - (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) - (Pixels (-11)) (Pixels (-11)) [], - Canvas.create_rectangle nc - (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) - (Pixels (-13)) (Pixels (-13)) [] - in - Canvas.raise_top nc t1; - Canvas.raise_top nc t2; - Canvas.lower_bot nc t3; - t1, t2, t3); - color= 0})) nexts_src in - let game_over () = () - in - [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg, - (c, cells), (nc, nexts), scorev, linev, levv, game_over - -let cell_get (c, cf) x y = - (Array.get (Array.get cf y) x).color - -let cell_set (c, cf) x y col = - let cur = Array.get (Array.get cf y) x in - let t1,t2,t3 = cur.tag in - if cur.color = col then () - else - if cur.color <> 0 && col = 0 then - begin - Canvas.move c t1 - (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) - (Pixels (- block_size * (y + 1) -10 - cell_border * 2)); - Canvas.move c t2 - (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) - (Pixels (- block_size * (y + 1) -10 - cell_border * 2)); - Canvas.move c t3 - (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) - (Pixels (- block_size * (y + 1) -10 - cell_border * 2)) - end - else - begin - Canvas.configure_rectangle c t2 - [FillColor (Array.get colors (col - 1)); - Outline (Array.get colors (col - 1))]; - Canvas.configure_rectangle c t1 - [FillColor Black; - Outline Black]; - Canvas.configure_rectangle c t3 - [FillColor (NamedColor "light gray"); - Outline (NamedColor "light gray")]; - if cur.color = 0 && col <> 0 then - begin - Canvas.move c t1 - (Pixels (block_size * (x+1)+10+ cell_border*2)) - (Pixels (block_size * (y+1)+10+ cell_border*2)); - Canvas.move c t2 - (Pixels (block_size * (x+1)+10+ cell_border*2)) - (Pixels (block_size * (y+1)+10+ cell_border*2)); - Canvas.move c t3 - (Pixels (block_size * (x+1)+10+ cell_border*2)) - (Pixels (block_size * (y+1)+10+ cell_border*2)) - end - end; - cur.color <- col - -let draw_block field col d x y = - for iy = 0 to 3 do - let base = ref 1 in - let xd = Array.get d iy in - for ix = 0 to 3 do - if xd land !base <> 0 then - begin - try cell_set field (ix + x) (iy + y) col with _ -> () - end - else - begin - (* cell_set field (ix + x) (iy + y) 0 *) () - end; - base := !base lsl 1 - done - done - -let timer_ref = (ref None : Timer.t option ref) -(* I know, this should be timer ref, but I'm not sure what should be - the initial value ... *) - -let remove_timer () = - match !timer_ref with - | None -> () - | Some t -> Timer.remove t (* ; prerr_endline "removed!" *) - -let do_after milli f = - timer_ref := Some (Timer.add milli f) - -let copy_block c = - { pattern= !c.pattern; - bcolor= !c.bcolor; - x= !c.x; - y= !c.y; - d= !c.d; - alive= !c.alive } - -let _ = - let top = opentk () in - let lb = Label.create top [] - and fw = Frame.create top [] - in - let set_message s = Label.configure lb [Text s] in - pack [lb; fw] [Side Side_Top]; - let score = ref 0 in - let line = ref 0 in - let level = ref 0 in - let time = ref 1000 in - let blocks = List.map (List.map decode_block) blocks in - let field = Array.create 26 0 in - let widgets, newg, exitg, cell_field, next_field, - scorev, linev, levv, game_over = - init fw in - let canvas = fst cell_field in - - let init_field () = - for i = 0 to 25 do - field.(i) <- line_empty - done; - field.(23) <- line_full; - for i = 0 to 19 do - for j = 0 to 9 do - cell_set cell_field j i 0 - done - done; - for i = 0 to 3 do - for j = 0 to 3 do - cell_set next_field j i 0 - done - done - in - - let draw_falling_block fb = - draw_block cell_field fb.bcolor - (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) - - and erase_falling_block fb = - draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) - in - - let stone fb = - for i=0 to 3 do - let cur = field.(i + fb.y) in - field.(i + fb.y) <- - cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x) - done; - for i=0 to 2 do - field.(i) <- line_empty - done - - and clear fb = - let l = ref 0 in - for i = 0 to 3 do - if i + fb.y >= 3 && i + fb.y <= 22 then - if field.(i + fb.y) = line_full then - begin - incr l; - field.(i + fb.y) <- line_empty; - for j = 0 to 9 do - cell_set cell_field j (i + fb.y - 3) 0 - done - end - done; - !l - - and fall_lines () = - let eye = ref 22 (* bottom *) - and cur = ref 22 (* bottom *) - in - try - while !eye >= 3 do - while field.(!eye) = line_empty do - decr eye; - if !eye = 2 then raise Done - done; - field.(!cur) <- field.(!eye); - for j = 0 to 9 do - cell_set cell_field j (!cur-3) (cell_get cell_field j (!eye-3)) - done; - decr eye; - decr cur - done - with Done -> (); - for i = 3 to !cur do - field.(i) <- line_empty; - for j = 0 to 9 do - cell_set cell_field j (i-3) 0 - done - done - in - - let next = ref 42 (* THE ANSWER *) - and current = - ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false} - in - - let draw_next () = - draw_block next_field (!next+1) (List.hd (List.nth blocks !next)) 0 0 - - and erase_next () = - draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0 - in - - let set_nextblock () = - current := - { pattern= (List.nth blocks !next); - bcolor= !next+1; - x=6; y= 1; d= 0; alive= true}; - erase_next (); - next := Random.int 7; - draw_next () - in - - let death_check fb = - try - for i=0 to 3 do - let cur = field.(i + fb.y) in - if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 - then raise Done - done; - false - with - Done -> true - in - - let try_to_move m = - if !current.alive then - let sub m = - if death_check m then false - else - begin - erase_falling_block !current; - draw_falling_block m; - current := m; - true - end - in - if sub m then () - else - begin - m.x <- m.x + 1; - if sub m then () - else - begin - m.x <- m.x - 2; - ignore (sub m) - end - end - else () - in - - let image_load = - let i = Canvas.create_image canvas - (Pixels (block_size * 5 + block_size / 2)) - (Pixels (block_size * 10 + block_size / 2)) - [Anchor Center] in - Canvas.lower_bot canvas i; - let img = Imagephoto.create [] in - fun file -> - try - Imagephoto.configure img [File file]; - Canvas.configure_image canvas i [ImagePhoto img] - with - _ -> - begin - Printf.eprintf "%s : No such image...\n" file; - flush stderr - end - in - - let add_score l = - let pline = !line in - if l <> 0 then - begin - line := !line + l; - score := !score + l * l; - set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2))) - end; - Textvariable.set linev (string_of_int !line); - Textvariable.set scorev (string_of_int !score); - - if !line /10 <> pline /10 then - (* update the background every 10 lines. *) - begin - let num_image = List.length backgrounds - 1 in - let n = !line/10 in - let n = if n > num_image then num_image else n in - let file = List.nth backgrounds n in - image_load file; - (* Future work: We should gain level after an image is put... *) - incr level; - Textvariable.set levv (string_of_int !level) - end - in - - let rec newblock () = - set_message "TETRIS"; - set_nextblock (); - draw_falling_block !current; - if death_check !current then - begin - !current.alive <- false; - set_message "GAME OVER"; - game_over () - end - else - begin - time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200); - if !time < 60 - !level * 3 then time := 60 - !level * 3; - do_after stop_a_bit loop - end - - and loop () = - let m = copy_block current in - m.y <- m.y + 1; - if death_check m then - begin - !current.alive <- false; - stone !current; - do_after stop_a_bit (fun () -> - let l = clear !current in - if l > 0 then - do_after stop_a_bit (fun () -> - fall_lines (); - add_score l; - do_after stop_a_bit newblock) - else - newblock ()) - end - else - begin - erase_falling_block !current; - draw_falling_block m; - current := m; - do_after !time loop - end - in - - let bind_game w = - bind w [([], KeyPress)] (BindSet ([Ev_KeySymString], - fun e -> - match e.ev_KeySymString with - | "h" -> - let m = copy_block current in - m.x <- m.x - 1; - try_to_move m - | "j" -> - let m = copy_block current in - m.d <- m.d + 1; - if m.d = List.length m.pattern then m.d <- 0; - try_to_move m - | "k" -> - let m = copy_block current in - m.d <- m.d - 1; - if m.d < 0 then m.d <- List.length m.pattern - 1; - try_to_move m - | "l" -> - let m = copy_block current in - m.x <- m.x + 1; - try_to_move m - | "m" -> - remove_timer (); - loop () - | "space" -> - if !current.alive then - begin - let m = copy_block current - and n = copy_block current in - while - m.y <- m.y + 1; - if death_check m then false - else begin n.y <- m.y; true end - do () done; - erase_falling_block !current; - draw_falling_block n; - current := n; - remove_timer (); - loop () - end - | _ -> () - )) - in - - let game_init () = - (* Game Initialization *) - set_message "Initializing ..."; - remove_timer (); - image_load (List.hd backgrounds); - time := 1000; - score := 0; - line := 0; - level := 1; - add_score 0; - init_field (); - next := Random.int 7; - set_message "Welcome to TETRIS"; - set_nextblock (); - draw_falling_block !current; - do_after !time loop - in - bind_game top; - Button.configure newg [Command game_init]; - Button.configure exitg [Command (fun () -> closeTk (); exit 0)]; - game_init () - -let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_camltk/text.ml b/otherlibs/labltk/examples_camltk/text.ml deleted file mode 100644 index 0f876337ff86..000000000000 --- a/otherlibs/labltk/examples_camltk/text.ml +++ /dev/null @@ -1,54 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Tk - -let top = opentk () - -let scroll_link sb tx = - Text.configure tx [YScrollCommand (Scrollbar.set sb)]; - Scrollbar.configure sb [ScrollCommand (Text.yview tx)] - -let f = Frame.create top [] -let text = Text.create f [] -let scrollbar = Scrollbar.create f [] - -let buffer = ref "" - -let kill () = - buffer := - Text.get text (TextIndex (Insert, [])) - (TextIndex (Insert, [LineEnd])); - Text.delete text (TextIndex (Insert, [])) - (TextIndex (Insert, [LineEnd])) -;; - -let yank () = - Text.insert text (TextIndex (Insert, [])) !buffer [] - -let _ = bind text [[Control], KeyPressDetail "y"] (BindSet ([], fun _ -> - yank () )) -;; -let _ = bind text [[Control], KeyPressDetail "k"] (BindSet ([], fun _ -> - kill () )) -;; - -let _ = - scroll_link scrollbar text; - - pack [text;f][]; - pack [f][]; - mainLoop () -;; diff --git a/otherlibs/labltk/examples_camltk/winskel.ml b/otherlibs/labltk/examples_camltk/winskel.ml deleted file mode 100644 index c83e6436843d..000000000000 --- a/otherlibs/labltk/examples_camltk/winskel.ml +++ /dev/null @@ -1,63 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* This examples is based on Ousterhout's book (fig 16.15) *) -open Camltk - -let main () = - let top = opentk() in - let mbar = Frame.create top [Relief Raised; BorderWidth (Pixels 2)] - and dummy = - Frame.create top [Width (Centimeters 10.); Height (Centimeters 5.)] in - pack [mbar; dummy] [Side Side_Top; Fill Fill_X]; - let file = Menubutton.create mbar [Text "File"; UnderlinedChar 0] - and edit = Menubutton.create mbar [Text "Edit"; UnderlinedChar 0] - and graphics = Menubutton.create mbar [Text "Graphics"; UnderlinedChar 0] - and text = Menubutton.create mbar [Text "Text"; UnderlinedChar 0] - and view = Menubutton.create mbar [Text "View"; UnderlinedChar 0] - and help = Menubutton.create mbar [Text "Help"; UnderlinedChar 0] in - pack [file;edit;graphics;text;view] [Side Side_Left]; - pack [help] [Side Side_Right]; - (* same code as chap16-14 *) - let m = Menu.create text [] in - let bold = Textvariable.create() - and italic = Textvariable.create() - and underline = Textvariable.create() in - Menu.add_checkbutton m [Label "Bold"; Variable bold]; - Menu.add_checkbutton m [Label "Italic"; Variable italic]; - Menu.add_checkbutton m [Label "Underline"; Variable underline]; - Menu.add_separator m; - let font = Textvariable.create() in - Menu.add_radiobutton m [Label "Times"; Variable font; Value "times"]; - Menu.add_radiobutton m [Label "Helvetica"; Variable font; Value "helvetica"] -; - Menu.add_radiobutton m [Label "Courier"; Variable font; Value "courier"]; - Menu.add_separator m; - Menu.add_command m [Label "Insert Bullet"; - Command (function () -> - print_string "Insert Bullet\n"; - flush stdout)]; - Menu.add_command m [Label "Margins and Tags..."; - Command (function () -> - print_string "margins\n"; - flush stdout)]; - Menubutton.configure text [Menu m]; - - mainLoop() - - - -let _ = - Printexc.catch main () diff --git a/otherlibs/labltk/examples_labltk/.ignore b/otherlibs/labltk/examples_labltk/.ignore deleted file mode 100644 index c1f6ec642f18..000000000000 --- a/otherlibs/labltk/examples_labltk/.ignore +++ /dev/null @@ -1,8 +0,0 @@ -calc -clock -demo -eyes -hello -tetris -lang -taquin diff --git a/otherlibs/labltk/examples_labltk/Lambda2.back.gif b/otherlibs/labltk/examples_labltk/Lambda2.back.gif deleted file mode 100644 index fdd1f078f4c8d8836f52d3ce3c6193a340f49035..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 53441 zcmbrl=U3Cu^FEwcLP-J#lF)ksNC)X1q&HFNO;A93limakorD%Tgx(?2MVhFgHxZ;a zrC0GSU;!+AZoj{O;l6es>^ZYL*Uaprotf1))KgS&dJJd)KS7|cU;nr9Z*F}3Km6|> zzV=RU{2L_FG_jXRB=zEny`TO1ex2?mZhYc?y8biY!NK7l?ez3NhJV!28()crnufik zfASDrOI=+_-4K#1vDekr(sHgdo%l~HNte{C+q>aPnhx36_~*nw6Lg9AkpE|$q@*rd z5{>>BGD}O#um2;3xVoYdlA!+|5c|Kg|92N4>T4_r1jHu9B_-nG;(@gIlvF}`c2;&? zenDYDZbo`iNj4aqgHKDw)z+4gvhd9<35~5UIua@H6g{Axu2+3;$^HE=Usk_pZ%@n^ zdNb?S{;$*!9&l}!~gC#mL> z9!`cFv5!<+z#WET_bzR98Uk*NJm98@;*6Z$mB`eO7P(>5vTKGvdOvkS^`Du1Fse$u z+U~evDLf$=&-HuKins3JTxC6{|Lt?t!&gGBKY#_E>#dbx**B3Cuqp1USY7Tvw_ zjqiR9h5i&{?eJRg_`3}bWptU_==|H`ZF^Pdvka~3d{oTIJ-*fVVn;>P&hs?p*}(@I zw)S5WuJbRLRXiUkhLP)DPELn~ss_evoMqhV>+$)Wb7Xk2f&Iv)`zZ?Q*Y(hi(kqWA z>i2FUhe_8Agf)Spz4JjLCo0=6VC73*dF-FuFbCD$t9>IpE1ZGHxo&H|!nvgT#%Agi z>(XY54o;C5*X`4>ExHGb*h(p{xwf%48`?79Qw2J$?HqY651pUgaw}xb7T|*N#lP%k zUCz4`y1Sb_SAyg8vWhjR&GVNZzmaT{Si9{zVtXav%!zz4=V~g=;F0FHz*-+6=@;e_ ztM1kFA&$=Kk~?#0MZfr&wV!QywO1(q@F|~@l3Vflnb3YTGv2Gr_JP%rKy5y;@HjeK z{ottSm+!HFe`NZqXv6Aox63nw!fte8ZC=EU4C7xSg3U8_RxVLeU~k{YDZlIl>x=RE zVnw3?h7UV-J98i6TAu#)R;QGW6z^`^rs8SWO|*VUO6n&aKc8-ALDam{n6T(!G3`En z1yxz)Xyk6VU6AUq#nx&KzGm>@FCqyvp1IR}TRDyTUu2kjSJ0}`ZXwwEPif7W-^uw1 z+o$;0qN$NG5n}6$Z ze7|-oWv`1xyJiT@FZ76gQe01+6IZg0_+OX8O2xqMi*%32=^shon%CX8Q&EVXomy@6 ztK*fn)t+(gbT@|r#DJ)G5rZ3h_)2Z${hBZD-&_AsBUSlD9ybbRgb}_pGD*%?9YrV% zCjW0$Y|S?1s%<1qg6?Yldi2R#j`fNBjP4WUy%Ty2Rh_DET$Gil;3@u7WAx9E$+DVD ztNS0>E=f;{U-7!XsmvAAmn+iSJNaJX3BT*(t8LcuROaO`3sEyx^O^6lRJ31z+{EsB z+e=c7^?#sj!LqAnc?5>G+rlSf4QbMT&*rr-W%)^R7<2FJTJ<5$Ps4fsa3d%U$ZHjZ zz`yX~)~5$Ndla7HJxA&B19LKl5k7%R)oVvuLIYb@ElGnrPRNY0Hi7gz3C5hoO*X@_ zD^m4$D_(6f-N@H%^!<>sl~RPz9J?ibZQ#}NY7T{~)&WN!1_}3V{fXKiMdAtJoLk#` zamk~4c}AuqzZ^K2u7zKle-TL&Tc;Hg?`Z?BTb?-f5n0DsM&_H&lipsI@fjNOe)^km zUt_RrP-sD%`9^JYhnS=2tEGNqq^V9g?IY1RCEgP`WWi{}&Wos#PJ@r{5~F1JOlL0@ zL;}qs9*GH@-#yYE{gRoxq2fv{iW~4>3@rNiZce|zm3RynFMY@OPWn#IU36`BZua+$ zSL;g5$Pk!)<-7%xdDU%?(5cd|$0cn7@IK}J>|`xYXKn{!lZp_E67^zNF(s1e?vca; zSc%)(vEkdnsemHgIqvOjb?v_oSIP=_@C@k-jF4vf<5_@Djlr%A4dB4iN7N1q4 zoNktMl3GojsdPO%dL~=X_0hv3&Uy9>xj=HBKT>>qIFTA?k>{^nRcmjl_|dgF?@uqw zYd>3sg2jx8=0MLo=E@ySdG8Ab%kiyzz$aqx2ON`0j1WjXx$W7*H3`u}lNsq9!SwlFXE zd{%3^T=zD+UL5()$Np7gLh#Q;p9i1aZ~Hv=y;C3we#S&zSM$rLk2DVyV6I~gdHf1q zSiQWJZi})PA$_lT=w0*q(a+a6-9rt`&frTOzb#wbKM)-c<@5WkzJGijXnfzpOWsPf zQHmMqV!@>y_-wd|q-_3s_*z=A>6MI)eT}h_U!_Uc<;!;cB}4L~bJ^Fm{DKvQC^$X(gsuz0<`X4$Y`X^;8%Qr|lMuuX9gcX#^Q zc&H}b`%;j@s&aj?^;4!&X2Bdh z{bgoXB)Q<)lFcRezi(}8SMD0w@{_NA`s=fZop_1>Fs=QAu?Qw}%FfLa4Ta_#x*ecWf zpWAQCTo&ph8-}$#Zn*!xSZd|>;0JScb6uH3w1N2PU*;rgmQ@jIapgFhP3P5~jfY>~ z37vWVeA9CMrwXEe{x3jO;3_l&CWj+GWuGUx_3VXw@c4!cLVyKO-fv)bK$nVEly*dc<^Um z?`m%h|m?r>wOZP`EGiPqQ=kD0jJME0#~kncRnJ zOp6a9W~l7GFGl-W`*y!{x|L=8I|=))Bj%th2F(1lCkzV+dZ)~}+^gkcKaAmIHJ%)H zwa+#7x*oNsy~LhdxrYk)aMpPh9Iy=z#n2>$4m@&H&3jCshzto0m|gNzDTw`};OsyV zza*$6)*Tq*7WOMN-pk!Durod(%p!!s-Jkk_evY2^#4)zCu$`io^5DftY-%JFX zKzID1219WoHqO~Oq232r?Y(DzhHt$(NO+a+ac3kL9p>?;R`o)3Uxn77O zRH=CVdL)fOrUOgabq< zKx74&&|o5K8oMO0A(URT41%EPD>p$j{+SHrAgCjVZWH9Am>EU=c(+D>i#cIjU#IZE zm1!&`!!?N2CWHC{9&!F)KSPOG8 z{)FI&T$>dFgCv;MF~_13}^G z2M6hUq1Xh)u>3F&PfuU(9*1fH6!ThWR*H zdTL>Qh7ypeRG6z|qIc*@^bEgQkfn1`Seq}ASLn^6NSlTRr8E#!RD2{t{Y&kJ)| zMADv(R~R(_mbkL7R|NKJa_ZMYT+JA+xI2>y3mR2SXK4WSuROc2XLqtxp0xb*wNN#3 zsW`<$UbX?mga&v_N`!ieHdh2g9I(n(6N)Rcji@ZU1eIL^JQ_LL4Zwm&&R4c7Gzjb- znLA@pRXm0-2?u0JAgUQ2YOiXgWy{3mI-#(CUQ|T>WT`mq*Y>Pzfayd>js>3VQJghPXEh3ZOG0d#4_`k!T zClhtX1{skao{fu%mHw&M2Kme34etwZ%!pE!%^W5Kcf={0nGX#mrS)+Qa5mXm4=!)v{W^=vd?@-dF;sBWEy&py{p@GO=Ei1 zRzvQGCgYE;vSEm}l3$fmcCErB;4Mw1BCLs9vT0BRoT1XFGYOW~Xk;e$8FBzpAc!Ox zybUYbBoZ%r8XFC(?ka(EXsR~v_e>ddNNDtXvI7zzF!Z{oK*XMu(_6rFii4Az!IGJu zpA1?EYKIP6PiA{5b+uG>gNnxpMfH`9<9HUrtItQ3Oawr0t#s)a*u)b&CkAwWgLOH; z)!ltEWD z#fB${i=+pUKw#`(B5lT0e6^%Gl#YyB_54TC^ChBVYYdD(PQyob(0|U*Pw6HucdtJu z(5GZGOF|s}fF%+A>nS5rGku$@eeVx}aS}1&sF3fp zqlwygeGRmb=d|FaVsfiJ&~D$_p$hKoOY3gL^{x*@A5Bs!z4)d0E)!QW%Gox4lKAfA z-PF6@Px2C}tfs;Qu%caagleCG%7CX`kF94d!RNyu2jovm?vyft@9%_7<7l!sAny;U zjhYZMfyj~j=xCc6Il&6JBDdb04TBPy&oyNQ6)7ue7vrz>VH0N0Yu|f}WGXdUJ}D`p z0UE||vZ=lBJ1t`O>1%pGIJ?$z`_@N&1?rzuCuo|JRu^ENa~Uc1b1S6=G+;#-Y0Gfr zztjoIR&ri9c=U6Zz+bR@`Sqx*I7FT!jY%bc_<2b-yuej$UINkf_qeo7tdyy5K>2FC z^m9Il?PY}r9y8hOYp`Gme{L-frNK5KTY+)KCW+IghPnIDd_lH0%v-1&*+_%oG@F$SUqu+ z{Y^+j=~_wKC2Y`02`@`3gZqPa&Q>}i7rM$9f*Z24Ir~|k0Aic17*gu@skOmZgxtx# zv62o(`&Kp+$X_GEl1&NBA1tT=Ua%!3^b%UuCn!Y0R=r*HYfbCVn`I(#zio0lKDSnr zatgx{o%el|oTX#p)L~fFqdS5o}TjSs6Q8tk1q70{+Um zl)|<-QSc)Bq%`q0A&<3m=W|VCMB|t7)c=&yK5)&xhpr9V_sDXcaDsaAo~3(Va$88B zgcJ_1W$Lx3;tyv?hvX()I(M6OL`jxJQ_gi-9$m8(;mFXtqt>sY=JKdQ{kZ1Sa@~WH z|J5H)O&&8jw6cOe^E?4wl0zr^x!qDgMT#_o+-maf)<`8SQ3yCTv1Vfdh>y!dlkq6?})jo1UC>>ie5~O;Tb?_bL03`hx~|>*PlGz4M~i=ECJ4h zU(vU=(U0TKlmPH1=#Oxosr4Ch=~=42`c3CU2|lO{4&+>v`sX=LK8^70V_H|*b;m|Y zEu%d-sG+j|P9sMvKo0`Tf!b7X*<~It=;#2|(+qZUnVNrEdh=zu;w4;tvEKgRu4heo zZW3T*5XxhedW8wQ3(f3c-Zs+SabbMSMI%9inIzhNHd{d^9uIdG%(l~RQ zz8lmTxG|fK^{~Gs1}BXzeiv_g`TF&o7g=|*p62$yU=!efaI7Yfa-%gml_u5Z;kR)7 zG92J4&puKDxK44E$q;J47oRpBw2b+qDaDR={ z`v@^rV|$;d)MC{?lk3JNAlfggYFx(Re`(Y1Onvfy!*#$q!)L z{R7;*yj#$%L!s>e4j5M@oaK{lGLlb69r~L$%8}J+=}j~{tDj?iKgA#?46T7*CT!_I zX)t<@07MT;bIBWiY(4vE$U%k)BNFf7#%uLTFQ%KkJxqgOwjV-!Iia4LG8y@LumD;@ zHuNTPzPd+RHE;={l@a?7GLGRxPN7;#9&5MHG&W?-3N9hjv#{Fyg9=N;>Sa=tJQ3ve zS}E_`Y?7LTHO3*ARw=LEV)h>S;})K4OpF`6{`T#?D^ zOWj*qK`3S~=r8BJJw&1XU2a!G85Mo6x)@QzplrTA6aL_mOyJ^d_B zwQe*M1!?jjM8Dpm1)Nlq4f@a7aZ_XU>U&1hOM$fJwXR=36y`!%9z>p5PM{CF`B_C0 zbYlygnIuP69#I?V6)NXB<;}X4M2{2(zSK2Y^+Z&6+EFyU4yAK%*VQfZ?LKm=P<|uF zvd%Z;>A222j*}l#C#&g~1QRW+=|fke7r8K-HPYN>VoI^xG{_x_UFt-~8GnGQzq^RnOC zkrIqmkx>hW2Xs~|8u(HOBy<+@conTUuNlP+hUNN z;uh}d(8my&YQ`LqRnKi4HMdQB3gxSl*#}QD3@9|gPfIR1!zfE!N|dV%JT$53UC>%; z@5PxupdY#tG;cH+NZ)>vY)saGT*IM=_w8CY=WcYYvxv!J zc9{3WMOz=03(&k*`KVklkBEay&Ig4;_fxglDX1d$e^#O2@R`B5qaC$;d3%^=DR|_5 z#&}RCo_cH|`yAs;Zjuot${0xrMgg%C9F52;3*9*(9(3RtgtKpm>sHN49CsPBO@54+ zC1zwmU@@dfO8f^|9Y!tlF?Ng}CR+{y--4)h8JX_xtNK$+cP?V=_*3^W{+E31Q_p9zJp#`OjvZ+xCoLie7ESS?&O?aZ9 zWn($|OHUF-D3bMnQ|K;ABT21Zk2P$5-}oTNf+?loX55WqIVMLao&TmnMl!!5sM;=x zB8fwt@`g~U#|jNUA2(&1s7U#8!p55glIe1s@apzVeXOOPRqh1y@0o%?+6u;dk~P9s z4F+v=6`%ty`diX2R`6TnHv&?362J%xilGE}(uwG!l~rTtz-Y!vy*6_WS%>R$I2sW@ z;!V%43%}H?zdkyviiQhQvMzWuWcs+JaxM4M(V?@D^ZOVcc1j9Wf4rg99bM++bh=;= zqwqrJz0v|M(O@Z9^VAT6WpFuk;EMB3GOc2kcS*gxHvD#Ky4OYgteMR~Y)}?HYhYj) z!b%2F%Az?+WT}LBB3Vq~*qmA&*C*<&6Cy9Ocv}AGi^*tCP6i+6^{n48@B4XsCSH$c zF!kYKx^1S5AEOSf=e|sp($ojp1L8`Dxpw!_9sgSQ;%x7g-S;r~c(HTIQ*U<>Bj8^4 z)C=?ve#%?-7W2#SJ~HxiMw1lmVvQD*NT{WdHV270ne>uviiTS0&31aVK**hz;GybP z7=8G4AEfAfH))8oKsmj4C;9L+KGaUS#h1>UhX$y^%fHYMS2X}9BXD=_`D5#`N&E?0 zK2DvAaQc%u`**OqqD52s(A>wN*;Q;)Hk&b8Vp>RsWtIbCCEY;Iwt+fEm)5ScF4#jW zy*IL&L$e$Hy>Z}fNS2AY#HbRARwKv#%kJ5t(cr!kJn~;+1gr>>px@MHmQ~VE-+oD8 z?!fXlMY2AIbHIJtzwpSKo5T>o4sMH;api+8{Ym}@h zU`-*}Hd;#?bY~xEkw~@#N`*B51}w&|B}KJ%&vo3$?Hry>y$6!INh$0|2Dn?XM)R3m ztW`V)bhNm+<#1FWY1`5f!ghCTP9&S4OZASC^OOCEeei9|KDTvs_UFkaLaY1tMs138 zqRaVO`hDJ@+ikTa`2pBr-68%G$%Byy_+j$U^krhq1Ef1;5NTXO&r!|5r>2Z1mTb1o z_Wq=if+E@JKQh*~?Nc|B_d#2+Aw`?k*HhZWaWiI_Qcl;Cr`kC*HX6AmrWOeX#-$t@ zUs<&M+vr>4ThilF1$ILwtRpL@L=_kM{+OztX*fqwULD1#N(&pmL|voqxr7;?a~el@ zp`XqCIg((8kM0WLi}~ijK*yngfDB5Vo93&Og#v{c;KJ;%G+o zt-xWhz}GxB^MrfGOWi6m9eJkkF!c=!EK~!G3f{%h$8c!R#GJ!V_i`fsvfk1;1&6YR zIA^QmQcJetmEp0@PkoLtc*`1J>Uh1=cCQ-n&Mn;t`}^0wgfwC76+*SCbiEAktgDRQ zL3K|30JtJ(s*VE$3O74=xcwSFDn$pPbp)tu*aR1cC35CLEmREfr3x;5lLz(#imY?2 z@d4laDg5(jPC;=ewQ=6N@%t}(447Ut`}sUh^};^f5mkY-L>!>`Gdk{2pFgJtif;cH|Db_egO)&xG#9)BK@zI}CF8nMbZksO4 zAO19$rpf;A^rL7Uql(B9 zR1}a&Yd+Lw6dr(&*U-$nN3&)}bIZwpJn+BXq-NhvlKX1%l)nPePk}rRQ)#B~{qF!c zO+udQKg)A|cG(pMZ+n&-NOv9P4Jr@^hsz6_VtEs=mHtt*HcBk!dbP9M3D0GG=droqoU>Bx&NYv909TUVrFCY-D4st7xzZouie{LXg5d{%t5;HB5C^15B>V z>fEuYljVNG%P76+e>0T+Gg|7|9zAy}I5C0#;Dv8sHGGf~EL+aHxDOq|*ty60q5L&z zO<{3WsW{#6SqSeUzkjl{KaW3Bk#Gyd?D4?UDeoLml}!ICNfGZVcff4SV3P-qwi5G z!rrltiQ0~VeL+bKW!km!J@_~PR^Nm;2hsDIK-RWUuFeQ@z@x((LXTYF2O937xgkN{ zSahpl*IgnMGQ14{lB)mlLm6S33f}acy(PENGm(V{gDh=_+VV^6JepUKJA{MELSGveQK+GA z?tc4vAtJ>q2r2aglO1AoYZn#G#JSvQ*78%nVhQOMfn*U9;@DJ|?L_lP^G51NzubaM z4iQ|E=pHNNwX`KnXDZHOASKd}NYumswE}$DK+dAv(Kt4~uhen%rnT_$+x z9Av;Q)xQ@$v_<~}4DK@Lcty6}ix-@<(*Muo?gU#St78<|s}KW<5QxvoiwI?{$T4k@ zx0Jnk1v3`YdQ@R;eid{pHZbj#Bb~>uu&WvC5-EV6kQa(~Dmtr@y}@9~XzXEh9a?;b z_)Z4nvNJO0q|r0JIE!2VnTVvH>wnvoE<$rxqwlE)V4*1GbVj6PvQ#=7vSc+}Zbxp# zOr*!epy~>W&l5?WsbttBjqi{om5UUVgWl}OK(Wtze?9M!%Q>TL9Dr9RxLPd6G_L(b zPZH^nn~gKe90aMRuKAolo-K#_uvL7m-K7sZxS5N$`AcEmK0D{(1luDE$uI0oU)ft8 zceI$Vq@m(ljz~{AW?FuLT4m9#E2ga#Nv$X+PN+5wy>%J zIM>9vMMXM7l@c%Pm%*sC!1fJOF@sK3anCAwb`Wr?3daIvlr(JDr@1P&0u`s~e^0@y zg}&xX(sGVA5tR~ME*8?U6}(u0+a$Augz`E^v$$wsX6nR1uQo3fOik-f*gfoVYESn& z&-qa9@sRxsx#*X9as+8Z-563B0jYml5{vNg+Zxxm2E zZ&#AWyRWD#f%t)D%SVo%U2Qo5q;8*$h@A0t4PuE8xc0pW;33@ly!^CFFP$@l&i_EK zEarh(KUkq$(eeU$q9Mn9mi+zx14dIhXi)Hrz|u?Cx8nsR`qG&PPH<)wks8VHgDs7C z6;>bV5rMH-e5g2L)8P@Oe<}#f5CVdeWun*VY(Avu8gim5f!rC1+g*Ln@{0#mLiAt* z;z9JH*x-&e3H}AUH<$EGg1K4zQZ<`Hr{x0sTd5!5Sc0i;+>+0#qW{hW(m!8_B>?>* zAgw>9mQ~;;Zw2%Tbz(|_+CH{fS#AWhEB{vrqA6Kj_d;z!r=qeP;47#9GOxs(b;W zh0>|T(A)J3q!fAfZbEC3Zn0?MH-5fXl}rvzwX3mrf1NH=VIyPF9Vic(Xj*0!b7FXE zR{U>z5fhHekhaO^2qwaOT{Tz)!Rj&+!f*U)by3_k%YUnVLV@sxRPI%ZhA3>p7VYoi zma^4pIAP-Um_JJ?ZPjehNB6Gn^bR6Q-YLS?No8VYw-^ZQo=QjxnKv$7eK#;RuQb?w z1WQxh^0GD`m$cos`gZG)ar)8mEtn&F)}Ua&*Q8J)tj+@VQp1p-;)imA@rGcn&rCBX zOx;kc?emN)n%$)_u+l5@hfbA(1uAuOZccflOR@@cm%7MIp<8gha^D<{&%ND@ITz(A z%io>02RWp*`b_OYCW(R?j!}`k5~7>g4P*%tXjcE=`M8L_ec1b*S!t#jKju=mPe!W| zmh8Nlpl=EutjI{TY5RM{o7I-9GNDZ$525hJmOPZFUk4e=(8=H?oV+S^%o-BYLsRw9 zH199d8yMor4Y5bRS*{nw7ybxHR}%8sc}4EPtcRI^>NTigf}Go5xM4pc%|uM0-z=*C z)3n>9D(A-j0OI>=xgTWf>4uWELD=Nt25OcA_>=?rBu&K+p?WV3Rfoava-wH87bEBq z%_|?Jx0YaeZ(_D^k#Y&cTL+FbcFSR0eB1GzB9ReJOflOrBTb@rcd&Xlk)RzP5zU?3 z-BClPC-@!o1ElJw9rWo=`U{^0;f35y(>vAK-PqkAEm3Cj?$p+<$0(brgrNBwHY;u! z*C?h9({bGHo(TJXktw8<&fVS`s4Cfp_jhdn_)s3z&*)$=^joKkkV8C;LYhiz9x09r zLhPzG2fMF*MX`6ZVSedNf*xO%TXtWtYpWZE=x!2Gav;v>P$VwrU8|pC3-DecwxGE5 z2$kc`B8vP;Qs6xk;s^WU*vcac3zUzZwc3Yo6yygT2>tLck;8_zrG`h7Hd-_oUbu3` z8jn6QK<0f35S1HE3RcF%sl@9rr2Eknoo?Tu+^;1O{-X7NVqvqkI@+EREdC|;shp2A z`nH*t&5RBca*L@lKZr=d&;(Q)FGQUjV*YG`&BOvVcc38wJwjC;OGIE)F)g6RylmLJ z!xjZe!dy4N3Zhrs7P{wi9vBpzmHCPr@%>I%;+}4!Q(nOwlviA`@pkkGzW`DtuDAdC zQiq{!o+0KY@-b5Tb^87PO(tI|Qt9-u$MFvRV!u3p&o{^YhnX`b;QgX3RALjxTf@1$ zzHpJF^7ACKJ(r>SlTyek{dCtB;lbBi7B=?Q0#CVK>e~9YR+R+&(*0aXw{owVD5;oE zrn8KH#d-=6b)2Gi|GHs)clscO%G82iE@a|L%@+SBKs6Ei0+G51tPGr$Qk_LpK#@#H z6pEcYnH!Umh~VL2=i_6;B%`v35bO*{ z1d@ZJGXnt|;9^Ii(HInFR9af>{d7uPS2+_ZuA8B&v!kRw4!MQ?mkY*RGp8U~SeQmx zqka~jAX{AM?;@kaE5@U=O{ScZ|IWIyxItWSQ!kmtqalsf6 z+_^Cz;%M}{HEsr1Y8y+@r<|G z#%(6Pqj`la*;s6i5NBF0H3d`T=aSS_RBUx1-l7% z^@t|}>6+zz%wP)9`q-HpNZkS^z4ecC*}UAD+nQ9URL4w1M5=~^9LhKePkk5c0qFC3 zkW+3xgljWfa>cqB{c9-C>xcNcA|}P^bTsb!W+(YH2D0|Rh+(3!VmpC%lGosW+ z=OM9Ay4D%fb!A?!lFYLvHieC&%!EGhvN|EE!z_RXC{3cO-IDb^FWY1*S>+>B@tG0+ zfmBmpGcUz}lCdwCWQ$lRAz}U{n6JWL$X0Ga$8w4gUV{37+evf=yjsO-acDMU6D?S_ zv2=z$OF`hGO(#FPq&#^&FgDm7!+4IQG|O^WSNO%)mXUpde)UCMrImU6P0BhNdx5L+bt5P=k3UuiL9p4 zO%W}bSD)rY6E18-8+C@vSS8w_dm)S0;$F&6ro5jYCOExhbyAt`JXgiDDB+S-FakBD zfqv3Qp+b*e<#}cq6rS;C?O`rfv%h-(`9kRL}`TAp)Wja@&IYzLSKoGFltM6O*+M z_aaIDDFQycZNaW?60ysUrr~BW_jMBRE#-)yyJw)^Z7Do1$L1NyZqWEK(2bu$8MHZz zv@Ryo=F;7o2v$_=G(QM@k!cW-Q<-`Nx^1>|Kk+QDKkJtypOAVz^^#&`wcF(;3P1CH zfjOq+_e&VB(EJ$hgG2s>iptcNoA(=9HPg@Rv3}g$rFh8?Rr(2g5MsCKJ#23J<0$8+ zxOyr*iWu5`#Z$lF7sF@)epIuZke13HGC!kkk6|N7198bxlvM~vyJF)$3t3t5lU1~Q zZr^_U1g^tNkq(KyuCy^)fuCr#vPMC*qM8WrsRJu&I)_>x?amlMTL%eR^=Jw?P)wbV zhRG=>pDdF{VpL9ImX>0N{cc-7+|M6|aCCQ&inM9O z)AAFrbT*xDRqn-u1FPLmwGv##Rx#oG`yUQWD}AxX;!n%{vCZOMcw?_=JdF%8(+ z7*Xlc4)&Co9J1@j+?K|J^NWkkvT2l#*c#5uWK9L@1_rPc+@^@gMn}q9tdt>+?b%Yy z-q~!)`I#N3B97X(3!5gwy#2;gD=DwTO{l)gU~U~3e*s)uHY6sjQ* z+ywQt0cV5v!rsPhj*Lw zC%kzh&6o;V^(4#~`^`NpCH))-NR&r^yv;D8*p**ObnHk@n;`#sS({NGtSj~CJiAZR zo14n^9h~4~-dSS6*5=}9TIoDK0QdBVzc4Nety11>j~}v(B1z)|vmI5no@^R!-2)wn zIT&vuYm^=FoX1iIE3uE?po!63s4=n;nI*|%L27sK9?V3`zqg!5j6X}2IVhj~dW0CS zGy4eM4oczs>vI|z9N^+=P=(yY<7Q_Mk@boMMA#hphx{LI&4_BrJRv?E-ug^$kD7eC z=(2FL@q2nEg?U14%ilAqVZXZ)F-ZPije zLslk5lJL-47i)#H9##pd-ND!}*Z2z}l5VIKoQY+btfP_^SQRx|fN}0LV(7m}wP8Rm zP^c}p&fV|E={~wQ2D``aDYr4Ufmrvw9#oYp*foJrMFD31Y-Xr^(R9(#|Q=6 znp6kGsFjk-tGqYTSx#Sija#!{hsMZ3-zf^sww%joHa8f{;loIw*&Y9+G{G*xeu`~z zRsg(X%xuc-EV$3=BzyZb#$aHG6&#sE(K<)U4Hn0pRYaG-1Zu&;Oe@ zd@i*m`E0G2juyThw?8wi8Cv~O-?jSw?^s<&Jyd3B%5z6z<8{Jg#(weUM7JhPPx>93 zJ$1y`bE~wzY_l#t zvA{mBmDt$vO%hDhGaqC)d|Is5U9cZ}|lqUx&3i8pAQe{9& zNVfu9S&2dJCP4xW!8Vv^18&1|+R@E07y{rT@Nkj2kQyf17s5AB^~paizT8m1UBSZE z4^~G2rGa#!A@EpDCj2AG4YGC1=96kc;KmF9r-aBlQsi5Tf^?<%CBYWbU|kKcsv|u4 z6xeD5W6x-%D;RP84&1F~i3#x97zHfEf*<1=SrOwNAO2?#)w;{5e&%}tVfO<7T{0KE z4%yVsuJ{6)0}(gtC-Gt(Q!KybkC~TqO<3SKvY_z%wle0dzo`R)%tDe;hRAn3scO7EbM1e$5 zV66ZbF6W{*WnwKncJ&RpXa2Q`K(8`EH%#&h4I&cCg+!4Q!{@%Ykc?VqqUC%@AtzQ* z&6_%vHdINRdl;V5b4Gs)EhYp+svLE@%`V*pEL9DN6F}Bgrjj6|o04DxLEz$?JQasBx19$<5xMW&_9@K%sP#YV2 z9>PygpM%Ih494RM zNZ*gGsOO3u(zL5!*hbM03kEJZKb7j{|CmVu)(u9riHnBZ6wUS9!Ade|I27yHS?#Ke zEdcm!mk|%~N+j(-`AsD$xh7jE!wUFWIN$bG**GBwSON1~iQuZ$;;fLK#YHof z+p%sHi}XY_xuWppEZ=pr} zHskHl@O-w-__r&(^OTKjNjszaw6dd0&93o2Qz{Bwt?tjGi;upYSM9yWPQOr{IxDBA z=VOkCT6)D#VQc<YHTud5!YGh4ts!>7kaa>o-R!vpG%2=y0+4yniN2U{G32~^gxaE@04?=`lex}o6{ zgG6aBtUS^(@&lehlcCm5>?nqoG(noqLM_cS%b}lJn?L9Cf8HZPbJcH^UL*9DoqgaK z{$NX37JZ*?7{zgFF<$7A>a_K4hCVVdg5~5>+Y5TjOJOt|^ zOKuuA-{djORS1u8R_UjNRylM|qJU{CA#uP2njH&OpUGt-WFA#iW$psgzx1zaZt-F% z@*JO=CaB3_5jr06cQdipm5iTdJQ>WyvdBsepohN_XyLlWPDe~@))6u>NKFKw>)-Sc zU~Qa@TnxOwer92vW%Sb@!Wl+e;Q{2di|_}9gjC$ zrHI&r49)=ER`=mQ^)F6)9o^{bGF5p$sB$_DMMtK6KVy2Z1;1$or!A&fugIF&L*kO* z48Oo%e>~AhbTK%5eV7sgl4Ah&?%iV3=ao{GcD$xwY&ZK?|0_E*70@)uaS>-=x6xvL z<^2PwDS9}97XEw|4N8Cx?jY}CAa?=C&%Dsj0nh=o)SnJ}kI^m#NeXx-6g30PpLT{< zYqX--s05R@vY;a6LIDX#gBgtVpu@?q62mMDSEjhKVmEcC#L~e&TA7ueKnNLSe zgNyI$Gz!yfK_69gZG7NnJp-5jMs4f}_f)ovNa+)XvQ#IaZ%t@xq{nclk8lL;vOtqw zeTOati$>rxm+*=HRs>ZyBNyuJID#=@hUR}cMB#J$@Lj~_i^onzW)}UnI+8Q~-)nt4 zJj;WbJ@wUZh4FNZKyRZWL@}LY0Uqk>JQO87+_0yMEeBALgvgjc&R^JlS_g0W^N9N= zdmIgRjHDASB{rfg-||mB_rLQoV1j>0!7LG0l;foCB-WN>NGNaCXF)yUP+gQpJxJo- zs)+s{M9wi0pCEvQyO9<@)6!P96(us1ota=2C{*@M3_R$DJHWU@AH*zr-8A@lGNL4o zfeZ6c0}Ym$si;0+`z?y(`DLP%1iPC*eaQsAn@RZ1s2_ZLIWPheWt^0PjUN97meqi$ z@X4*Yx^+|rJoo^m`fQhZXev|@^tRKkAW#GTfvaqmHimjk$s*#OlyJr_+Yi35ka>*w zo;-cEZJgWcfRJ7FQtA%4=30g7#$nX6-y?{nWMmZEq%ObK!FUHJ(qv>#7S+0ds%iW0 zOho!}8NRB-dH#;?Of|SW;`Ru78Z>3VAD-Z^KV%2h)o65Xd$gQwN;eRUXa!tTplgEe z6JXURp_s->iKxHog;;edMPHbl@TDb`CZY@_`BLPDh$!acN5F&-%>B1xdQ$}2&|xTk z-tjMo^R5#Z&{(El;8H&Y&R^dPxik<#gePO^dMjn^{s8J%H~Fv>11X8?rjJjT$B&Mf z&i72j&xw%%u=FMc`dy7%r;uzNy%=|BSK;jp!TWEVLdja@uR3;Dq_sZv*}-y=w1$biKi`Yi%18e2cWnuz+GzY zQC7Ih$_f$p2v=D)&@@L@I7*ubM{2fQ+3q+in`oWZ>G=Km`}h6(z2573p7*)$hJyLZ zS<*i|#2GUBa5+|k=W9Kuy>@b~DZFZ6&MXb)dx$pmUB{3$509SDEjUDbc(RexVx{53 zj57R?x^*XWSi9xIwq%(oX#3yO(OqT0hL5A=3X2Khb7hrnlxvd!BI+wB`*&+voZH3fYp9fU82l6tT2IqUC!hpgYhXm;^|2a2~HEpr7g9h_27>Hg&OQUkJ${LJ>D5mWKzyNvgb^jkA?pZ;nFHS^?eaOLZ7bY}R5$?Oh? z-mSM;R#|4QT1$zc@%*vX%Jm}SY-K&^@%9iWxkmoprV9mvojvOdp5j;A;cj7UbjwTe z)}WZ<^L)=70^qy}&HFn)3-mRpS+h)e}c;_l-++ht2qFAa`@*iLIswujZH;D?9s1} zUs-u|LfTPRS#!wJ3FG}?c1n-fahanF@xyu*OW9GZX0vROY+^?P6y zNj95bs5Zx?(*n%B(I!Agfp)z;3K3~gR=Jg@^rVX~@t%e+R-uoV#7GcASi0tVUY=4(na)cgs z2~PqC!!$K}?kbAA1i(IQETT-si4}9J#;J> z4Qe(Ku9*+0KhBPS?DSqT8z2T{#Uo%2FL~}rYjppBIvHs_V6~Y1X z^k*ng)qg-l~IP{peGtmNb3$_zcr6H<`bN*l;X7gC22OJP5$-aEuQa|+b_18RP611xb?%uYoDKAuu~i}AC!~v>gHWz zO!du<7_SfgJwsuo7lWUte^}}bbs}%L_NMW|hO|%Z$_*P=O}xIS6}_xq`*K@+@y)%z zz^Djif4hRQ+Z=ggUKxmSXQU-)O#!qWGeyyP2&=M>nVXqU87~f(-;d2zsk>k7JN6*_ z4uCm;%Q$Y8a?~DqX7S}4#D%+;Z;z^3IC6Mbp2#TUEcXX#hGV55;)$^e~J7X1(u}&?+guvfe2V- zePbk`3bhccz5IdyePzIVl<>rMZ&wj42mpXZi3@^M^yZnyTFgL7Q1QpP^4Fid_UMk* za(Ni2p=ayn5AD%T(=FxyMJyiLav)bjTvxm?jqFxLG@2+NBQUUGN);MG7WUCDI;SQ~ zg(3fp7UDw8)yY4k?CR{jo@Nt;=XcOg3Wr(DzwayV}2Gc?O3}jH+RUgfovHMCs0Xl%x9_ zyrwT`?-46hJF;`5BNX-&UoInmRiuW7(4Y6$^(H1@Cf~8tK%B6Y)lM=u2(+KFL+AcX zZ&R*Lvb6Lm)l&5uGv=F5cpHrW@3b~2rYT8f%|hsB+6UbEo^2f2$&k4B=J#w}jQ4n@ z6rq9`a-wYkbs3Z!AX>_6i;knx8%Ri~=J4?Xku8%bMy&0Hr6qGrNv(>swVz;Uc^*@` z`r0iVF6;C8iZPp$ED%?6j}EC|+)E>!ZiYO*a4A*qFRZ)`);Y|rswJmNeVW?4$5=8Q5(72_`m$Qu9Mo)TO7=vXRaV74eG?d`Ta+>~cG>;r zs${y2wRg+1i$=&ok8Yphux$+bg=1HXZkTVIcQu*t^n4JTIMKC(VUc;?IFA;1ww^F? zBYqa{O7N>Xjj(Nb^aq_ftO>>><|FhJo_7Dkcbax>f^XGOI}~~vZlCkG%*#3UYG?Tf z3{M8swC1i}4J#8mCL@mZ%)*)*AJ;p_J<)tQ8|khtUUim(z42h|ae38)=zG}AKRX<6 z)770$bsNC(BpR)5Ejk)KaiU=31+6;S(1v5oSP&$RW#2RaYpZ1aue;O z17d4_GJeUwQ0R2uxko%)z9-^t>{~p`;uV#t90)uk2x@j9J=kVE)xJaeEEikDQrTQ5 zayr&1#`ZB>&J?G8@vQ1(gAR|PUt z>0b&~h}CNimmtTN4Q=s{dD|b^AoD)b37G#P5YcX()vurZCYx$YE`{IOdG^om4gFV7 zhrSCejmxOMFh_grq=Jzop%zRhL;QTkIw#{#tJ^)-g7(Ilx_XMXyfxS(mJD>&5hy zyFAZ@6>mvvI(XHy=#Tk`=xnHSoW?aL&JsOIa_{WGDdOm<`v2-Krn#j5HSlfdn)ANb zMfhtQ8z7FDeunmBuySWY^WC$zlXsgVwj&&#n+!(X1gE~%wETJMmM%8TTz+^ESrs|I z<)TKc_1dj;J)^)ZxP+CU4>Q0N&~5`MxQgRfH6lPjAna&kt^(4X zU~^s)g`3o8gQDQX{TsBA!;9PZO_1Z+aD(xnv1pB^MM$kI4buR0baK9f-10IFN*Ee) zxpRCB_%SghBgDT+q?!DWrn3aAB_t{VU~zFa%qJTK_LSR?pX;P4lHMC#`?6qEXGW5gqy_&Uy!}2w7tck?s4lz5gFp;Y90d{!sL zp46bQR~<&VcZSm@U@ceFwU+$e+0ls!&cBo@LrFEG@nIU&CWv5*c?&!C>RvBktv6GQMJ^9a~&^lF`KRZ&am`joAc)Sz!y55&+;~GUPUp(pqHn`49L!i5w=SVtd<3nr~7gjfn@G~yrQHD$4*%%k(h$8Gu zK?t=$=Y=pnpieir*}#5f&7BdGm^0{+@zZ565OKQ(W|W}eomkMONX}j{zsrXmSxi6c zT{$4%UKw3X6&;_-^@6hiD0ru?r+&(@z$z~oX9D7)^fheoQ4fUB8wx%ws2gZOJ;&X8 zy1Ak}8%AZpil|j^I8>8_n5itEpgMo|X%$s&Zamo5e6T@^eSkA_LnrLbCi+N? zm`MfgGCnd*|32C^M%&#`26d618fLnD0Kwog&;T{<%d5^THr1cg5eJ67&wQ2l0{C zpY!>U5tr{}F)D}p35hlsBf7BgB2_@Q2DXF%IMB8V1&5d9z9~0$5Tx(81lBD^ERW-K zes0+`cT%Y&o-KmTh%{CdJZV0npK9a1pRtj7+$bQ3cbETYibog@WM3-$g3nYmm6Q0KrN zGsr%LJv)nhn@H5-q1r;uLaHqu=93uF$!2D9^`}_8mTk+OoZ{$A*@5G0xN2zjHFd2E zus@>2R8=@;Hf{<)Ag4-FOfLKycS_xH!CZXdw=nL+;|qTsAlGAB?k$}eIk|i6t? z?`CV{k37#QgyYNsY85!6GaqjE_T=9u(Q_x^3+=$tbvjRcNi0TuxZeBe_a&&wWk3Gq zAJ_dcotM4FFHb_`_sDYNMuXVjjP12@JGoqMT<)xt?*s3|zQDQ#bsqVK(zzFA`=nD- z*@>of)%H6UIhdN?=n5rl@#pYbL18xk`r6&Y*73leG5D4%Fz20mt~X9vp?lIc_IR}P zT+0bk6xC z(dcMpZcD8$hKIgG9L9}pHFUF1UVfG)%qbb z=;@@>WhnEIbu~hj`to2RJ5VKuMFBPXfc`32lORUs4C1~!dC0d*_Uad^m|57eRqKp2 ztt|$-0Lx~?g?X?y(Y%!nb?1$J9S2vAYjhLW@sU%`Xz(!hUR$e%E4p-EYoJ~SDisv# zq|$vEcDFLnBLh+W4Q>||6m~ORSJ#lrh?wi7bgu{43Fi%@d|w$D zcyGLUS9q&*4;$^=jVW_ig4c?~NtW3iN@)@K8r(Y~u%8mbsarDzs$G=MQOIcV0|Obfn_zx|rT18138NwjLGib=y9^W%3h3d}oDydt zlp@j?h3Sr<>z`NVHi8l&Ln_c9b^b25tOb4-(mdNXd2$s@;2~2zcgW^Ba?itA@0ym9 z;5%mM(^Fui5{zgBkEO$Jk}qxU!8#cv>+WmI$}^a%)RWCR(q)K9zNh`n*@9MA5Ly3e zG*MzQhRBR(uzeV*iNV%!?~LW>PC{XHTX1nmgn=QPm3Lt>g6ITQl#^cR+pNkG!?n%1 z${VfoYwAzwhFs7?_Df(G{=`6@#LXD)YP~nB8eFYHe}bO8V&n6SYLhbogq4&CA3y>W zkhnu70Sc&Hi-!BG>1hd;$$;L&*Q+)0o#78NCIEVHa@Z-*92>Pfs!#NQX$l)ggJN{A z<1fr1wCCW%Utfrof{h%%y&q3$3L(9cT=>jEm^u({DPEE!6G*UqI^f-GkCY{RFed1v z`CrGb%rMWGXLoYre$m;+0P(Mh03XF<2G>$G|BkvpW01Uj{O9Y`RU7@{{g|%b5cNTc* z+ZUYjoBibCj~pvQf87>@oZItIUc7F&&83ihU& zQ_xA1l;EGNxQTVN5Nmv0&v@_z`sx!{E6XBn7)EZ^u(ZB@pY@dZm+Mv)I1!2^ zOTqPqz-8FU;;Y!pwfw@%2NV6&zh~Upe*)wsn)PAnU(184M2xPnxT{dj;3X(9li~<8DyidiHi}d2cnX%GI#R zRj(JTOSU`N4Y%YTHE<3vb~ZBda&|U0FmPEgencjF6mqFlHmyWv$2>)9VjlOgld(Nr z7Z2z!M_({xYI+;m(I(kGD6Fw7L8lR_--oEVzKOrR=d208Jj(4RIX;DBZm!QP7TLozf~#v74iA4k=V962*fi6sEF2t$UgTMO zsICM-9{lj zKdqr>5L9lvr5j-V@=p=h`DQk|>CUd#ibP&cEd7o3mdM&!Z3%-@rMai2ZnT zu{6uquJc-Q!;x$KSU=-PyDov<4BcKVJZc<>NV|&%Z?;;Yjt@2(NQEAosM&j=xY<^o zWWR0gEZcIXUvO^c9|BV{(z-o^5l@8O&?1e?32HezzR585iLAHbR|$Yl*G? zAP5$wPMVG*L2s&(`oq|n>5ppcZ#8!y$YvI!95b+m*g7hBwjX8CcMcr*xMC>}89Ub6 zu!!dB$7)^97VH>W zre-NUhZch;Td)Iz_qs#Jx%(9X2Z)K-E$4lwq8HE>>^-y`*7%Vi(p&YNPiE`` zF@-%MxVhf=km;$Lo%ZVPA*+JzkdHn+LiNuI8UFXjxr_%Q)Pl_-9`x# zBvCtx_Qq9+^3rmmAx5lW#yjg`)X)b?^_(Exf1)YP*d6X4J%G!W-dJ3GE4m^#a6c2* zx)dg~70;G#Q1!gnB_%Tmgi>U@Kv&Qd7dX&~=IMIgc*vcF=!PASC(Cm+bD$;Z{ByY;c?=omcvqPJOWVE$TeTz=G0ReeV@B)5|F zb;oq)PL*cZ)IkZfqtK-(_3}aN&(|geL{~DlF~@c>=y#?E;`=YJE%6qTKf?mI7+c_o z3mf{s-=X++s1gEMEFaa#mO%Hu--yg4+LN;-@DM4HFuhJGo54`4)LpMA_h5N5Be?Uz ze9QPz^#{g-Y2%B*?PIdr>2;+rrF4@U-UB_t@yOG+b}f-8uoh2-(DzkJ1Ro`Pmuds(0AS=F-*K~e_qYtY%5&;&mK`#&H<0yjtpCmttBR-C)PISlxP_({82#gE~;;mJ$`ogGsEz=&WlOa62huM4oaoxze^N&$0IT;?pdYNP)HOJ-cXp+Q zE*44reu_*6N>OIcBpBndiB93q-D`DMy?tJb2HeoUx-m3*;R^1cvSjb+N*XHJ57!{28Tf|#s6Kj3PkhMg3-D36IJAWUkYK$j69f5Cc}D%95;P z$MsIJwoo;;TRGCU_Oz4Uqr1!cY>j^U?QKvJ44hZAICbv;V;tq(S{|V2*O2kBkBmM1 zeua%#?hv}%u?_LJG8l0k?h(r#BcxXYwftU!C1dwxn5UrpG~EHtN&iOA{Aa4_snWo> zp{ARbL^k5YRIZ7c9QJaf?~)0701X}1#ou_c!`05SGD@`RBS zABV7OL^F@uWhqyy*{G=e3rh^J8qfPivy)t`mprd(Uv%(gIqR9RwMG_`As+MRwl8GM z&Ussk#UoXc+OS#`4{vWwh+OA?Yqs8qYK$$s6qYh za6|5my{w_Q36aYCmo7#{GEsfjef}2DyJ*|eB2rs-$zc^ZBoNAH=^@fv3;D>;2@0(N^W zTbD;sB?VhBAj`nUk!UljoO>xGoAeb%rZ`vHsarHazpO*I0<2CnVqOz^MM?{4*1s8O z*O`3VOl8%$!FzjF0byhXD`19?6Pa48Pz&2&10`fFwkn%yZG@Om-!IA2>hj}f-P`ieu056Na}BM!bLNx3%{H#|jx&+pg+#tVv z$UQKln(9XUdWa<3B7kx8`csho>wyfD>j)>Yit_8UioC0Y!$lQoC}*I!>M5+oQT>=B zsiU%ZSzdf98FB_z!X}oy%R)7q*;84Uet3?hmEBo_jQw0QBt4CPL?{H~^dAq^mjcD~1}j+JxegZWL2HhLA{%${_rl$?X6tpEKLktX z(QqxY@IRj3y%mU?y<2}Y&@_bqay1&qBnpbUR&zcu%^X z#x*K*6~qR>bqc?o!0iUn={$atEc{ xDn#K3MuS7eddpc_z2pT8DW% zL#`lN7JbvlOCXv`wEmNXcv!q@BQO#~>1DV(D=mycV2nF-RSVIVa)_9QEKq?|tq0eb zkTTr9XqEhsF?`2dOy(~v`yVM3vTt3AYoddwm4}bdo{YurYt-E5!y_K-N|(>s_40LF zyD7_Z$8R`%W}e?71Gp))ERpHQe$^>w)As#CBc^a=ylg3Y`)j@~bA)u6-$E4qTLm{GXgcIRGLU6$iLuC>P*JZr#XrN%@sCs zx|ovWE2#FQeIKV2g}PYJ;7IT8~QO1gt@ByCbzBK1U`%yF3p;} zPw3SgjKD@?T@CWnWegLNDDC8|`#?s##!1Vo?v@TfYdHhG;e^K2`NPAc3+ra)`dWHD z_Zanq-g`BjJ5|t}Rf{%Yzn2mgM9@HgJMKyF9$f{0nGdCWhjFCncn5Yhz|NQICNu-H z102mTpiv2={lL0ekghN`JaIs53nO^Rz=UZ8MZR~O!btwPhD$>P%0P$ ze8rGOI)X*~%LOC9#H}~6Tw58W105Eh=2ZC1G4yx!x)5z8ANrwAual@_6ay{w+xTaF z{h@QkOB|Q$v1zFVX_=yHJC3+(F26+dFmdOsER}t_UeY(W3a}NI?8xfrD z;Rb^G5lQfvy$OW@?P3@+EU!(V5i^2{BXuJS;IAmS-Yh5u&0Jt1RPrM`17RgRFe6UA z=m}0Y8b<|T3_y5;tLE4GHP_`WR_he{TE7c5%?4D8oHs&9GDsgbnDC^V% zW#dsB+gB-vn4ZuV)5gPcFNq9&Qw?790@>dcb=qQIV**tCCfKJ0YLdr1DCU`b)a&ZX zx;uj?91oOPS$51F`Y|tyh+&&m>MhT5Is3Rd6X~^s_|AS^Oj#KIrM8xH zhS4Cqr3!gr$ojo5;sbhM%|Q$|zUd{C3`lA`SnN$pO9PVGLn*q0_KZP0WQfD5L8wiK zbBC$x9}CtgeGXF4M%?8U0rO3b{<1=IRllQ2x^sqgEI1-5^b|B)-}cYf$Vhr!G(9gi z6%n60d|F82Gz`-e!@K>1?Y|*1{5M5M==6=ls0|}IFS$pMHjf-edwHXUH_w#NVP$_{ z6{$EW{q8&jH5~{&o?~;eg?LIog#FLms)iHr=*%=V;Xi7^Q$>@>fy~@Hk*{K!P4q6O z%q5zUA-&^K8P-tC;}0dqp|zwN)$R5UYUh*w!9+?n1U=_EUvs^g8&$#U>R{VWTp@t9 zylm&jR_pbXJ&&x+9c0* z06|n6!Axye-G&PqC1`w_Bz&osdet0h4S4b#YF8oQ;wu`LbnK?F*g*Ur4HYa7>9 z;>@&Zel<5c;EkRM#-Js7lj=-`Ntzy4p?%)cJ7JE83+#OJRS>0y0)O8>d`>^y9ng`Y zQ*klpWqcUI$XNuL$b}Kd`Me>QY6Y$?&=7oLFAlA3br)}y)?g$Gy%c$W8X@$?;4B>q ziSnXdtEda!hi|2+Lo7~%de?PQ)wxSe8!FPCE#_eVRDSfvaD24*YwUA*;KVF76 zloVcT`gam}ZglE(F48y-;>3z?$<>5_vP5iaUE3>PvLi zxd&PI(NC;&?};$C@xWoF3g0UCw_V)Wuj&I0R|7SpUud04sI^?va%UX6d2Npvad3xw znP6vkQb(P(k(h_GZ?LOgg=`2VSC+)sbXqO{NOH52`b{lK z&462+`khs$_^zVguM(;`z~|Ygq%a*1ZRjrFJd2nhi+!)Z@rKs7h_(~i|0p{lm9I~Y zi?0CqkAVcb5NXMHJ9HQO0=?UQ`pOqf`<^E7!3PNXziawOmC*aSVB>$TI(P{Z|H0nq ze6U3poR5yARO<>~<1|@8_jU;aKq?59d6`%0eoCxY=6SNzGah3#O@sKUT8Z}}CBl^= z`PZWSL|fkHT2`hJCT$&gDEXir0meQ0bZ+x)sc)yE|E^on=TL|A^XQ%YA%!Lm8|3zD zlEwi3OqKqzfidOR%G4m9|6M!L`Sx|D@i6*TiTgko_ODyh(1iSyd!)+08M_z1GvBkI z+XuV+tYJH9w7?yn`)9bU9p5&1EkidlncjG|Z;^`08mm0;>1B9N7mp)hO1?4SvKHC7~^*tlhAZ5*YR2or=G`VXRUvxvyHuIe_28QqVv{=he4oW-IU~J-^lg!^-TtzW( zh0z)%@Bl+^DeOcz+54y=_dty@x3!>h7cJW{cpy$9jq|P^MNij^+&A5lT@z;a6;{#d zbxJkHx+%YG7wPsdS-4Gq;Trl9hyT7`0+(Efb5nO>M;s%T>&?1P zU?#BZHtqyJ*m@=9N!P9q-z_7`#Y+#Hw-wfW>&^bknZEIMtC8CgkV=JZk#u&Tz`)S+ z)X!&R&vHA*1JI3oUU)&BrV|BQ)!NGyCwI#4UM+@Qd3Bz%yCB=#eGl=E36(NH z1s^p&b5|)w+`qd&FZeYf&fn5bF>}oR60vgt@mzlZMmG&O&flamF`tVpiVxLyH6?M{ zJdd|U>-aCW%G%i69HBSc`_*i6ntPF4a`-cJ;@#GI)@nQDxHne7U8->}#@1D&OTq#& z74DZq=BGKAZ&k^_&1^g$=%!}!ps0W#Gl`7-Ei=%3b0y$`4k^fj;%{9N=3!p#Z+Vb= zj4B!@AD;`G#sn0hQCK)S!F%6jH2ZE#=^vH`)!k(LqZ*ngZo5e>qinUsv**hbTh?n_ zs!PrqXeSkIthjI#{SR{sL)xQc2N=mFBR8BCf%;k9#07Ux=DOp-`IXJwz}LAJbupbTjqU>qwlj}38(f8cRu!`_hS$HzS+hjSw>&vpbrH< zpgnW#E%4v+nxrYQ*nQFEFT8o| z`yV2f8oN1W>D=Z0n%4j_s67wbvCvwJ#I{D$aGST(h&-Bm+tJY&isHF;bT5|d1Hf5| zxoR2=b1{?})CCK6`|_)u%ve`*ZqoGOb($FvvWhJtXak(Id_q@C>NS!47}RLZ7-B<> zdy6f0gZdP{vbH&LwCK1)jc1DEm296qt~Y9FKpW%IAnp30g_Qp_+&lAfpJDo9i|Gr> z3zFj!)2`N1$A=Ml`y*TPeXGLnn{4c_F%kez29ZE_pLC&ZuE*BiNq4S`Qaiw`HX&S~ zyAcM=ePz1(A<5Y^SddDv5|W5l*=orHVi&mp)*yF1HEWBuDj^S3=k?rwg5u=!z4bvw zYT__9Hkz~X&WZCjzUf0If<=cQe7g#jz&?6v6E=W0Z6PDRk)@&Kmq zHH{0cWxJc7Pq~2RPtTAB^dRhFwsVF}hvoYe75KJ>D(FxeY)Bu>=9nQ#lD3y3Scw42 zPJL6V)bs@|rko^?sU9_2*ZF!NUz;DuluetzF);|sM_(;=G^*@|xv_?5Vi3-}7RZ`? zPk=+g7I4{=*Q4Ji=godx-!|s~r+BNz>;~G?MnTyB5xhu>%1Zv?odhP@EOt8k)ZWuW z2DIm>yUuag9c0eFO{ACD{mPqF;8a6?eYskntqu8SG^e{}v!Dk95O@no9`D*5UiV6~ z`W_ux`+Db*cUI34{eO}f=!Xy9T`~A(9eXYx;nlXLF<0V#zd&%HT9iD-Zu8%b3XI`M zHV>|-_j=1tr_~qu>-{c%#QPe&ke!Q}Y21|jZ1F54c);o3^dSub8K%Ah+PH;uJaK5q z_wvqZ^hr{6R}KrlU^aj=0fl4*;W0~LVC+e=aWX-x!SR;@b$GV7q5bU4Q=AY z264JRL6l3A%m<~PLH3avu8krQ>;4uQLK(N8_g6GoAi zMG|uTpYzlI|b=Hm8te9EB3!V=2hEYe!<&($uu)1GHwx2Wr|c@ zjefiDp@31#%skkfx2@#^9=0hg+&3Zsw(e#g(imms>T-<<20XMHFgfa;%-Ek;>OF3vJrUX>v2CG3c60Yt- zg3ka`2AeKZ(N{)^M~jLWHn4s3>FMvOuIUK4?le8@Cm*een6^KlOo-9>4nu);FL)+j z(~yeJHonuuWh;9$7P)jboMcQ_p7?mI^v1Ja8L9HA#CO{xKwSsYksnge_~7BGqq&<5Ve_?iFeSI!V58=I=(|gN3)`DUvlc89O?K|S#&+A@QS|4iw z&gRR2TOP#;#5mkJml-Cr5F(DsyfIqz_h{`ooUTQdxVgZ1 z`;*NYDV_PMd5X-ffn#ef1^+Rh%KM0^t8LY3Qzp7*YHytF0naF0)}H%*n2PA9hGqHi zfS+tNLYy9IRBvUW=pzPJNvNli4iQ=DiVA8d9 z{i`C=eY3qZW$333L_p#VW~6Griin*3gdy)dYT3Aq$YrdH1>9y`wJ~rnp7!e)T{}~R zy&OG02@X`%xh_CRI}beIz%PJ2`lmRGNej)@J!fln+$TlopWC!7QvZwL_Tan21);mq z_{NQ@+o~0$H3-Q=%m6%laFdf;@+U0fCUU7VM*|!C>)dTzh4rTxK{221DAo3tdV3SG zBh}Ck82IIhz=n8RFNp7+d7Zzcq|2Q;OI*bJBQQN zTAGa97Iq|ZZTC&`R~+18@_gKt5PZDpxpat&aTLv+?XKxSXB_76_AV$9mnp!VDV$3jR5efC|C&F8mDxdd zIgHz8H4|IV30~Byu?s`MI^z;1D*QZvXFqc}qmZH};Epvcl+g#sJ7L#xn!YT6M?Ark zZ=^~wvc^EWS&YdOuWLLT$x`)lFvNRg`;8x{qm4fAp9Ip?d|1^`k{q2;gv^E_?#x#I zuc2y7sNI6x)X&!ce`JYOil(QCU_6T`Xhn|jG~5_b9FU6v z!`RpcaRLhV89%(<+5b0%6NCX4Ea=*{P=qZeJV2P#B$8M#j&HUGzZdE(*a9xZ6ZL~o z9Twb-3bC1m)Q8iK&Yx(m@p?f#*|dzH&l$M3A=QJejHve{*1LD38!8PB55cZ2 zo84H}2vl{bz@7@_o)R((M^ZN2-H*Jd13XxUJW8q3XCpcUr{4%QepQ|RY_k{sp7!@f z^&X+kApeZJ@XYe^p^wXFOj@|BzdX>Krt?-#lb%L429W<}^N zqEMq^G}xqu99d=GKknvK3mq_pe*H?eFh`fogMVCexj{62$ws6Tped zYVoW*G4`7n<_;=!7_YeoLNrL7e3g(r%~9!C4LS>bxi4(<1P;zi*+G)}<~qdJYKg}I zy>al?YoXk6H}(EaH@acRN1!fflkV_i627~{=3HNEd6co1s;QQXK;tMi_Jun$H(rKj zAq2xF+#0KV44wkI+$?oWNULS})D0})%VZJf+8sCd;ZPVS8Vjg;dhj#F_Fm2Ip$k<g~5NX%@ zFGfQc|G5{1aK-s@!3{oSHh$}^w`JVwvw?sy>7I{xb$%@Rlr zEd`36MXlICt8$Uyc!KA2^?O!;##5PHL)Ylu{kGN`wu-~#z1?u-7X5C<%Xklmv@g&fgU7LGDSUdhCcOv@jW7-~J-_d`Lz1%+dJ9nDc3sU_2DeZ*aehh;SOY~Q z$8N|8XCd<4+rW2)e*cU1x6!=xwY$Iz7vo~1-}ODjN|wKLCGx{tQOA;zq3B2%i@nxh z9^@H^jGZZ*;}y@22fdX0EBs7~X2X$Cn!w4g{g)ZQ4qewr=*)#Td1ySbE;F4tXoar+ z^foZ@eK2+-R(Ha!&&&4SJd}y%=abwMNL2h*-J?s@T^SI)ajTMkb1(tAY4Gr=N~x$UB$va{z_CenkI~KmpdNH}pU70sL34x=D%WoVM>9Jb|M;uqoH)};Y zOSNf3juFj%-^b3wJ$jAD&KoMW-{GUTJXzB{RA;QK#Tp+` zw+)GY{>!#X%gy#}0hZw>>C|H=^qcv*RZxm42^Dtd`q%aVY=MzYT6Q-YyxhEfga?O{ z4xCMfZtE>Q2%L`Juj4vkz3p1v)VNGFt(g5Ur9!)$ISE0C?MziQQwwCDM=fmAtPi~; zN80b{9oS|9q33m5{x{>HpY24Q!W}7M3&*F35Vx(kE$PRmq?qSCm|+myMTutQQvNoE>DD1gfVMsp>dU~FB6GLF zUDS8r&nqo&6m8aY9NW(anm*Q=+J~Q$T6IP;#d#2(T-!fd>K2&3G;nXRz4yo~)1BU~ zFM=emCb`?WqmrHufN}aa9{WPecku#dcK~|$Fs;q z_7+NKqgG{jeLoda(B)yrAED+XTiBon-xl3}|K6W)rQQi@yit8P zK0;`4SAkYPrH;`6G`!XMjv|XXbGw1;<JU!l-mmwZ@KSe9eJS1C>-y7G~O z=E8AXPT%Z8px!lpQ8{t&mh@c}EpdoE0Vc=#D}_6KvF(qHO;xbkcJkLYbmlk9ct2|| zg3WS&60sW@?W!pzdN(dbszkbH$mpRyb;eh97uuHG96Y-9OT$r&xR8aO@>!37I+F|S z7*4p0#-IBg-wa6?!9+}151$_$1-LbvBdrTe?3aZJ0+?^mr!RJ7LOEP4}2}2 zEWL?n_-ZFhL+*e%VIAm{P9108hgXJn#fhCXI374I78?Cs5TX40K& zDc1VN5@QOJ$+59<=1{yPLRY+TGqV$atkaw9EDXe-Vv+mtqzcX|$C8Es+PFnz48eSED=_4GK8jK?W1td>XDs!1ek+Y;-Bmoz$!R)#-E_NMrK z{o24Oab2zUD_hfLnIpCSHSa?UnWFlN@^3}5^t9ozT0e;kBfUM1R}UK1sVpNF#&J}G zuaCu8XfoRriwIIE{~5D0F?{-yq&M;>F4($iKslQ{u2!YBU*DZNH>?)u_XI_Lx+Vc1 zga$YBB80sXQ_x4086mn|f%B&Jq|Yt;Y2rQS^&N&DBIy+Lj^Dk5G-C(TTA|W8t+KT} zwKnc$Ttb`#r0VW{DKs2vJAst-L5<<{ zW!q5q4{*PbcOIppA06wD$VwkYQ<^w{dt9odM$Z-Vn7yg z^?cSIy>-7&CXBw9ZPV=4H$zRLJ#nTcgaMNY zKJ9#e{R?o}ZwuS)TWCbVzY%y%eHOlPx5s{|FZN$@0gGV1M=^;DTZ0yBhO|Zry_pk{ zAd1?kC?*AC={me|Iqyz7{daDf>G3|b&3jly=DK@Mi3(=7m5qx*f8!{Z4f&O%Y!3Dj zEhj#GA1(%ltklYDrF7nS1H;674sTD_U|IOD&Jqo}i2GzMa_I(Gl_#+y)QyQt!(3SDG7~_xQkjs3g$K=grh>7%D|6F&o#hQI zKg}K6o_WxE{3lwgCSL31j9)jur~XYhHPEvZBv;p~;KX8HHFBPlAtXr@);Wh<%rT;_ zpXN4sgNi#2%d3-l$ld*4N?3K)6Q)AYuEupllT*a?O(Yn`1Y-SaShXbo^;BPVcG{ZC z?Kr{19llq=7*Ss*AgON_=)JmQ#vEBIUoA5l8p7jtSxus0{^Er631UvkoeJI5ao2kn z7anrEg2p%F@YMc6go#YK!E|n%ujQ)RGM*+Nr|L-J-8`H8o8HF=_YC##YwasTKEOQ+J0e-G`_uW9fs5`l z&DARNlFpOtjF24t=`MfgQ}L7??Ad1?=HIZg%G%7W*Pzcfjk;Vq)4{FLAD#SI=GyYE zcDJ?a@EgGO@)qO=J~{G;SEj=4!wX2Zo%l$#<;j5_zD|1+#){Q#!g!Xi#?e2GrT z7tLId!um|LKV_C*+xBT!Qr6F-XyMzAIjw&Rm>lCzt=-^TBWU4N=do|HZm(d>5Yn|` zNJuNyX?dyUQG@c$1HP(j%j9ZngUX-3b;N$@r~S(7<$gunigwg?hwN05TCU>60Jd|B z?W}s?Gt-JG@Pvie&rJpYsf=9gxtrI{{_tqHBo z_p~z?s*J|DfGrLPiSDA{wnwRpRM&R>Y*2$;OZnJ8?txcSqgJZ6m3h-8s}rYSkXM6h z9D(Becsks~Qb-=m6IrZO_}uykIT%7IS-o7*v66z*;0Q`IX0vFQXrW|@D&)h9yC!DW z>M$%V6VXazU~}Bv^yZ<8`(`C=9jI~7-W)26_?~%df(8<7H6kk)11IG+Gh;b7tifNzsatNcyATh zqlAd6E^hah&v>4Dk`M-z#m@V{o< z$mJlZ8lhrGATO<>EBQQJUp#tV!~NhxbDpom5$z7;XvyMh7oO@+5}{SK!K{bDUd^0T zYm_Hk46Qe1BPYXT6{O26gf%?H(cOWvH6=}YE|8(McVD~C$LSx*;r*TD+;4}dRw>uV z75F56drL5G?%46<$doU1ryD)Oq9YB5e}&=lRu>#n6c+DwS3j@#sc?GAZ?e;!vZSnRyI%iqK9X2zhvTv9zee#W?r^guzC z14(TmM2c91loE~|s)FN5=KmCyF9z_0>A zr2lkseWSxMv^hMWW@e-I-0F@lRiST7lX#={owHR?*9y*9kPVfA|tw-lHt_x>v> zu-}5}wBS#s7KRE6J*9>JP8N1-!P9|~)&7zTKkP2IK(4x~kE!DSQ!A>~qSnRcNZ|UZ zI=X?e7N^KXU$V?Pp{sfC#=I42-d~ET5zdGQF!hc|i9e^1rv$9;9A7S20PxqGT93!DKX3Rck*?e#y)r_Z*Xqx&w4j*~I zmcOBv1l}(;5GtX5a!i*@u(dldgP>24pgj73mi}VjzTLTdwq!kq5=f?@TPeoUy^`#$ zMqEpOUT`Q5>&4$PNuZthk(lI<-@FvOnY`}VSB#$kjB@bU3bi{9#4edbS4dEr0B?ZZ zjpAW%@=eg;gc7k^O&%uCf{XFb$>!7!v-IQJr4m~~u~|9Stzv7W{@3(} zKO(DF6>&%htE0&}QgY}aXUu_;;%ZatkYOjytb;wn+9q5m85=v6hrBl?-bqmx#b9dq zwc}f(YgGV^f3TOPZ~6okVv2GN*g!6^TF=&i2@PTwlM45s9_AfW;ev?UI{QbEUl}1CWYjIbmZgrQ zNop*CSOs>l&Ie#e$Fwv1nj^22|20&K0Y7?Y#n zZfR|L(dh7$17A>JGv*oqpdFCU#`fFYb_t$SuT?^6Qb&@aa$-*Mc||`hoA8xpEsWr4 z&b7a0dHc4g9~i`>zp7vEtEiA0CoH0N=N$gZFkw=R&WbetgRJ6go{?5ly?xr9=F)bR zJCXB5&URdAv)oD8VZ&x*nLLK7iwMX3Vn0)zVL8pzzMRl1f}ILRE$;pu0oeKCy+~HY z{mo(V+Cy3!GJ2txhr20DTFLD(yev?Qbi#;dSl-@5X|h=2;oO>#)ll6gG4;$cVaPX! zCASXfk1fqow>xj6ACLT|a%rFQX@cdnD4{><-6n{7Gkv0Rm|n9yTUTE{G8B&mnEIp^! zj?H4S{ZnI!tlp~$lxpkZ`*cq0TZ&<6uB(T3ZF>)W!Dr9RM|W#EK3(p%Xbt}<$Ih&n zsdKWdc{@6^@QF*7k09tOHBt7c9k^uwZy9$n5PSYn;s7D@w3#WL9=GSppU^hzZB5n_ zP~O;fjIS8<9mQOu>j~buK6q<>f2HNaoJOTTddfOC?6$g8adJ!+8JbpCUV>rz>Uikb z1WD>%JA(H6vb~OHh`2GLc!`LCCi4?wBWw(mHpg(d(>Ne^{*c1l92f53EQNhwIr=y@ zt}Q<kIYl+A8Ln!i6hymQ2m#dn^6 zYW4dK#@i2995A)c)++XwX|KX2fdH%rffff$8uYCV{jCMeLDQ5;3c0VCumew3gsr(~ zD?0jb5B8TR`^#bH0pGyy3FlpH4z5?*K)3bV-(W|()v~*D;!7*n|EgU8u z6<^wCK%NC~f*o|B4Kmc}tVPLX#Mic3>3ToqWfkV7m2+tAh+$MU?z2FM%nh}XC; zcs#5Vcq;S!0@WxdfG*s?GbaEWNc0_2yz3feL`of%)^B`4czL~!c&KHJhh5cjWMW{~ zR#S|Er8YegH^xDY&H7>Mcme;3O)n?IE@kU2zV>UOxaMTxRK?h{^=@wp2oIlxhW>Kt z|3zF8+%8j8E)Xh|PPc0lb$^I4KkAVP7m@8x^e@?=4%MbhBs9$``_@nF{G?fi<*D2& zktJ}K%pB??p5o1@lR>)O{}2h^X*#&KJS|#aY@=P9nkRC8oe>wc)Lauv^0>LM(MSN( z!)kqY@zgLMLX4UksfQS=w6CyiXQedodylCbMHSvaMxR+;#m1`m&!QvFy z4Ti44eBF07$f%kCHL~mCC>D(~>tFL}$^r_Ct%?!oTT0mfuAA{%%^@!{R{ts1x#kP6 znEYecTOA8`9Z9bG<_ps(eY2;1DYzl$kPeH9!9in-f{z5?O>^#hKQK4qcrQ&8C#JF< z+x}UG&cBN-q=Swp@`IV0PkJ^Oi;Yg*!McAz&eu5GU3{RWgtg5OGuyeDeOY08SS$kn zlq!00W$Oz`c(yazV9EK;Y)RF8fkO*iF>`9s%RJ?=*o` z_pksmeGkX~wyID$rljZj2 zPaPL$6WELIJYJmf_H1%HT9NGsL7!=~7R=l)E<5JA#qFh`@nVP$gKxIy3hG|!gZXrw z&lQ;E_TH1ikmPE{I_QVPCDzPPm~+0~MKayK3@jKVCgUwKl22#NYe?sjvaw37-q+{0 zI|lUUOeJi-LVM!^1A6IC4_Yez2JaZ4bM~-{gO;>oqrG=`HU?6upG)_*y;cc6 z5zm|d>w2miGIc`<)8Ruu;=;OYfdfk}-R2JeYmfxq#O!c1dNPUWyNi6o%e&5_HSMWy zlns2VIQ?^nUg|#3g637*#CWhCC^h+X_%~~H8+t>W=t&kFpY>W7n1ue6YnSs(bL#C< zjW(36QrKBqOCyUlpDD@|V>@2n&209UPwRI43v=3#^Xpv!PX`ky`h7>^ov_0L=f=V1(xl)6yN1+zrd&*Qv$Kk(linV zP&(o|_v$X-x@PCe_=QJ-tmS8Wk*|7tvU4S5rd8^zSCdopAuGcF3g0g+g;QTZU;6n@ zO-4jDa`%6lBd^*1aesZ8dzF(Lm6Eo)5I*wzWq4OtRL6AIw1ZO=_{T`j=f9bOLeMmA z0Q=37RjqOV`$?7JRX{hXO%g(-yh2!21v`cR-eX!hPG!ce{Z!V1*(6^}V3Nuz)1hU+RM~Unr@Gy9iBp3z#F_W>h!-1rIt@?VzTt1B=RPRnCW%Y&_!UDjOZpv?DdDpl9@k zlkJw7B~N@ud$o>gd|pjmDQ?GW%@n@)ke_(R>yH2q&8mZ9a$Uo=D8%1mExw2gWPst5 zcP>mtP#m4}Y)u1SQG+FomhH3omOV}^l(_@6)|^^75NY*-!>&xAhZEVvy6`R&bJw)* z;pV}6=kJ8R=SG#NZGdN$paULbo1%`!m70+KKcl=*1AjG-zE{rfGb zgHF2j5KU8lB&gw`qKOhcUM>WwlcR*;=44DGLlZMtI#SPEgl)pktVNI0yfF@91byI< z&{MG*qBBDKpGtbf*+lfVMyCeUclfqc_ zI8H9`?A-e(_lStFs@IQg4EB!OlMjvaMzD>SHIgAbIyTP0dwBkJKnX z1VZ+6{jW(?VqOA|ANHg)`LX^;(7wt__1wFKIO%W5m#gV16@!AVh-&aWnyZDcqrO(# z?QRt2Mw|SuWh`0ex>6ctL9-2C9~J%-n-w~Cwz8w|YuUa>k#zB@~tvRg4xVuL( zQ#Lv?9HHB;6vj-K^>LglG=~ilbs);=ypW7}73G|+=7?7aiy07L`W@py84i1)R=M3; zfN*UTJF6J4kWVTD_)b0e^mK+`qV+Ihq^s9}*p5;&WmhRiS4rn;x^mv(QRhA7z;>ws zAf^v$#9%=*?cQ!Z@*y^nB{A4P66fl07k6-|vo~s9ceiz92}0ZHplxwLa8G5_0X#l_ zStB6Gy(${aBAcu=c=a$^EoQ0Ei6%dD*Z2ua2el&W20;AjaOm>yXpP|HU6c}v?zJx^ zXNk!yVnY^~`d8!mJ6MWgFmnjWlA9L(8-#Fd9b7CE7avdWfM37N`{t`?c}S&K`Lpiq z8=EY~)i5GvxWVWIDU?$43WmkrcIhDmkswU7e=VW#XzcCF z=@x}GGHz75QQdqAtqNZv+o9}d#~fF}A6_+dsVnyeJFo@}mduk)J-eba==64^Dwk3P z9-cpEp2x0A3ny$GVCr1k+s) zD0B-$%lL+K?pjbCEmjp9E(pMCN2sP1O@tU{z-P8Y)D>phowIVsFH^5DNe%(UNfb8e z=V2Tpb>NKCR^FCn^ZG`3IiwnE$zg4zgO{1-=y{?3J@mdm!NDdE? zlw?Whgn!7$S$^wyZL)ZFptgzkt(GWf|Iu1Z?<{GthO}h%%dS z`Tf}0b&HZ6wlY^RE$jqtb|KWw7fUm}AgJ>eKy*vg!jk-scY`u7TUuq&mh1{{X{SVC9j2}O4^{y_wjKr{T6#+khr&q%%vx^H2?E_0+r zI`R-tMv-|ZuZ|2;3W_;@O76_{nq7)K+dcVyPsNd)X?KO#+pLLKjlb^yfE_S;Bl9=@*om7`pGBe(?eL_G9q-488(ET4F}0J?_n>v&(#hHES^cy=vvd} znkU-9{R|~+nHVRUn%0fK+~ceLOUukf48<`R2+t^AM6Cy{~f(^0IUNo%i?9L~;YUYhwCJP+h}( zmeE%3TNp>I785KDO)XR%4&iQ83zFR+zn~gErMWl_Se<AkP3moc_l8b08tJSxoa0077p?I zddbA=JBmr$sGUr9--?TYTE2K>Kl(V`UxC}0oaX+WLQEmILUzs3whVH2bw}$wcBG>t zbsEXQd%oxOQb7nY;HIBChXh!^!2wR{wSb-)RPXF6R{sgi(0URiaG4vzy=)apmrS+% z7zQK=Y%C?6Lj&PBTmKc`?1-pa{ZPQIGH*{TlW$>+g?ne~;H7SV;4zL83PA8O=7Ddv zVV%XBvvOh9q+lQEj%8AM5Z7gbZ+$Nc6iZyJp*7DMExl;LOfi(B_@j>_#P@(ZyMb5J z8%{Li{I;Z>h3W@$Q|;ssb9pU>U-EZ)iMxQuc7bJYAusmtV>fdCm%P?W7>9aA@PcNo zpMw<-TZVU0-ZPvU6*?^{ecytFoF}XkV`g-6*H=_PCrcCCXtEnP$d^%;gia##q2b)12u|3I@Cp$%k*@CE90J5*PS zG00A@on)P2d1sr&j%nqdW<=}Bf!FD_PmVj|X#vx0aE_mj0n}T>95PMQlLj>jG&0O9 zW@EK#2PrdBu*}~mU9DzmZG#X4n$gx|a`<2?)S8?(qsUXFSAm?`7GCZChT7+|waS&+ z`OCmUdY#o&3~!*$f3mI{dC-`AknMNy`yzFv75tUH^IwirHI_^#i+%E}{IJ{9;wgtr zeO^q7tDyDXr26Mm#M~}jop*eFy(*(NJJL^*sTI^L9%j)dv3V-lifFh^YoKr&7PA}J z;s%eOtALjtc|JFdY1Js_r7xy5>IoWyuB47n17SbWT&pGq&Q`IfDgH{+Ka)*vs;1<< zwCi!rw*2P7p61MV&3vntT)j}U%Xnh=rY7vpeGR&G4jV-f=!y+Mh^&hDy)ksC0G0vdh-oUH(|jSgi5>seNc2OnFwrS2`#!=%Bmm>EgijcK)p| zI9Gzsji(m7>Ghr#jpt}b$KUODRR;Pg_e+;FjA+=1@;!8jsMFM8ox*Y;nsRRSDe8Y* z@Ci-Nl?HxMLHhtrVi}K$!)sjB*Ak;X1~e57lj59 z#6LSJ`xjXLi1u#_9*+6zy17aCVA3(V%yKnLcS(I+@~t$edCtunmPd^a2P!D?u&^%@2Q zRAU1quhnk`IX%sXjlF{%2r~MjGVzs4w&!RhIlHixG4Z6l7M#mwX+V*#U;_>ahJqZvi0q;eG2C~dPD0#Q8u(dsMXS1}brIN^iT1wBG zxH6GG&(k+SVWlbLz&_nyB~*`Oa9Mj`EW0dc4vEa)c#@}+Iq8totWC+;_>_KeP>}d_ z9*sT$hVtP_DsY36x`70jjluHwU7C@F#D4*;9fA>gy07O^eS)AbRrWE1`OOFzNs-|8y@l!C6!n*=Z3l%(e`Q!M1vm`~&`*^-Uzv|F%j(6FfzRGF z7kOoma;KgOU6sN-MTh2?7XMI$?Cu7}1*=~F4VhA*wYMnv_T=+wRlV!40pa1Wb+7V| z_HB$5xqpbGsCA;ozQBTLaCApy#YvN0meTiF>0KJ_*^I*xgvq!fx8z3$MX7C*VO4c&GyYg)x`}IV(dn6N-x8o(HG1 zE?I{A__z#A#vs=z4)*qP5_%0M>eHyFQf_07sI!2MpL&<~1dT>c>?kfPxi;q1Y2yL!{{opdqxF(~+f3lple=wbn z-?cSYK->-kzNFnJ-cWa~?(sqIGnp;8=E|c)+G_eLU{$yK_++hL+U)4y4JG{4l~)6Z znWIT}qO| z6Qp;~Vc=ZZ+VR3S@Zqt_O9?V~zWUjGb%bUSoJm5s^|8C%?ii?&{Iwn0+Jl--xbK&2 zrTl~)9@KEWzDbpgJG=!=>;f6G*3}B4(^_3vG3bA~Io9z$K|Shg1ZzJ9`aprYL)S>x zV@%_G-*#FL)3LJQJ~ZKjnZXWW#5D3bfc(3m$gKJ0nGafm-!NFMhE^#!9Q z@xmZ!@v5i1FS{uoCro%;NZWKxH+>1|ZkmJIdqW((JA^`mI%56{cgsdx+e7kl%4F7Sefo}Gq<%|l^XL1bCT*8J#HucMvT z$j2;q4kWXHf{|j-T3CEQg_wDf@RwZU(xBm8nuaxm^`X7*J70s%-SS6bw!)86$sa=0 zDo{5R@$K$g25=W(=9?Q$h&w0GE*tCJm^4btz+?+3W+Hv&R8R*$Qxr5PTYZ-De5&N% zDG~Nj?pM#C@J9*RkJ#cz<%0t2rAI%^r-h7Z|D)4E_ou_qkI}!u$fU=yM;~u|`FOL@ z6M>QbrV~E;Vp&EgYRCSJUA1Tx&U0-TRN{;Z&dk(L&geYX6xcNikNWH@gq7{od%&~4 zJvbYvoHYZU`jeh+%K@80XSyX%`!7GeH23tE;Ffoxv7SRP3qAm& zL5Q;G+AqWdB^w5(aPKMj$q^Upr?6$3(OsO@wQbrd*}JRcq*IG}YdT(ot%GhU`kp=q zol+Xx36AQndw|vry*s()ZQm7}Y>m_2Jr%{4J-+o@z7dOfcjisns^W3defU)j;?@gz z1olaq;H_rJy$BL~yZ5DCnc&)&YTZ1tbxX!#c830-`P~~nGOe_I1?Y&m3N}q|Sn7Oy zN~649^M+ruu$jWJjLjKJyrtAi>TwTLU@*-P&oR?}QgnGAAbKVmQ~|Sbtk!?)vv8Ut zETDY~I?mlMXxHW9fzi@{vkbtx?mS!?>*BTsNw*!mSDXIRx#5F;6x0Qc1lJpBZvD!$ z#Ld2p*bqhB33Ffn2OWKkL6sPCws9zBjrNQ0cpI?&t3&qVl1=G%imB-@V?H`trh}Ni zO$mHKSOR@t?esbCVc zyJhR9mj39~4A4M+WnJ3#85J;2#R#|VMV~;z0q~et+*&NdpcR^2RR?=vpkf9jWhcCG zSPLyc!*qc0>kRctsP=t~j~Ki#Odc0c8Y z`SAMFG8c>-i(!&@RlUC71f#xpZra^14GYwY%GmCH9+_sKQ6tYds5pwF6-AYzXLyko z4z75IEw{t1U}H(AkVvLb=>7lAwq$yR(4UH~uZK4_H9;ES?r3v!f{C7~o=q1s*wx$G z8bvVmArRP9PcwE<5W&vJI@r(8nrZFoGUCegCJTLCheuo{Tu8RIuB>%6!gY_0Y5xAR z-W(2{*d zYHAkJYPYeOzxvd-EToMVb+KTH0%G*6d9+Pn;FgJ2%e1k~E7|andUL&m9z66u0;BsN z^LoM3M>yK#Qxqe;ey#+g=PDuovutKd(1;Z-V<8mMM{oC7^E)fQqE^?PM*#1Emx@UL+LctcoJFSP(G{C{$@ z=>P=^bdBT8IAzGSNcA$_)H{tDNU4Y;Zu8oyAf>QGXbS7gUsC1-2XD%}en*FL)!|rTVc6uY^3v1{CMWd=1VS+f=vBSq?Fw)6*S|P01?|GxggX ztS^YOy$A)51qwp2b_2uH2?67d!Z4;tjDwha9!*RJnT1@wXM3DmxD`o^7& zFP;c`uP(hY;1A)p8D?*^n|YBldB*SPp4ki?Fn_o}?O4I;0zBEc@P5zjWBc+cj+^)Y zc>M$Y$11c!Bw%CHNrzDVZ($`Gz6DR#6B8=h%jo>Yl5$cNr=!yF_~lZzZQgQ9jpLJo zSD^dn*;faRQ1M{BKjmZ^cNp^x(-;|%Vb)AZZ-caK8uB~Yn)ZwL2Ays$eUq@$MZNoo zAJv?BG~d3X+h=^`3RLQi4C-mGD7={7`I#8y+hr7jt~owYb1DO&SHLaS)U9!C!Lj1h zqp|wCbVO816h#2xjE{i?+2=PR^sQ1lFiRjgWa6KpmWDMvFtR%{o4+bxSP|*V1b!4t z-ip2nGDVKge?k1BMxwI*a{PsxD=uvLMe|$5my_n-7F++OKPLaM9aXBaaP=asnA6xz zMZ(`5Be>1mNHGW_af%<&j#DgJE7)ub*9q}KfK!(h)C0KK+1f3l?C1Yw;H^dRb-;OcNp({Pg$dB zXNZO(gFqZPaK+XRcdrA}oX7oRjN5~W`h^hJ53W>Dd>1S1BO*jE6O+~4EQOfQP>}&gDe_bRx^RJa2(<$Zx(oDSh4#g4{Z_oT=l;dl9MGkiskkKbZzX$gH<1j)xwq{5DEz&bwU!jJ-z+^f2 zyLWk&*Sm-z#Vom_kwC772?FrBau7|bCDBPDOO>7FL*0ibHS}4tPRpy8)k6o@MKhts zhByceBFI&f38+1vbT_6U_CnISs9vVX?_WzbYZ~dd*bi*}c^AgfOa|FnP*gdoM4RIZ z9vV=(2|FZt%~-EBU<{h407AWG!hgyRdfi3e#h=}Vvsw9EA7xomEu_|eVCt%Wl_1lJ zKRoElYRr#cM=fsiOP}>enA`Vt)yNg4_MXKj?GFHP=U{lxStnN&-DBAV2WTphx(yl?v%f9RESdU-?>T>T^V zCApe%sZ{&+VNq(?TmHvyaO{vWl2$W_wv&zP?&?2yp2Q3YR-Ow!%LQqIIkb^wllX>2 zxy|!cy%E$5+ru?IR~Ah<@^O3VFuxT2;~C3t3eYZ8iCya&Ka3HWpSWp z`O2Y2lE0r=E-zgxEPE=Fa7JEAkESFdRgC<3eFKvQykI3aCXy&zX9UplOQ zVu!i3!i-E;wHiea{DKx#j06j zyZmhx<>PwMUy~ixIv*;ztH1K>-sZ;cj(C6e?61e?Z+<(wQTJntE0DG=&ueh^cC~1; zj%4yAJnL=1n(;P`pT8-ZQg}Pxaz0-$0|)~O%F1y&M>RLf3TodLh%dn<0ejzM?|m%Z zTULTTG6Nh_D?AVxGLc5D;ubyVVxD{pJ2g}2rz%`OsP~Ds?}7zzDL>xR-0YfK(Wh*r zdpy&tgbKWVmIw04ni4ULL1d}(v&Y%&Mu_X}Cg9p2EJTdLG{Hi+ z0NE9I?u*oKbnjKF&vV`LThVRj?e?`sCM>I0BIr%jo&WCf)L{}DX22K*;mDc*KxpO{gMeXcq2C1N2FT`n>fvubjLgz+M```Yx8#XMd8!KSd4h$@5 ztsn?Gl5e}q2}G`uT)2!i;IAoHo63L^A*dK?8M6_JfV0qo{cxFc5N{j037DQUdQ z5gpUu=n9zkt>#%Cjz`a3;-quWDJ0rR<9<8>9!rwibvs}0;Is4UK+H}15yXQVkqI%< z;74n&I7x~f36$k&#tv@Re*}+Rg3T*@69VDel>si{V1HaPp%1>D2WN=4N0IjULNxcE z1QNwNH*)cv3k4%@;6WtQ4r-7=A6#^@<-vEX)ntl?0^F>C$1742`338qrR@F|Ea=>@ zz}wVAGZ{^D16y>Ov$5_m;DcNTt{WpY3vNwf9-Y&h=NA21(HU1ltvhuw{h<>qGqrxA zK7Va7f&R%dJBEWsZUxalts!!lV>!fw!OF2_X=Sj9if#id11kkM*_PNV6?+Qc(_|nH zf+$3|T0mSMEIFg)px{~e>i$DVByv^{M4h8pdnKN~6&&c@#*Q}`KPzEw-26~%ko8gq zdoSEq@#k4{LV^O=4%OtSGN>z?)!TuDZm{NU-j~Oj$ue+r6TZ3|?j;8wd~Mhwh2NRY zw3`HN2V?TJT9P1eHdc5QOm)hFCqiOxj#T`h$8O@o>HTN8;`dMo_o0v>V^ zZmkG>-U$w!FQBC~ZrP)?Q3_gp-|nS=besVHJ6^-aBJ%dBvsGY(Y7c%r;jDH(HHKgw z4px~WF2o@oeb1n}!1MFH)Db(M`KLTK-)?7qHjx3Wd(vw}Mnsn4%JbnL(Qx}W#dhCQ zkcS{1GW5?b+uzz?T>wUGo+gy={pA6IF7OK<31q8Je6OK@0l5lLrSw{H(#0?6i6()e z9_IcI;F1b9zm!Jdg6o6B(KJ9VGuToL8cPA0SS*u@&1g_G@22DGy(2Bpx&hhw@zJvD z4)8Dm{FW0uQVOutT_tyqq9Jfqa5#lzs4LU?@(O+I2|i{NW^}^qIf0;X!5_<`?Y)-~ zs(_Z=Yvf0R_Qe;e&8NJSa4v0g3>Uy=;hp+G^Obz9@8!CUot9Rvx-w7o)J#KfxL{GT;BaJc&~Faru7*#`tL2p%*j z?{)RnX~>*kpFaf7ltD%E@cRqQ307RjQcNI?@PJ&adf!oQ4mk7m^ts?^zWP-MT{}o@ zEX}r=tnJ1}K_FLj%@Og6@et+st9>^Kyql|wr*0NiowV6l|Br#($--rM$1PvMtzXX} zzn|ZtqU2Cd2+R|JAHi}2@`FUL2b1!yucNq+aKgkHbl#wz;rQ6|!2`K)lI;*RbBHY% zij@v+kPjs*hc04=Z}|;x8_Zai5p2yc2{)_kZNiheuUqB8yE5dmna1;Ohlz9@uQYkyE^}L zZ~(OtnpT6Er;sDGEX|OK^)W^dI$3)ndBur}jS+jipyok7dR{wY;ae4+GXz4M0-hqP zA}x(t`ok0DFsDJ-4_`$3J-pp~vJp8b3=Q9diM`@@mJf&X{n||(z_lrvK|^FX0A@=6 zwLGXF1pd$g{pmHV^a}gc@sKBv*XRgmfBxu*?%uOwZp*tU5Nw196AxDbsa!q)sP^}tk_&?Ut;qGk;)ZEzffVA+3@c#?^4g>K7 zV!+(6Knv7KsXD#0(j@}U{vjKk^mZ;WS6&oUd4!B z@JMCQiX!fKg>5_-A+OMQSKIoG&{%C&02-td2Hugr10xwY`60sta z?tu3)5k6^*+I9t7fCL_95&pd*WB>#|G83#8B-v9|E8%#St|KPCt#jpK+p3IGAgja5 z&6TJE1>;9UAS2)NR$H(gS5Ulll# z`U(XcS?2&C<`*pnkwCO(umf{S0U%uhCH>|jP0|z4r@XxY3*ZF|bq2y63w{3Z3Z=zI z0I~{D!RFj{C$S>6C{+juVcgRKRsd~|w*+M11!e0Jl_+76Xmw2B5_ac`RRG2S#&}!6 zcj7D&Pc8lva1}fyx}U)w>I)dJ41Cs}M)Jl+1)5Dm5xHFeJTO<(YV|%M6PN3O3jq&s)dhQ)>3BuC zQ1B{9RNfbj1$4uk$K3=Kxw1>U3D`-}e_D~e{WVWObFkn9B>?f1UjQ?A0>w)c6Cbh+ z3`$y6pDa!0T1`eJXjuIRt)Db7@~o_~Pwbihzh zSU6As005+>hULV>lvr@KlXKaCnVHkj>3IoyNfCN-Vi@^ks9KmZG2v9QDmzPCYr9%n za01nIb#-J4z!MckMKwkR78Vvo7DhHURzwv>9c=}6OhpD=J;n+~){?y}RMow;rKD6O z#Jv@UJl53YrLqOqg@si%7N(W12{SVAmMJ4sY}>JP1)Fh67e<*CE5x?>1Cy-`nQ+{? zg((BFOtNp#o@^<`O$!w+U6jS!a-;)BYSqY8Ij3a|xo6w1XwcB2%NHqKib~6D-U8jVTHR$`h7No;)c!^h!D|WW{3SB8ZSGM2Z+Wf+Pt5r5&YmB?2%2 zz=<4n0fhPsYJjO*hH|)iWoyR{!iG!=)+CNsQAW^WeG7%x+TWA zsP1{J>NYSr{cWLA=H|I$SB#;I#%STVMR2Nx9&8E)~%3>66x zLxvC$9fOQ7M=W^67VHt<0S`R>{Wb9cC$+HP zNEBd1GD#(j6|xs#e+oc=EGcxN<6%Y2c*|sVDVCLDt3+}|6G~jM%+(rr40L6%owY|+CKOH`o|8OC&@1sO#Yp+pPPb+%rV5IM6F7ra@~#S^}O zxs?{6rK3_uV2~(Y8Ot~$omf;@At)F{OcljVB4M=5e@#%i4;lS{iH2&KVnjw4QTlQW z7q0#3A*RoW#7#8?r8mYCIAm1<74XEi1s6w=h|d!KT_FTWTX3TWqg|FNRy5Bw@kLf- za3NMaV_cB{C!rY9mLph90i#?1EH-0}IULXl1u7iCNdpHwcFO*5@D|X@1S2?Mi(O|h zVb>~)?NH{YMspedf`bTD zSgI>?UhoE$n)p?vW;9l@%hIa6$v}vNgaZEbQ~G6He5{7m$quR>EJhoRP(E zJ-!l4Eq0}lK^ke`vI`Vqw5^yFz9_}ym{$O6GLup|ss2(Cv1V=U$M^9qM0Pcy2B382 zZ~+7mr>zQ23n!-ow--Tpmh}$JvuArcOIhIsvF>olMHaZ5De1KWJu~Wj1x1uiI$}J% zCCIQHgC=eLz&%qm2*x88DqR5z3IIb6u5cyz5hD!l=m<29^$}u>!3$e}LMf6KCG8k4 z9oyJ~NwzSBEuo1UXkbPaDpiGOd~jE?%8-aQWUvA>U=;{ZfC)@c0v?BfRN9 zsCmL~b}&IGkVOipDN(N?(h_cArfB{uOrc5Wq2@z5BP1N3s6u&)huGlZHSB;&8Wf}%pe}{Y@vSBatb}Z zkdx75YM3GN#Q>o|E<+$d0}pt>1aJVPAclg71E9cO6az2IH6e677~KR)M~l+|AuFa3 zm^XbPyDLoOTE2LbSAs^HlP!TDzQ{>6ZbAkkz~>y$xWW*&Py{pX;AB?t#c;N;gi1c+ z96S(@AJ+&QlcmWu(%H}zf-nZ#SOaDL)Iya%AZC&=oZtwVi3%44wF)at3scupfti}2 z1Z=E{W8YB-cr3LgPh~7?A~V)D8Bzq$L}Uy-Py!SLg&L>!#u}DF2uRix3XWV0BI)?X z|H6Q#vt}$&WvJ9YoN$wsY~?u*Axjpr01z(B$1Bll!Vwx%01A}z0V6n(?c|{9f`&vH0_G++C zDC}Wrl-R{K_ObZ{i~!t8fllP$vQB^k04R_F^O0r?NOQ#qHY@6N zN>@1blamGsH;P@M1sm~SKSD~NQt{wq6KoU4sDJ~^P=hQY=*Akv^PglW<9St~&K8gm zjeDpd2q57?5S+m%cntM6SJ+QF+`*49(1Rb*=u^bt!6YRx4;nuw%2z*m@r7uCQw(4bf)Kz!Ae?GpN$h}=FOai9_z(nV_Rz^h zya0sqXkme2@PeFTg^VgpLBR2XW7pG-61M@PG=w0TgDZTKn7pH<{K^W9?PJSF)oO} z3~TUt5t>1UBizSJSU$#^3<k zG@XNkXi^ytoG>lvXbO3z)Utn^!-GmrZ5dPG#t?Mk%ktnCnrdo|Gt%UQE<}*gIuRDq z(IkfY>8cD<&x*mKr39Bf9h^Jpf)K7E1V!-=IG3#_&p{)S3p0CcpHW7DJ&Ceu+gRt&Q+U^CS2eJAd*8o00pZ<0ZH%^89)Msz!&{e0Edx*_muX5 zCGY`<;ft=|fF%G#`=Ud8K>_aMLmA*QOpt&|kQh6#DPuwwd80+%RCr_{9~gl%S70U_ z)dIy*S7?(a%>WWmH3o_jbQ1&wo*{-gw true - -let ops = ['+',(+.); '-',(-.); '*',( *.); '/',(/.)] - -(* The abstract calculator class. - Does not use Tk (only Textvariable) *) - -class calc () = object (calc) - val variable = Textvariable.create () - val mutable x = 0.0 - val mutable op = None - val mutable displaying = true - - method set = Textvariable.set variable - method get = Textvariable.get variable - method insert s = calc#set (calc#get ^ s) - method get_float = float_of_string (calc#get) - - method command s = - if s <> "" then match s.[0] with - '0'..'9' -> - if displaying then (calc#set ""; displaying <- false); - calc#insert s - | '.' -> - if displaying then - (calc#set "0."; displaying <- false) - else - if not (mem_string ~elt:'.' calc#get) then calc#insert s - | '+'|'-'|'*'|'/' as c -> - displaying <- true; - begin match op with - None -> - x <- calc#get_float; - op <- Some (List.assoc c ops) - | Some f -> - x <- f x (calc#get_float); - op <- Some (List.assoc c ops); - calc#set (Printf.sprintf "%g" x) - end - | '='|'\n'|'\r' -> - displaying <- true; - begin match op with - None -> () - | Some f -> - x <- f x (calc#get_float); - op <- None; - calc#set (Printf.sprintf "%g" x) - end - | 'q' -> closeTk (); exit 0 - | _ -> () -end - -(* Buttons for the calculator *) - -let m = - [|["7";"8";"9";"+"]; - ["4";"5";"6";"-"]; - ["1";"2";"3";"*"]; - ["0";".";"=";"/"]|] - -(* The physical calculator. Inherits from the abstract one *) - -class calculator ~parent = object - inherit calc () as calc - - val label = Label.create ~anchor:`E ~relief:`Sunken ~padx:10 parent - val frame = Frame.create parent - - initializer - let buttons = - Array.map ~f: - (List.map ~f: - (fun text -> - Button.create ~text ~command:(fun () -> calc#command text) frame)) - m - in - Label.configure ~textvariable:variable label; - calc#set "0"; - bind ~events:[`KeyPress] ~fields:[`Char] - ~action:(fun ev -> calc#command ev.ev_Char) - parent; - for i = 0 to Array.length m - 1 do - Grid.configure ~row:i buttons.(i) - done; - pack ~side:`Top ~fill:`X [label]; - pack ~side:`Bottom ~fill:`Both ~expand:true [frame]; -end - -(* Finally start everything *) - -let top = openTk () - -let applet = new calculator ~parent:top - -let _ = mainLoop () diff --git a/otherlibs/labltk/examples_labltk/clock.ml b/otherlibs/labltk/examples_labltk/clock.ml deleted file mode 100644 index 6903acb21a8c..000000000000 --- a/otherlibs/labltk/examples_labltk/clock.ml +++ /dev/null @@ -1,133 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Clock/V, a simple clock. - Reverts every time you push the right button. - Adapted from ASCII/V May 1997 - - Uses Tk and Unix, so you must link with - labltklink unix.cma clock.ml -o clock -cclib -lunix -*) - -open Tk - -(* pi is not a constant! *) -let pi = acos (-1.) - -(* The main class: - * create it with a parent: [new clock parent:top] - * initialize with [#init] -*) - -class clock ~parent = object (self) - - (* Instance variables *) - val canvas = Canvas.create ~width:100 ~height:100 parent - val mutable height = 100 - val mutable width = 100 - val mutable rflag = -1 - - (* Convert from -1.0 .. 1.0 to actual positions on the canvas *) - method x x0 = truncate (float width *. (x0 +. 1.) /. 2.) - method y y0 = truncate (float height *. (y0 +. 1.) /. 2.) - - initializer - (* Create the oval border *) - Canvas.create_oval canvas ~tags:["cadran"] - ~x1:1 ~y1:1 ~x2:(width - 2) ~y2:(height - 2) - ~width:3 ~outline:`Yellow ~fill:`White; - (* Draw the figures *) - self#draw_figures; - (* Create the arrows with dummy position *) - Canvas.create_line canvas - ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] - ~tags:["hours"] ~fill:`Red; - Canvas.create_line canvas - ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] - ~tags:["minutes"] ~fill:`Blue; - Canvas.create_line canvas - ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] - ~tags:["seconds"] ~fill:`Black; - (* Setup a timer every second *) - let rec timer () = - self#draw_arrows (Unix.localtime (Unix.time ())); - Timer.add ~ms:1000 ~callback:timer; () - in timer (); - (* Redraw when configured (changes size) *) - bind canvas ~events:[`Configure] ~action: - begin fun _ -> - width <- Winfo.width canvas; - height <- Winfo.height canvas; - self#redraw - end; - (* Change direction with right button *) - bind canvas ~events:[`ButtonPressDetail 3] - ~action:(fun _ -> rflag <- -rflag; self#redraw); - (* Pack, expanding in both directions *) - pack ~fill:`Both ~expand:true [canvas] - - (* Redraw everything *) - method redraw = - Canvas.coords_set canvas (`Tag "cadran") - ~xys:[ 1, 1; width - 2, height - 2 ]; - self#draw_figures; - self#draw_arrows (Unix.localtime (Unix.time ())) - - (* Delete and redraw the figures *) - method draw_figures = - Canvas.delete canvas [`Tag "figures"]; - for i = 1 to 12 do - let angle = float (rflag * i - 3) *. pi /. 6. in - Canvas.create_text canvas - ~x:(self#x (0.8 *. cos angle)) ~y:(self#y (0.8 *. sin angle)) - ~tags:["figures"] - ~text:(string_of_int i) ~font:"variable" - ~anchor:`Center - done - - (* Resize and reposition the arrows *) - method draw_arrows tm = - Canvas.configure_line ~width:(min width height / 40) - canvas (`Tag "hours"); - let hangle = - float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180) - *. pi /. 360. in - Canvas.coords_set canvas (`Tag "hours") - ~xys:[ self#x 0., self#y 0.; - self#x (cos hangle /. 2.), self#y (sin hangle /. 2.) ]; - Canvas.configure_line ~width:(min width height / 50) - canvas (`Tag "minutes"); - let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in - Canvas.coords_set canvas (`Tag "minutes") - ~xys:[ self#x 0., self#y 0.; - self#x (cos mangle /. 1.5), self#y (sin mangle /. 1.5) ]; - let sangle = float (rflag * tm.Unix.tm_sec - 15) *. pi /. 30. in - Canvas.coords_set canvas (`Tag "seconds") - ~xys:[ self#x 0., self#y 0.; - self#x (cos sangle /. 1.25), self#y (sin sangle /. 1.25) ] -end - -(* Initialize the Tcl interpreter *) -let top = openTk () - -(* Create a clock on the main window *) -let clock = - new clock ~parent:top - -(* Wait for events *) -let _ = mainLoop () diff --git a/otherlibs/labltk/examples_labltk/demo.ml b/otherlibs/labltk/examples_labltk/demo.ml deleted file mode 100644 index 9524c1c7e09c..000000000000 --- a/otherlibs/labltk/examples_labltk/demo.ml +++ /dev/null @@ -1,166 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Some CamlTk4 Demonstration by JPF *) - -(* First, open these modules for convenience *) -open StdLabels -open Tk - -(* Dummy let *) -let _ = - -(* Initialize Tk *) -let top = openTk () in -(* Title setting *) -Wm.title_set top "LablTk demo"; - -(* Base frame *) -let base = Frame.create top in -pack [base]; - -(* Menu bar *) -let bar = Frame.create ~borderwidth:2 ~relief:`Raised base in -pack ~fill:`X [bar]; - - (* Menu and Menubutton *) - let meb = Menubutton.create ~text:"Menu" bar in - let men = Menu.create meb in - Menu.add_command ~label:"Quit" ~command:(fun () -> closeTk (); exit 0) men; - Menubutton.configure ~menu:men meb; - - (* Frames *) - let base2 = Frame.create base in - let left = Frame.create base2 in - let right = Frame.create base2 in - pack [base2]; - pack ~side:`Left [left; right]; - - (* Widgets on left and right *) - - (* Button *) - let but = Button.create ~text:"Welcome to LablTk" left in - - (* Canvas *) - let can = - Canvas.create ~width:100 ~height:100 ~borderwidth:1 ~relief:`Sunken left - in - let oval = Canvas.create_oval ~x1: 10 ~y1: 10 - ~x2: 90 ~y2: 90 - ~fill: `Red - can - in ignore oval; - - (* Check button *) - let che = Checkbutton.create ~text:"Check" left in - - (* Entry *) - let ent = Entry.create ~width:10 left in - - (* Label *) - let lab = Label.create ~text:"Welcome to LablTk" left in - - (* Listbox *) - let lis = Listbox.create left in - Listbox.insert lis ~index:`End ~texts:["This"; "is"; "Listbox"]; - - (* Message *) - let mes = Message.create - ~text: "Hello this is a message widget with very long text, but ..." - left in - - (* Radio buttons *) - let tv = Textvariable.create () in - Textvariable.set tv "One"; - let radf = Frame.create right in - let rads = List.map - ~f:(fun t -> Radiobutton.create ~text:t ~value:t ~variable:tv radf) - ["One"; "Two"; "Three"] in - - (* Scale *) - let sca = Scale.create ~label:"Scale" ~length:100 ~showvalue:true right in - - (* Text and scrollbar *) - let texf = Frame.create right in - - (* Text *) - let tex = Text.create ~width:20 ~height:8 texf in - Text.insert ~index:(`End,[]) ~text:"This is a text widget." tex; - - (* Scrollbar *) - let scr = Scrollbar.create texf in - - (* Text and Scrollbar widget link *) - let scroll_link sb tx = - Text.configure ~yscrollcommand:(Scrollbar.set sb) tx; - Scrollbar.configure ~command:(Text.yview tx) sb in - scroll_link scr tex; - - pack ~side:`Right ~fill:`Y [scr]; - pack ~side:`Left ~fill:`Both ~expand:true [tex]; - - (* Pack them *) - pack ~side:`Left [meb]; - pack [coe but; coe can; coe che; coe ent; coe lab; coe lis; coe mes]; - pack [coe radf; coe sca; coe texf]; - pack rads; - - (* Toplevel *) - let top2 = Toplevel.create top in - Wm.title_set top2 "LablTk demo control"; - let defcol = `Color "#dfdfdf" in - let selcol = `Color "#ffdfdf" in - let buttons = - List.map ~f:(fun (w, t, c, a) -> - let b = Button.create ~text:t ~command:c top2 in - bind ~events:[`Enter] ~action:(fun _ -> a selcol) b; - bind ~events:[`Leave] ~action:(fun _ -> a defcol) b; - b) - [coe bar, "Frame", (fun () -> ()), - (fun background -> Frame.configure ~background bar); - coe meb, "Menubutton", (fun () -> ()), - (fun background -> Menubutton.configure ~background meb); - coe but, "Button", (fun () -> ()), - (fun background -> Button.configure ~background but); - coe can, "Canvas", (fun () -> ()), - (fun background -> Canvas.configure ~background can); - coe che, "CheckButton", (fun () -> ()), - (fun background -> Checkbutton.configure ~background che); - coe ent, "Entry", (fun () -> ()), - (fun background -> Entry.configure ~background ent); - coe lab, "Label", (fun () -> ()), - (fun background -> Label.configure ~background lab); - coe lis, "Listbox", (fun () -> ()), - (fun background -> Listbox.configure ~background lis); - coe mes, "Message", (fun () -> ()), - (fun background -> Message.configure ~background mes); - coe radf, "Radiobox", (fun () -> ()), - (fun background -> - List.iter ~f:(fun b -> Radiobutton.configure ~background b) rads); - coe sca, "Scale", (fun () -> ()), - (fun background -> Scale.configure ~background sca); - coe tex, "Text", (fun () -> ()), - (fun background -> Text.configure ~background tex); - coe scr, "Scrollbar", (fun () -> ()), - (fun background -> Scrollbar.configure ~background scr) - ] - in - pack ~fill:`X buttons; - -(* Main Loop *) -Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_labltk/eyes.ml b/otherlibs/labltk/examples_labltk/eyes.ml deleted file mode 100644 index a96e08260a3e..000000000000 --- a/otherlibs/labltk/examples_labltk/eyes.ml +++ /dev/null @@ -1,62 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Tk - -let _ = - let top = openTk () in - let fw = Frame.create top in - pack [fw]; - let c = Canvas.create ~width: 200 ~height: 200 fw in - let create_eye cx cy wx wy ewx ewy bnd = - let o2 = Canvas.create_oval - ~x1:(cx - wx) ~y1:(cy - wy) - ~x2:(cx + wx) ~y2:(cy + wy) - ~outline: `Black ~width: 7 - ~fill: `White - c - and o = Canvas.create_oval - ~x1:(cx - ewx) ~y1:(cy - ewy) - ~x2:(cx + ewx) ~y2:(cy + ewy) - ~fill:`Black - c in - let curx = ref cx - and cury = ref cy in - bind ~events:[`Motion] ~extend:true ~fields:[`MouseX; `MouseY] - ~action:(fun e -> - let nx, ny = - let xdiff = e.ev_MouseX - cx - and ydiff = e.ev_MouseY - cy in - let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. - (float ydiff /. (float wy *. bnd)) ** 2.0) in - if diff > 1.0 then - truncate ((float xdiff) *. (1.0 /. diff)) + cx, - truncate ((float ydiff) *. (1.0 /. diff)) + cy - else - e.ev_MouseX, e.ev_MouseY - in - Canvas.move c o ~x: (nx - !curx) ~y: (ny - !cury); - curx := nx; - cury := ny) - c - in - create_eye 60 100 30 40 5 6 0.6; - create_eye 140 100 30 40 5 6 0.6; - pack [c] - -let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_labltk/hello.ml b/otherlibs/labltk/examples_labltk/hello.ml deleted file mode 100644 index 838b50ffc381..000000000000 --- a/otherlibs/labltk/examples_labltk/hello.ml +++ /dev/null @@ -1,38 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* LablTk4 Demonstration by JPF *) - -(* First, open this modules for convenience *) -open Tk - -(* initialization of Tk --- the result is a toplevel widget *) -let top = openTk () - -(* create a button on top *) -(* Button.create : use of create function defined in button.ml *) -(* But you shouldn't open Button module for other widget class modules use *) -let b = Button.create ~text: "Hello, LablTk!" top - -(* Lack of toplevel expressions in lsl, you must use dummy let exp. *) -let _ = pack [coe b] - -(* Last, you must call mainLoop *) -(* You can write just let _ = mainLoop () *) -(* But Printexc.print will help you *) -let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_labltk/hello.tcl b/otherlibs/labltk/examples_labltk/hello.tcl deleted file mode 100755 index 84ceccd6d1fa..000000000000 --- a/otherlibs/labltk/examples_labltk/hello.tcl +++ /dev/null @@ -1,5 +0,0 @@ -#!/usr/bin/wish - -button .hello -text "Hello, TclTk!" - -pack .hello diff --git a/otherlibs/labltk/examples_labltk/lang.ml b/otherlibs/labltk/examples_labltk/lang.ml deleted file mode 100644 index 0d6ba8c9cc10..000000000000 --- a/otherlibs/labltk/examples_labltk/lang.ml +++ /dev/null @@ -1,75 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* language encoding using UTF-8 *) -open Tk - -let top = opentk () - -(* declare Tk that we use utf-8 to communicate *) -(* problem: Text display is highly dependent on your font installation - and configulation. The fonts with no-scale setting are selected - only if the point sizes are exactly same??? -*) -let _ = - Encoding.system_set "utf-8"; - let l = Label.create top ~text: "???" in - pack [l]; - let t = Text.create top in - pack [t]; - - let create_hello lang hello = - let b = Button.create t ~text: lang ~command: (fun () -> - Label.configure l ~text: hello) - in - Text.window_create t ~index: (`End,[]) ~window: b - in - List.iter (fun (lang, hello) -> create_hello lang hello) - ["Amharic(አማርኛ)", "ሠላáˆ"; - "Arabic", "�����������"; - "Croatian (Hrvatski)", "Bog (Bok), Dobar dan"; - "Czech (Äesky)", "Dobrý den"; - "Danish (Dansk)", "Hej, Goddag"; - "English", "Hello"; - "Esperanto", "Saluton"; - "Estonian", "Tere, Tervist"; - "FORTRAN", "PROGRAM"; - "Finnish (Suomi)", "Hei"; - "French (Français)", "Bonjour, Salut"; - "German (Deutsch Nord)", "Guten Tag"; - "German (Deutsch Süd)", "Grüß Gott"; - "Greek (Ελληνικά)", "Γειά σας"; - "Hebrew", "שלו×"; - "Italiano", "Ciao, Buon giorno"; - "Maltese", "Ciao"; - "Nederlands, Vlaams", "Hallo, Hoi, Goedendag"; - "Norwegian (Norsk)", "Hei, God dag"; - "Polish", "Cześć!"; - "Russian (РуÑÑкий)", "ЗдравÑтвуйте!"; - "Slovak", "Dobrý deň"; - "Spanish (Español)", "¡Hola!"; - "Swedish (Svenska)", "Hej, Goddag"; - "Thai (�������)", "�������, ������"; - "Tigrigna (ትáŒáˆ­áŠ›)", "ሰላማት"; - "Turkish (Türkçe)", "Merhaba"; - "Vietnamese (Tiếng Việt)", "Chào bạn"; - "Japanese (日本語)", "ã“ã‚“ã«ã¡ã¯"; - "Chinese (中文,普通è¯,汉语)", "你好"; - "Cantonese (粵語,廣æ±è©±)", "早晨, 你好"; - "Hangul (한글)", "안녕하세요, 안녕하십니까" ] -;; - -let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_labltk/taquin.ml b/otherlibs/labltk/examples_labltk/taquin.ml deleted file mode 100644 index 616f38cb46aa..000000000000 --- a/otherlibs/labltk/examples_labltk/taquin.ml +++ /dev/null @@ -1,143 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Tk;; - -let découpe_image img nx ny = - let l = Imagephoto.width img - and h = Imagephoto.height img in - let tx = l / nx and ty = h / ny in - let pièces = ref [] in - for x = 0 to nx - 1 do - for y = 0 to ny - 1 do - let pièce = Imagephoto.create ~width:tx ~height:ty () in - Imagephoto.copy ~src:img - ~src_area:(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty) pièce; - pièces := pièce :: !pièces - done - done; - (tx, ty, List.tl !pièces);; - -let remplir_taquin c nx ny tx ty pièces = - let trou_x = ref (nx - 1) - and trou_y = ref (ny - 1) in - let trou = - Canvas.create_rectangle - ~x1:(!trou_x * tx) ~y1:(!trou_y * ty) ~x2:tx ~y2:ty c in - let taquin = Array.make_matrix nx ny trou in - let p = ref pièces in - for x = 0 to nx - 1 do - for y = 0 to ny - 1 do - match !p with - | [] -> () - | pièce :: reste -> - taquin.(x).(y) <- - Canvas.create_image - ~x:(x * tx) ~y:(y * ty) - ~image:pièce ~anchor:`Nw ~tags:["pièce"] c; - p := reste - done - done; - let déplacer x y = - let pièce = taquin.(x).(y) in - Canvas.coords_set c pièce - ~xys:[!trou_x * tx, !trou_y * ty]; - Canvas.coords_set c trou - ~xys:[x * tx, y * ty; tx, ty]; - taquin.(!trou_x).(!trou_y) <- pièce; - taquin.(x).(y) <- trou; - trou_x := x; trou_y := y in - let jouer ei = - let x = ei.ev_MouseX / tx and y = ei.ev_MouseY / ty in - if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1) - || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1) - then déplacer x y in - Canvas.bind ~events:[`ButtonPress] - ~fields:[`MouseX; `MouseY] ~action:jouer c (`Tag "pièce");; - -let rec permutation = function - | [] -> [] - | l -> let n = Random.int (List.length l) in - let (élément, reste) = partage l n in - élément :: permutation reste - -and partage l n = - match l with - | [] -> failwith "partage" - | tête :: reste -> - if n = 0 then (tête, reste) else - let (élément, reste') = partage reste (n - 1) in - (élément, tête :: reste');; - -let create_filled_text parent lines = - let lnum = List.length lines - and lwidth = - List.fold_right - (fun line max -> - let l = String.length line in - if l > max then l else max) - lines 1 in - let txtw = Text.create ~width:lwidth ~height:lnum parent in - List.iter - (fun line -> - Text.insert ~index:(`End, []) ~text:line txtw; - Text.insert ~index:(`End, []) ~text:"\n" txtw) - lines; - txtw;; - -let give_help parent lines () = - let help_window = Toplevel.create parent in - Wm.title_set help_window "Help"; - - let help_frame = Frame.create help_window in - - let help_txtw = create_filled_text help_frame lines in - - let quit_help () = destroy help_window in - let ok_button = Button.create ~text:"Ok" ~command:quit_help help_frame in - - pack ~side:`Bottom [help_txtw]; - pack ~side:`Bottom [ok_button ]; - pack [help_frame];; - -let taquin nom_fichier nx ny = - let fp = openTk () in - Wm.title_set fp "Taquin"; - let img = Imagephoto.create ~file:nom_fichier () in - let c = - Canvas.create ~background:`Black - ~width:(Imagephoto.width img) - ~height:(Imagephoto.height img) fp in - let (tx, ty, pièces) = découpe_image img nx ny in - remplir_taquin c nx ny tx ty (permutation pièces); - pack [c]; - - let quit = Button.create ~text:"Quit" ~command:closeTk fp in - let help_lines = - ["Pour jouer, cliquer sur une des pièces"; - "entourant le trou"; - ""; - "To play, click on a part around the hole"] in - let help = - Button.create ~text:"Help" ~command:(give_help fp help_lines) fp in - pack ~side:`Left ~fill:`X [quit] ; - pack ~side:`Left ~fill:`X [help] ; - mainLoop ();; - -if !Sys.interactive then () else -begin taquin "Lambda2.back.gif" 4 4; exit 0 end;; diff --git a/otherlibs/labltk/examples_labltk/tetris.ml b/otherlibs/labltk/examples_labltk/tetris.ml deleted file mode 100644 index 8260fc205950..000000000000 --- a/otherlibs/labltk/examples_labltk/tetris.ml +++ /dev/null @@ -1,710 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* A Tetris game for LablTk *) -(* written by Jun P. Furuse *) - -open StdLabels -open Tk - -exception Done - -type falling_block = { - mutable pattern: int array list; - mutable bcolor: int; - mutable x: int; - mutable y: int; - mutable d: int; - mutable alive: bool - } - -let stop_a_bit = 300 - -let field_width = 10 -let field_height = 20 - -let colors = [| - `Color "red"; - `Color "yellow"; - - `Color "blue"; - `Color "orange"; - - `Color "magenta"; - `Color "green"; - - `Color "cyan" -|] - -(* Put here your favorite image files *) -let backgrounds = [ - "Lambda2.back.gif" -] - -(* blocks *) -let block_size = 16 -let cell_border = 2 - -let blocks = [ - [ [|"0000"; - "0000"; - "1111"; - "0000" |]; - - [|"0010"; - "0010"; - "0010"; - "0010" |]; - - [|"0000"; - "0000"; - "1111"; - "0000" |]; - - [|"0010"; - "0010"; - "0010"; - "0010" |] ]; - - [ [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |]; - - [|"0000"; - "0110"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "0111"; - "0100"; - "0000" |]; - - [|"0000"; - "0110"; - "0010"; - "0010" |]; - - [|"0000"; - "0010"; - "1110"; - "0000" |]; - - [|"0100"; - "0100"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "0100"; - "0111"; - "0000" |]; - - [|"0000"; - "0110"; - "0100"; - "0100" |]; - - [|"0000"; - "1110"; - "0010"; - "0000" |]; - - [|"0010"; - "0010"; - "0110"; - "0000" |] ]; - - [ [|"0000"; - "1100"; - "0110"; - "0000" |]; - - [|"0010"; - "0110"; - "0100"; - "0000" |]; - - [|"0000"; - "1100"; - "0110"; - "0000" |]; - - [|"0010"; - "0110"; - "0100"; - "0000" |] ]; - - [ [|"0000"; - "0011"; - "0110"; - "0000" |]; - - [|"0100"; - "0110"; - "0010"; - "0000" |]; - - [|"0000"; - "0011"; - "0110"; - "0000" |]; - - [|"0000"; - "0100"; - "0110"; - "0010" |] ]; - - [ [|"0000"; - "0000"; - "1110"; - "0100" |]; - - [|"0000"; - "0100"; - "1100"; - "0100" |]; - - [|"0000"; - "0100"; - "1110"; - "0000" |]; - - [|"0000"; - "0100"; - "0110"; - "0100" |] ] - -] - -let line_empty = int_of_string "0b1110000000000111" -let line_full = int_of_string "0b1111111111111111" - -let decode_block dvec = - let btoi d = int_of_string ("0b"^d) in - Array.map ~f:btoi dvec - -class cell t1 t2 t3 ~canvas ~x ~y = object - val mutable color = 0 - method get = color - method set ~color:col = - if color = col then () else - if color <> 0 && col = 0 then begin - Canvas.move canvas t1 - ~x:(- block_size * (x + 1) -10 - cell_border * 2) - ~y:(- block_size * (y + 1) -10 - cell_border * 2); - Canvas.move canvas t2 - ~x:(- block_size * (x + 1) -10 - cell_border * 2) - ~y:(- block_size * (y + 1) -10 - cell_border * 2); - Canvas.move canvas t3 - ~x:(- block_size * (x + 1) -10 - cell_border * 2) - ~y:(- block_size * (y + 1) -10 - cell_border * 2) - end else begin - Canvas.configure_rectangle canvas t2 - ~fill: colors.(col - 1) - ~outline: colors.(col - 1); - Canvas.configure_rectangle canvas t1 - ~fill: `Black - ~outline: `Black; - Canvas.configure_rectangle canvas t3 - ~fill: (`Color "light gray") - ~outline: (`Color "light gray"); - if color = 0 && col <> 0 then begin - Canvas.move canvas t1 - ~x: (block_size * (x+1)+10+ cell_border*2) - ~y: (block_size * (y+1)+10+ cell_border*2); - Canvas.move canvas t2 - ~x: (block_size * (x+1)+10+ cell_border*2) - ~y: (block_size * (y+1)+10+ cell_border*2); - Canvas.move canvas t3 - ~x: (block_size * (x+1)+10+ cell_border*2) - ~y: (block_size * (y+1)+10+ cell_border*2) - end - end; - color <- col -end - -let cell_get (c, cf) x y = cf.(y).(x) #get - -let cell_set (c, cf) ~x ~y ~color = - if x >= 0 && y >= 0 && Array.length cf > y && Array.length cf.(y) > x then - let cur = cf.(y).(x) in - if cur#get = color then () else cur#set ~color - -let create_base_matrix ~cols ~rows = - let m = Array.create_matrix ~dimx:rows ~dimy:cols (0,0) in - for x = 0 to cols - 1 do for y = 0 to rows - 1 do - m.(y).(x) <- (x,y) - done done; - m - -let init fw = - let scorev = Textvariable.create () - and linev = Textvariable.create () - and levv = Textvariable.create () - and namev = Textvariable.create () - in - let f = Frame.create fw ~borderwidth: 2 in - let c = Canvas.create f ~width: (block_size * 10) - ~height: (block_size * 20) - ~borderwidth: cell_border - ~relief: `Sunken - ~background: `Black - and r = Frame.create f - and r' = Frame.create f in - - let nl = Label.create r ~text: "Next" ~font: "variable" in - let nc = Canvas.create r ~width: (block_size * 4) - ~height: (block_size * 4) - ~borderwidth: cell_border - ~relief: `Sunken - ~background: `Black in - let scl = Label.create r ~text: "Score" ~font: "variable" in - let sc = Label.create r ~textvariable: scorev ~font: "variable" in - let lnl = Label.create r ~text: "Lines" ~font: "variable" in - let ln = Label.create r ~textvariable: linev ~font: "variable" in - let levl = Label.create r ~text: "Level" ~font: "variable" in - let lev = Label.create r ~textvariable: levv ~font: "variable" in - let newg = Button.create r ~text: "New Game" ~font: "variable" in - - pack [f]; - pack [coe c; coe r; coe r'] ~side: `Left ~fill: `Y; - pack [coe nl; coe nc] ~side: `Top; - pack [coe scl; coe sc; coe lnl; coe ln; coe levl; coe lev; coe newg] - ~side: `Top; - - let cells_src = create_base_matrix ~cols:field_width ~rows:field_height in - let cells = - Array.map cells_src ~f: - (Array.map ~f: - begin fun (x,y) -> - let t1 = - Canvas.create_rectangle c - ~x1:(-block_size - 8) ~y1:(-block_size - 8) - ~x2:(-9) ~y2:(-9) - and t2 = - Canvas.create_rectangle c - ~x1:(-block_size - 10) ~y1:(-block_size - 10) - ~x2:(-11) ~y2:(-11) - and t3 = - Canvas.create_rectangle c - ~x1:(-block_size - 12) ~y1:(-block_size - 12) - ~x2:(-13) ~y2:(-13) - in - Canvas.raise c t1; - Canvas.raise c t2; - Canvas.lower c t3; - new cell ~canvas:c ~x ~y t1 t2 t3 - end) - in - let nexts_src = create_base_matrix ~cols:4 ~rows:4 in - let nexts = - Array.map nexts_src ~f: - (Array.map ~f: - begin fun (x,y) -> - let t1 = - Canvas.create_rectangle nc - ~x1:(-block_size - 8) ~y1:(-block_size - 8) - ~x2:(-9) ~y2:(-9) - and t2 = - Canvas.create_rectangle nc - ~x1:(-block_size - 10) ~y1:(-block_size - 10) - ~x2:(-11) ~y2:(-11) - and t3 = - Canvas.create_rectangle nc - ~x1:(-block_size - 12) ~y1:(-block_size - 12) - ~x2:(-13) ~y2:(-13) - in - Canvas.raise nc t1; - Canvas.raise nc t2; - Canvas.lower nc t3; - new cell ~canvas:nc ~x ~y t1 t2 t3 - end) - in - let game_over () = () - in - (* What a mess ! *) - [ coe f; coe c; coe r; coe nl; coe nc; coe scl; coe sc; coe levl; coe lev; - coe lnl; coe ln ], - newg, (c, cells), (nc, nexts), scorev, linev, levv, game_over - - -let draw_block field ~color ~block ~x ~y = - for iy = 0 to 3 do - let base = ref 1 in - let xd = block.(iy) in - for ix = 0 to 3 do - if xd land !base <> 0 then - cell_set field ~x:(ix + x) ~y:(iy + y) ~color; - base := !base lsl 1 - done - done - -let timer_ref = (ref None : Timer.t option ref) -(* I know, this should be timer ref, but I'm not sure what should be - the initial value ... *) - -let remove_timer () = - match !timer_ref with - None -> () - | Some t -> Timer.remove t (* ; prerr_endline "removed!" *) - -let do_after ~ms ~callback = - timer_ref := Some (Timer.add ~ms ~callback) - -let copy_block c = - { pattern= !c.pattern; - bcolor= !c.bcolor; - x= !c.x; - y= !c.y; - d= !c.d; - alive= !c.alive } - -let _ = - let top = openTk () in - let lb = Label.create top - and fw = Frame.create top - in - let set_message s = Label.configure lb ~text:s in - pack [coe lb; coe fw] ~side: `Top; - let score = ref 0 in - let line = ref 0 in - let level = ref 0 in - let time = ref 1000 in - let blocks = List.map ~f:(List.map ~f:decode_block) blocks in - let field = Array.create 26 0 in - let widgets, button, cell_field, next_field, scorev, linev, levv, game_over - = init fw in - let canvas = fst cell_field in - - let init_field () = - for i = 0 to 25 do - field.(i) <- line_empty - done; - field.(23) <- line_full; - for i = 0 to 19 do - for j = 0 to 9 do - cell_set cell_field ~x:j ~y:i ~color:0 - done - done; - for i = 0 to 3 do - for j = 0 to 3 do - cell_set next_field ~x:j ~y:i ~color:0 - done - done - in - - let draw_falling_block fb = - draw_block cell_field ~color: fb.bcolor - ~block: (List.nth fb.pattern fb.d) - ~x: (fb.x - 3) - ~y: (fb.y - 3) - - and erase_falling_block fb = - draw_block cell_field ~color: 0 - ~block: (List.nth fb.pattern fb.d) - ~x: (fb.x - 3) - ~y: (fb.y - 3) - in - - let stone fb = - for i=0 to 3 do - let cur = field.(i + fb.y) in - field.(i + fb.y) <- - cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x) - done; - for i=0 to 2 do - field.(i) <- line_empty - done - - and clear fb = - let l = ref 0 in - for i = 0 to 3 do - if i + fb.y >= 3 && i + fb.y <= 22 then - if field.(i + fb.y) = line_full then - begin - incr l; - field.(i + fb.y) <- line_empty; - for j = 0 to 9 do - cell_set cell_field ~x:j ~y:(i + fb.y - 3) ~color:0 - done - end - done; - !l - - and fall_lines () = - let eye = ref 22 (* bottom *) - and cur = ref 22 (* bottom *) - in - try - while !eye >= 3 do - while field.(!eye) = line_empty do - decr eye; - if !eye = 2 then raise Done - done; - field.(!cur) <- field.(!eye); - for j = 0 to 9 do - cell_set cell_field ~x:j ~y:(!cur-3) - ~color:(cell_get cell_field j (!eye-3)) - done; - decr eye; - decr cur - done - with Done -> (); - for i = 3 to !cur do - field.(i) <- line_empty; - for j = 0 to 9 do - cell_set cell_field ~x:j ~y:(i-3) ~color:0 - done - done - in - - let next = ref 42 (* THE ANSWER *) - and current = - ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false} - in - - let draw_next () = - draw_block next_field ~color: (!next+1) - ~block: (List.hd (List.nth blocks !next)) - ~x: 0 ~y: 0 - - and erase_next () = - draw_block next_field ~color: 0 - ~block: (List.hd (List.nth blocks !next)) - ~x: 0 ~y: 0 - in - - let set_nextblock () = - current := - { pattern= (List.nth blocks !next); - bcolor= !next+1; - x=6; y= 1; d= 0; alive= true}; - erase_next (); - next := Random.int 7; - draw_next () - in - - let death_check fb = - try - for i=0 to 3 do - let cur = field.(i + fb.y) in - if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 - then raise Done - done; - false - with - Done -> true - in - - let try_to_move m = - if !current.alive then - let sub m = - if death_check m then false - else - begin - erase_falling_block !current; - draw_falling_block m; - current := m; - true - end - in - if sub m then true - else - begin - m.x <- m.x + 1; - if sub m then true - else - begin - m.x <- m.x - 2; - sub m - end - end - else false - in - - let image_load = - let i = Canvas.create_image canvas - ~x: (block_size * 5 + block_size / 2) - ~y: (block_size * 10 + block_size / 2) - ~anchor: `Center in - Canvas.lower canvas i; - let img = Imagephoto.create () in - fun file -> - try - Imagephoto.configure img ~file: file; - Canvas.configure_image canvas i ~image: img - with - _ -> - begin - Printf.eprintf "%s : No such image...\n" file; - flush stderr - end - in - - let add_score l = - let pline = !line in - if l <> 0 then - begin - line := !line + l; - score := !score + l * l; - set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2))) - end; - Textvariable.set linev (string_of_int !line); - Textvariable.set scorev (string_of_int !score); - - if !line /10 <> pline /10 then - (* update the background every 10 lines. *) - begin - let num_image = List.length backgrounds - 1 in - let n = !line/10 in - let n = if n > num_image then num_image else n in - let file = List.nth backgrounds n in - image_load file; - incr level; - Textvariable.set levv (string_of_int !level) - end - in - - let rec newblock () = - set_message "TETRIS"; - set_nextblock (); - draw_falling_block !current; - if death_check !current then - begin - !current.alive <- false; - set_message "GAME OVER"; - game_over () - end - else - begin - time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200); - if !time < 60 - !level * 3 then time := 60 - !level * 3; - do_after ~ms:stop_a_bit ~callback:loop - end - - and loop () = - let m = copy_block current in - m.y <- m.y + 1; - if death_check m then - begin - !current.alive <- false; - stone !current; - do_after ~ms:stop_a_bit ~callback: - begin fun () -> - let l = clear !current in - if l > 0 then - do_after ~ms:stop_a_bit ~callback: - begin fun () -> - fall_lines (); - add_score l; - do_after ~ms:stop_a_bit ~callback:newblock - end - else - newblock () - end - end - else - begin - erase_falling_block !current; - draw_falling_block m; - current := m; - do_after ~ms:!time ~callback:loop - end - in - - let bind_game w = - bind w ~events:[`KeyPress] ~fields:[`KeySymString] ~action: - begin fun e -> - match e.ev_KeySymString with - | "h"|"Left" -> - let m = copy_block current in - m.x <- m.x - 1; - ignore (try_to_move m) - | "j"|"Up" -> - let m = copy_block current in - m.d <- m.d + 1; - if m.d = List.length m.pattern then m.d <- 0; - ignore (try_to_move m) - | "k"|"Down" -> - let m = copy_block current in - m.d <- m.d - 1; - if m.d < 0 then m.d <- List.length m.pattern - 1; - ignore (try_to_move m) - | "l"|"Right" -> - let m = copy_block current in - m.x <- m.x + 1; - ignore (try_to_move m) - | "m" -> - remove_timer (); - loop () - | "space" -> - if !current.alive then - begin - let m = copy_block current - and n = copy_block current in - while - m.y <- m.y + 1; - if death_check m then false - else begin n.y <- m.y; true end - do () done; - erase_falling_block !current; - draw_falling_block n; - current := n; - remove_timer (); - loop () - end - | _ -> () - end - in - - let game_init () = - (* Game Initialization *) - set_message "Initializing ..."; - remove_timer (); - image_load (List.hd backgrounds); - time := 1000; - score := 0; - line := 0; - level := 1; - add_score 0; - init_field (); - next := Random.int 7; - set_message "Welcome to TETRIS"; - set_nextblock (); - draw_falling_block !current; - do_after ~ms:!time ~callback:loop - in - (* As an applet, it was required... *) - (* List.iter f: bind_game widgets; *) - bind_game top; - Button.configure button ~command: game_init; - game_init () - -let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/frx/.depend b/otherlibs/labltk/frx/.depend deleted file mode 100644 index 9b27a76b0b53..000000000000 --- a/otherlibs/labltk/frx/.depend +++ /dev/null @@ -1,38 +0,0 @@ -frx_after.cmo: frx_after.cmi -frx_after.cmx: frx_after.cmi -frx_color.cmo: frx_color.cmi -frx_color.cmx: frx_color.cmi -frx_ctext.cmo: frx_fit.cmi frx_text.cmi frx_ctext.cmi -frx_ctext.cmx: frx_fit.cmx frx_text.cmx frx_ctext.cmi -frx_dialog.cmo: frx_dialog.cmi -frx_dialog.cmx: frx_dialog.cmi -frx_entry.cmo: frx_entry.cmi -frx_entry.cmx: frx_entry.cmi -frx_fillbox.cmo: frx_fillbox.cmi -frx_fillbox.cmx: frx_fillbox.cmi -frx_fit.cmo: frx_after.cmi frx_fit.cmi -frx_fit.cmx: frx_after.cmx frx_fit.cmi -frx_focus.cmo: frx_focus.cmi -frx_focus.cmx: frx_focus.cmi -frx_font.cmo: frx_misc.cmi frx_font.cmi -frx_font.cmx: frx_misc.cmx frx_font.cmi -frx_lbutton.cmo: frx_lbutton.cmi -frx_lbutton.cmx: frx_lbutton.cmi -frx_listbox.cmo: frx_listbox.cmi -frx_listbox.cmx: frx_listbox.cmi -frx_mem.cmo: frx_mem.cmi -frx_mem.cmx: frx_mem.cmi -frx_misc.cmo: frx_misc.cmi -frx_misc.cmx: frx_misc.cmi -frx_req.cmo: frx_entry.cmi frx_listbox.cmi frx_widget.cmi frx_req.cmi -frx_req.cmx: frx_entry.cmx frx_listbox.cmx frx_widget.cmx frx_req.cmi -frx_rpc.cmo: frx_rpc.cmi -frx_rpc.cmx: frx_rpc.cmi -frx_selection.cmo: frx_selection.cmi -frx_selection.cmx: frx_selection.cmi -frx_synth.cmo: frx_synth.cmi -frx_synth.cmx: frx_synth.cmi -frx_text.cmo: frx_misc.cmi frx_text.cmi -frx_text.cmx: frx_misc.cmx frx_text.cmi -frx_widget.cmo: frx_widget.cmi -frx_widget.cmx: frx_widget.cmi diff --git a/otherlibs/labltk/frx/Makefile b/otherlibs/labltk/frx/Makefile deleted file mode 100644 index 947e174d9cde..000000000000 --- a/otherlibs/labltk/frx/Makefile +++ /dev/null @@ -1,67 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 2002 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -include ../support/Makefile.common - -COMPFLAGS=-I ../camltk -I ../support -I $(OTHERS)/unix - -OBJS= frx_misc.cmo frx_widget.cmo frx_font.cmo frx_entry.cmo frx_text.cmo \ - frx_listbox.cmo frx_req.cmo frx_fillbox.cmo frx_focus.cmo \ - frx_dialog.cmo frx_mem.cmo frx_rpc.cmo frx_synth.cmo frx_selection.cmo \ - frx_after.cmo frx_fit.cmo frx_ctext.cmo frx_color.cmo - -OBJSX = $(OBJS:.cmo=.cmx) - -all: frxlib.cma - -opt: frxlib.cmxa - -frxlib.cma: $(OBJS) - $(CAMLLIBR) -o frxlib.cma $(OBJS) - -frxlib.cmxa: $(OBJSX) - $(CAMLOPTLIBR) -o frxlib.cmxa $(OBJSX) - -install: frxlib.cma - cp *.cmi *.mli frxlib.cma $(INSTALLDIR) - -installopt: frxlib.cmxa - cp frxlib.cmxa frxlib.a $(INSTALLDIR) - -clean: - rm -f *.cm* *.o *.a - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJSX): ../lib/$(LIBNAME).cmxa - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .cmx - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -nojoin -c $(COMPFLAGS) $< - - -depend: - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/labltk/frx/Makefile.nt b/otherlibs/labltk/frx/Makefile.nt deleted file mode 100644 index 2f37a4cb9139..000000000000 --- a/otherlibs/labltk/frx/Makefile.nt +++ /dev/null @@ -1,53 +0,0 @@ -include ../support/Makefile.common.nt - -COMPFLAGS=-I ../camltk -I ../support - -OBJS= frx_misc.cmo frx_widget.cmo frx_font.cmo frx_entry.cmo frx_text.cmo \ - frx_listbox.cmo frx_req.cmo frx_fillbox.cmo frx_focus.cmo \ - frx_dialog.cmo frx_mem.cmo frx_rpc.cmo frx_synth.cmo frx_selection.cmo \ - frx_after.cmo frx_fit.cmo frx_ctext.cmo frx_color.cmo - -OBJSX = $(OBJS:.cmo=.cmx) - -all: libfrx.cma - -opt: libfrx.cmxa - -libfrx.cma: $(OBJS) - $(CAMLLIBR) -o libfrx.cma $(OBJS) - -libfrx.cmxa: $(OBJSX) - $(CAMLOPTLIBR) -o libfrx.cmxa $(OBJSX) - - -install: libfrx.cma - cp *.cmi *.mli libfrx.cma $(INSTALLDIR) - -installopt: libfrx.cmxa - cp libfrx.cmxa libfrx.$(A) $(INSTALLDIR) - - -clean: - rm -f *.cm* *.$(O) *.$(A) *~ *test - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJSX): ../lib/$(LIBNAME).cmxa - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .cmx - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - - -depend: - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/labltk/frx/README b/otherlibs/labltk/frx/README deleted file mode 100644 index b86f8dcd8567..000000000000 --- a/otherlibs/labltk/frx/README +++ /dev/null @@ -1,2 +0,0 @@ -This is Francois Rouaix's widget set library, Frx. -It uses CamlTk API. \ No newline at end of file diff --git a/otherlibs/labltk/frx/frx_after.ml b/otherlibs/labltk/frx/frx_after.ml deleted file mode 100644 index 1b7dfef8bd3a..000000000000 --- a/otherlibs/labltk/frx/frx_after.ml +++ /dev/null @@ -1,24 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Protocol -let idle f = - let id = new_function_id () in - let wrapped _ = - clear_callback id; (* do it first in case f raises exception *) - f() in - Hashtbl.add callback_naming_table id wrapped; - tkCommand [| TkToken "after"; TkToken "idle"; - TkToken ("camlcb "^ string_of_cbid id) |] diff --git a/otherlibs/labltk/frx/frx_after.mli b/otherlibs/labltk/frx/frx_after.mli deleted file mode 100644 index 45e30456c406..000000000000 --- a/otherlibs/labltk/frx/frx_after.mli +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -val idle : (unit -> unit) -> unit - (* [idle f] is equivalent to Tk "after idle {camlcb f}" *) diff --git a/otherlibs/labltk/frx/frx_color.ml b/otherlibs/labltk/frx/frx_color.ml deleted file mode 100644 index e3e616a98ec0..000000000000 --- a/otherlibs/labltk/frx/frx_color.ml +++ /dev/null @@ -1,35 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Protocol - -module StringSet = Set.Make(struct type t = string let compare = compare end) - -(* should we keep a negative cache ? *) -let available_colors = ref (StringSet.empty) - -let check s = - if StringSet.mem s !available_colors then true - else begin - try - let f = Frame.create_named Widget.default_toplevel "frxcolorcheck" - [Background (NamedColor s)] in - available_colors := StringSet.add s !available_colors; - destroy f; - true - with - TkError _ -> false - end diff --git a/otherlibs/labltk/frx/frx_color.mli b/otherlibs/labltk/frx/frx_color.mli deleted file mode 100644 index b2791655a5dc..000000000000 --- a/otherlibs/labltk/frx/frx_color.mli +++ /dev/null @@ -1,16 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -val check : string -> bool diff --git a/otherlibs/labltk/frx/frx_ctext.ml b/otherlibs/labltk/frx/frx_ctext.ml deleted file mode 100644 index 498fe8ec7811..000000000000 --- a/otherlibs/labltk/frx/frx_ctext.ml +++ /dev/null @@ -1,66 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* A trick by Steve Ball to do pixel scrolling on text widgets *) -(* USES frx_fit *) -open Camltk - -let create top opts navigation = - let f = Frame.create top [BorderWidth (Pixels 2); Relief Raised] in - let lf = Frame.create f [] in - let rf = Frame.create f [] in - let c = Canvas.create lf [BorderWidth (Pixels 0)] - and xscroll = Scrollbar.create lf [Orient Horizontal] - and yscroll = Scrollbar.create rf [Orient Vertical] - and secret = Frame.create_named rf "secret" [] - in - let t = Text.create c (BorderWidth(Pixels 0) :: opts) in - if navigation then Frx_text.navigation_keys t; - - (* Make the text widget an embedded canvas object *) - ignore - (Canvas.create_window c (Pixels 0) (Pixels 0) - [Anchor NW; Window t; Tags [Tag "main"]]); - Canvas.focus c (Tag "main"); - (* - Canvas.configure c [Width (Pixels (Winfo.reqwidth t)); - Height(Pixels (Winfo.reqheight t))]; - *) - Canvas.configure c [YScrollCommand (Scrollbar.set yscroll)]; - (* The horizontal scrollbar is directly attached to the - * text widget, because h scrolling works properly *) - Scrollbar.configure xscroll [ScrollCommand (Text.xview t)]; - (* But vertical scroll is attached to the canvas *) - Scrollbar.configure yscroll [ScrollCommand (Canvas.yview c)]; - let scroll, check = Frx_fit.vert t in - Text.configure t [ - XScrollCommand (Scrollbar.set xscroll); - YScrollCommand (fun first last -> - scroll first last; - let x,y,w,h = Canvas.bbox c [Tag "main"] in - Canvas.configure c - [ScrollRegion (Pixels x, Pixels y, Pixels w, Pixels h)]) - ]; - - bind c [[],Configure] (BindSet ([Ev_Width], (fun ei -> - Canvas.configure_window c (Tag "main") [Width (Pixels ei.ev_Width)]))); - - pack [rf] [Side Side_Right; Fill Fill_Y]; - pack [lf] [Side Side_Left; Fill Fill_Both; Expand true]; - pack [secret] [Side Side_Bottom]; - pack [yscroll] [Side Side_Top; Fill Fill_Y; Expand true]; - pack [xscroll] [Side Side_Bottom; Fill Fill_X]; - pack [c] [Side Side_Left; Fill Fill_Both; Expand true]; - f, t diff --git a/otherlibs/labltk/frx/frx_ctext.mli b/otherlibs/labltk/frx/frx_ctext.mli deleted file mode 100644 index 2f696abea1fe..000000000000 --- a/otherlibs/labltk/frx/frx_ctext.mli +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -val create : - Widget.widget -> Camltk.options list -> bool -> Widget.widget * Widget.widget - (* [create parent opts nav_keys] creates a text widget - with "pixel scrolling". Based on a trick learned from Steve Ball. - Returns (frame widget, text widget). - *) diff --git a/otherlibs/labltk/frx/frx_dialog.ml b/otherlibs/labltk/frx/frx_dialog.ml deleted file mode 100644 index 096812dbc61a..000000000000 --- a/otherlibs/labltk/frx/frx_dialog.ml +++ /dev/null @@ -1,115 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Protocol - -let rec mapi f n l = - match l with - [] -> [] - | x::l -> let v = f n x in v::(mapi f (succ n) l) - -(* Same as tk_dialog, but not sharing the tkwait variable *) -(* w IS the parent widget *) -let f w name title mesg bitmap def buttons = - let t = Toplevel.create_named w name [Class "Dialog"] in - Wm.title_set t title; - Wm.iconname_set t "Dialog"; - Wm.protocol_set t "WM_DELETE_WINDOW" (function () -> ()); - (* Wm.transient_set t (Winfo.toplevel w); *) - let ftop = - Frame.create_named t "top" [Relief Raised; BorderWidth (Pixels 1)] - and fbot = - Frame.create_named t "bot" [Relief Raised; BorderWidth (Pixels 1)] - in - pack [ftop][Side Side_Top; Fill Fill_Both]; - pack [fbot][Side Side_Bottom; Fill Fill_Both]; - - let l = - Label.create_named ftop "msg" - [Justify Justify_Left; Text mesg; WrapLength (Pixels 600)] in - pack [l][Side Side_Right; Expand true; Fill Fill_Both; - PadX (Millimeters 3.0); PadY (Millimeters 3.0)]; - begin match bitmap with - Predefined "" -> () - | _ -> - let b = - Label.create_named ftop "bitmap" [Bitmap bitmap] in - pack [b][Side Side_Left; PadX (Millimeters 3.0); PadY (Millimeters 3.0)] - end; - - let waitv = Textvariable.create_temporary t in - - let buttons = - mapi (fun i bname -> - let b = Button.create t - [Text bname; - Command (fun () -> Textvariable.set waitv (string_of_int i))] in - if i = def then begin - let f = Frame.create_named fbot "default" - [Relief Sunken; BorderWidth (Pixels 1)] in - raise_window_above b f; - pack [f][Side Side_Left; Expand true; - PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; - pack [b][In f; PadX (Millimeters 2.0); PadY (Millimeters 2.0)]; - bind t [[], KeyPressDetail "Return"] - (BindSet ([], (fun _ -> Button.flash b; Button.invoke b))) - end - else - pack [b][In fbot; Side Side_Left; Expand true; - PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; - b - ) - 0 buttons in - - Wm.withdraw t; - update_idletasks(); - let x = (Winfo.screenwidth t)/2 - (Winfo.reqwidth t)/2 - - (Winfo.vrootx (Winfo.parent t)) - and y = (Winfo.screenheight t)/2 - (Winfo.reqheight t)/2 - - (Winfo.vrooty (Winfo.parent t)) in - Wm.geometry_set t (Printf.sprintf "+%d+%d" x y); - Wm.deiconify t; - - let oldfocus = try Some (Focus.get()) with _ -> None - and oldgrab = Grab.current ~displayof: t () - and grabstatus = ref None in - begin match oldgrab with - [] -> () - | x::l -> grabstatus := Some(Grab.status x) - end; - - (* avoid errors here because it makes the entire app useless *) - (try Grab.set t with TkError _ -> ()); - Tkwait.visibility t; - Focus.set (if def >= 0 then List.nth buttons def else t); - - Tkwait.variable waitv; - begin match oldfocus with - None -> () - | Some w -> try Focus.set w with _ -> () - end; - destroy t; - begin match oldgrab with - [] -> () - | x::l -> - try - match !grabstatus with - Some(GrabGlobal) -> Grab.set_global x - | _ -> Grab.set x - with TkError _ -> () - end; - - int_of_string (Textvariable.get waitv) diff --git a/otherlibs/labltk/frx/frx_dialog.mli b/otherlibs/labltk/frx/frx_dialog.mli deleted file mode 100644 index fd816d34c277..000000000000 --- a/otherlibs/labltk/frx/frx_dialog.mli +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val f : - Widget.widget -> - string -> string -> string -> Camltk.bitmap -> int -> string list -> int - (* same as Dialog.create_named, but with a local variable for - synchronisation. Makes it possible to have several dialogs - simultaneously *) diff --git a/otherlibs/labltk/frx/frx_entry.ml b/otherlibs/labltk/frx/frx_entry.ml deleted file mode 100644 index 0b7c339a0229..000000000000 --- a/otherlibs/labltk/frx/frx_entry.ml +++ /dev/null @@ -1,40 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let version = "$Id$" - -(* - * Tk 4.0 has emacs bindings for entry widgets - *) - -let new_label_entry parent txt action = - let f = Frame.create parent [] in - let m = Label.create f [Text txt] - and e = Entry.create f [Relief Sunken; TextWidth 0] in - Camltk.bind e [[], KeyPressDetail "Return"] - (BindSet ([], fun _ -> action(Entry.get e))); - pack [m][Side Side_Left]; - pack [e][Side Side_Right; Fill Fill_X; Expand true]; - f,e - -let new_labelm_entry parent txt memo = - let f = Frame.create parent [] in - let m = Label.create f [Text txt] - and e = Entry.create f [Relief Sunken; TextVariable memo; TextWidth 0] in - pack [m][Side Side_Left]; - pack [e][Side Side_Right; Fill Fill_X; Expand true]; - f,e diff --git a/otherlibs/labltk/frx/frx_entry.mli b/otherlibs/labltk/frx/frx_entry.mli deleted file mode 100644 index 0b09f16d3d2a..000000000000 --- a/otherlibs/labltk/frx/frx_entry.mli +++ /dev/null @@ -1,31 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val new_label_entry : - Widget.widget -> - string -> (string -> unit) -> Widget.widget * Widget.widget - (* [new_label_entry parent label action] - creates a "labelled" entry widget where [action] will be invoked - when the user types Return in the widget. - Returns (frame widget, entry widget) - *) -val new_labelm_entry : - Widget.widget -> - string -> Textvariable.textVariable -> Widget.widget * Widget.widget - (* [new_labelm_entry parent label variable] - creates a "labelled" entry widget whose contents is [variable]. - Returns (frame widget, entry widget) - *) diff --git a/otherlibs/labltk/frx/frx_fileinput.ml b/otherlibs/labltk/frx/frx_fileinput.ml deleted file mode 100644 index dfba7a0f82d9..000000000000 --- a/otherlibs/labltk/frx/frx_fileinput.ml +++ /dev/null @@ -1,39 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let version = "$Id$" - -(* - * Simple spooling for fileinput callbacks - *) - -let waiting_list = Queue. new() -and waiting = ref 0 -and max_open = ref 10 -and cur_open = ref 0 - -let add fd f = - if !cur_open < !max_open then begin - incr cur_open; - add_fileinput fd f - end - else begin - incr waiting; - Queue.add (fd,f) waiting_list - end - -let remove fd = diff --git a/otherlibs/labltk/frx/frx_fillbox.ml b/otherlibs/labltk/frx/frx_fillbox.ml deleted file mode 100644 index 143bea4a2121..000000000000 --- a/otherlibs/labltk/frx/frx_fillbox.ml +++ /dev/null @@ -1,65 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -(* - * Progress indicators - *) -let okcolor = NamedColor "#3cb371" -and kocolor = NamedColor "#dc5c5c" - - -let new_vertical parent w h = - let c = Canvas.create_named parent "fillbox" - [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); - Relief Sunken] - in - let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels w) (Pixels 0) - [FillColor okcolor; Outline okcolor] - in - c, (function - 0 -> Canvas.configure_rectangle c i [FillColor okcolor; - Outline okcolor]; - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels w; Pixels 0] - | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; - Outline kocolor] - | n -> - let percent = if n > 100 then 100 else n in - let hf = percent*h/100 in - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels w; Pixels hf]) - -let new_horizontal parent w h = - let c = Canvas.create_named parent "fillbox" - [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); - Relief Sunken] - in - let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels 0) (Pixels h) - [FillColor okcolor; Outline okcolor] - in - c, (function - 0 -> Canvas.configure_rectangle c i [FillColor okcolor; - Outline okcolor]; - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels 0; Pixels h] - | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; - Outline kocolor] - | n -> - let percent = if n > 100 then 100 else n in - let wf = percent*w/100 in - Canvas.coords_set c i [Pixels 0; Pixels 0; - Pixels wf; Pixels h]) diff --git a/otherlibs/labltk/frx/frx_fillbox.mli b/otherlibs/labltk/frx/frx_fillbox.mli deleted file mode 100644 index 9cfc9e780bdf..000000000000 --- a/otherlibs/labltk/frx/frx_fillbox.mli +++ /dev/null @@ -1,31 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -val new_vertical : - Widget.widget -> int -> int -> Widget.widget * (int -> unit) - (* [new_vertical parent width height] - creates a vertical fillbox of [width] and [height]. - Returns a frame widget and a function to set the current value of - the fillbox. The value can be - n < 0 : the fillbox changes color (reddish) - 0 <= n <= 100: the fillbox fills up to n percent - 100 <= n : the fillbox fills up to 95% - *) - -val new_horizontal : - Widget.widget -> int -> int -> Widget.widget * (int -> unit) - (* save as above, except the widget is horizontal *) diff --git a/otherlibs/labltk/frx/frx_fit.ml b/otherlibs/labltk/frx/frx_fit.ml deleted file mode 100644 index bcfd457a2e3a..000000000000 --- a/otherlibs/labltk/frx/frx_fit.ml +++ /dev/null @@ -1,83 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let debug = ref false - -let vert wid = - let newsize = ref 0 - and pending_resize = ref false - and last_last = ref 0.0 in - let rec resize () = - pending_resize := false; - if !debug then - (Printf.eprintf "%s Resize %d\n" - (Widget.name wid) !newsize; flush stderr); - Text.configure wid [TextHeight !newsize]; - () - and check () = - let first, last = Text.yview_get wid in - check1 first last - - and check1 first last = - let curheight = int_of_string (cget wid CHeight) in - if !debug then begin - Printf.eprintf "%s C %d %f %f\n" - (Widget.name wid) curheight first last; - flush stderr - end; - if first = 0.0 && last = 1.0 then () - (* Don't attempt anything if widget is not visible *) - else if not (Winfo.viewable wid) then begin - if !debug then - (Printf.eprintf "%s C notviewable\n" (Widget.name wid); - flush stderr); - (* Try again later *) - bind wid [[], Expose] (BindSet ([], fun _ -> - bind wid [[], Expose] BindRemove; - check())) - end - else begin - let delta = - if last = 0.0 then 1 - else if last = !last_last then - (* it didn't change since our last resize ! *) - 1 - else begin - last_last := last; - (* never to more than double *) - let visible = max 0.5 (last -. first) in - max 1 (truncate (float curheight *. (1. -. visible))) - end in - newsize := max (curheight + delta) !newsize; - if !debug then - (Printf.eprintf "%s newsize: %d\n" (Widget.name wid) !newsize; - flush stderr); - if !pending_resize then () - else begin - pending_resize := true; - Timer.set 300 (fun () -> Frx_after.idle resize) - end - end - - and scroll first last = - if !debug then - (Printf.eprintf "%s V %f %f\n" (Widget.name wid) first last; - flush stderr); - if first = 0.0 && last = 1.0 then () - else check1 first last - in - scroll, check diff --git a/otherlibs/labltk/frx/frx_fit.mli b/otherlibs/labltk/frx/frx_fit.mli deleted file mode 100644 index e61496455319..000000000000 --- a/otherlibs/labltk/frx/frx_fit.mli +++ /dev/null @@ -1,29 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget - -val debug: bool ref -val vert: widget -> (float -> float -> unit) * (unit -> unit) - -(* [vert widget] - can be applied to a text widget so that it expands to show its full - contents. Returns [scroll] and [check]. [scroll] must be used as - the YScrollCommand of the widget. [check] can be called when some - modification occurs in the content of the widget (such as a size change - in some embedded windows. - This feature is a terrible hack and should be used with extreme caution. - *) diff --git a/otherlibs/labltk/frx/frx_focus.ml b/otherlibs/labltk/frx/frx_focus.ml deleted file mode 100644 index 29eba574d8c3..000000000000 --- a/otherlibs/labltk/frx/frx_focus.ml +++ /dev/null @@ -1,26 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -(* Temporary focus *) - -(* ? use bind tag ? how about the global reference then *) -let auto w = - let old_focus = ref w in - bind w [[],Enter] - (BindSet([], fun _ -> old_focus := Focus.get (); Focus.set w)); - bind w [[],Leave] - (BindSet([], fun _ -> Focus.set !old_focus)) diff --git a/otherlibs/labltk/frx/frx_focus.mli b/otherlibs/labltk/frx/frx_focus.mli deleted file mode 100644 index dcb9317f8dbe..000000000000 --- a/otherlibs/labltk/frx/frx_focus.mli +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val auto : Widget.widget -> unit - (* *) diff --git a/otherlibs/labltk/frx/frx_font.ml b/otherlibs/labltk/frx/frx_font.ml deleted file mode 100644 index 4acb59979ea6..000000000000 --- a/otherlibs/labltk/frx/frx_font.ml +++ /dev/null @@ -1,50 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget - -let version = "$Id$" - -(* - * Finding fonts. Inspired by code in Ical by Sanjay Ghemawat. - * Possibly bogus because some families use "i" for italic where others - * use "o". - * wght: bold, medium - * slant: i, o, r - * pxlsz: 8, 10, ... -*) -module StringSet = Set.Make(struct type t = string let compare = compare end) - -let available_fonts = ref (StringSet.empty) - -let get_canvas = - Frx_misc.autodef (fun () -> Canvas.create Widget.default_toplevel []) - - -let find fmly wght slant pxlsz = - let fontspec = - "-*-"^fmly^"-"^wght^"-"^slant^"-normal-*-"^string_of_int pxlsz^"-*-*-*-*-*-iso8859-1" in - if StringSet.mem fontspec !available_fonts then fontspec - else - let c = get_canvas() in - try - let tag = Canvas.create_text c (Pixels 0) (Pixels 0) - [Text "foo"; Font fontspec] in - Canvas.delete c [tag]; - available_fonts := StringSet.add fontspec !available_fonts; - fontspec - with - _ -> raise (Invalid_argument fontspec) diff --git a/otherlibs/labltk/frx/frx_font.mli b/otherlibs/labltk/frx/frx_font.mli deleted file mode 100644 index 4ed235f4ce10..000000000000 --- a/otherlibs/labltk/frx/frx_font.mli +++ /dev/null @@ -1,20 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -val find : string -> string -> string -> int -> string - (* [find family weight slant pxlsz] returns the X11 full name of - the font required font, if available. - Raises Invalid_argument fullname otherwise. - *) diff --git a/otherlibs/labltk/frx/frx_group.ml b/otherlibs/labltk/frx/frx_group.ml deleted file mode 100644 index 1adc2d8804c2..000000000000 --- a/otherlibs/labltk/frx/frx_group.ml +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let vgroup top l = - let f = Frame.create top [] in - Pack.forget l; - Pack.configure l [In f]; - f diff --git a/otherlibs/labltk/frx/frx_lbutton.ml b/otherlibs/labltk/frx/frx_lbutton.ml deleted file mode 100644 index 82ea8a8cc90d..000000000000 --- a/otherlibs/labltk/frx/frx_lbutton.ml +++ /dev/null @@ -1,50 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -open Widget - - -let version = "$Id$" - -(* - * Simulate a button with a bitmap AND a label - *) - -let rec sort_options but lab com = function - [] -> but,lab,com - |(Command f as o)::l -> sort_options (o::but) lab com l - |(Bitmap b as o)::l -> sort_options (o::but) lab com l - |(Text t as o)::l -> sort_options but (o::lab) com l - |o::l -> sort_options but lab (o::com) l - -let create parent options = - let but,lab,com = sort_options [] [] [] options in - let f = Frame.create parent com in - let b = Button.create f (but@com) - and l = Label.create f (lab@com) in - pack [b;l][]; - bind l [[],ButtonPressDetail 1] (BindSet ([],(function _ -> Button.invoke b))); - f - -let configure f options = - let but,lab,com = sort_options [] [] [] options in - match Pack.slaves f with - [b;l] -> - Frame.configure f com; - Button.configure b (but@com); - Label.configure l (lab@com) - | _ -> raise (Invalid_argument "lbutton configure") diff --git a/otherlibs/labltk/frx/frx_lbutton.mli b/otherlibs/labltk/frx/frx_lbutton.mli deleted file mode 100644 index 5522e5c24884..000000000000 --- a/otherlibs/labltk/frx/frx_lbutton.mli +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Widget -open Camltk - - -val version : string - -val create : Widget -> option list -> Widget -and configure : Widget -> option list -> unit diff --git a/otherlibs/labltk/frx/frx_listbox.ml b/otherlibs/labltk/frx/frx_listbox.ml deleted file mode 100644 index 6d04262b698f..000000000000 --- a/otherlibs/labltk/frx/frx_listbox.ml +++ /dev/null @@ -1,92 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let version = "$Id$" - -(* - * Link a scrollbar and a listbox - *) -let scroll_link sb lb = - Listbox.configure lb - [YScrollCommand (Scrollbar.set sb)]; - Scrollbar.configure sb - [ScrollCommand (Listbox.yview lb)] - -(* - * Completion for listboxes, Macintosh style. - * As long as you type fast enough, the listbox is repositioned to the - * first entry "greater" than the typed prefix. - * assumes: - * sorted list (otherwise it's stupid) - * fixed size, because we don't recompute size at each callback invocation - *) - -let add_completion lb action = - let prefx = ref "" (* current match prefix *) - and maxi = Listbox.size lb - 1 (* maximum index (doesn't matter actually) *) - and current = ref 0 (* current position *) - and lastevent = ref 0 in - - let rec move_forward () = - if Listbox.get lb (Number !current) < !prefx then - if !current < maxi then begin incr current; move_forward() end - - and recenter () = - let element = Number !current in - (* Clean the selection *) - Listbox.selection_clear lb (Number 0) End; - (* Set it to our unique element *) - Listbox.selection_set lb element element; - (* Activate it, to keep consistent with Up/Down. - You have to be in Extended or Browse mode *) - Listbox.activate lb element; - Listbox.selection_anchor lb element; - Listbox.see lb element in - - let complete time s = - if time - !lastevent < 500 then (* sorry, hard coded limit *) - prefx := !prefx ^ s - else begin (* reset *) - current := 0; - prefx := s - end; - lastevent := time; - move_forward(); - recenter() in - - - bind lb [[], KeyPress] - (BindSet([Ev_Char; Ev_Time], - (function ev -> - (* consider only keys producing characters. The callback is called - * even if you press Shift. - *) - if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char))); - (* Key specific bindings override KeyPress *) - bind lb [[], KeyPressDetail "Return"] (BindSet([], action)); - (* Finally, we have to set focus, otherwise events dont get through *) - Focus.set lb; - recenter() (* so that first item is selected *) - -let new_scrollable_listbox top options = - let f = Frame.create top [] in - let lb = Listbox.create f options - and sb = Scrollbar.create f [] in - scroll_link sb lb; - pack [lb] [Side Side_Left; Fill Fill_Both; Expand true]; - pack [sb] [Side Side_Left; Fill Fill_Y]; - f, lb diff --git a/otherlibs/labltk/frx/frx_listbox.mli b/otherlibs/labltk/frx/frx_listbox.mli deleted file mode 100644 index 54e7ec6a72c6..000000000000 --- a/otherlibs/labltk/frx/frx_listbox.mli +++ /dev/null @@ -1,32 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val scroll_link : Widget.widget -> Widget.widget -> unit - (* [scroll_link scrollbar listbox] links [scrollbar] and [listbox] - as expected. - *) - -val add_completion : Widget.widget -> (eventInfo -> unit) -> unit - (* [add_completion listbox action] adds Macintosh like electric navigation - in the listbox when characters are typed in. - [action] is invoked if Return is pressed - *) - -val new_scrollable_listbox : - Widget.widget -> options list -> Widget.widget * Widget.widget - (* [new_scrollable_listbox parent options] makes a scrollable listbox and - returns (frame, listbox) - *) diff --git a/otherlibs/labltk/frx/frx_mem.ml b/otherlibs/labltk/frx/frx_mem.ml deleted file mode 100644 index 6df0da75f17d..000000000000 --- a/otherlibs/labltk/frx/frx_mem.ml +++ /dev/null @@ -1,89 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Memory gauge *) -open Camltk -open Gc - -let inited = ref None -let w = ref 300 -let delay = ref 5 (* in seconds *) -let wordsize = (* officially approved *) - if 1 lsl 31 = 0 then 4 else 8 - - -let init () = - let top = Toplevel.create Widget.default_toplevel [Class "CamlGC"] in - let name = Camltk.appname_get () in - Wm.title_set top (name ^ " Memory Gauge"); - Wm.withdraw top; - inited := Some top; - (* this should be executed before the internal "all" binding *) - bind top [[], Destroy] (BindSet ([], (fun _ -> inited := None))); - let fminors = Frame.create top [] in - let lminors = Label.create fminors [Text "Minor collections"] - and vminors = Label.create fminors [] in - pack [lminors][Side Side_Left]; - pack [vminors][Side Side_Right; Fill Fill_X; Expand true]; - let fmajors = Frame.create top [] in - let lmajors = Label.create fmajors [Text "Major collections"] - and vmajors = Label.create fmajors [] in - pack [lmajors][Side Side_Left]; - pack [vmajors][Side Side_Right; Fill Fill_X; Expand true]; - let fcompacts = Frame.create top [] in - let lcompacts = Label.create fcompacts [Text "Compactions"] - and vcompacts = Label.create fcompacts [] in - pack [lcompacts][Side Side_Left]; - pack [vcompacts][Side Side_Right; Fill Fill_X; Expand true]; - let fsize = Frame.create top [] in - let lsize = Label.create fsize [Text "Heap size (bytes)"] - and vsize = Label.create fsize [] in - pack [lsize][Side Side_Left]; - pack [vsize][Side Side_Right; Fill Fill_X; Expand true]; - let fheap = Frame.create top [Width (Pixels !w); Height (Pixels 10)] in - let flive = Frame.create fheap [Background Red] - and ffree = Frame.create fheap [Background Green] - and fdead = Frame.create fheap [Background Black] in - pack [fminors; fmajors; fcompacts; fsize; fheap][Fill Fill_X]; - - let display () = - let st = Gc.stat() in - Label.configure vminors [Text (string_of_int st.minor_collections)]; - Label.configure vmajors [Text (string_of_int st.major_collections)]; - Label.configure vcompacts [Text (string_of_int st.compactions)]; - Label.configure vsize [Text (string_of_int (wordsize * st.heap_words))]; - let liver = (float st.live_words) /. (float st.heap_words) - and freer = (float st.free_words) /. (float st.heap_words) in - Place.configure flive [X (Pixels 0); Y (Pixels 0); - RelWidth liver; RelHeight 1.0]; - Place.configure ffree [RelX liver; Y (Pixels 0); - RelWidth freer; RelHeight 1.0]; - Place.configure fdead [RelX (liver +. freer); Y (Pixels 0); - RelWidth (1.0 -. freer -. liver); RelHeight 1.0] - - in - let rec tim () = - if Winfo.exists top then begin - display(); - Timer.set (!delay * 1000) tim - end - in - tim() - - -let rec f () = - match !inited with - Some w -> Wm.deiconify w - | None -> init (); f() diff --git a/otherlibs/labltk/frx/frx_mem.mli b/otherlibs/labltk/frx/frx_mem.mli deleted file mode 100644 index 190297b5e82c..000000000000 --- a/otherlibs/labltk/frx/frx_mem.mli +++ /dev/null @@ -1,22 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* A Garbage Collector Gauge for OCaml *) - -val init : unit -> unit - (* [init ()] creates the gauge and its updater, but keeps it iconified *) - -val f : unit -> unit - (* [f ()] makes the gauge visible if it has not been destroyed *) diff --git a/otherlibs/labltk/frx/frx_misc.ml b/otherlibs/labltk/frx/frx_misc.ml deleted file mode 100644 index e45c5f0f03a0..000000000000 --- a/otherlibs/labltk/frx/frx_misc.ml +++ /dev/null @@ -1,69 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Delayed global, a.k.a cache&carry *) -let autodef f = - let v = ref None in - (function () -> - match !v with - None -> - let x = f() in - v := Some x; - x - | Some x -> x) - -open Camltk - -(* allows Data in options *) -let create_photo options = - let hasopt = ref None in - (* Check options *) - List.iter (function - Data s -> - begin match !hasopt with - None -> hasopt := Some (Data s) - | Some _ -> raise (Protocol.TkError "two data sources in options") - end - | File f -> - begin match !hasopt with - None -> hasopt := Some (File f) - | Some _ -> raise (Protocol.TkError "two data sources in options") - end - | o -> ()) - options; - match !hasopt with - None -> raise (Protocol.TkError "no data source in options") - | Some (Data s) -> - begin - let tmpfile = Filename.temp_file "img" "" in - let oc = open_out_bin tmpfile in - output_string oc s; - close_out oc; - let newopts = - List.map (function - | Data s -> File tmpfile - | o -> o) - options in - try - let i = Imagephoto.create newopts in - (try Sys.remove tmpfile with Sys_error _ -> ()); - i - with - e -> - (try Sys.remove tmpfile with Sys_error _ -> ()); - raise e - end - | Some (File s) -> Imagephoto.create options - | _ -> assert false diff --git a/otherlibs/labltk/frx/frx_misc.mli b/otherlibs/labltk/frx/frx_misc.mli deleted file mode 100644 index cd3d589fa1e3..000000000000 --- a/otherlibs/labltk/frx/frx_misc.mli +++ /dev/null @@ -1,21 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -val autodef : (unit -> 'a) -> (unit -> 'a) - (* [autodef make] is a pleasant wrapper around 'a option ref *) - -val create_photo : Camltk.options list -> Camltk.imagePhoto - (* [create_photo options] allows Data in options (by saving to tmp file) *) diff --git a/otherlibs/labltk/frx/frx_req.ml b/otherlibs/labltk/frx/frx_req.ml deleted file mode 100644 index 41590c14515d..000000000000 --- a/otherlibs/labltk/frx/frx_req.ml +++ /dev/null @@ -1,198 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -(* - * Some standard requesters (in Amiga techspeak) or dialog boxes (in Apple - * jargon). -*) - -let version = "$Id$" - -(* - * Simple requester - * an entry field, unrestricted, with emacs-like bindings - * Note: grabs focus, thus always unique at one given moment, and we - * shouldn't have to worry about toplevel widget name. - * We add a title widget in case the window manager does not decorate - * toplevel windows. -*) - -let open_simple title action notaction memory = - let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in - Focus.set t; - Wm.title_set t title; - let tit = Label.create t [Text title] in - let len = max 40 (String.length (Textvariable.get memory)) in - let e = - Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in - - let activate _ = - let v = Entry.get e in - Grab.release t; (* because of wm *) - destroy t; (* so action can call open_simple *) - action v in - - bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); - - let f = Frame.create t [] in - let bok = Button.create f [Text "Ok"; Command activate] in - let bcancel = Button.create f - [Text "Cancel"; - Command (fun () -> notaction(); Grab.release t; destroy t)] in - - bind e [[], KeyPressDetail "Escape"] - (BindSet ([], (fun _ -> Button.invoke bcancel))); - pack [bok] [Side Side_Left; Expand true]; - pack [bcancel] [Side Side_Right; Expand true]; - pack [tit;e] [Fill Fill_X]; - pack [f] [Side Side_Bottom; Fill Fill_X]; - Frx_widget.resizeable t; - Focus.set e; - Tkwait.visibility t; - Grab.set t - -(* A synchronous version *) -let open_simple_synchronous title memory = - let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in - Focus.set t; - Wm.title_set t title; - let tit = Label.create t [Text title] in - let len = max 40 (String.length (Textvariable.get memory)) in - let e = - Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in - - let waiting = Textvariable.create_temporary t in - - let activate _ = - Grab.release t; (* because of wm *) - destroy t; (* so action can call open_simple *) - Textvariable.set waiting "1" in - - bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); - - let f = Frame.create t [] in - let bok = Button.create f [Text "Ok"; Command activate] in - let bcancel = - Button.create f - [Text "Cancel"; - Command (fun () -> - Grab.release t; destroy t; Textvariable.set waiting "0")] in - - bind e [[], KeyPressDetail "Escape"] - (BindSet ([], (fun _ -> Button.invoke bcancel))); - pack [bok] [Side Side_Left; Expand true]; - pack [bcancel] [Side Side_Right; Expand true]; - pack [tit;e] [Fill Fill_X]; - pack [f] [Side Side_Bottom; Fill Fill_X]; - Frx_widget.resizeable t; - Focus.set e; - Tkwait.visibility t; - Grab.set t; - Tkwait.variable waiting; - begin match Textvariable.get waiting with - "1" -> true - | _ -> false - end - -(* - * Simple list requester - * Same remarks as in open_simple. - * focus seems to be in the listbox automatically - *) -let open_list title elements action notaction = - let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in - Wm.title_set t title; - - let tit = Label.create t [Text title] in - let fls = Frame.create t [Relief Sunken; BorderWidth (Pixels 2)] in - let lb = Listbox.create fls [SelectMode Extended] in - let sb = Scrollbar.create fls [] in - Frx_listbox.scroll_link sb lb; - Listbox.insert lb End elements; - - (* activation: we have to break() because we destroy the requester *) - let activate _ = - let l = List.map (Listbox.get lb) (Listbox.curselection lb) in - Grab.release t; - destroy t; - List.iter action l; - break() in - - - bind lb [[Double], ButtonPressDetail 1] (BindSetBreakable ([], activate)); - - Frx_listbox.add_completion lb activate; - - let f = Frame.create t [] in - let bok = Button.create f [Text "Ok"; Command activate] in - let bcancel = Button.create f - [Text "Cancel"; - Command (fun () -> notaction(); Grab.release t; destroy t)] in - - pack [bok; bcancel] [Side Side_Left; Fill Fill_X; Expand true]; - pack [lb] [Side Side_Left; Fill Fill_Both; Expand true]; - pack [sb] [Side Side_Right; Fill Fill_Y]; - pack [tit] [Fill Fill_X]; - pack [fls] [Fill Fill_Both; Expand true]; - pack [f] [Side Side_Bottom; Fill Fill_X]; - Frx_widget.resizeable t; - Tkwait.visibility t; - Grab.set t - - -(* Synchronous *) -let open_passwd title = - let username = ref "" - and password = ref "" - and cancelled = ref false in - let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in - Focus.set t; - Wm.title_set t title; - let tit = Label.create t [Text title] - and fu,eu = Frx_entry.new_label_entry t "Username" (fun s -> ()) - and fp,ep = Frx_entry.new_label_entry t "Password" (fun s -> ()) - in - let fb = Frame.create t [] in - let bok = Button.create fb - [Text "Ok"; Command (fun _ -> - username := Entry.get eu; - password := Entry.get ep; - Grab.release t; (* because of wm *) - destroy t)] (* will return from tkwait *) - and bcancel = Button.create fb - [Text "Cancel"; Command (fun _ -> - cancelled := true; - Grab.release t; (* because of wm *) - destroy t)] (* will return from tkwait *) - in - Entry.configure ep [Show '*']; - bind eu [[], KeyPressDetail "Return"] - (BindSetBreakable ([], (fun _ -> Focus.set ep; break()))); - bind ep [[], KeyPressDetail "Return"] - (BindSetBreakable ([], (fun _ -> Button.flash bok; - Button.invoke bok; - break()))); - - pack [bok] [Side Side_Left; Expand true]; - pack [bcancel] [Side Side_Right; Expand true]; - pack [tit;fu;fp;fb] [Fill Fill_X]; - Tkwait.visibility t; - Focus.set eu; - Grab.set t; - Tkwait.window t; - if !cancelled then failwith "cancelled" - else (!username, !password) diff --git a/otherlibs/labltk/frx/frx_req.mli b/otherlibs/labltk/frx/frx_req.mli deleted file mode 100644 index 62985b9f90f0..000000000000 --- a/otherlibs/labltk/frx/frx_req.mli +++ /dev/null @@ -1,43 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Various dialog boxes *) -val open_simple : - string -> - (string -> unit) -> (unit -> 'a) -> Textvariable.textVariable -> unit - (* [open_simple title action cancelled memory] - A dialog with a message and an entry field (with memory between - invocations). Either [action] or [cancelled] is called when the user - answers to the dialog (with Ok or Cancel) - *) - -val open_simple_synchronous : string -> Textvariable.textVariable -> bool - (* [open_simple_synchronous title memory] - A synchronous dialog with a message and an entry field (with - memory between invocations). Returns true if the user clicks Ok - or false if the user clicks Cancel. - *) -val open_list : - string -> string list -> (string -> unit) -> (unit -> unit) -> unit - (* [open_list title elements action cancelled] - A dialog for selecting from a list of elements. [action] is called - on each selected element, or [cancelled] is called if the user clicks - Cancel. - *) - -val open_passwd : string -> string * string - (* [open_passwd title] pops up a username/password dialog and returns - (username, password). - *) diff --git a/otherlibs/labltk/frx/frx_rpc.ml b/otherlibs/labltk/frx/frx_rpc.ml deleted file mode 100644 index 5de7a15de715..000000000000 --- a/otherlibs/labltk/frx/frx_rpc.ml +++ /dev/null @@ -1,55 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Some notion of RPC *) -open Camltk -open Protocol - -(* A RPC is just a callback with a particular name, plus a Tcl procedure *) -let register name f = - let id = new_function_id() in - Hashtbl.add callback_naming_table id f; - (* For rpc_info *) - Textvariable.set (Textvariable.coerce ("camltkrpc("^name^")")) - (string_of_cbid id); - tkCommand [| TkToken "proc"; TkToken name; TkToken "args"; - TkToken ("camlcb "^(string_of_cbid id)^" $args") |] - -(* RPC *) -let invoke interp f args = - tkEval [| - TkToken "send"; - TkToken interp; - TkToken f; - TkTokenList (List.map (fun s -> TkToken s) args) - |] - -let async_invoke interp f args = - tkCommand [| - TkToken "send"; - TkToken "-async"; - TkToken interp; - TkToken f; - TkTokenList (List.map (fun s -> TkToken s) args) - |] - -let rpc_info interp = - tkEval [| - TkToken "send"; - TkToken interp; - TkToken "array"; - TkToken "names"; - TkToken "camltkrpc" - |] diff --git a/otherlibs/labltk/frx/frx_rpc.mli b/otherlibs/labltk/frx/frx_rpc.mli deleted file mode 100644 index 20811738a5bd..000000000000 --- a/otherlibs/labltk/frx/frx_rpc.mli +++ /dev/null @@ -1,25 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Some notion of RPC *) - -val register : string -> (string list -> unit) -> unit - (* [register external_name f] *) -val invoke : string -> string -> string list -> string - (* [invoke interp name args] *) -val async_invoke : string -> string -> string list -> unit - (* [async_invoke interp name args] *) -val rpc_info : string -> string - (* [rpc_info interp] *) diff --git a/otherlibs/labltk/frx/frx_selection.ml b/otherlibs/labltk/frx/frx_selection.ml deleted file mode 100644 index ad037ce2d809..000000000000 --- a/otherlibs/labltk/frx/frx_selection.ml +++ /dev/null @@ -1,45 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* A selection handler *) -open Widget -open Protocol -open Camltk - -let frame = ref None -let selection = ref "" - -let read ofs n = - let res = - if ofs < 0 then "" - else if ofs + n > String.length !selection - then String.sub !selection ofs (String.length !selection - ofs) - else String.sub !selection ofs n in - tkreturn res - -(* As long as we don't loose the selection, we keep the widget *) -(* Calling this function means that we own the selection *) -(* When we loose the selection, both cb are destroyed *) -let own () = - match !frame with - None -> - let f = Frame.create_named Widget.default_toplevel "frx_selection" [] in - let lost () = selection := ""; destroy f; frame := None in - Selection.own_set [Selection "PRIMARY"; LostCommand lost] f; - Selection.handle_set [Selection "PRIMARY"; ICCCMType "STRING"] f read; - frame := Some f - | Some f -> () - -let set s = own(); selection := s diff --git a/otherlibs/labltk/frx/frx_selection.mli b/otherlibs/labltk/frx/frx_selection.mli deleted file mode 100644 index b15265834b34..000000000000 --- a/otherlibs/labltk/frx/frx_selection.mli +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -val set : string -> unit - (* [set s] sets the X PRIMARY selection to [s] *) diff --git a/otherlibs/labltk/frx/frx_synth.ml b/otherlibs/labltk/frx/frx_synth.ml deleted file mode 100644 index 21bd7fa86e9b..000000000000 --- a/otherlibs/labltk/frx/frx_synth.ml +++ /dev/null @@ -1,88 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Some notion of synthetic events *) -open Camltk -open Widget -open Protocol - -(* To each event is associated a table of (widget, callback) *) -let events = Hashtbl.create 37 - -(* Notes: - * "cascading" events (on the same event) are not supported - * Only one binding active at a time for each event on each widget. - *) - -(* Get the callback table associated with . Initializes if required *) -let get_event name = - try Hashtbl.find events name - with - Not_found -> - let h = Hashtbl.create 37 in - Hashtbl.add events name h; - (* Initialize the callback invocation mechanism, based on - variable trace - *) - let var = "camltk_events(" ^ name ^")" in - let tkvar = Textvariable.coerce var in - let rec set () = - Textvariable.handle tkvar - (fun () -> - begin match Textvariable.get tkvar with - "all" -> (* Invoke all callbacks *) - Hashtbl.iter - (fun p f -> - try - f (cTKtoCAMLwidget p) - with _ -> ()) - h - | p -> (* Invoke callback for p *) - try - let w = cTKtoCAMLwidget p - and f = Hashtbl.find h p in - f w - with - _ -> () - end; - set ()(* reactivate the callback *) - ) in - set(); - h - -(* Remove binding for event on widget *) -let remove w name = - Hashtbl.remove (get_event name) (Widget.name w) - -(* Adds as callback for widget on event *) -let bind w name f = - remove w name; - Hashtbl.add (get_event name) (Widget.name w) f - -(* Sends event to all widgets *) -let broadcast name = - Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) "all" - -(* Sends event to widget *) -let send name w = - Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) - (Widget.name w) - -(* Remove all callbacks associated to widget *) -let remove_callbacks w = - Hashtbl.iter (fun _ h -> Hashtbl.remove h (Widget.name w)) events - -let _ = - add_destroy_hook remove_callbacks diff --git a/otherlibs/labltk/frx/frx_synth.mli b/otherlibs/labltk/frx/frx_synth.mli deleted file mode 100644 index e5a96aa85fcd..000000000000 --- a/otherlibs/labltk/frx/frx_synth.mli +++ /dev/null @@ -1,31 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* Synthetic events *) -open Camltk -open Widget - - -val send : string -> widget -> unit - (* [send event_name widget] *) - -val broadcast : string -> unit - (* [broadcase event_name] *) - -val bind : widget -> string -> (widget -> unit) -> unit - (* [bind event_name callback] *) - -val remove : widget -> string -> unit - (* [remove widget event_name] *) diff --git a/otherlibs/labltk/frx/frx_text.ml b/otherlibs/labltk/frx/frx_text.ml deleted file mode 100644 index a9ca17a3722a..000000000000 --- a/otherlibs/labltk/frx/frx_text.ml +++ /dev/null @@ -1,228 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -let version = "$Id$" - -(* - * convert an integer to an absolute index -*) -let abs_index n = - TextIndex (LineChar(0,0), [CharOffset n]) - -let insertMark = - TextIndex(Mark "insert", []) - -let currentMark = - TextIndex(Mark "current", []) - -let textEnd = - TextIndex(End, []) - -let textBegin = - TextIndex (LineChar(0,0), []) - -(* - * Link a scrollbar and a text widget -*) -let scroll_link sb tx = - Text.configure tx [YScrollCommand (Scrollbar.set sb)]; - Scrollbar.configure sb [ScrollCommand (Text.yview tx)] - - -(* - * Tk 4.0 has navigation in Text widgets, sometimes using scrolling - * sometimes using the insertion mark. It is a pain to add more - * compatible bindings. We do our own. - *) -let page_up tx = Text.yview tx (ScrollPage (-1)) -and page_down tx = Text.yview tx (ScrollPage 1) -and line_up tx = Text.yview tx (ScrollUnit (-1)) -and line_down tx = Text.yview tx (ScrollUnit 1) -and top tx = Text.yview_index tx textBegin -and bottom tx = Text.yview_index tx textEnd - -let navigation_keys tx = - let tags = bindtags_get tx in - match tags with - (WidgetBindings t)::l when t = tx -> - bindtags tx ((WidgetBindings tx) :: (TagBindings "TEXT_RO") :: l) - | _ -> () - -let new_scrollable_text top options navigation = - let f = Frame.create top [] in - let tx = Text.create f options - and sb = Scrollbar.create f [] in - scroll_link sb tx; - (* IN THIS ORDER -- RESIZING *) - pack [sb] [Side Side_Right; Fill Fill_Y]; - pack [tx] [Side Side_Left; Fill Fill_Both; Expand true]; - if navigation then navigation_keys tx; - f, tx - -(* - * Searching - *) -let patternv = Frx_misc.autodef Textvariable.create -and casev = Frx_misc.autodef Textvariable.create - -let topsearch t = - (* The user interface *) - let top = Toplevel.create t [Class "TextSearch"] in - Wm.title_set top "Text search"; - let f = Frame.create_named top "fpattern" [] in - let m = Label.create_named f "search" [Text "Search pattern"] - and e = Entry.create_named f "pattern" - [Relief Sunken; TextVariable (patternv()) ] in - let hgroup = Frame.create top [] - and bgroup = Frame.create top [] in - let fdir = Frame.create hgroup [] - and fmisc = Frame.create hgroup [] in - let direction = Textvariable.create_temporary fdir - and exactv = Textvariable.create_temporary fdir - in - let forw = Radiobutton.create_named fdir "forward" - [Text "Forward"; Variable direction; Value "f"] - and backw = Radiobutton.create_named fdir "backward" - [Text "Backward"; Variable direction; Value "b"] - and exact = Checkbutton.create_named fmisc "exact" - [Text "Exact match"; Variable exactv] - and case = Checkbutton.create_named fmisc "case" - [Text "Fold Case"; Variable (casev())] - and searchb = Button.create_named bgroup "search" [Text "Search"] - and contb = Button.create_named bgroup "continue" [Text "Continue"] - and dismissb = Button.create_named bgroup "dismiss" - [Text "Dismiss"; - Command (fun () -> Text.tag_delete t ["search"]; destroy top)] in - - Radiobutton.invoke forw; - pack [m][Side Side_Left]; - pack [e][Side Side_Right; Fill Fill_X; Expand true]; - pack [forw; backw] [Anchor W]; - pack [exact; case] [Anchor W]; - pack [fdir; fmisc] [Side Side_Left; Anchor Center]; - pack [searchb; contb; dismissb] [Side Side_Left; Fill Fill_X]; - pack [f;hgroup;bgroup] [Fill Fill_X; Expand true]; - - let current_index = ref textBegin in - - let search cont = fun () -> - let opts = ref [] in - if Textvariable.get direction = "f" then - opts := Forwards :: !opts - else opts := Backwards :: !opts ; - if Textvariable.get exactv = "1" then - opts := Exact :: !opts; - if Textvariable.get (casev()) = "1" then - opts := Nocase :: !opts; - try - let forward = Textvariable.get direction = "f" in - let i = Text.search t !opts (Entry.get e) - (if cont then !current_index - else if forward then textBegin - else TextIndex(End, [CharOffset (-1)])) (* does not work with end *) - (if forward then textEnd - else textBegin) in - let found = TextIndex (i, []) in - current_index := - TextIndex(i, [CharOffset (if forward then 1 else (-1))]); - Text.tag_delete t ["search"]; - Text.tag_add t "search" found (TextIndex (i, [WordEnd])); - Text.tag_configure t "search" - [Relief Raised; BorderWidth (Pixels 1); - Background Red]; - Text.see t found - with - Invalid_argument _ -> Bell.ring() in - - bind e [[], KeyPressDetail "Return"] - (BindSet ([], fun _ -> search false ())); - Button.configure searchb [Command (search false)]; - Button.configure contb [Command (search true)]; - Tkwait.visibility top; - Focus.set e - -let addsearch tx = - let tags = bindtags_get tx in - match tags with - (WidgetBindings t)::l when t = tx -> - bindtags tx ((WidgetBindings tx) :: (TagBindings "SEARCH") :: l) - | _ -> () - -(* We use Mod1 instead of Meta or Alt *) -let init () = - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> page_up ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "BackSpace"]; - [[], KeyPressDetail "Delete"]; - [[], KeyPressDetail "Prior"]; - [[], KeyPressDetail "b"]; - [[Mod1], KeyPressDetail "v"] - ]; - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> page_down ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "space"]; - [[], KeyPressDetail "Next"]; - [[Control], KeyPressDetail "v"] - ]; - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> line_up ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "Up"]; - [[Mod1], KeyPressDetail "z"] - ]; - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> line_down ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "Down"]; - [[Control], KeyPressDetail "z"] - ]; - - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> top ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "Home"]; - [[Mod1], KeyPressDetail "less"] - ]; - - List.iter (function ev -> - tag_bind "TEXT_RO" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> bottom ei.ev_Widget; break())))) - [ - [[], KeyPressDetail "End"]; - [[Mod1], KeyPressDetail "greater"] - ]; - - List.iter (function ev -> - tag_bind "SEARCH" ev - (BindSetBreakable ([Ev_Widget], - (fun ei -> topsearch ei.ev_Widget; break())))) - [ - [[Control], KeyPressDetail "s"] - ] diff --git a/otherlibs/labltk/frx/frx_text.mli b/otherlibs/labltk/frx/frx_text.mli deleted file mode 100644 index 97783fa96d2c..000000000000 --- a/otherlibs/labltk/frx/frx_text.mli +++ /dev/null @@ -1,46 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk - -val abs_index : int -> textIndex - (* [abs_index offs] returns the corresponding TextIndex *) - -val insertMark : textIndex -val currentMark : textIndex -val textEnd : textIndex -val textBegin : textIndex - (* shortcuts for various positions in a text widget *) - -val scroll_link : Widget.widget -> Widget.widget -> unit - (* [scroll_link scrollbar text] links a scrollbar and a text widget - as expected - *) - -val new_scrollable_text : - Widget.widget -> options list -> bool -> Widget.widget * Widget.widget - (* [new_scrollable_text parent opts nav_keys] makes a scrollable text - widget with optional navigation keys. Returns frame and text widget. - *) -val addsearch : Widget.widget -> unit - (* [addsearch textw] adds a search dialog bound on [Control-s] - on the text widget - *) - -val navigation_keys : Widget.widget -> unit - (* [navigation_keys textw] adds common navigations functions to [textw] *) - -val init : unit -> unit - (* [init ()] must be called before any of the above features is used *) diff --git a/otherlibs/labltk/frx/frx_toplevel.mli b/otherlibs/labltk/frx/frx_toplevel.mli deleted file mode 100644 index 628cde207809..000000000000 --- a/otherlibs/labltk/frx/frx_toplevel.mli +++ /dev/null @@ -1,17 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Widget -val make_visible : Widget -> unit diff --git a/otherlibs/labltk/frx/frx_widget.ml b/otherlibs/labltk/frx/frx_widget.ml deleted file mode 100644 index 9045134361cc..000000000000 --- a/otherlibs/labltk/frx/frx_widget.ml +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget - -let version = "$Id$" -(* Make a window (toplevel widget) resizeable *) -let resizeable t = - update_idletasks(); (* wait until layout is computed *) - Wm.minsize_set t (Winfo.width t) (Winfo.height t) diff --git a/otherlibs/labltk/frx/frx_widget.mli b/otherlibs/labltk/frx/frx_widget.mli deleted file mode 100644 index f856664cf3bf..000000000000 --- a/otherlibs/labltk/frx/frx_widget.mli +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget -val resizeable : widget -> unit diff --git a/otherlibs/labltk/jpf/Makefile b/otherlibs/labltk/jpf/Makefile deleted file mode 100644 index 8ed86590387d..000000000000 --- a/otherlibs/labltk/jpf/Makefile +++ /dev/null @@ -1,93 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -include ../support/Makefile.common - -COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/unix -I $(OTHERS)/str - -OBJS= fileselect.cmo balloon.cmo shell.cmo jpf_font.cmo - -OBJSX = $(OBJS:.cmo=.cmx) - -all: jpflib.cma - -opt: jpflib.cmxa - -test: balloontest - -testopt: balloontest.opt - -jpflib.cma: $(OBJS) - $(CAMLLIBR) -o jpflib.cma $(OBJS) - -jpflib.cmxa: $(OBJSX) - $(CAMLOPTLIBR) -o jpflib.cmxa $(OBJSX) - -install: jpflib.cma - cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) jpflib.cma $(INSTALLDIR) - -installopt: jpflib.cmxa - cp jpflib.cmxa jpflib.a $(OBJS:.cmo=.cmx) $(INSTALLDIR) - -clean: - rm -f *.cm* *.o *.a *~ *test - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJSX): ../lib/$(LIBNAME).cmxa - -### Tests - -balloontest: balloontest.cmo - $(CAMLC) -nojoin -o balloontest -I ../support -I ../lib \ - -custom $(LIBNAME).cma jpflib.cma balloontest.cmo - -balloontest.opt: balloontest.cmx - $(CAMLOPT) -nojoin -o balloontest.opt -I ../support -I ../lib \ - $(LIBNAME).cmxa jpflib.cmxa balloontest.cmx - -balloontest.cmo : balloon.cmo jpflib.cma - -balloontest.cmx : balloon.cmx jpflib.cmxa - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -nojoin -c $(COMPFLAGS) $< - -depend: - mv Makefile Makefile.bak - (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \ - $(CAMLDEP) *.mli *.ml) > Makefile - - -### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED -### DO NOT DELETE THIS LINE -balloon.cmo: balloon.cmi -balloon.cmx: balloon.cmi -fileselect.cmo: fileselect.cmi -fileselect.cmx: fileselect.cmi -jpf_font.cmo: shell.cmi jpf_font.cmi -jpf_font.cmx: shell.cmx jpf_font.cmi -shell.cmo: shell.cmi -shell.cmx: shell.cmi diff --git a/otherlibs/labltk/jpf/Makefile.nt b/otherlibs/labltk/jpf/Makefile.nt deleted file mode 100644 index 7501a01d4b71..000000000000 --- a/otherlibs/labltk/jpf/Makefile.nt +++ /dev/null @@ -1,75 +0,0 @@ -include ../support/Makefile.common.nt - -COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/str - -OBJS= fileselect.cmo balloon.cmo - -OBJSX = $(OBJS:.cmo=.cmx) - -all: libjpf.cma - -opt: libjpf.cmxa - -test: balloontest - -testopt: balloontest.opt - -libjpf.cma: $(OBJS) - $(CAMLLIBR) -o libjpf.cma $(OBJS) - -libjpf.cmxa: $(OBJSX) - $(CAMLOPTLIBR) -o libjpf.cmxa $(OBJSX) - -install: libjpf.cma - cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) libjpf.cma $(INSTALLDIR) - -installopt: libjpf.cmxa - cp libjpf.cmxa libjpf.$(A) $(INSTALLDIR) - -clean: - rm -f *.cm* *.$(O) *.$(A) *~ *test - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJSX): ../lib/$(LIBNAME).cmxa - -### Tests - -balloontest: balloontest.cmo - $(CAMLC) -o balloontest -I ../support -I ../labltk -I ../lib \ - -custom $(LIBNAME).cma libjpf.cma balloontest.cmo $(TKLINKOPT) - -balloontest.opt: balloontest.cmx - $(CAMLOPT) -o balloontest.opt -I ../support -I ../labltk -I ../lib \ - $(LIBNAME).cmxa libjpf.cmxa balloontest.cmx $(TKLINKOPT) - -balloontest.cmo : balloon.cmo libjpf.cma - -balloontest.cmx : balloon.cmx libjpf.cmxa - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: - mv Makefile Makefile.bak - (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \ - $(CAMLDEP) *.mli *.ml) > Makefile - - -### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED -### DO NOT DELETE THIS LINE -balloon.cmo: balloon.cmi -balloon.cmx: balloon.cmi -balloontest.cmo: balloon.cmi -balloontest.cmx: balloon.cmx -fileselect.cmo: fileselect.cmi -fileselect.cmx: fileselect.cmi diff --git a/otherlibs/labltk/jpf/README b/otherlibs/labltk/jpf/README deleted file mode 100644 index 275c2d7803d5..000000000000 --- a/otherlibs/labltk/jpf/README +++ /dev/null @@ -1,2 +0,0 @@ -This is Jun Furuse's widget set library, Jpf. -It uses LablTk API. diff --git a/otherlibs/labltk/jpf/balloon.ml b/otherlibs/labltk/jpf/balloon.ml deleted file mode 100644 index e880f2777451..000000000000 --- a/otherlibs/labltk/jpf/balloon.ml +++ /dev/null @@ -1,102 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open StdLabels - -(* easy balloon help facility *) - -open Tk -open Widget -open Protocol -open Support - -(* switch -- if you do not want balloons, set false *) -let flag = ref true -let debug = ref false - -(* We assume we have at most one popup label at a time *) -let topw = ref default_toplevel -and popupw = ref (Obj.magic dummy : message widget) - -let configure_cursor w cursor = - (* DDDDDDDDDIIIIIIIRRRRRRRRTTTTTTTTYYYYYYY *) - Protocol.tkCommand [| TkToken (name w); - TkToken "configure"; - TkToken "-cursor"; - TkToken cursor |] - -let put ~on: w ~ms: millisec mesg = - let t = ref None in - let cursor = ref "" in - - let reset () = - begin - match !t with - Some t -> Timer.remove t - | _ -> () - end; - (* if there is a popup label, unmap it *) - if Winfo.exists !topw && Wm.state !topw <> "withdrawn" then - begin - Wm.withdraw !topw; - if Winfo.exists w then configure_cursor w !cursor - end - and set ev = - if !flag then - t := Some (Timer.add ~ms: millisec ~callback: (fun () -> - t := None; - if !debug then - prerr_endline ("Balloon: " ^ Widget.name w); - update_idletasks(); - Message.configure !popupw ~text: mesg; - raise_window !topw; - Wm.geometry_set !topw (* 9 & 8 are some kind of magic... *) - ("+"^(string_of_int (ev.ev_RootX + 9))^ - "+"^(string_of_int (ev.ev_RootY + 8))); - Wm.deiconify !topw; - cursor := cget w `Cursor; - configure_cursor w "hand2")) - in - - List.iter [[`Leave]; [`ButtonPress]; [`ButtonRelease]; [`Destroy]; - [`KeyPress]; [`KeyRelease]] - ~f:(fun events -> bind w ~events ~extend:true ~action:(fun _ -> reset ())); - List.iter [[`Enter]; [`Motion]] ~f: - begin fun events -> - bind w ~events ~extend:true ~fields:[`RootX; `RootY] - ~action:(fun ev -> reset (); set ev) - end - -let init () = - let t = Hashtbl.create 101 in - Protocol.add_destroy_hook (fun w -> - Hashtbl.remove t w); - topw := Toplevel.create default_toplevel; - Wm.overrideredirect_set !topw true; - Wm.withdraw !topw; - popupw := Message.create !topw ~name: "balloon" - ~background: (`Color "yellow") ~aspect: 300; - pack [!popupw]; - bind_class "all" ~events: [`Enter] ~extend:true ~fields:[`Widget] ~action: - begin fun w -> - try Hashtbl.find t w.ev_Widget - with Not_found -> - Hashtbl.add t w.ev_Widget (); - let x = Option.get w.ev_Widget ~name: "balloon" ~clas: "Balloon" in - if x <> "" then put ~on: w.ev_Widget ~ms: 1000 x - end diff --git a/otherlibs/labltk/jpf/balloon.mli b/otherlibs/labltk/jpf/balloon.mli deleted file mode 100644 index f3e65269da95..000000000000 --- a/otherlibs/labltk/jpf/balloon.mli +++ /dev/null @@ -1,24 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* easy balloon help facility *) -open Widget - -val flag : bool ref -val init : unit -> unit -val put : on: 'a widget -> ms: int -> string -> unit diff --git a/otherlibs/labltk/jpf/balloontest.ml b/otherlibs/labltk/jpf/balloontest.ml deleted file mode 100644 index 236f6174bffe..000000000000 --- a/otherlibs/labltk/jpf/balloontest.ml +++ /dev/null @@ -1,31 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Tk -open Widget -open Balloon -open Protocol - -let _ = - let t = openTk () in - Balloon.init (); - let b = Button.create t ~text: "hello" in - Button.configure b ~command: (fun () -> destroy b); - pack [b]; - Balloon.put ~on: b ~ms: 1000 "Balloon"; - Printexc.catch mainLoop () diff --git a/otherlibs/labltk/jpf/fileselect.ml b/otherlibs/labltk/jpf/fileselect.ml deleted file mode 100644 index 23aaeb6d293c..000000000000 --- a/otherlibs/labltk/jpf/fileselect.ml +++ /dev/null @@ -1,367 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* file selection box *) - -(* This file selecter works only under the OS with the full unix support. - For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *) - -open StdLabels -open UnixLabels -open Str -open Filename - -open Tk -open Widget - -exception Not_selected - -(********************************************************** Search directory *) -(* Default is curdir *) -let global_dir = ref (getcwd ()) - -(***************************************************** Some widgets creation *) - -(* from frx_listbox.ml *) -let scroll_link sb lb = - Listbox.configure lb ~yscrollcommand: (Scrollbar.set sb); - Scrollbar.configure sb ~command: (Listbox.yview lb) - -(* focus when enter binding *) -let bind_enter_focus w = - bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w);; - -let myentry_create p ~variable = - let w = Entry.create p ~relief: `Sunken ~textvariable: variable in - bind_enter_focus w; w - -(************************************************************* Subshell call *) - -let subshell cmd = - let r,w = pipe () in - match fork () with - 0 -> close r; dup2 ~src:w ~dst:stdout; - execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |] - | id -> - close w; - let rc = in_channel_of_descr r in - let rec it l = - match - try Some(input_line rc) with _ -> None - with - Some x -> it (x::l) - | None -> List.rev l - in - let answer = it [] in - close_in rc; (* because of finalize_channel *) - let _ = waitpid ~mode:[] id in answer - -(***************************************************************** Path name *) - -(* find directory name which doesn't contain "?*[" *) -let dirget = regexp "^\\([^\\*?[]*/\\)\\(.*\\)" - -let parse_filter src = - (* replace // by / *) - let s = global_replace (regexp "/+") "/" src in - (* replace /./ by / *) - let s = global_replace (regexp "/\\./") "/" s in - (* replace ????/../ by "" *) - let s = global_replace - (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./") - "" - s in - (* replace ????/..$ by "" *) - let s = global_replace - (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$") - "" - s in - (* replace ^/../../ by / *) - let s = global_replace (regexp "^\\(/\\.\\.\\)+/") "/" s in - if string_match dirget s 0 then - let dirs = matched_group 1 s - and ptrn = matched_group 2 s - in - dirs, ptrn - else "", s - -let ls dir pattern = - subshell ("cd " ^ dir ^ ";/bin/ls -ad " ^ pattern ^" 2>/dev/null") - -(*************************************************************** File System *) - -let get_files_in_directory dir = - let dirh = opendir dir in - let rec get_them l = - match - try Some(Unix.readdir dirh) with _ -> None - with - | None -> - Unix.closedir dirh; l - | Some x -> - get_them (x::l) - in - List.sort ~cmp:compare (get_them []) - -let rec get_directories_in_files path = - List.filter - ~f:(fun x -> try (stat (path ^ x)).st_kind = S_DIR with _ -> false) - -let remove_directories path = - List.filter - ~f:(fun x -> try (stat (path ^ x)).st_kind <> S_DIR with _ -> false) - -(************************* a nice interface to listbox - from frx_listbox.ml *) - -let add_completion lb action = - let prefx = ref "" (* current match prefix *) - and maxi = ref 0 (* maximum index (doesn'y matter actually) *) - and current = ref 0 (* current position *) - and lastevent = ref 0 in - - let rec move_forward () = - if Listbox.get lb ~index:(`Num !current) < !prefx then - if !current < !maxi then begin incr current; move_forward() end - - and recenter () = - let element = `Num !current in - (* Clean the selection *) - Listbox.selection_clear lb ~first:(`Num 0) ~last:`End; - (* Set it to our unique element *) - Listbox.selection_set lb ~first:element ~last:element; - (* Activate it, to keep consistent with Up/Down. - You have to be in Extended or Browse mode *) - Listbox.activate lb ~index:element; - Listbox.selection_anchor lb ~index:element; - Listbox.see lb ~index:element in - - let complete time s = - if time - !lastevent < 500 then (* sorry, hard coded limit *) - prefx := !prefx ^ s - else begin (* reset *) - current := 0; - prefx := s - end; - lastevent := time; - move_forward(); - recenter() in - - - bind lb ~events:[`KeyPress] ~fields:[`Char; `Time] - (* consider only keys producing characters. The callback is called - if you press Shift. *) - ~action:(fun ev -> if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char); - (* Key specific bindings override KeyPress *) - bind lb ~events:[`KeyPressDetail "Return"] ~action; - (* Finally, we have to set focus, otherwise events dont get through *) - Focus.set lb; - recenter() (* so that first item is selected *); - (* returns init_completion function *) - (fun lb -> - prefx := ""; - maxi := Listbox.size lb - 1; - current := 0) - -(****************************************************************** Creation *) - -let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync = - (* Ah ! Now I regret about the names of the widgets... *) - - let current_pattern = ref "" - and current_dir = ref "" in - - (* init_completions *) - let filter_init_completion = ref (fun _ -> ()) - and directory_init_completion = ref (fun _ -> ()) in - - let tl = Toplevel.create default_toplevel in - Focus.set tl; - Wm.title_set tl title; - - let filter_var = Textvariable.create ~on:tl () (* new_temporary *) - and selection_var = Textvariable.create ~on:tl () - and sync_var = Textvariable.create ~on:tl () in - - let frm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in - let frm = Frame.create frm' ~borderwidth: 8 in - let fl = Label.create frm ~text: "Filter" in - let df = Frame.create frm in - let dfl = Frame.create df in - let dfll = Label.create dfl ~text: "Directories" in - let dflf = Frame.create dfl in - let directory_listbox = Listbox.create dflf ~relief: `Sunken - and directory_scrollbar = Scrollbar.create dflf in - scroll_link directory_scrollbar directory_listbox; - let dfr = Frame.create df in - let dfrl = Label.create dfr ~text: "Files" in - let dfrf = Frame.create dfr in - let filter_listbox = Listbox.create dfrf ~relief: `Sunken in - let filter_scrollbar = Scrollbar.create dfrf in - scroll_link filter_scrollbar filter_listbox; - let sl = Label.create frm ~text: "Selection" in - let filter_entry = myentry_create frm ~variable: filter_var in - let selection_entry = myentry_create frm ~variable: selection_var - in - let cfrm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in - let cfrm = Frame.create cfrm' ~borderwidth: 8 in - let dumf = Frame.create cfrm in - let dumf2 = Frame.create cfrm in - - let configure filter = - (* OLDER let curdir = getcwd () in *) -(* Printf.eprintf "CURDIR %s\n" curdir; *) - let filter = - if string_match (regexp "^/.*") filter 0 then filter - else - if filter = "" then !global_dir ^ "/*" - else !global_dir ^ "/" ^ filter in -(* Printf.eprintf "FILTER %s\n" filter; *) - let dirname, patternname = parse_filter filter in -(* Printf.eprintf "DIRNAME %s PATTERNNAME %s\n" dirname patternname; *) - current_dir := dirname; - global_dir := dirname; - let patternname = if patternname = "" then "*" else patternname in - current_pattern := patternname; - let filter = dirname ^ patternname in -(* Printf.eprintf "FILTER : %s\n\n" filter; *) -(* flush Pervasives.stderr; *) - try - let directories = get_directories_in_files dirname - (get_files_in_directory dirname) in - (* get matched file by subshell call. *) - let matched_files = remove_directories dirname (ls dirname patternname) - in - Textvariable.set filter_var filter; - Textvariable.set selection_var (dirname ^ deffile); - Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End; - Listbox.insert directory_listbox ~index:`End ~texts:directories; - Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End; - Listbox.insert filter_listbox ~index:`End ~texts:matched_files; - !directory_init_completion directory_listbox; - !filter_init_completion filter_listbox - with - Unix_error (ENOENT,_,_) -> - (* Directory is not found (maybe) *) - Bell.ring () - in - - let selected_files = ref [] in (* used for synchronous mode *) - let activate l () = - Grab.release tl; - destroy tl; - if sync then - begin - selected_files := l; - Textvariable.set sync_var "1" - end - else - begin - proc l; - break () - end - in - - (* and buttons *) - let okb = Button.create cfrm ~text: "OK" ~command: - begin fun () -> - let files = - List.map (Listbox.curselection filter_listbox) - ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x)) - in - let files = if files = [] then [Textvariable.get selection_var] - else files in - activate files () - end - in - let flb = Button.create cfrm ~text: "Filter" - ~command: (fun () -> configure (Textvariable.get filter_var)) in - let ccb = Button.create cfrm ~text: "Cancel" - ~command: (fun () -> activate [] ()) in - - (* binding *) - bind selection_entry ~events:[`KeyPressDetail "Return"] ~breakable:true - ~action:(fun _ -> activate [Textvariable.get selection_var] ()); - bind filter_entry ~events:[`KeyPressDetail "Return"] - ~action:(fun _ -> configure (Textvariable.get filter_var)); - - let action _ = - let files = - List.map (Listbox.curselection filter_listbox) - ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x)) - in - activate files () - in - bind filter_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~breakable:true ~action; - if multi then Listbox.configure filter_listbox ~selectmode: `Multiple; - filter_init_completion := add_completion filter_listbox action; - - let action _ = - try - configure (!current_dir ^ ((function - [x] -> Listbox.get directory_listbox ~index:x - | _ -> (* you must choose at least one directory. *) - Bell.ring (); raise Not_selected) - (Listbox.curselection directory_listbox)) ^ "/" ^ !current_pattern) - with _ -> () in - bind directory_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] - ~breakable:true ~action; - Listbox.configure directory_listbox ~selectmode: `Browse; - directory_init_completion := add_completion directory_listbox action; - - pack [frm'; frm] ~fill: `X; - (* filter *) - pack [fl] ~side: `Top ~anchor: `W; - pack [filter_entry] ~side: `Top ~fill: `X; - (* directory + files *) - pack [df] ~side: `Top ~fill: `X ~ipadx: 8; - (* directory *) - pack [dfl] ~side: `Left; - pack [dfll] ~side: `Top ~anchor: `W; - pack [dflf] ~side: `Top; - pack [coe directory_listbox; coe directory_scrollbar] - ~side: `Left ~fill: `Y; - (* files *) - pack [dfr] ~side: `Right; - pack [dfrl] ~side: `Top ~anchor: `W; - pack [dfrf] ~side: `Top; - pack [coe filter_listbox; coe filter_scrollbar] ~side: `Left ~fill: `Y; - (* selection *) - pack [sl] ~side: `Top ~anchor: `W; - pack [selection_entry] ~side: `Top ~fill: `X; - - (* create OK, Filter and Cancel buttons *) - pack [cfrm'] ~fill: `X; - pack [cfrm] ~fill: `X; - pack [okb] ~side: `Left; - pack [dumf] ~side: `Left ~expand: true; - pack [flb] ~side: `Left; - pack [dumf2] ~side: `Left ~expand: true; - pack [ccb] ~side: `Left; - - configure deffilter; - - Tkwait.visibility tl; - Grab.set tl; - - if sync then - begin - Tkwait.variable sync_var; - proc !selected_files - end; - () diff --git a/otherlibs/labltk/jpf/fileselect.mli b/otherlibs/labltk/jpf/fileselect.mli deleted file mode 100644 index 42f7d34fa3b7..000000000000 --- a/otherlibs/labltk/jpf/fileselect.mli +++ /dev/null @@ -1,37 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* This file selecter works only under the OS with the full unix support. - For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *) - -open Support - -val f : - title:string -> - action:(string list -> unit) -> - filter:string -> file:string -> multi:bool -> sync:bool -> unit - -(* action - [] means canceled - if multi select is false, then the list is null or a singleton *) - -(* multi select - if true then more than one file are selectable *) - -(* sync it - if true then in synchronous mode *) diff --git a/otherlibs/labltk/jpf/jpf_font.ml b/otherlibs/labltk/jpf/jpf_font.ml deleted file mode 100644 index b036d421abd2..000000000000 --- a/otherlibs/labltk/jpf/jpf_font.ml +++ /dev/null @@ -1,218 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -(* find font information *) - -let debug = ref false -let log s = - if !debug then try prerr_endline s with _ -> () - -type ('s, 'i) xlfd = { - (* some of them are currently not interesting for me *) - mutable foundry: 's; - mutable family: 's; - mutable weight: 's; - mutable slant: 's; - mutable setWidth: 's; - mutable addStyle: 's; - mutable pixelSize: 'i; - mutable pointSize: 'i; - mutable resolutionX: 'i; - mutable resolutionY: 'i; - mutable spacing: 's; - mutable averageWidth: 'i; - mutable registry: 's; - mutable encoding: 's - } - -let copy xlfd = {xlfd with foundry= xlfd.foundry} - -let string_of_xlfd s i xlfd = - let foundry= s xlfd.foundry - and family= s xlfd.family - and weight= s xlfd.weight - and slant= s xlfd.slant - and setWidth = s xlfd.setWidth - and addStyle = s xlfd.addStyle - and pixelSize= i xlfd.pixelSize - and pointSize = i xlfd.pointSize - and resolutionX = i xlfd.resolutionX - and resolutionY = i xlfd.resolutionY - and spacing= s xlfd.spacing - and averageWidth = i xlfd.averageWidth - and registry= s xlfd.registry - and encoding = s xlfd.encoding in - - "-"^foundry^ - "-"^family^ - "-"^weight^ - "-"^slant^ - "-"^setWidth ^ - "-"^addStyle ^ - "-"^pixelSize^ - "-"^pointSize ^ - "-"^resolutionX ^ - "-"^resolutionY ^ - "-"^spacing^ - "-"^averageWidth ^ - "-"^registry^ - "-"^encoding - -exception Parse_Xlfd_Failure of string - -let parse_xlfd xlfd_string = - (* this must not be a pattern *) - let split_str char_sep str = - let len = String.length str in - let rec split beg cur = - if cur >= len then [String.sub str beg (len - beg)] - else if char_sep (String.get str cur) - then - let nextw = succ cur in - (String.sub str beg (cur - beg)) - ::(split nextw nextw) - else split beg (succ cur) in - split 0 0 - in - match split_str (function '-' -> true | _ -> false) xlfd_string with - | [ _; foundry; family; weight; slant; setWidth; addStyle; pixelSize; - pointSize; resolutionX; resolutionY; spacing; averageWidth; - registry; encoding ] -> - { foundry= foundry; - family= family; - weight= weight; - slant= slant; - setWidth= setWidth; - addStyle= addStyle; - pixelSize= int_of_string pixelSize; - pointSize= int_of_string pointSize; - resolutionX= int_of_string resolutionX; - resolutionY= int_of_string resolutionY; - spacing= spacing; - averageWidth= int_of_string averageWidth; - registry= registry; - encoding= encoding; - } - | _ -> raise (Parse_Xlfd_Failure xlfd_string) - -type valid_xlfd = (string, int) xlfd - -let string_of_valid_xlfd = string_of_xlfd (fun x -> x) string_of_int - -type pattern = (string option, int option) xlfd - -let empty_pattern = - { foundry= None; - family= None; - weight= None; - slant= None; - setWidth= None; - addStyle= None; - pixelSize= None; - pointSize= None; - resolutionX= None; - resolutionY= None; - spacing= None; - averageWidth= None; - registry= None; - encoding= None; - } - -let string_of_pattern = - let pat f = function - Some x -> f x - | None -> "*" - in - let pat_string = pat (fun x -> x) in - let pat_int = pat string_of_int in - string_of_xlfd pat_string pat_int - -let is_vector_font xlfd = - (xlfd.pixelSize = 0 && xlfd.resolutionX = 0 && xlfd.resolutionY = 0) || - xlfd.spacing <> "c" - -let list_fonts dispname pattern = - let dispopt = match dispname with - None -> "" - | Some x -> "-display " ^ x - in - let result = List.map parse_xlfd - (Shell.subshell ("xlsfonts "^dispopt^" -fn "^string_of_pattern pattern)) - in - if result = [] then raise Not_found - else result - -let available_pixel_size_aux dispname pattern = - (* return available pixel size without font resizing *) - (* to obtain good result, *) - (* the pattern should contain as many information as possible *) - let pattern = copy pattern in - pattern.pixelSize <- None; - let xlfds = list_fonts dispname pattern in - let pxszs = Hashtbl.create 107 in - List.iter (fun xlfd -> - Hashtbl.add pxszs xlfd.pixelSize xlfd) xlfds; - pxszs - -let extract_size_font_hash tbl = - let keys = ref [] in - Hashtbl.iter (fun k _ -> - if not (List.mem k !keys) then keys := k :: !keys) tbl; - Sort.list (fun (k1,_) (k2,_) -> k1 < k2) - (List.map (fun k -> k, Hashtbl.find_all tbl k) !keys) - -let available_pixel_size dispname pattern = - let pxszs = available_pixel_size_aux dispname pattern in - extract_size_font_hash pxszs - -let nearest_pixel_size dispname vector_ok pattern = - (* find the font with the nearest pixel size *) - log ("\n*** "^string_of_pattern pattern); - let pxlsz = - match pattern.pixelSize with - None -> raise (Failure "invalid pixelSize pattern") - | Some x -> x - in - let tbl = available_pixel_size_aux dispname pattern in - let newtbl = Hashtbl.create 107 in - Hashtbl.iter (fun s xlfd -> - if vector_ok then - if s = 0 then begin - if is_vector_font xlfd then begin - log (Printf.sprintf "%s is vector" (string_of_valid_xlfd xlfd)); - xlfd.pixelSize <- pxlsz; - Hashtbl.add newtbl pxlsz xlfd - end - end else Hashtbl.add newtbl s xlfd - else if not (is_vector_font xlfd) && s <> 0 then - Hashtbl.add newtbl s xlfd) tbl; - - let size_font_table = extract_size_font_hash newtbl in - - let diff = ref 10000 in - let min = ref None in - List.iter (fun (s,xlfds) -> - let d = abs(s - pxlsz) in - if d < !diff then begin - min := Some (s,xlfds); - diff := d - end) size_font_table; - (* if it contains more than one font, just return the first *) - match !min with - | None -> raise Not_found - | Some(s, xlfds) -> - log (Printf.sprintf "Size %d is selected" s); - List.iter (fun xlfd -> log (string_of_valid_xlfd xlfd)) xlfds; - List.hd xlfds diff --git a/otherlibs/labltk/jpf/jpf_font.mli b/otherlibs/labltk/jpf/jpf_font.mli deleted file mode 100644 index f3045a9c8b78..000000000000 --- a/otherlibs/labltk/jpf/jpf_font.mli +++ /dev/null @@ -1,54 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -val debug : bool ref - -type ('a, 'b) xlfd = - { mutable foundry: 'a; - mutable family: 'a; - mutable weight: 'a; - mutable slant: 'a; - mutable setWidth: 'a; - mutable addStyle: 'a; - mutable pixelSize: 'b; - mutable pointSize: 'b; - mutable resolutionX: 'b; - mutable resolutionY: 'b; - mutable spacing: 'a; - mutable averageWidth: 'b; - mutable registry: 'a; - mutable encoding: 'a } - -exception Parse_Xlfd_Failure of string - -type valid_xlfd = (string, int) xlfd -type pattern = (string option, int option) xlfd - -val empty_pattern : pattern - -val copy : ('a, 'b) xlfd -> ('a, 'b) xlfd - -val string_of_valid_xlfd : valid_xlfd -> string -val string_of_pattern : pattern -> string - -val is_vector_font : valid_xlfd -> bool - -val list_fonts : string option -> pattern -> valid_xlfd list - -val available_pixel_size : - string option -> pattern -> (int * valid_xlfd list) list - -val nearest_pixel_size : - string option -> bool -> pattern -> valid_xlfd diff --git a/otherlibs/labltk/jpf/shell.ml b/otherlibs/labltk/jpf/shell.ml deleted file mode 100644 index 0d566e050e9a..000000000000 --- a/otherlibs/labltk/jpf/shell.ml +++ /dev/null @@ -1,35 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -open Unix - -(************************************************************* Subshell call *) - -let subshell cmd = - let r,w = pipe () in - match fork () with - 0 -> close r; dup2 w stdout; - close stderr; - execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] - | 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 _ = waitpid [] id in answer diff --git a/otherlibs/labltk/jpf/shell.mli b/otherlibs/labltk/jpf/shell.mli deleted file mode 100644 index 7c7dd8e1a0c3..000000000000 --- a/otherlibs/labltk/jpf/shell.mli +++ /dev/null @@ -1,16 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -val subshell : string -> string list diff --git a/otherlibs/labltk/labl.gif b/otherlibs/labltk/labl.gif deleted file mode 100644 index d0a29fab1d0f58c94935caaaf65aa77023053344..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1533 zcmcJM|5K880LMSi!{Z|&=0k!$e#sCYn;My(xX@S=g-GjZFn#)B(4>68d0Fd=x7wC#-O81+`Xl!G;r-L=?)}3{ma|-# zu1*I@U=RRrzqhxy*XFRb9%}8m*i%taVQsR0prTBx-%;UmxokF@-l$h8MAix^DdtPX zQnS&lqDXU@)LBPPbgML!KqM5AIV827a&|hkB^s@ow3dm+T&js4O-~a^ks|L^uUT)_ zlxWO#W-5p8bx;**!OOp2`ri2{l5};uG-}Fblv1R0a&nSVP(3|8H#$`+l0Wv#SZiym z%SujO)TmUdH}Bq9%~rEk)NA|T3MOAns?;iyByD=BM!_E&8FM~kjxuLqLxdrh<_w7ae=>d$E zqjiByq#lC(g60HcET`i%V4OOP&JAI6Lc{Rzz(d_lG`}uOL}b*w==t0j1}_#T;J)U- zIFAuJu;3HU{OEXQLSh0!EM)TUSP+I8L6Q6DqR^!I|0XTwCHfKz=|foThD%};$D7JB z4NNGINi-Waq345BH{69_qju|)6>3WX5)WR?T zR%fE`;d87lW`%RzD;!@ZA8^x=1tvV*2n7hS#b98D1=!3^osU(EnUG`!RD^FC-`{T{ z2wc$iNWB8FmZ`CLo?|>1&YgX_3M!NYE>o73VR@^*PI{R}6K=Rn!meps)jbLd@GI!ix*j^3F z6EKf)LtcZ7VxaQV8;f)^c1V0Dg=Yx_K6O+ffMrV z!emXx(d}z_%wa5VIouW-tz2aDJ_sh{DKXoczR9@_`z6y2Ez#}LzFiP9b@xd3jE-P_ z&M%YfJL$Tw2?}R-SQ1l(*_o@0jkQOWz)^1EAoh&010~O=qH8S1%gekG?1j(oY@}UgjKU=?j+GX&-&5ikEaL%AK7F|Q!yb21p z5q+!&olZ}6Zl@gyh-ChLoz6%co=9&S0tS?URYd?8*fHbr9u46EGDa~rufvY_2R5EK6i3pTSj{qE$kX2`%9*>@qM{6 zZOCqbWQ}|Fm*!#*gMkv)4RiU)@`Lb+DpCR|20*r%`fDw~GQ376NHB-J4<2*c|$x0jDgIAZj*Y4;Tv3D=Dr+3^Bgc=G4Uxj<7OIw#DJR09JkJ;mR?&`(mkSc;*4Tpl@Tm%M7{{yv~E$RRO diff --git a/otherlibs/labltk/labltk/.ignore b/otherlibs/labltk/labltk/.ignore deleted file mode 100644 index 81bd183eb8dc..000000000000 --- a/otherlibs/labltk/labltk/.ignore +++ /dev/null @@ -1,4 +0,0 @@ -*.ml -*.mli -labltktop -labltk diff --git a/otherlibs/labltk/labltk/Makefile b/otherlibs/labltk/labltk/Makefile deleted file mode 100644 index 429c3c5376bf..000000000000 --- a/otherlibs/labltk/labltk/Makefile +++ /dev/null @@ -1,59 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 2002 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -include ../support/Makefile.common - -COMPFLAGS= -I ../support - -all: labltkobjs - -opt: labltkobjsx - -include ./modules - -LABLTKOBJS = $(WIDGETOBJS) tk.cmo labltk.cmo -LABLTKOBJSX = $(LABLTKOBJS:.cmo=.cmx) - -labltkobjs: $(LABLTKOBJS) - -labltkobjsx: $(LABLTKOBJSX) - -install: $(LABLTKOBJS) - if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(LABLTKOBJS:.cmo=.cmi) $(WIDGETOBJS:.cmo=.mli) $(INSTALLDIR) - chmod 644 $(INSTALLDIR)/*.cmi - -installopt: $(LABLTKOBJSX) - @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(LABLTKOBJSX) $(INSTALLDIR) - chmod 644 $(INSTALLDIR)/*.cmx - -clean: - $(MAKE) -f Makefile.gen clean - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -nojoin -c $(COMPFLAGS) $< - -include .depend diff --git a/otherlibs/labltk/labltk/Makefile.gen b/otherlibs/labltk/labltk/Makefile.gen deleted file mode 100644 index efcf8a66b94a..000000000000 --- a/otherlibs/labltk/labltk/Makefile.gen +++ /dev/null @@ -1,61 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 2002 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -include ../support/Makefile.common - -all: tk.ml labltk.ml .depend - -_tkgen.ml: ../Widgets.src ../compiler/tkcompiler - cd ..; $(CAMLRUNGEN) compiler/tkcompiler -outdir labltk - -# dependencies are broken: wouldn't work with gmake 3.77 - -tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../builtin/builtin_*.ml - (echo 'open StdLabels'; \ - echo 'open Widget'; \ - echo 'open Protocol'; \ - echo 'open Support'; \ - echo 'open Textvariable'; \ - cat ../builtin/report.ml; \ - cat ../builtin/builtin_*.ml; \ - cat _tkgen.ml; \ - echo ; \ - echo ; \ - echo 'module Tkintf = struct'; \ - cat ../builtin/builtini_*.ml; \ - cat _tkigen.ml; \ - echo 'end (* module Tkintf *)'; \ - echo ; \ - echo ; \ - echo 'open Tkintf' ;\ - echo ; \ - echo ; \ - cat ../builtin/builtinf_*.ml; \ - cat _tkfgen.ml; \ - echo ; \ - ) > _tk.ml - $(CAMLRUN) ../compiler/pp < _tk.ml > tk.ml - rm -f _tk.ml - $(CAMLDEP) -I ../support [a-z]*.mli [a-z]*.ml > .depend - -../compiler/pp: - cd ../compiler; $(MAKE) pp - -# All .{ml,mli} files are generated in this directory -clean: - rm -f *.cm* *.ml *.mli *.o *.a .depend - -# rm -f modules diff --git a/otherlibs/labltk/labltk/Makefile.gen.nt b/otherlibs/labltk/labltk/Makefile.gen.nt deleted file mode 100644 index 8c65224049ab..000000000000 --- a/otherlibs/labltk/labltk/Makefile.gen.nt +++ /dev/null @@ -1,40 +0,0 @@ -include ../support/Makefile.common.nt - -all: tk.ml labltk.ml .depend - -_tkgen.ml: ../Widgets.src ../compiler/tkcompiler.exe - cd .. ; $(CAMLRUNGEN) compiler/tkcompiler.exe -outdir labltk - -# dependencies are broken: wouldn't work with gmake 3.77 - -tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp.exe #../builtin/builtin_*.ml - (echo 'open StdLabels'; \ - echo 'open Widget'; \ - echo 'open Protocol'; \ - echo 'open Support'; \ - echo 'open Textvariable'; \ - cat ../builtin/report.ml; \ - cat ../builtin/builtin_*.ml; \ - cat _tkgen.ml; \ - echo ; \ - echo ; \ - echo 'module Tkintf = struct'; \ - cat ../builtin/builtini_*.ml; \ - cat _tkigen.ml; \ - echo 'end (* module Tkintf *)'; \ - echo ; \ - echo ; \ - echo 'open Tkintf' ;\ - echo ; \ - echo ; \ - cat ../builtin/builtinf_*.ml; \ - cat _tkfgen.ml; \ - echo ; \ - ) > _tk.ml - $(CAMLRUN) ../compiler/pp < _tk.ml > tk.ml - rm -f _tk.ml - $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend - -clean: - rm -f *.cm* *.ml *.mli *.$(O) *.$(A) -# rm -f modules .depend diff --git a/otherlibs/labltk/labltk/Makefile.nt b/otherlibs/labltk/labltk/Makefile.nt deleted file mode 100644 index a8f4f694d982..000000000000 --- a/otherlibs/labltk/labltk/Makefile.nt +++ /dev/null @@ -1,43 +0,0 @@ -include ../support/Makefile.common.nt - -COMPFLAGS= -I ../support - -all: labltkobjs - -opt: labltkobjsx - -# All .{ml,mli} files are generated in this directory -clean : - rm -f *.cm* *.ml *.mli *.$(A) *.$(O) - $(MAKE) -f Makefile.gen.nt clean - -include ./modules - -LABLTKOBJS = $(WIDGETOBJS) tk.cmo labltk.cmo -LABLTKOBJSX = $(LABLTKOBJS:.cmo=.cmx) - -labltkobjs: $(LABLTKOBJS) - -labltkobjsx: $(LABLTKOBJSX) - -install: $(LABLTKOBJS) - mkdir -p $(INSTALLDIR) - cp *.cmi [a-z]*.mli $(INSTALLDIR) - -installopt: $(LABLTKOBJSX) - mkdir -p $(INSTALLDIR) - cp $(LABLTKOBJSX) $(INSTALLDIR) - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -include .depend diff --git a/otherlibs/labltk/labltk/modules b/otherlibs/labltk/labltk/modules deleted file mode 100644 index bb8d3e5b79e8..000000000000 --- a/otherlibs/labltk/labltk/modules +++ /dev/null @@ -1,77 +0,0 @@ -WIDGETOBJS=bell.cmo scale.cmo winfo.cmo scrollbar.cmo entry.cmo listbox.cmo wm.cmo tkwait.cmo grab.cmo font.cmo canvas.cmo image.cmo clipboard.cmo label.cmo message.cmo text.cmo imagephoto.cmo option.cmo frame.cmo selection.cmo dialog.cmo place.cmo pixmap.cmo menubutton.cmo radiobutton.cmo focus.cmo pack.cmo imagebitmap.cmo encoding.cmo optionmenu.cmo checkbutton.cmo tkvars.cmo palette.cmo menu.cmo button.cmo toplevel.cmo grid.cmo -bell.ml scale.ml winfo.ml scrollbar.ml entry.ml listbox.ml wm.ml tkwait.ml grab.ml font.ml canvas.ml image.ml clipboard.ml label.ml message.ml text.ml imagephoto.ml option.ml frame.ml selection.ml dialog.ml place.ml pixmap.ml menubutton.ml radiobutton.ml focus.ml pack.ml imagebitmap.ml encoding.ml optionmenu.ml checkbutton.ml tkvars.ml palette.ml menu.ml button.ml toplevel.ml grid.ml : _tkgen.ml - -bell.cmo : bell.ml -bell.cmi : bell.mli -scale.cmo : scale.ml -scale.cmi : scale.mli -winfo.cmo : winfo.ml -winfo.cmi : winfo.mli -scrollbar.cmo : scrollbar.ml -scrollbar.cmi : scrollbar.mli -entry.cmo : entry.ml -entry.cmi : entry.mli -listbox.cmo : listbox.ml -listbox.cmi : listbox.mli -wm.cmo : wm.ml -wm.cmi : wm.mli -tkwait.cmo : tkwait.ml -tkwait.cmi : tkwait.mli -grab.cmo : grab.ml -grab.cmi : grab.mli -font.cmo : font.ml -font.cmi : font.mli -canvas.cmo : canvas.ml -canvas.cmi : canvas.mli -image.cmo : image.ml -image.cmi : image.mli -clipboard.cmo : clipboard.ml -clipboard.cmi : clipboard.mli -label.cmo : label.ml -label.cmi : label.mli -message.cmo : message.ml -message.cmi : message.mli -text.cmo : text.ml -text.cmi : text.mli -imagephoto.cmo : imagephoto.ml -imagephoto.cmi : imagephoto.mli -option.cmo : option.ml -option.cmi : option.mli -frame.cmo : frame.ml -frame.cmi : frame.mli -selection.cmo : selection.ml -selection.cmi : selection.mli -dialog.cmo : dialog.ml -dialog.cmi : dialog.mli -place.cmo : place.ml -place.cmi : place.mli -pixmap.cmo : pixmap.ml -pixmap.cmi : pixmap.mli -menubutton.cmo : menubutton.ml -menubutton.cmi : menubutton.mli -radiobutton.cmo : radiobutton.ml -radiobutton.cmi : radiobutton.mli -focus.cmo : focus.ml -focus.cmi : focus.mli -pack.cmo : pack.ml -pack.cmi : pack.mli -imagebitmap.cmo : imagebitmap.ml -imagebitmap.cmi : imagebitmap.mli -encoding.cmo : encoding.ml -encoding.cmi : encoding.mli -optionmenu.cmo : optionmenu.ml -optionmenu.cmi : optionmenu.mli -checkbutton.cmo : checkbutton.ml -checkbutton.cmi : checkbutton.mli -tkvars.cmo : tkvars.ml -tkvars.cmi : tkvars.mli -palette.cmo : palette.ml -palette.cmi : palette.mli -menu.cmo : menu.ml -menu.cmi : menu.mli -button.cmo : button.ml -button.cmi : button.mli -toplevel.cmo : toplevel.ml -toplevel.cmi : toplevel.mli -grid.cmo : grid.ml -grid.cmi : grid.mli diff --git a/otherlibs/labltk/lib/.ignore b/otherlibs/labltk/lib/.ignore deleted file mode 100644 index 005295fcadb2..000000000000 --- a/otherlibs/labltk/lib/.ignore +++ /dev/null @@ -1,7 +0,0 @@ -labltktop -labltk -mltktop -mltk -.depend -*.ml -*.mli diff --git a/otherlibs/labltk/lib/Makefile b/otherlibs/labltk/lib/Makefile deleted file mode 100644 index c21b3fe461d5..000000000000 --- a/otherlibs/labltk/lib/Makefile +++ /dev/null @@ -1,109 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -include ../support/Makefile.common - -all: $(LIBNAME).cma $(LIBNAME)top$(EXE) $(LIBNAME) - -opt: $(LIBNAME).cmxa - -clean: - rm -f $(LIBNAME)top$(EXE) $(LIBNAME) *.cm* *.a - -superclean: - - if test -f tk.cmo; then \ - echo We have changes... Now lib directory has no .cmo files; \ - rm -f *.cm* *.o; \ - fi - -include ../labltk/modules -LABLTKOBJS=tk.cmo $(WIDGETOBJS) - -include ../camltk/modules -CAMLTKOBJS=cTk.cmo $(CWIDGETOBJS) labltk.cmo camltk.cmo - -SUPPORT=../support/support.cmo ../support/rawwidget.cmo \ - ../support/widget.cmo ../support/protocol.cmo \ - ../support/textvariable.cmo ../support/timer.cmo \ - ../support/fileevent.cmo ../support/camltkwrap.cmo - -TKOBJS=$(SUPPORT) $(LABLTKOBJS) $(CAMLTKOBJS) - -TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo - -$(LIBNAME).cma: $(SUPPORT) ../Widgets.src - $(MAKE) superclean - cd ../labltk; $(MAKE) - cd ../camltk; $(MAKE) - $(MKLIB) -ocamlc '$(CAMLC)' -o $(LIBNAME) -oc $(LIBNAME) \ -<<<<<<< .courant - -I ../labltk -I ../camltk $(TKOBJS) \ - $(TK_LINK) -======= - -I ../labltk -I ../camltk $(TKOBJS) \ - -ccopt "\"$(TK_LINK)\"" ->>>>>>> .fusion-droit.r10497 - -$(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src - $(MAKE) superclean - cd ../labltk; $(MAKE) opt - cd ../camltk; $(MAKE) opt - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o $(LIBNAME) -oc $(LIBNAME) \ -<<<<<<< .courant - -I ../labltk -I ../camltk $(TKOBJS:.cmo=.cmx) \ - $(TK_LINK) -======= - -I ../labltk -I ../camltk $(TKOBJS:.cmo=.cmx) \ - -ccopt "\"$(TK_LINK)\"" ->>>>>>> .fusion-droit.r10497 - -$(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).a - $(CAMLC) -verbose -linkall -o $(LIBNAME)top$(EXE) -I ../support \ - -I $(TOPDIR)/toplevel toplevellib.cma \ - -I ../labltk -I ../camltk $(LIBNAME).cma \ - -I $(OTHERS)/unix unix.cma \ - -I $(OTHERS)/str str.cma \ - topstart.cmo - -$(LIBNAME): Makefile $(TOPDIR)/config/Makefile - @echo Generate $@ - @echo "#!/bin/sh" > $@ - @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) "$$@"' >> $@ - -install-script: $(LIBNAME) - cp $(LIBNAME) $(BINDIR) - chmod 755 $(BINDIR)/$(LIBNAME) - -install-batch: - cp labltk.bat $(BINDIR) - -install: - if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(LIBNAME).cma $(LIBNAME)top$(EXE) $(INSTALLDIR) - chmod 644 $(INSTALLDIR)/$(LIBNAME).cma - chmod 755 $(INSTALLDIR)/$(LIBNAME)top$(EXE) - @if test -d $(BINDIR); then : ; else mkdir $(BINDIR); fi - @case x$(TOOLCHAIN) in \ - xmingw|xmsvc) $(MAKE) install-batch ;; \ - *) $(MAKE) install-script ;; \ - esac - -installopt: - @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(LIBNAME).cmxa $(LIBNAME).a $(INSTALLDIR) - cd $(INSTALLDIR); $(RANLIB) $(LIBNAME).a - chmod 644 $(INSTALLDIR)/$(LIBNAME).cmxa - chmod 644 $(INSTALLDIR)/$(LIBNAME).a diff --git a/otherlibs/labltk/lib/Makefile.nt b/otherlibs/labltk/lib/Makefile.nt deleted file mode 100644 index 4ce22aca5ee7..000000000000 --- a/otherlibs/labltk/lib/Makefile.nt +++ /dev/null @@ -1,60 +0,0 @@ -include ../support/Makefile.common.nt - -all: $(LIBNAME).cma - -opt: $(LIBNAME).cmxa - -clean: - rm -f $(LIBNAME).cma $(LIBNAME).cmxa *.$(A) - -include ../labltk/modules -LABLTKOBJS=tk.cmo $(WIDGETOBJS) - -include ../camltk/modules -CAMLTKOBJS=cTk.cmo $(CWIDGETOBJS) labltk.cmo camltk.cmo - -SUPPORT=../support/support.cmo ../support/rawwidget.cmo \ - ../support/widget.cmo ../support/protocol.cmo \ - ../support/textvariable.cmo ../support/timer.cmo \ - ../support/fileevent.cmo ../support/camltkwrap.cmo - -TKOBJS=$(SUPPORT) $(LABLTKOBJS) $(CAMLTKOBJS) - -TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo - -UNIXLIB = $(call SYSLIB,wsock32) - -$(LIBNAME).cma: $(SUPPORT) - cd ../labltk ; $(MAKEREC) - cd ../camltk ; $(MAKEREC) - $(CAMLLIBR) -o $(LIBNAME).cma -I ../labltk -I ../camltk $(TKOBJS) \ - -dllib -l$(LIBNAME) -cclib -l$(LIBNAME) \ - -cclib "$(TK_LINK)" -cclib $(UNIXLIB) - -$(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) - cd ../labltk; $(MAKEREC) opt - cd ../camltk; $(MAKEREC) opt - $(CAMLOPTLIBR) -o $(LIBNAME).cmxa -I ../labltk -I ../camltk \ - $(TKOBJS:.cmo=.cmx) -cclib -l$(LIBNAME) \ - -cclib "$(TK_LINK)" -cclib $(UNIXLIB) - -# $(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).a -# $(CAMLC) -linkall -o $(LIBNAME)top$(EXE) -I ../support \ -# -I $(TOPDIR)/toplevel toplevellib.cma \ -# -I ../labltk -I ../camltk $(LIBNAME).cma \ -# -I $(OTHERS)/unix unix.cma \ -# -I $(OTHERS)/str str.cma \ -# topmain.cmo -# -# $(LIBNAME): Makefile $(TOPDIR)/config/Makefile -# @echo Generate $@ -# @echo "#!/bin/sh" > $@ -# @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) $$*' >> $@ - -install: all - mkdir -p $(INSTALLDIR) - cp $(LIBNAME).cma $(INSTALLDIR) - -installopt: opt - mkdir -p $(INSTALLDIR) - cp $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALLDIR) diff --git a/otherlibs/labltk/lib/labltk.bat b/otherlibs/labltk/lib/labltk.bat deleted file mode 100755 index f760e80006eb..000000000000 --- a/otherlibs/labltk/lib/labltk.bat +++ /dev/null @@ -1 +0,0 @@ -@ocaml -I +labltk labltk.cma %1 %2 %3 %4 %5 %6 %7 %8 %9 \ No newline at end of file diff --git a/otherlibs/labltk/support/.depend b/otherlibs/labltk/support/.depend deleted file mode 100644 index 5b3d45683867..000000000000 --- a/otherlibs/labltk/support/.depend +++ /dev/null @@ -1,59 +0,0 @@ -<<<<<<< .courant -camltkwrap.cmi: protocol.cmi textvariable.cmi timer.cmi widget.cmi -protocol.cmi: widget.cmi -textvariable.cmi: protocol.cmi widget.cmi -widget.cmi: rawwidget.cmi -======= -camltkwrap.cmi: widget.cmi timer.cmi textvariable.cmi protocol.cmi -protocol.cmi: widget.cmi -textvariable.cmi: widget.cmi protocol.cmi -tkthread.cmi: widget.cmi -widget.cmi: rawwidget.cmi ->>>>>>> .fusion-droit.r10497 -<<<<<<< .courant -camltkwrap.cmo: fileevent.cmi protocol.cmi rawwidget.cmi textvariable.cmi \ - timer.cmi camltkwrap.cmi -camltkwrap.cmx: fileevent.cmx protocol.cmx rawwidget.cmx textvariable.cmx \ - timer.cmx camltkwrap.cmi -fileevent.cmo: protocol.cmi support.cmi fileevent.cmi -fileevent.cmx: protocol.cmx support.cmx fileevent.cmi -protocol.cmo: support.cmi widget.cmi protocol.cmi -protocol.cmx: support.cmx widget.cmx protocol.cmi -rawwidget.cmo: support.cmi rawwidget.cmi -rawwidget.cmx: support.cmx rawwidget.cmi -slave.cmo: widget.cmi -slave.cmx: widget.cmx -support.cmo: support.cmi -support.cmx: support.cmi -textvariable.cmo: protocol.cmi support.cmi widget.cmi textvariable.cmi -textvariable.cmx: protocol.cmx support.cmx widget.cmx textvariable.cmi -timer.cmo: protocol.cmi support.cmi timer.cmi -timer.cmx: protocol.cmx support.cmx timer.cmi -tkthread.cmo: protocol.cmi timer.cmi widget.cmi tkthread.cmi -tkthread.cmx: protocol.cmx timer.cmx widget.cmx tkthread.cmi -widget.cmo: rawwidget.cmi widget.cmi -widget.cmx: rawwidget.cmx widget.cmi -======= -camltkwrap.cmo: timer.cmi textvariable.cmi rawwidget.cmi protocol.cmi \ - fileevent.cmi camltkwrap.cmi -camltkwrap.cmx: timer.cmx textvariable.cmx rawwidget.cmx protocol.cmx \ - fileevent.cmx camltkwrap.cmi -fileevent.cmo: support.cmi protocol.cmi fileevent.cmi -fileevent.cmx: support.cmx protocol.cmx fileevent.cmi -protocol.cmo: widget.cmi support.cmi protocol.cmi -protocol.cmx: widget.cmx support.cmx protocol.cmi -rawwidget.cmo: support.cmi rawwidget.cmi -rawwidget.cmx: support.cmx rawwidget.cmi -slave.cmo: widget.cmi -slave.cmx: widget.cmx -support.cmo: support.cmi -support.cmx: support.cmi -textvariable.cmo: widget.cmi support.cmi protocol.cmi textvariable.cmi -textvariable.cmx: widget.cmx support.cmx protocol.cmx textvariable.cmi -timer.cmo: support.cmi protocol.cmi timer.cmi -timer.cmx: support.cmx protocol.cmx timer.cmi -tkthread.cmo: widget.cmi timer.cmi protocol.cmi tkthread.cmi -tkthread.cmx: widget.cmx timer.cmx protocol.cmx tkthread.cmi -widget.cmo: rawwidget.cmi widget.cmi -widget.cmx: rawwidget.cmx widget.cmi ->>>>>>> .fusion-droit.r10497 diff --git a/otherlibs/labltk/support/Makefile b/otherlibs/labltk/support/Makefile deleted file mode 100644 index 26f4c50f14ff..000000000000 --- a/otherlibs/labltk/support/Makefile +++ /dev/null @@ -1,92 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -include Makefile.common - -all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \ - textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \ - tkthread.cmo lib$(LIBNAME).$(A) - -opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \ - textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \ - tkthread.cmx lib$(LIBNAME).$(A) - -COBJS=cltkCaml.$(O) cltkUtf.$(O) cltkEval.$(O) cltkEvent.$(O) \ - cltkFile.$(O) cltkMain.$(O) cltkMisc.$(O) cltkTimer.$(O) \ - cltkVar.$(O) cltkWait.$(O) cltkImg.$(O) - -CCFLAGS=-I../../../byterun $(TK_DEFS) $(SHAREDCCCOMPOPTS) - -COMPFLAGS=-I $(OTHERS)/win32unix -I $(OTHERS)/unix -THFLAGS=-I $(OTHERS)/systhreads -I $(OTHERS)/threads -TKLDOPTS=$(TK_LINK:%=-ldopt "%") - -lib$(LIBNAME).$(A): $(COBJS) - $(MKLIB) -o $(LIBNAME) $(COBJS) $(TKLDOPTS) - -PUBMLI=fileevent.mli protocol.mli textvariable.mli timer.mli \ - rawwidget.mli widget.mli -PUB= $(PUBMLI) $(PUBMLI:.mli=.cmi) tkthread.mli tkthread.cmi tkthread.cmo - -install: - if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(PUB) lib$(LIBNAME).$(A) $(INSTALLDIR) - cd $(INSTALLDIR); $(RANLIB) lib$(LIBNAME).$(A) - cd $(INSTALLDIR); chmod 644 $(PUB) lib$(LIBNAME).$(A) - if test -f dll$(LIBNAME)$(EXT_DLL); then \ - cp dll$(LIBNAME)$(EXT_DLL) $(STUBLIBDIR)/; fi - -installopt: - @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(PUBMLI:.mli=.cmx) $(INSTALLDIR) - if test -f tkthread.$(O); then \ - cp tkthread.cmx tkthread.$(O) $(INSTALLDIR); \ - chmod 644 $(INSTALLDIR)/tkthread.cmx $(INSTALLDIR)/tkthread.$(O); \ - fi - -clean: - rm -f *.cm* *.o *.a *.so *.obj *.lib *.dll *.exp - -.SUFFIXES: -.SUFFIXES: .mli .ml .cmi .cmo .cmx .mlp .c .$(O) - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(O): - $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< - -tkthread.cmi: tkthread.mli - $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $< -tkthread.cmo: tkthread.ml - $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $< -tkthread.cmx: tkthread.ml - if test -f $(OTHERS)/systhreads/threads.cmxa; then \ - $(CAMLOPT) -c $(COMPFLAGS) $(THFLAGS) $< ; \ - fi - -depend: - $(CAMLDEP) *.mli *.ml > .depend - -$(COBJS): $(TOPDIR)/config/Makefile camltk.h - -include .depend diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common deleted file mode 100644 index 2a0d73d0c8f8..000000000000 --- a/otherlibs/labltk/support/Makefile.common +++ /dev/null @@ -1,43 +0,0 @@ -####################################################################### -# # -# MLTk, Tcl/Tk interface of OCaml # -# # -# Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # -# projet Cristal, INRIA Rocquencourt # -# Jacques Garrigue, Kyoto University RIMS # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique and Kyoto University. All rights reserved. # -# This file is distributed under the terms of the GNU Library # -# General Public License, with the special exception on linking # -# described in file LICENSE found in the OCaml source tree. # -# # -####################################################################### - -## Paths are relative to subdirectories -## Where you compiled OCaml -TOPDIR=../../.. -## Path to the otherlibs subdirectory -OTHERS=../.. - -LIBNAME=labltk - -include $(TOPDIR)/config/Makefile - -INSTALLDIR=$(LIBDIR)/$(LIBNAME) - -## Tools from the OCaml distribution - -CAMLRUN=$(TOPDIR)/boot/ocamlrun -CAMLC=$(TOPDIR)/ocamlcomp.sh -CAMLOPT=$(TOPDIR)/ocamlcompopt.sh -CAMLCOMP=$(CAMLC) -c -warn-error A -nojoin -CAMLYACC=$(TOPDIR)/boot/ocamlyacc -v -CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex -CAMLLIBR=$(CAMLC) -a -nojoin -CAMLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep -nojoin -COMPFLAGS= -LINKFLAGS= -CAMLOPTLIBR=$(CAMLOPT) -a -nojoin -MKLIB=$(CAMLRUN) $(TOPDIR)/tools/ocamlmklib -CAMLRUNGEN=../../boot/ocamlrun diff --git a/otherlibs/labltk/support/Makefile.common.nt b/otherlibs/labltk/support/Makefile.common.nt deleted file mode 100644 index 3f37dda0061b..000000000000 --- a/otherlibs/labltk/support/Makefile.common.nt +++ /dev/null @@ -1,30 +0,0 @@ -## Paths are relative to subdirectories -## Where you compiled Objective Caml -TOPDIR=../../.. -## Where to find OCaml binaries -EXEDIR=$(TOPDIR) -## Path to the otherlibs subdirectory -OTHERS=../.. - -LIBNAME=labltk - -include $(TOPDIR)/config/Makefile - -INSTALLDIR=$(LIBDIR)/$(LIBNAME) -TKLINKOPT=$(STATIC) - -## Tools from the Objective Caml distribution - -CAMLRUN=$(EXEDIR)/boot/ocamlrun -CAMLC=$(CAMLRUN) $(TOPDIR)/ocamlc -I $(TOPDIR)/stdlib -CAMLCOMP=$(CAMLC) -c -CAMLYACC=$(EXEDIR)/boot/ocamlyacc -v -CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex -CAMLLIBR=$(CAMLC) -a -CAMLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep -COMPFLAGS= -LINKFLAGS= - -CAMLOPT=$(CAMLRUN) $(TOPDIR)/ocamlopt -I $(TOPDIR)/stdlib -CAMLOPTLIBR=$(CAMLOPT) -a -CAMLRUNGEN=../../boot/ocamlrun diff --git a/otherlibs/labltk/support/Makefile.nt b/otherlibs/labltk/support/Makefile.nt deleted file mode 100644 index 64188e3c2bfa..000000000000 --- a/otherlibs/labltk/support/Makefile.nt +++ /dev/null @@ -1,80 +0,0 @@ -include Makefile.common.nt - -all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \ - textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \ - tkthread.cmo dll$(LIBNAME).dll lib$(LIBNAME).$(A) - -opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \ - textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \ - tkthread.cmx lib$(LIBNAME).$(A) - -COBJS=cltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o \ - cltkMain.o cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o -DCOBJS=$(COBJS:.o=.$(DO)) -SCOBJS=$(COBJS:.o=.$(SO)) - -CCFLAGS=-I../../../byterun -I../../win32unix $(TK_DEFS) -DIN_CAMLTKSUPPORT - -COMPFLAGS=-I $(OTHERS)/win32unix -THFLAGS=-I $(OTHERS)/systhreads -I $(OTHERS)/threads - -dll$(LIBNAME).dll : $(DCOBJS) - $(call MKDLL,dll$(LIBNAME).dll,dll$(LIBNAME).$(A),\ - $(DCOBJS) ../../../byterun/ocamlrun.$(A) \ - $(TK_LINK) $(call SYSLIB,wsock32)) - -lib$(LIBNAME).$(A) : $(SCOBJS) - $(call MKLIB,lib$(LIBNAME).$(A), $(SCOBJS)) - -PUBMLI=fileevent.mli protocol.mli textvariable.mli timer.mli \ - rawwidget.mli widget.mli tkthread.mli -PUB= $(PUBMLI) $(PUBMLI:.mli=.cmi) tkthread.cmo - -install: - mkdir -p $(INSTALLDIR) - cp $(PUB) $(INSTALLDIR) - cp dll$(LIBNAME).dll $(STUBLIBDIR)/dll$(LIBNAME).dll - cp dll$(LIBNAME).$(A) lib$(LIBNAME).$(A) $(INSTALLDIR) - -installopt: - @mkdir -p $(INSTALLDIR) - cp $(PUBMLI:.mli=.cmx) $(INSTALLDIR) - cp tkthread.$(O) $(INSTALLDIR) - -clean : - rm -f *.cm* *.$(O) *.dll *.$(A) *.exp - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .cmx .mlp .c .$(DO) .$(SO) - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CCFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< - mv $*.$(O) $*.$(SO) - -tkthread.cmi: tkthread.mli - $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $< -tkthread.cmo: tkthread.ml - $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $< -tkthread.cmx: tkthread.ml - if test -f $(OTHERS)/systhreads/threads.cmxa; then \ - $(CAMLOPT) -c $(COMPFLAGS) $(THFLAGS) $< ; \ - fi -depend: - $(CAMLDEP) *.mli *.ml > .depend - -$(DCOBJS) $(SCOBJS): camltk.h - -include .depend diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h deleted file mode 100644 index 13f1de44db36..000000000000 --- a/otherlibs/labltk/support/camltk.h +++ /dev/null @@ -1,60 +0,0 @@ -/*************************************************************************/ -/* */ -/* OCaml LablTk library */ -/* */ -/* Francois Rouaix, Francois Pessaux and Jun Furuse */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 1999 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file ../../../LICENSE. */ -/* */ -/*************************************************************************/ - -/* $Id$ */ - -#if defined(_WIN32) && defined(CAML_DLL) && defined(IN_CAMLTKSUPPORT) -#define CAMLTKextern CAMLexport -#else -#define CAMLTKextern CAMLextern -#endif - -/* if Tcl_GetStringResult is not defined, we use interp->result */ -#ifndef Tcl_GetStringResult -# define Tcl_GetStringResult(interp) (interp->result) -#endif - -/* cltkMisc.c */ -/* copy an OCaml string to the C heap. Must be deallocated with stat_free */ -extern char *string_to_c(value s); - -/* cltkUtf.c */ -extern value tcl_string_to_caml( char * ); -extern char * caml_string_to_tcl( value ); - -/* cltkEval.c */ -CAMLTKextern Tcl_Interp *cltclinterp; /* The Tcl interpretor */ -extern value copy_string_list(int argc, char ** argv); - -/* cltkCaml.c */ -/* pointers to OCaml values */ -extern value *tkerror_exn; -extern value *handler_code; -extern int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, - int argc, char *argv[]); -CAMLTKextern void tk_error(char * errmsg) Noreturn; - -/* cltkMain.c */ -extern int signal_events; -extern void invoke_pending_caml_signals(ClientData clientdata); -extern Tk_Window cltk_mainWindow; -extern int cltk_slave_mode; - -/* check that initialisations took place */ -#define CheckInit() if (!cltclinterp) tk_error("Tcl/Tk not initialised") - -#define RCNAME ".camltkrc" -#define CAMLCB "camlcb" diff --git a/otherlibs/labltk/support/camltkwrap.ml b/otherlibs/labltk/support/camltkwrap.ml deleted file mode 100644 index 635349a31562..000000000000 --- a/otherlibs/labltk/support/camltkwrap.ml +++ /dev/null @@ -1,77 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -module Widget = struct - include Rawwidget - type widget = raw_any raw_widget - - let default_toplevel = coe default_toplevel -end - -module Protocol = struct - open Widget - include Protocol - - let opentk () = coe (opentk ()) - let opentk_with_args args = coe (opentk_with_args args) - let openTk ?display ?clas () = coe (openTk ?display ?clas ()) - - let cCAMLtoTKwidget table w = - Widget.check_class w table; (* we need run time type check of widgets *) - TkToken (Widget.name w) - - (* backward compatibility *) - let openTkClass s = coe (openTkClass s) - let openTkDisplayClass disp c = coe (openTkDisplayClass disp c) -end - -module Textvariable = struct - open Textvariable - type textVariable = Textvariable.textVariable - let create = create - let set = set - let get = get - let name = name - let cCAMLtoTKtextVariable = cCAMLtoTKtextVariable - let handle tv cbk = handle tv ~callback:cbk - let coerce = coerce - - (*-*) - let free = free - - (* backward compatibility *) - let create_temporary w = create ~on: w () -end - -module Fileevent = struct - open Fileevent - let add_fileinput fd callback = add_fileinput ~fd ~callback - let remove_fileinput fd = remove_fileinput ~fd - let add_fileoutput fd callback = add_fileoutput ~fd ~callback - let remove_fileoutput fd = remove_fileoutput ~fd -end - -module Timer = struct - open Timer - type t = Timer.t - let add ms callback = add ~ms ~callback - let set ms callback = set ~ms ~callback - let remove = remove -end - -(* -Not compiled in support -module Tkwait = Tkwait -*) diff --git a/otherlibs/labltk/support/camltkwrap.mli b/otherlibs/labltk/support/camltkwrap.mli deleted file mode 100644 index 4fc7e3c1590f..000000000000 --- a/otherlibs/labltk/support/camltkwrap.mli +++ /dev/null @@ -1,251 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) -module Widget : sig - type widget = Widget.any Widget.widget - (* widget is an abstract type *) - - val default_toplevel : widget - (* [default_toplevel] is "." in Tk, the toplevel widget that is - always existing during a Tk session. Destroying [default_toplevel] - ends the main loop - *) - - val atom : parent: widget -> name: string -> widget - (* [atom parent name] returns the widget [parent.name]. The widget is - not created. Only its name is returned. In a given parent, there may - only exist one children for a given name. - This function should only be used to check the existence of a widget - with a known name. It doesn't add the widget to the internal tables - of CamlTk. - *) - - val name : widget -> string - (* [name w] returns the name (tk "path") of a widget *) - - (*--*) - (* The following functions are used internally. - There is normally no need for them in users programs - *) - - val known_class : widget -> string - (* [known_class w] returns the class of a widget (e.g. toplevel, frame), - as known by the CamlTk interface. - Not equivalent to "winfo w" in Tk. - *) - - val dummy : widget - (* [dummy] is a widget used as context when we don't have any. - It is *not* a real widget. - *) - - val new_atom : parent: widget -> ?name: string -> string -> widget - (* incompatible with the classic camltk *) - - val get_atom : string -> widget - (* [get_atom path] returns the widget with Tk path [path] *) - - val remove : widget -> unit - (* [remove w] removes widget from the internal tables *) - - (* Subtypes tables *) - val widget_any_table : string list - val widget_button_table : string list - val widget_canvas_table : string list - val widget_checkbutton_table : string list - val widget_entry_table : string list - val widget_frame_table : string list - val widget_label_table : string list - val widget_listbox_table : string list - val widget_menu_table : string list - val widget_menubutton_table : string list - val widget_message_table : string list - val widget_radiobutton_table : string list - val widget_scale_table : string list - val widget_scrollbar_table : string list - val widget_text_table : string list - val widget_toplevel_table : string list - - val chk_sub : string -> 'a list -> 'a -> unit - val check_class : widget -> string list -> unit - (* Widget subtyping *) - - exception IllegalWidgetType of string - (* Raised when widget command applied illegally*) - - (* this function is not used, but introduced for the compatibility - with labltk. useless for camltk users *) - val coe : 'a Widget.widget -> Widget.any Widget.widget -end - -module Protocol : sig - open Widget - - (* Lower level interface *) - exception TkError of string - (* Raised by the communication functions *) - - val debug : bool ref - (* When set to true, displays approximation of intermediate Tcl code *) - - type tkArgs = - TkToken of string - | TkTokenList of tkArgs list (* to be expanded *) - | TkQuote of tkArgs (* mapped to Tcl list *) - - - (* Misc *) - external splitlist : string -> string list - = "camltk_splitlist" - - val add_destroy_hook : (widget -> unit) -> unit - - - (* Opening, closing, and mainloop *) - val default_display : unit -> string - - val opentk : unit -> widget - (* The basic initialization function. [opentk ()] parses automatically - the command line options and use the tk related options in them - such as "-display localhost:0" to initialize Tk applications. - Consult wish manpage about the supported options. *) - - val keywords : (string * Arg.spec * string) list - (* Command line parsing specification for Arg.parse, which contains - the standard Tcl/Tk command line options such as "-display" and "-name". - These Tk command line options are used by opentk *) - - val opentk_with_args : string list -> widget - (* [opentk_with_args argv] invokes [opentk] with the tk related - command line options given by [argv] to the executable program. *) - - val openTk : ?display:string -> ?clas:string -> unit -> widget - (* [openTk ~display:display ~clas:clas ()] is equivalent to - [opentk ["-display"; display; "-name"; clas]] *) - - (* Legacy opentk functions *) - val openTkClass: string -> widget - (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *) - val openTkDisplayClass: string -> string -> widget - (* [openTkDisplayClass disp class] is equivalent to - [opentk ["-display"; disp; "-name"; class]] *) - - val closeTk : unit -> unit - val finalizeTk : unit -> unit - (* Finalize tcl/tk before exiting. This function will be automatically - called when you call [Pervasives.exit ()] *) - - val mainLoop : unit -> unit - - - (* Direct evaluation of tcl code *) - val tkEval : tkArgs array -> string - - val tkCommand : tkArgs array -> unit - - (* Returning a value from a Tcl callback *) - val tkreturn: string -> unit - - - (* Callbacks: this is private *) - - type cbid = Protocol.cbid - - type callback_buffer = string list - (* Buffer for reading callback arguments *) - - val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t - (* CAMLTK val callback_memo_table : (widget, cbid) Hashtbl.t *) - val callback_memo_table : (widget, cbid) Hashtbl.t - (* Exported for debug purposes only. Don't use them unless you - know what you are doing *) - val new_function_id : unit -> cbid - val string_of_cbid : cbid -> string - val register_callback : widget -> callback:(callback_buffer -> unit) -> string - (* Callback support *) - val clear_callback : cbid -> unit - (* Remove a given callback from the table *) - val remove_callbacks : widget -> unit - (* Clean up callbacks associated to widget. Must be used only when - the Destroy event is bind by the user and masks the default - Destroy event binding *) - - val cTKtoCAMLwidget : string -> widget - val cCAMLtoTKwidget : string list -> widget -> tkArgs - - val register : string -> callback:(callback_buffer -> unit) -> unit - - (*-*) - val prerr_cbid : cbid -> unit -end - -module Textvariable : sig - open Widget - open Protocol - - type textVariable = Textvariable.textVariable - (* TextVariable is an abstract type *) - - val create : ?on: widget -> unit -> textVariable - (* Allocation of a textVariable with lifetime associated to widget - if a widget is specified *) - val create_temporary : widget -> textVariable - (* for backward compatibility - [create_temporary w] is equivalent to [create ~on:w ()] *) - - val set : textVariable -> string -> unit - (* Setting the val of a textVariable *) - val get : textVariable -> string - (* Reading the val of a textVariable *) - val name : textVariable -> string - (* Its tcl name *) - - val cCAMLtoTKtextVariable : textVariable -> tkArgs - (* Internal conversion function *) - - val handle : textVariable -> (unit -> unit) -> unit - (* Callbacks on variable modifications *) - - val coerce : string -> textVariable - - (*-*) - val free : textVariable -> unit -end - -module Fileevent : sig - open Unix - - val add_fileinput : file_descr -> (unit -> unit) -> unit - val remove_fileinput: file_descr -> unit - val add_fileoutput : file_descr -> (unit -> unit) -> unit - val remove_fileoutput: file_descr -> unit - (* see [tk] module *) -end - -module Timer : sig - type t = Timer.t - - val add : int -> (unit -> unit) -> t - val set : int -> (unit -> unit) -> unit - val remove : t -> unit -end - -(* -Tkwait exists, but is not used in support -module Tkwait : sig - val internal_tracevis : string -> Protocol.cbid -> unit - val internal_tracedestroy : string -> Protocol.cbid -> unit -end -*) diff --git a/otherlibs/labltk/support/cltkCaml.c b/otherlibs/labltk/support/cltkCaml.c deleted file mode 100644 index 51b8ae11a5cb..000000000000 --- a/otherlibs/labltk/support/cltkCaml.c +++ /dev/null @@ -1,83 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of OCaml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the OCaml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include -#include -#include -#include -#include "camltk.h" - -value * tkerror_exn = NULL; -value * handler_code = NULL; - -/* The Tcl command for evaluating callback in OCaml */ -int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, int argc, char **argv) -{ - CheckInit(); - - /* Assumes no result */ - Tcl_SetResult(interp, NULL, NULL); - if (argc >= 2) { - int id; - if (Tcl_GetInt(interp, argv[1], &id) != TCL_OK) - return TCL_ERROR; - callback2(*handler_code,Val_int(id),copy_string_list(argc - 2,&argv[2])); - /* Never fails (OCaml would have raised an exception) */ - /* but result may have been set by callback */ - return TCL_OK; - } - else - return TCL_ERROR; -} - -/* Callbacks are always of type _ -> unit, to simplify storage - * But a callback can nevertheless return something (to Tcl) by - * using the following. TCL_VOLATILE ensures that Tcl will make - * a copy of the string - */ -CAMLprim value camltk_return (value v) -{ - CheckInit(); - - Tcl_SetResult(cltclinterp, String_val(v), TCL_VOLATILE); - return Val_unit; -} - -/* Note: raise_with_string WILL copy the error message */ -CAMLprim void tk_error(char *errmsg) -{ - raise_with_string(*tkerror_exn, errmsg); -} - - -/* The initialisation of the C global variables pointing to OCaml values - must be made accessible from OCaml, so that we are sure that it *always* - takes place during loading of the protocol module - */ - -CAMLprim value camltk_init(value v) -{ - /* Initialize the OCaml pointers */ - if (tkerror_exn == NULL) - tkerror_exn = caml_named_value("tkerror"); - if (handler_code == NULL) - handler_code = caml_named_value("camlcb"); - return Val_unit; -} diff --git a/otherlibs/labltk/support/cltkDMain.c b/otherlibs/labltk/support/cltkDMain.c deleted file mode 100644 index de6c42e7446c..000000000000 --- a/otherlibs/labltk/support/cltkDMain.c +++ /dev/null @@ -1,247 +0,0 @@ -/*************************************************************************/ -/* */ -/* OCaml LablTk library */ -/* */ -/* Francois Rouaix, Francois Pessaux and Jun Furuse */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 1999 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file ../../../LICENSE. */ -/* */ -/*************************************************************************/ - -/* $Id$ */ - -#include -#include -#include -#include -#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 OCaml, - * the actual execution of the signal handler upon reception of the - * signal is delayed until we are sure we are out of the GC. - * If a signal occurs during the MainLoop, we would have to wait - * the next event for the handler to be invoked. - * The following function will invoke a pending signal handler if any, - * and we put in on a regular timer. - */ - -#define SIGNAL_INTERVAL 300 - -int signal_events = 0; /* do we have a pending timer */ - -void invoke_pending_caml_signals (clientdata) - ClientData clientdata; -{ - signal_events = 0; - enter_blocking_section(); /* triggers signal handling */ - /* Rearm timer */ - Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL); - signal_events = 1; - leave_blocking_section(); -} -/* The following is taken from byterun/startup.c */ -header_t atom_table[256]; -code_t start_code; -asize_t code_size; - -static void init_atoms() -{ - int i; - for(i = 0; i < 256; i++) atom_table[i] = Make_header(0, i, White); -} - -static unsigned long read_size(p) - unsigned char * p; -{ - return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) + - ((unsigned long) p[2] << 8) + p[3]; -} - -#define FILE_NOT_FOUND (-1) -#define TRUNCATED_FILE (-2) -#define BAD_MAGIC_NUM (-3) - -static int read_trailer(fd, trail) - int fd; - struct exec_trailer * trail; -{ - char buffer[TRAILER_SIZE]; - - lseek(fd, (long) -TRAILER_SIZE, 2); - if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return TRUNCATED_FILE; - trail->code_size = read_size(buffer); - trail->data_size = read_size(buffer+4); - trail->symbol_size = read_size(buffer+8); - trail->debug_size = read_size(buffer+12); - if (strncmp(buffer + 16, EXEC_MAGIC, 12) == 0) - return 0; - else - return BAD_MAGIC_NUM; -} - -int attempt_open(name, trail, do_open_script) - char ** name; - struct exec_trailer * trail; - int do_open_script; -{ - char * truename; - int fd; - int err; - char buf [2]; - - truename = searchpath(*name); - if (truename == 0) truename = *name; else *name = truename; - fd = open(truename, O_RDONLY | O_BINARY); - if (fd == -1) return FILE_NOT_FOUND; - if (!do_open_script){ - err = read (fd, buf, 2); - if (err < 2) { close(fd); return TRUNCATED_FILE; } - if (buf [0] == '#' && buf [1] == '!') { close(fd); return BAD_MAGIC_NUM; } - } - err = read_trailer(fd, trail); - if (err != 0) { close(fd); return err; } - return fd; -} - - -/* Command for loading the bytecode file */ -int CamlRunCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - int fd; - struct exec_trailer trail; - struct longjmp_buffer raise_buf; - struct channel * chan; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " foo.cmo args\"", (char *) NULL); - return TCL_ERROR; - } - fd = attempt_open(&argv[1], &trail, 1); - - switch(fd) { - case FILE_NOT_FOUND: - fatal_error_arg("Fatal error: cannot find file %s\n", argv[1]); - break; - case TRUNCATED_FILE: - case BAD_MAGIC_NUM: - fatal_error_arg( - "Fatal error: the file %s is not a bytecode executable file\n", - argv[1]); - break; - } - - if (sigsetjmp(raise_buf.buf, 1) == 0) { - - external_raise = &raise_buf; - - lseek(fd, - (long) (TRAILER_SIZE + trail.code_size + trail.data_size - + trail.symbol_size + trail.debug_size), 2); - - code_size = trail.code_size; - start_code = (code_t) stat_alloc(code_size); - if (read(fd, (char *) start_code, code_size) != code_size) - fatal_error("Fatal error: truncated bytecode file.\n"); - -#ifdef ARCH_BIG_ENDIAN - fixup_endianness(start_code, code_size); -#endif - - chan = open_descr(fd); - global_data = input_value(chan); - close_channel(chan); - /* Ensure that the globals are in the major heap. */ - oldify(global_data, &global_data); - - sys_init(argv + 1); - interprete(start_code, code_size); - return TCL_OK; - } else { - Tcl_AppendResult(interp, "Caml program", argv[1], " raised exception \"", - String_val(Field(Field(exn_bucket, 0), 0))); - return TCL_ERROR; - } -} - -int CamlInvokeCmd(dummy - - - -/* Now the real Tk stuff */ -Tk_Window cltk_mainWindow; - -#define RCNAME ".camltkrc" -#define CAMLCB "camlcb" - -/* Initialisation of the dynamically loaded module */ -int Caml_Init(interp) - Tcl_Interp *interp; -{ - cltclinterp = interp; - /* Create the camlcallback command */ - Tcl_CreateCommand(cltclinterp, - CAMLCB, CamlCBCmd, - (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL); - - /* This is required by "unknown" and thus autoload */ - Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - /* Our hack for implementing break in callbacks */ - Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY); - - /* Load the traditional rc file */ - { - char *home = getenv("HOME"); - if (home != NULL) { - char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2); - f[0]='\0'; - strcat(f, home); - strcat(f, "/"); - strcat(f, RCNAME); - if (0 == access(f,R_OK)) - if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { - stat_free(f); - tk_error(Tcl_GetStringResult(cltclinterp)); - }; - stat_free(f); - } - } - - /* Initialisations from caml_main */ - { - int verbose_init = 0, - percent_free_init = Percent_free_def; - long minor_heap_init = Minor_heap_def, - heap_chunk_init = Heap_chunk_def; - - /* Machine-dependent initialization of the floating-point hardware - so that it behaves as much as possible as specified in IEEE */ - init_ieee_floats(); - init_gc (minor_heap_init, heap_chunk_init, percent_free_init, - verbose_init); - init_stack(); - init_atoms(); - } -} diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c deleted file mode 100644 index e1e3d5ba0f23..000000000000 --- a/otherlibs/labltk/support/cltkEval.c +++ /dev/null @@ -1,244 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of OCaml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the OCaml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include - -#include -#include -#include -#include -#include -#ifdef HAS_UNISTD -#include -#endif -#include "camltk.h" - -/* The Tcl interpretor */ -Tcl_Interp *cltclinterp = NULL; - -/* Copy a list of strings from the C heap to OCaml */ -value copy_string_list(int argc, char **argv) -{ - CAMLparam0(); - CAMLlocal3( res, oldres, str ); - int i; - oldres = Val_unit; - str = Val_unit; - - res = Val_int(0); /* [] */ - for (i = argc-1; i >= 0; i--) { - oldres = res; - str = tcl_string_to_caml(argv[i]); - res = alloc(2, 0); - Field(res, 0) = str; - Field(res, 1) = oldres; - } - CAMLreturn(res); -} - -/* - * Calling Tcl from OCaml - * this version works on an arbitrary Tcl command, - * and does parsing and substitution - */ -CAMLprim value camltk_tcl_eval(value str) -{ - int code; - char *cmd = NULL; - - CheckInit(); - - /* Tcl_Eval may write to its argument, so we take a copy - * If the evaluation raises an OCaml exception, we have a space - * leak - */ - Tcl_ResetResult(cltclinterp); - cmd = caml_string_to_tcl(str); - code = Tcl_Eval(cltclinterp, cmd); - stat_free(cmd); - - switch (code) { - case TCL_OK: - return tcl_string_to_caml(Tcl_GetStringResult(cltclinterp)); - case TCL_ERROR: - tk_error(Tcl_GetStringResult(cltclinterp)); - default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ - tk_error("bad tcl result"); - } -} - - -/* - * Calling Tcl from OCaml - * direct call, argument is TkArgs vect - type TkArgs = - TkToken of string - | TkTokenList of TkArgs list (* to be expanded *) - | TkQuote of TkArgs (* mapped to Tcl list *) - * NO PARSING, NO SUBSTITUTION - */ - -/* - * Compute the size of the argument (of type TkArgs). - * TkTokenList must be expanded, - * TkQuote count for one. - */ -int argv_size(value v) -{ - switch (Tag_val(v)) { - case 0: /* TkToken */ - return 1; - case 1: /* TkTokenList */ - { int n = 0; - value l; - for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1)) - n+=argv_size(Field(l,0)); - return n; - } - case 2: /* TkQuote */ - return 1; - default: - tk_error("argv_size: illegal tag"); - } -} - -/* Fill a preallocated vector arguments, doing expansion and all. - * Assumes Tcl will - * not tamper with our strings - * make copies if strings are "persistent" - */ -int fill_args (char **argv, int where, value v) -{ - value l; - - switch (Tag_val(v)) { - case 0: - argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by stat_free */ - return (where + 1); - case 1: - for (l=Field(v,0); Is_block(l); l=Field(l,1)) - where = fill_args(argv,where,Field(l,0)); - return where; - case 2: - { char **tmpargv; - char *merged; - int i; - int size = argv_size(Field(v,0)); - tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *)); - fill_args(tmpargv,0,Field(v,0)); - tmpargv[size] = NULL; - merged = Tcl_Merge(size,(const char *const*)tmpargv); - for(i = 0 ; i= 8) - /* info.proc might be a NULL pointer - * We should probably attempt an Obj invocation, but the following quick - * hack is easier. - */ - if (info.proc == NULL) { - Tcl_DString buf; - Tcl_DStringInit(&buf); - Tcl_DStringAppend(&buf, argv[0], -1); - for (i=1; i= 0; i--) - argv[i+1] = argv[i]; - argv[0] = "unknown"; - result = (*info.proc)(info.clientData,cltclinterp,size+1,(const char**)argv); - } else { /* ah, it isn't there at all */ - result = TCL_ERROR; - Tcl_AppendResult(cltclinterp, "Unknown command \"", - argv[0], "\"", NULL); - } - } - - /* Free the various things we allocated */ - for(i=0; i< size; i ++){ - stat_free((char *) allocated[i]); - } - stat_free((char *)argv); - stat_free((char *)allocated); - - switch (result) { - case TCL_OK: - return tcl_string_to_caml (Tcl_GetStringResult(cltclinterp)); - case TCL_ERROR: - tk_error(Tcl_GetStringResult(cltclinterp)); - default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ - tk_error("bad tcl result"); - } -} diff --git a/otherlibs/labltk/support/cltkEvent.c b/otherlibs/labltk/support/cltkEvent.c deleted file mode 100644 index 4507cf6943e7..000000000000 --- a/otherlibs/labltk/support/cltkEvent.c +++ /dev/null @@ -1,54 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of OCaml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the OCaml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include -#include -#include "camltk.h" - -CAMLprim value camltk_tk_mainloop(void) -{ - CheckInit(); - - if (cltk_slave_mode) return Val_unit; - - if (!signal_events) { - /* Initialise signal handling */ - signal_events = 1; - Tk_CreateTimerHandler(100, invoke_pending_caml_signals, NULL); - } - Tk_MainLoop(); - return Val_unit; -} - -/* Note: this HAS to be reported "as-is" in ML source */ -static int event_flag_table[] = { - TK_DONT_WAIT, TK_X_EVENTS, TK_FILE_EVENTS, TK_TIMER_EVENTS, TK_IDLE_EVENTS, - TK_ALL_EVENTS -}; - -CAMLprim value camltk_dooneevent(value flags) -{ - int ret; - - CheckInit(); - - ret = Tk_DoOneEvent(convert_flag_list(flags, event_flag_table)); - return Val_int(ret); -} diff --git a/otherlibs/labltk/support/cltkFile.c b/otherlibs/labltk/support/cltkFile.c deleted file mode 100644 index b4ebca614441..000000000000 --- a/otherlibs/labltk/support/cltkFile.c +++ /dev/null @@ -1,158 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of OCaml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the OCaml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#ifdef __CYGWIN__ -#define _WIN32 -#endif - -#ifdef _WIN32 -#include -#include -#include -#endif -#include -#include -#include -#include -#include "camltk.h" - -/* - * File descriptor callbacks - */ - -void FileProc(ClientData clientdata, int mask) -{ - callback2(*handler_code,Val_int(clientdata),Val_int(0)); -} - -/* Map Unix.file_descr values to Tcl file handles */ - -#ifndef _WIN32 - -/* Under Unix, we use file handlers */ - -/* Map Unix.file_descr values to Tcl file handles (for tcl 7) - or Unix file descriptors (for tcl 8). */ - -#if (TCL_MAJOR_VERSION < 8) -static Tcl_File tcl_filehandle(value fd) -{ - return Tcl_GetFile((ClientData)Long_val(fd), TCL_UNIX_FD); -} -#else -#define tcl_filehandle(fd) Int_val(fd) -#define Tcl_File int -#endif - -CAMLprim value camltk_add_file_input(value fd, value cbid) -{ - CheckInit(); - Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_READABLE, - FileProc, (ClientData)(Long_val(cbid))); - return Val_unit; -} - -/* We have to free the Tcl handle when we are finished using it (Tcl - * asks us to, and moreover it is probably dangerous to keep the same - * handle over two allocations of the same fd by the kernel). - * But we don't know when we are finished with the fd, so we free it - * in rem_file (it doesn't close the fd anyway). For fds for which we - * repeatedly add/rem, this will cause some overhead. - */ -CAMLprim value camltk_rem_file_input(value fd, value cbid) -{ - Tcl_File fh = tcl_filehandle(fd); - Tcl_DeleteFileHandler(fh); -#if (TCL_MAJOR_VERSION < 8) - Tcl_FreeFile(fh); -#endif - return Val_unit; -} - -CAMLprim value camltk_add_file_output(value fd, value cbid) -{ - CheckInit(); - Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_WRITABLE, - FileProc, (ClientData) (Long_val(cbid))); - return Val_unit; -} - -CAMLprim value camltk_rem_file_output(value fd, value cbid) -{ - Tcl_File fh = tcl_filehandle(fd); - Tcl_DeleteFileHandler(fh); -#if (TCL_MAJOR_VERSION < 8) - Tcl_FreeFile(fh); -#endif - return Val_unit; -} - -#else - -/* Under Win32, we go through the generic channel abstraction */ - -#define Handle_val(v) (*((HANDLE *) Data_custom_val(v))) - -/* Map Unix.file_descr values to Tcl channels */ - -static Tcl_Channel tcl_channel(value fd, int flags) -{ - HANDLE h = Handle_val(fd); - int optval, optsize; - - optsize = sizeof(optval); - if (getsockopt((SOCKET) h, SOL_SOCKET, SO_TYPE, - (char *)&optval, &optsize) == 0) - return Tcl_MakeTcpClientChannel((ClientData) h); - else - return Tcl_MakeFileChannel((ClientData) h, flags); -} - -CAMLprim value camltk_add_file_input(value fd, value cbid) -{ - CheckInit(); - Tcl_CreateChannelHandler(tcl_channel(fd, TCL_READABLE), - TCL_READABLE, - FileProc, (ClientData) (Int_val(cbid))); - return Val_unit; -} - -CAMLprim value camltk_rem_file_input(value fd, value cbid) -{ - Tcl_DeleteChannelHandler(tcl_channel(fd, TCL_READABLE), - FileProc, (ClientData) (Int_val(cbid))); - return Val_unit; -} - -CAMLprim value camltk_add_file_output(value fd, value cbid) -{ - CheckInit(); - Tcl_CreateChannelHandler(tcl_channel(fd, TCL_WRITABLE), - TCL_WRITABLE, - FileProc, (ClientData) (Int_val(cbid))); - return Val_unit; -} - -CAMLprim value camltk_rem_file_output(value fd, value cbid) -{ - Tcl_DeleteChannelHandler(tcl_channel(fd, TCL_WRITABLE), - FileProc, (ClientData) (Int_val(cbid))); - return Val_unit; -} - -#endif diff --git a/otherlibs/labltk/support/cltkImg.c b/otherlibs/labltk/support/cltkImg.c deleted file mode 100644 index 712eda2fee80..000000000000 --- a/otherlibs/labltk/support/cltkImg.c +++ /dev/null @@ -1,114 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of OCaml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the OCaml source tree. */ -/* */ -/***********************************************************************/ -#include -#include -#include -#include -#include -#include -#include "camltk.h" - -/* - * Pixmap manipulation from OCaml : get the pixmap from an arbitrary photo - * image, and put it back in some (possibly other) image. - * TODO: other blits - * We use the same format of "internal" pixmap data as in Tk, that is - * 24 bits per pixel - */ - -CAMLprim value camltk_getimgdata (value imgname) /* ML */ -{ - CAMLparam1(imgname); - CAMLlocal1(res); - Tk_PhotoHandle ph; - Tk_PhotoImageBlock pib; - int code,size; - -#if (TK_MAJOR_VERSION < 8) - if (NULL == (ph = Tk_FindPhoto(String_val(imgname)))) - tk_error("no such image"); -#else - if (NULL == (ph = Tk_FindPhoto(cltclinterp, String_val(imgname)))) - tk_error("no such image"); -#endif - - code = Tk_PhotoGetImage(ph,&pib); /* never fails ? */ - size = pib.width * pib.height * pib.pixelSize; - res = alloc_string(size); - - /* no holes, default format ? */ - if ((pib.pixelSize == 3) && - (pib.pitch == (pib.width * pib.pixelSize)) && - (pib.offset[0] == 0) && - (pib.offset[1] == 1) && - (pib.offset[2] == 2)) { - memcpy(pib.pixelPtr, String_val(res),size); - CAMLreturn(res); - } else { - int y; /* varies from 0 to height - 1 */ - int yoffs = 0; /* byte offset of line in src */ - int yidx = 0; /* byte offset of line in dst */ - for (y=0; y= 4 || TK_MAJOR_VERSION > 8) - , TK_PHOTO_COMPOSITE_SET -#endif - ); -} - -CAMLprim void camltk_setimgdata_bytecode(argv,argn) - value *argv; - int argn; -{ - camltk_setimgdata_native(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5]); -} diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c deleted file mode 100644 index cb18c870904f..000000000000 --- a/otherlibs/labltk/support/cltkMain.c +++ /dev/null @@ -1,181 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of OCaml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the OCaml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#ifdef HAS_UNISTD -#include /* 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 OCaml, - * the actual execution of the signal handler upon reception of the - * signal is delayed until we are sure we are out of the GC. - * If a signal occurs during the MainLoop, we would have to wait - * the next event for the handler to be invoked. - * The following function will invoke a pending signal handler if any, - * and we put in on a regular timer. - */ - -#define SIGNAL_INTERVAL 300 - -int signal_events = 0; /* do we have a pending timer */ - -void invoke_pending_caml_signals (ClientData clientdata) -{ - signal_events = 0; - enter_blocking_section(); /* triggers signal handling */ - /* Rearm timer */ - Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL); - signal_events = 1; - leave_blocking_section(); -} - -/* Now the real Tk stuff */ - -Tk_Window cltk_mainWindow; - - -/* In slave mode, the interpreter *already* exists */ -int cltk_slave_mode = 0; - -/* Initialisation, based on tkMain.c */ -CAMLprim value camltk_opentk(value argv) -{ - CAMLparam1(argv); - CAMLlocal1(tmp); - char *argv0; - - /* argv must contain argv[0], the application command name */ - tmp = Val_unit; - - if ( argv == Val_int(0) ){ - failwith("camltk_opentk: argv is empty"); - } - argv0 = String_val( Field( argv, 0 ) ); - - if (!cltk_slave_mode) { - /* Create an interpreter, dies if error */ -#if TCL_MAJOR_VERSION >= 8 - Tcl_FindExecutable(String_val(argv0)); -#endif - cltclinterp = Tcl_CreateInterp(); - { - /* Register cltclinterp for use in other related extensions */ - value *interp = caml_named_value("cltclinterp"); - if (interp != NULL) - Store_field(*interp,0,copy_nativeint((intnat)cltclinterp)); - } - - if (Tcl_Init(cltclinterp) != TCL_OK) - tk_error(Tcl_GetStringResult(cltclinterp)); - Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY); - - { /* Sets argv */ - int argc = 0; - - tmp = Field(argv, 1); /* starts from argv[1] */ - while ( tmp != Val_int(0) ) { - argc++; - tmp = Field(tmp, 1); - } - - if( argc != 0 ){ - int i; - char *args; - char **tkargv; - char argcstr[256]; /* string of argc */ - - tkargv = (char**)stat_alloc(sizeof( char* ) * argc ); - tmp = Field(argv, 1); /* starts from argv[1] */ - i = 0; - - while ( tmp != Val_int(0) ) { - tkargv[i] = String_val(Field(tmp, 0)); - tmp = Field(tmp, 1); - i++; - } - - sprintf( argcstr, "%d", argc ); - Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY); - args = Tcl_Merge(argc, (const char *const*)tkargv); /* args must be freed by Tcl_Free */ - Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY); - Tcl_Free(args); - stat_free( tkargv ); - } - } - if (Tk_Init(cltclinterp) != TCL_OK) - tk_error(Tcl_GetStringResult(cltclinterp)); - - /* Retrieve the main window */ - cltk_mainWindow = Tk_MainWindow(cltclinterp); - - if (NULL == cltk_mainWindow) - tk_error(Tcl_GetStringResult(cltclinterp)); - - 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(Tcl_GetStringResult(cltclinterp)); - }; - stat_free(f); - } - } - - CAMLreturn(Val_unit); -} - -CAMLprim value camltk_finalize(value unit) /* ML */ -{ - Tcl_Finalize(); - return Val_unit; -} diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c deleted file mode 100644 index a89ea341f195..000000000000 --- a/otherlibs/labltk/support/cltkMisc.c +++ /dev/null @@ -1,62 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of OCaml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the OCaml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include -#include -#include -#include "camltk.h" - -/* Parsing results */ -CAMLprim value camltk_splitlist (value v) -{ - int argc; - char **argv; - int result; - char *utf; - - CheckInit(); - - utf = caml_string_to_tcl(v); - /* argv is allocated by Tcl, to be freed by us */ - result = Tcl_SplitList(cltclinterp,utf,&argc,(const char ***)&argv); - switch(result) { - case TCL_OK: - { value res = copy_string_list(argc,argv); - Tcl_Free((char *)argv); /* only one large block was allocated */ - /* argv points into utf: utf must be freed after argv are freed */ - stat_free( utf ); - return res; - } - case TCL_ERROR: - default: - stat_free( utf ); - tk_error(Tcl_GetStringResult(cltclinterp)); - } -} - -/* Copy an OCaml string to the C heap. Should deallocate with stat_free */ -char *string_to_c(value s) -{ - int l = string_length(s); - char *res = stat_alloc(l + 1); - memmove (res, String_val (s), l); - res[l] = '\0'; - return res; -} diff --git a/otherlibs/labltk/support/cltkTimer.c b/otherlibs/labltk/support/cltkTimer.c deleted file mode 100644 index afebef8e1d82..000000000000 --- a/otherlibs/labltk/support/cltkTimer.c +++ /dev/null @@ -1,44 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of OCaml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the OCaml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include -#include -#include "camltk.h" - - -/* Basically the same thing as FileProc */ -void TimerProc (ClientData clientdata) -{ - callback2(*handler_code,Val_long(clientdata),Val_int(0)); -} - -CAMLprim value camltk_add_timer(value milli, value cbid) -{ - CheckInit(); - /* look at tkEvent.c , Tk_Token is an int */ - return (Val_int(Tcl_CreateTimerHandler(Int_val(milli), TimerProc, - (ClientData) (Long_val(cbid))))); -} - -CAMLprim value camltk_rem_timer(value token) -{ - Tcl_DeleteTimerHandler((Tcl_TimerToken) Long_val(token)); - return Val_unit; -} diff --git a/otherlibs/labltk/support/cltkUtf.c b/otherlibs/labltk/support/cltkUtf.c deleted file mode 100644 index 448e06a1cfe5..000000000000 --- a/otherlibs/labltk/support/cltkUtf.c +++ /dev/null @@ -1,89 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of OCaml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the OCaml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include - -#include -#include -#include -#include -#include -#ifdef HAS_UNISTD -#include -#endif -#include "camltk.h" - -#if (TCL_MAJOR_VERSION > 8 || \ - (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)) /* 8.1 */ -# define UTFCONVERSION -#endif - -#ifdef UTFCONVERSION - -char *external_to_utf( char *str ){ - char *res; - Tcl_DString dstr; - int length; - - Tcl_ExternalToUtfDString(NULL, str, strlen(str), &dstr); - length = Tcl_DStringLength(&dstr); - res = stat_alloc(length + 1); - memmove( res, Tcl_DStringValue(&dstr), length+1); - Tcl_DStringFree(&dstr); - - return res; -} - -char *utf_to_external( char *str ){ - char *res; - Tcl_DString dstr; - int length; - - Tcl_UtfToExternalDString(NULL, str, strlen(str), &dstr); - length = Tcl_DStringLength(&dstr); - res = stat_alloc(length + 1); - memmove( res, Tcl_DStringValue(&dstr), length+1); - Tcl_DStringFree(&dstr); - - return res; -} - -char *caml_string_to_tcl( value s ) -{ - return external_to_utf( String_val(s) ); -} - -value tcl_string_to_caml( char *s ) -{ - CAMLparam0(); - CAMLlocal1(res); - char *str; - - str = utf_to_external( s ); - res = copy_string(str); - stat_free(str); - CAMLreturn(res); -} - -#else - -char *caml_string_to_tcl(value s){ return string_to_c(s); } -value tcl_string_to_caml(char *s){ return copy_string(s); } - -#endif diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c deleted file mode 100644 index dcda8a77c15a..000000000000 --- a/otherlibs/labltk/support/cltkVar.c +++ /dev/null @@ -1,128 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of OCaml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the OCaml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Alternative to tkwait variable */ -#include -#include -#include -#include -#include -#include -#include -#include "camltk.h" - -CAMLprim value camltk_getvar(value var) -{ - char *s; - char *stable_var = NULL; - CheckInit(); - - stable_var = string_to_c(var); - s = (char *)Tcl_GetVar(cltclinterp,stable_var, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); - stat_free(stable_var); - - if (s == NULL) - tk_error(Tcl_GetStringResult(cltclinterp)); - else - return(tcl_string_to_caml(s)); -} - -CAMLprim value camltk_setvar(value var, value contents) -{ - char *s; - char *stable_var = NULL; - char *utf_contents; - CheckInit(); - - /* SetVar makes a copy of the contents. */ - /* In case we have write traces in OCaml, it's better to make sure that - var doesn't move... */ - stable_var = string_to_c(var); - utf_contents = caml_string_to_tcl(contents); - s = (char *)Tcl_SetVar(cltclinterp,stable_var, utf_contents, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); - stat_free(stable_var); - if( s == utf_contents ){ - tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!"); - } - stat_free(utf_contents); - - if (s == NULL) - tk_error(Tcl_GetStringResult(cltclinterp)); - else - return(Val_unit); -} - - -/* The appropriate type is -typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *part1, char *part2, int flags)); - */ -static char * tracevar(clientdata, interp, name1, name2, flags) - ClientData clientdata; - Tcl_Interp *interp; /* Interpreter containing variable. */ - char *name1; /* Name of variable. */ - char *name2; /* Second part of variable name. */ - int flags; /* Information about what happened. */ -{ - Tcl_UntraceVar2(interp, name1, name2, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - tracevar, clientdata); - callback2(*handler_code,Val_int(clientdata),Val_unit); - return (char *)NULL; -} - -/* Sets up a callback upon modification of a variable */ -CAMLprim value camltk_trace_var(value var, value cbid) -{ - char *cvar = NULL; - - CheckInit(); - /* Make a copy of var, since Tcl will modify it in place, and we - * don't trust that much what it will do here - */ - cvar = string_to_c(var); - if (Tcl_TraceVar(cltclinterp, cvar, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - tracevar, - (ClientData) (Long_val(cbid))) - != TCL_OK) { - stat_free(cvar); - tk_error(Tcl_GetStringResult(cltclinterp)); - }; - stat_free(cvar); - return Val_unit; -} - -CAMLprim value camltk_untrace_var(value var, value cbid) -{ - char *cvar = NULL; - - CheckInit(); - /* Make a copy of var, since Tcl will modify it in place, and we - * don't trust that much what it will do here - */ - cvar = string_to_c(var); - Tcl_UntraceVar(cltclinterp, cvar, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - tracevar, - (ClientData) (Long_val(cbid))); - stat_free(cvar); - return Val_unit; -} diff --git a/otherlibs/labltk/support/cltkWait.c b/otherlibs/labltk/support/cltkWait.c deleted file mode 100644 index a46860b85ce1..000000000000 --- a/otherlibs/labltk/support/cltkWait.c +++ /dev/null @@ -1,102 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of OCaml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the OCaml source tree. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include -#include -#include -#include "camltk.h" - -/* The following are replacements for - tkwait visibility - tkwait window - in the case where we use threads (tkwait internally calls an event loop, - and thus prevents thread scheduling from taking place). - - Instead, one should set up a callback, wait for a signal, and signal - from inside the callback -*/ - -static void WaitVisibilityProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -static void WaitWindowProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); - -/* For the other handlers, we need a bit more data */ -struct WinCBData { - int cbid; - Tk_Window win; -}; - -static void WaitVisibilityProc(clientData, eventPtr) - ClientData clientData; - XEvent *eventPtr; /* Information about event (not used). */ -{ - struct WinCBData *vis = clientData; - value cbid = Val_int(vis->cbid); - - Tk_DeleteEventHandler(vis->win, VisibilityChangeMask, - WaitVisibilityProc, clientData); - - stat_free((char *)vis); - callback2(*handler_code,cbid,Val_int(0)); -} - -/* Sets up a callback upon Visibility of a window */ -CAMLprim value camltk_wait_vis(value win, value cbid) -{ - struct WinCBData *vis = - (struct WinCBData *)stat_alloc(sizeof(struct WinCBData)); - vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); - if (vis -> win == NULL) { - stat_free((char *)vis); - tk_error(Tcl_GetStringResult(cltclinterp)); - }; - vis->cbid = Int_val(cbid); - Tk_CreateEventHandler(vis->win, VisibilityChangeMask, - WaitVisibilityProc, (ClientData) vis); - return Val_unit; -} - -static void WaitWindowProc(ClientData clientData, XEvent *eventPtr) -{ - if (eventPtr->type == DestroyNotify) { - struct WinCBData *vis = clientData; - value cbid = Val_int(vis->cbid); - stat_free((char *)clientData); - /* The handler is destroyed by Tk itself */ - callback2(*handler_code,cbid,Val_int(0)); - } -} - -/* Sets up a callback upon window destruction */ -CAMLprim value camltk_wait_des(value win, value cbid) -{ - struct WinCBData *vis = - (struct WinCBData *)stat_alloc(sizeof(struct WinCBData)); - vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); - if (vis -> win == NULL) { - stat_free((char *)vis); - tk_error(Tcl_GetStringResult(cltclinterp)); - }; - vis->cbid = Int_val(cbid); - Tk_CreateEventHandler(vis->win, StructureNotifyMask, - WaitWindowProc, (ClientData) vis); - return Val_unit; -} diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml deleted file mode 100644 index ae1cc261a339..000000000000 --- a/otherlibs/labltk/support/fileevent.ml +++ /dev/null @@ -1,80 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Unix -open Support -open Protocol - -external add_file_input : file_descr -> cbid -> unit - = "camltk_add_file_input" -external rem_file_input : file_descr -> cbid -> unit - = "camltk_rem_file_input" -external add_file_output : file_descr -> cbid -> unit - = "camltk_add_file_output" -external rem_file_output : file_descr -> cbid -> unit - = "camltk_rem_file_output" - -(* File input handlers *) - -let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *) - -let add_fileinput ~fd ~callback:f = - let id = new_function_id () in - Hashtbl.add callback_naming_table id (fun _ -> f()); - Hashtbl.add fd_table (fd, 'r') id; - if !Protocol.debug then begin - Protocol.prerr_cbid id; prerr_endline " for fileinput" - end; - add_file_input fd id - -let remove_fileinput ~fd = - try - let id = Hashtbl.find fd_table (fd, 'r') in - clear_callback id; - Hashtbl.remove fd_table (fd, 'r'); - if !Protocol.debug then begin - prerr_string "clear "; - Protocol.prerr_cbid id; - prerr_endline " for fileinput" - end; - rem_file_input fd id - with - Not_found -> () - -let add_fileoutput ~fd ~callback:f = - let id = new_function_id () in - Hashtbl.add callback_naming_table id (fun _ -> f()); - Hashtbl.add fd_table (fd, 'w') id; - if !Protocol.debug then begin - Protocol.prerr_cbid id; prerr_endline " for fileoutput" - end; - add_file_output fd id - -let remove_fileoutput ~fd = - try - let id = Hashtbl.find fd_table (fd, 'w') in - clear_callback id; - Hashtbl.remove fd_table (fd, 'w'); - if !Protocol.debug then begin - prerr_string "clear "; - Protocol.prerr_cbid id; - prerr_endline " for fileoutput" - end; - rem_file_output fd id - with - Not_found -> () diff --git a/otherlibs/labltk/support/fileevent.mli b/otherlibs/labltk/support/fileevent.mli deleted file mode 100644 index f5468ca599c5..000000000000 --- a/otherlibs/labltk/support/fileevent.mli +++ /dev/null @@ -1,25 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Unix - -val add_fileinput : fd:file_descr -> callback:(unit -> unit) -> unit -val remove_fileinput: fd:file_descr -> unit -val add_fileoutput : fd:file_descr -> callback:(unit -> unit) -> unit -val remove_fileoutput: fd:file_descr -> unit - (* see [tk] module *) diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml deleted file mode 100644 index e55f1e8bcbb7..000000000000 --- a/otherlibs/labltk/support/protocol.ml +++ /dev/null @@ -1,275 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Support -open Widget - -type callback_buffer = string list - (* Buffer for reading callback arguments *) - -type tkArgs = - TkToken of string - | TkTokenList of tkArgs list (* to be expanded *) - | TkQuote of tkArgs (* mapped to Tcl list *) - -type cbid = int - -external opentk_low : string list -> unit - = "camltk_opentk" -external tcl_eval : string -> string - = "camltk_tcl_eval" -external tk_mainloop : unit -> unit - = "camltk_tk_mainloop" -external tcl_direct_eval : tkArgs array -> string - = "camltk_tcl_direct_eval" -external splitlist : string -> string list - = "camltk_splitlist" -external tkreturn : string -> unit - = "camltk_return" -external callback_init : unit -> unit - = "camltk_init" -external finalizeTk : unit -> unit - = "camltk_finalize" - (* Finalize tcl/tk before exiting. This function will be automatically - called when you call [Pervasives.exit ()] (This is installed at - [install_cleanup ()] *) - -let tcl_command s = ignore (tcl_eval s);; - -exception TkError of string - (* Raised by the communication functions *) -let () = Callback.register_exception "tkerror" (TkError "") - -let cltclinterp = ref Nativeint.zero - (* For use in other extensions *) -let () = Callback.register "cltclinterp" cltclinterp - -(* Debugging support *) -let debug = - ref (try ignore (Sys.getenv "CAMLTKDEBUG"); true - with Not_found -> false) - -(* This is approximative, since we don't quote what needs to be quoted *) -let dump_args args = - let rec print_arg = function - TkToken s -> prerr_string s; prerr_string " " - | TkTokenList l -> List.iter print_arg l - | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} " - in - Array.iter print_arg args; - prerr_newline() - -(* - * Evaluating Tcl code - * debugging support should not affect performances... - *) - -let tkEval args = - if !debug then dump_args args; - let res = tcl_direct_eval args in - if !debug then begin - prerr_string "->>"; - prerr_endline res - end; - res - -let tkCommand args = ignore (tkEval args) - -(* - * Callbacks - *) - -(* LablTk only *) -let cCAMLtoTKwidget w = - (* Widget.check_class w table; (* with subtyping, it is redundant *) *) - TkToken (Widget.name w) - -let cTKtoCAMLwidget = function - "" -> raise (Invalid_argument "cTKtoCAMLwidget") - | s -> Widget.get_atom s - -let callback_naming_table = - (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t) - -let callback_memo_table = - (Hashtbl.create 401 : (any widget, int) Hashtbl.t) - -let new_function_id = - let counter = ref 0 in - function () -> incr counter; !counter - -let string_of_cbid = string_of_int - -(* Add a new callback, associated to widget w *) -(* The callback should be cleared when w is destroyed *) -let register_callback w ~callback:f = - let id = new_function_id () in - Hashtbl.add callback_naming_table id f; - if (forget_type w) <> (forget_type Widget.dummy) then - Hashtbl.add callback_memo_table (forget_type w) id; - (string_of_cbid id) - -let clear_callback id = - Hashtbl.remove callback_naming_table id - -(* Clear callbacks associated to a given widget *) -let remove_callbacks w = - let w = forget_type w in - let cb_ids = Hashtbl.find_all callback_memo_table w in - List.iter clear_callback cb_ids; - for i = 1 to List.length cb_ids do - Hashtbl.remove callback_memo_table w - done - -(* Hand-coded callback for destroyed widgets - * This may be extended by the application, or by other layers of Camltk. - * Could use bind + of Tk, but I'd rather give an alternate mechanism so - * that hooks can be set up at load time (i.e. before openTk) - *) -let destroy_hooks = ref [] -let add_destroy_hook f = - destroy_hooks := f :: !destroy_hooks - -let _ = - add_destroy_hook (fun w -> remove_callbacks w; Widget.remove w) - -let install_cleanup () = - let call_destroy_hooks = function - [wname] -> - let w = cTKtoCAMLwidget wname in - List.iter (fun f -> f w) !destroy_hooks - | _ -> raise (TkError "bad cleanup callback") in - let fid = new_function_id () in - Hashtbl.add callback_naming_table fid call_destroy_hooks; - (* setup general destroy callback *) - tcl_command ("bind all {camlcb " ^ (string_of_cbid fid) ^" %W}"); - at_exit finalizeTk - -let prerr_cbid id = - prerr_string "camlcb "; prerr_int id - -(* The callback dispatch function *) -let dispatch_callback id args = - if !debug then begin - prerr_cbid id; - List.iter (fun x -> prerr_string " "; prerr_string x) args; - prerr_newline() - end; - (Hashtbl.find callback_naming_table id) args; - if !debug then prerr_endline "<<-" - -let protected_dispatch id args = - try - dispatch_callback id args - with - | e -> - try - Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e); - flush stderr; - (* raise x *) - with - Out_of_memory -> raise Out_of_memory - | Sys.Break -> raise Sys.Break - -let _ = Callback.register "camlcb" protected_dispatch - -(* Make sure the C variables are initialised *) -let _ = callback_init () - -(* Different version of initialisation functions *) -let default_display_name = ref "" -let default_display () = !default_display_name - -let camltk_argv = ref [] - -(* options for Arg.parse *) -let keywords = [ - "-display", Arg.String (fun s -> - camltk_argv := "-display" :: s :: !camltk_argv), - " : X server to contact (CamlTk)"; - "-colormap", Arg.String (fun s -> - camltk_argv := "-colormap" :: s :: !camltk_argv), - " : colormap to use (CamlTk)"; - "-geometry", Arg.String (fun s -> - camltk_argv := "-geometry" :: s :: !camltk_argv), - " : size and position (CamlTk)"; - "-name", Arg.String (fun s -> - camltk_argv := "-name" :: s :: !camltk_argv), - " : application class (CamlTk)"; - "-sync", Arg.Unit (fun () -> - camltk_argv := "-sync" :: !camltk_argv), - ": sync mode (CamlTk)"; - "-use", Arg.String (fun s -> - camltk_argv := "-use" :: s :: !camltk_argv), - " : parent window id (CamlTk)"; - "-window", Arg.String (fun s -> - camltk_argv := "-use" :: s :: !camltk_argv), - " : parent window id (CamlTk)"; - "-visual", Arg.String (fun s -> - camltk_argv := "-visual" :: s :: !camltk_argv), - " : visual to use (CamlTk)" ] - -let opentk_with_args argv (* = [argv1;..;argvn] *) = - (* argv must be command line for wish *) - let argv0 = Sys.argv.(0) in - let rec find_display = function - | "-display" :: s :: xs -> s - | "-colormap" :: s :: xs -> find_display xs - | "-geometry" :: s :: xs -> find_display xs - | "-name" :: s :: xs -> find_display xs - | "-sync" :: xs -> find_display xs - | "-use" :: s :: xs -> find_display xs - | "-window" :: s :: xs -> find_display xs - | "-visual" :: s :: xs -> find_display xs - | "--" :: _ -> "" - | _ :: xs -> find_display xs - | [] -> "" - in - default_display_name := find_display argv; - opentk_low (argv0 :: argv); - install_cleanup(); - Widget.default_toplevel - -let opentk () = opentk_with_args !camltk_argv;; - -let openTkClass s = opentk_with_args ["-name"; s] -let openTkDisplayClass disp cl = opentk_with_args ["-display"; disp; "-name"; cl] - -(*JPF CAMLTK/LABLTK? *) -let openTk ?(display = "") ?(clas = "LablTk") () = - let dispopt = - match display with - | "" -> [] - | _ -> ["-display"; display] - in - opentk_with_args (dispopt @ ["-name"; clas]) - -(* Destroy all widgets, thus cleaning up table and exiting the loop *) -let closeTk () = - tcl_command "destroy ." - -let mainLoop = - tk_mainloop - - -(* [register tclname f] makes [f] available from Tcl with - name [tclname] *) -let register tclname ~callback = - let s = register_callback Widget.default_toplevel ~callback in - tcl_command (Printf.sprintf "proc %s {args} {eval {camlcb %s} $args}" - tclname s) diff --git a/otherlibs/labltk/support/protocol.mli b/otherlibs/labltk/support/protocol.mli deleted file mode 100644 index f7c12ffdc010..000000000000 --- a/otherlibs/labltk/support/protocol.mli +++ /dev/null @@ -1,115 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Widget - -(* Lower level interface *) -exception TkError of string - (* Raised by the communication functions *) - -val debug : bool ref - (* When set to true, displays approximation of intermediate Tcl code *) - -type tkArgs = - TkToken of string - | TkTokenList of tkArgs list (* to be expanded *) - | TkQuote of tkArgs (* mapped to Tcl list *) - - -(* Misc *) -external splitlist : string -> string list - = "camltk_splitlist" - -val add_destroy_hook : (any widget -> unit) -> unit - - -(* Opening, closing, and mainloop *) -val default_display : unit -> string - -val opentk : unit -> toplevel widget - (* The basic initialization function. *) - -val keywords : (string * Arg.spec * string) list - (* Command line parsing specification for Arg.parse, which contains - the standard Tcl/Tk command line options such as "-display" and "-name". - Add [keywords] to a [Arg.parse] call, then call [opentk]. - Then [opentk] can make use of these command line options - to initiate applications. *) - -val opentk_with_args : string list -> toplevel widget - (* [opentk_with_args] is a lower level interface to initiate Tcl/Tk - applications. [opentk_with_args argv] initializes Tcl/Tk with - the command line options given by [argv] *) - -val openTk : ?display:string -> ?clas:string -> unit -> toplevel widget - (* [openTk ~display:display ~clas:clas ()] is equivalent to - [opentk_with_args ["-display"; display; "-name"; clas]] *) - -(* Legacy opentk functions *) -val openTkClass: string -> toplevel widget - (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *) -val openTkDisplayClass: string -> string -> toplevel widget - (* [openTkDisplayClass disp class] is equivalent to - [opentk ["-display"; disp; "-name"; class]] *) - -val closeTk : unit -> unit -val finalizeTk : unit -> unit - (* Finalize tcl/tk before exiting. This function will be automatically - called when you call [Pervasives.exit ()] *) - -val mainLoop : unit -> unit - - -(* Direct evaluation of tcl code *) -val tkEval : tkArgs array -> string - -val tkCommand : tkArgs array -> unit - -(* Returning a value from a Tcl callback *) -val tkreturn: string -> unit - - -(* Callbacks: this is private *) - -type cbid - -type callback_buffer = string list - (* Buffer for reading callback arguments *) - -val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t -val callback_memo_table : (any widget, cbid) Hashtbl.t - (* Exported for debug purposes only. Don't use them unless you - know what you are doing *) -val new_function_id : unit -> cbid -val string_of_cbid : cbid -> string -val register_callback : 'a widget -> callback:(callback_buffer -> unit) -> string - (* Callback support *) -val clear_callback : cbid -> unit - (* Remove a given callback from the table *) -val remove_callbacks : 'a widget -> unit - (* Clean up callbacks associated to widget. Must be used only when - the Destroy event is bind by the user and masks the default - Destroy event binding *) - -val cTKtoCAMLwidget : string -> any widget -val cCAMLtoTKwidget : 'a widget -> tkArgs - -val register : string -> callback:(callback_buffer -> unit) -> unit - -(*-*) -val prerr_cbid : cbid -> unit diff --git a/otherlibs/labltk/support/rawwidget.ml b/otherlibs/labltk/support/rawwidget.ml deleted file mode 100644 index f216df726a5a..000000000000 --- a/otherlibs/labltk/support/rawwidget.ml +++ /dev/null @@ -1,176 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Support - -(* - * Widgets - *) - -exception IllegalWidgetType of string - (* Raised when widget command applied illegally*) - -(***************************************************) -(* Widgets *) -(* This 'a raw_widget will be 'a Widget.widget *) -(***************************************************) -type 'a raw_widget = - Untyped of string -| Typed of string * string - -type raw_any (* will be Widget.any *) -and button -and canvas -and checkbutton -and entry -and frame -and label -and listbox -and menu -and menubutton -and message -and radiobutton -and scale -and scrollbar -and text -and toplevel - -let forget_type w = (Obj.magic (w : 'a raw_widget) : raw_any raw_widget) -let coe = forget_type - -(* table of widgets *) -let table = (Hashtbl.create 401 : (string, raw_any raw_widget) Hashtbl.t) - -let name = function - Untyped s -> s - | Typed (s,_) -> s - -(* Normally all widgets are known *) -(* this is a provision for send commands to external tk processes *) -let known_class = function - Untyped _ -> "unknown" - | Typed (_,c) -> c - -(* This one is always created by opentk *) -let default_toplevel = - let wname = "." in - let w = Typed (wname, "toplevel") in - Hashtbl.add table wname w; - w - -(* Dummy widget to which global callbacks are associated *) -(* also passed around by camltotkoption when no widget in context *) -let dummy = - Untyped "dummy" - -let remove w = - Hashtbl.remove table (name w) - -(* Retype widgets returned from Tk *) -(* JPF report: sometime s is "", see Protocol.cTKtoCAMLwidget *) -let get_atom s = - try - Hashtbl.find table s - with - Not_found -> Untyped s - -let naming_scheme = [ - "button", "b"; - "canvas", "ca"; - "checkbutton", "cb"; - "entry", "en"; - "frame", "f"; - "label", "l"; - "listbox", "li"; - "menu", "me"; - "menubutton", "mb"; - "message", "ms"; - "radiobutton", "rb"; - "scale", "sc"; - "scrollbar", "sb"; - "text", "t"; - "toplevel", "top" ] - - -let widget_any_table = List.map fst naming_scheme -(* subtypes *) -let widget_button_table = [ "button" ] -and widget_canvas_table = [ "canvas" ] -and widget_checkbutton_table = [ "checkbutton" ] -and widget_entry_table = [ "entry" ] -and widget_frame_table = [ "frame" ] -and widget_label_table = [ "label" ] -and widget_listbox_table = [ "listbox" ] -and widget_menu_table = [ "menu" ] -and widget_menubutton_table = [ "menubutton" ] -and widget_message_table = [ "message" ] -and widget_radiobutton_table = [ "radiobutton" ] -and widget_scale_table = [ "scale" ] -and widget_scrollbar_table = [ "scrollbar" ] -and widget_text_table = [ "text" ] -and widget_toplevel_table = [ "toplevel" ] - -let new_suffix clas n = - try - (List.assoc clas naming_scheme) ^ (string_of_int n) - with - Not_found -> "w" ^ (string_of_int n) - -(* The function called by generic creation *) -let counter = ref 0 -let new_atom ~parent ?name:nom clas = - let parentpath = name parent in - let path = - match nom with - None -> - incr counter; - if parentpath = "." - then "." ^ (new_suffix clas !counter) - else parentpath ^ "." ^ (new_suffix clas !counter) - | Some name -> - if parentpath = "." - then "." ^ name - else parentpath ^ "." ^ name - in - let w = Typed(path,clas) in - Hashtbl.add table path w; - w - -(* Just create a path. Only to check existence of widgets *) -(* Use with care *) -let atom ~parent ~name:pathcomp = - let parentpath = name parent in - let path = - if parentpath = "." - then "." ^ pathcomp - else parentpath ^ "." ^ pathcomp in - Untyped path - -(* LablTk: Redundant with subtyping of Widget, backward compatibility *) -let check_class w clas = - match w with - Untyped _ -> () (* assume run-time check by tk*) - | Typed(_,c) -> - if List.mem c clas then () - else raise (IllegalWidgetType c) - - -(* Checking membership of constructor in subtype table *) -let chk_sub errname table c = - if List.mem c table then () - else raise (Invalid_argument errname) diff --git a/otherlibs/labltk/support/rawwidget.mli b/otherlibs/labltk/support/rawwidget.mli deleted file mode 100644 index e9f82ef2cc1c..000000000000 --- a/otherlibs/labltk/support/rawwidget.mli +++ /dev/null @@ -1,109 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Support for widget manipulations *) - -type 'a raw_widget - (* widget is an abstract type *) - -type raw_any -and button -and canvas -and checkbutton -and entry -and frame -and label -and listbox -and menu -and menubutton -and message -and radiobutton -and scale -and scrollbar -and text -and toplevel - -val forget_type : 'a raw_widget -> raw_any raw_widget -val coe : 'a raw_widget -> raw_any raw_widget - -val default_toplevel : toplevel raw_widget - (* [default_toplevel] is "." in Tk, the toplevel widget that is - always existing during a Tk session. Destroying [default_toplevel] - ends the main loop - *) - -val atom : parent: 'a raw_widget -> name: string -> raw_any raw_widget - (* [atom parent name] returns the widget [parent.name]. The widget is - not created. Only its name is returned. In a given parent, there may - only exist one children for a given name. - This function should only be used to check the existence of a widget - with a known name. It doesn't add the widget to the internal tables - of CamlTk. - *) - -val name : 'a raw_widget -> string - (* [name w] returns the name (tk "path") of a widget *) - -(*--*) -(* The following functions are used internally. - There is normally no need for them in users programs - *) - -val known_class : 'a raw_widget -> string - (* [known_class w] returns the class of a widget (e.g. toplevel, frame), - as known by the CamlTk interface. - Not equivalent to "winfo w" in Tk. - *) - -val dummy : raw_any raw_widget - (* [dummy] is a widget used as context when we don't have any. - It is *not* a real widget. - *) - -val new_atom : parent:'a raw_widget -> ?name: string -> string -> 'b raw_widget - -val get_atom : string -> raw_any raw_widget - (* [get_atom path] returns the widget with Tk path [path] *) - -val remove : 'a raw_widget -> unit - (* [remove w] removes widget from the internal tables *) - -(* Subtypes tables *) -val widget_any_table : string list -val widget_button_table : string list -val widget_canvas_table : string list -val widget_checkbutton_table : string list -val widget_entry_table : string list -val widget_frame_table : string list -val widget_label_table : string list -val widget_listbox_table : string list -val widget_menu_table : string list -val widget_menubutton_table : string list -val widget_message_table : string list -val widget_radiobutton_table : string list -val widget_scale_table : string list -val widget_scrollbar_table : string list -val widget_text_table : string list -val widget_toplevel_table : string list - -val chk_sub : string -> 'a list -> 'a -> unit -val check_class : 'a raw_widget -> string list -> unit - (* Widget subtyping *) - -exception IllegalWidgetType of string - (* Raised when widget command applied illegally*) diff --git a/otherlibs/labltk/support/slave.ml b/otherlibs/labltk/support/slave.ml deleted file mode 100644 index 44349c05cfa4..000000000000 --- a/otherlibs/labltk/support/slave.ml +++ /dev/null @@ -1,51 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* The code run on initialisation, in addition to normal Tk code - * NOTE: camltk has not fully been initialised yet - *) -external tcl_eval : string -> string - = "camltk_tcl_eval" -let tcl_command s = ignore (tcl_eval s);; -open Printf - -let dynload args = - List.iter Dynlink.loadfile args - -(* Default modules include everything from -let default_modules = [] -*) - -(* [caml::run foo.cmo .. bar.cmo] is now available from Tcl *) -let init () = - Dynlink.init(); - (* Make it unsafe by default, with everything available *) - Dynlink.allow_unsafe_modules true; - Dynlink.add_interfaces [] []; - let s = register_callback Widget.dummy dynload in - tcl_command (sprintf "proc caml::run {l} {camlcb %s l}" s) - -let _ = - Printexc.print init () - -(* A typical master program would then - * caml::run foo.cmo - * # during initialisation, "foo" was registered as a tcl procedure - * foo x y z - * # proceed with some Tcl code calling foo - *) diff --git a/otherlibs/labltk/support/support.ml b/otherlibs/labltk/support/support.ml deleted file mode 100644 index 7d019967c02f..000000000000 --- a/otherlibs/labltk/support/support.ml +++ /dev/null @@ -1,48 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Parsing results of Tcl *) -(* List.split a string according to char_sep predicate *) -let split_str ~pred:char_sep str = - let len = String.length str in - let rec skip_sep cur = - if cur >= len then cur - else if char_sep str.[cur] then skip_sep (succ cur) - else cur in - let rec split beg cur = - if cur >= len then - if beg = cur then [] - else [String.sub str beg (len - beg)] - else if char_sep str.[cur] - then - let nextw = skip_sep cur in - (String.sub str beg (cur - beg)) - ::(split nextw nextw) - else split beg (succ cur) in - let wstart = skip_sep 0 in - split wstart wstart - -(* Very easy hack for option type *) -let may f = function - Some x -> Some (f x) -| None -> None - -let maycons f x l = - match x with - Some x -> f x :: l - | None -> l diff --git a/otherlibs/labltk/support/support.mli b/otherlibs/labltk/support/support.mli deleted file mode 100644 index fe30208ac20b..000000000000 --- a/otherlibs/labltk/support/support.mli +++ /dev/null @@ -1,21 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -val split_str : pred:(char -> bool) -> string -> string list -val may : ('a -> 'b) -> 'a option -> 'b option -val maycons : ('a -> 'b) -> 'a option -> 'b list -> 'b list diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml deleted file mode 100644 index 4e17a008adc6..000000000000 --- a/otherlibs/labltk/support/textvariable.ml +++ /dev/null @@ -1,151 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Support -open Protocol - -external internal_tracevar : string -> cbid -> unit - = "camltk_trace_var" -external internal_untracevar : string -> cbid -> unit - = "camltk_untrace_var" -external set : string -> string -> unit = "camltk_setvar" -external get : string -> string = "camltk_getvar" - - -type textVariable = string - -(* List of handles *) -let handles = Hashtbl.create 401 - -let add_handle var cbid = - try - let r = Hashtbl.find handles var in - r := cbid :: !r - with - Not_found -> - Hashtbl.add handles var (ref [cbid]) - -let exceptq x = - let rec ex acc = function - [] -> acc - | y::l when y == x -> ex acc l - | y::l -> ex (y::acc) l - in - ex [] - -let rem_handle var cbid = - try - let r = Hashtbl.find handles var in - match exceptq cbid !r with - [] -> Hashtbl.remove handles var - | remaining -> r := remaining - with - Not_found -> () - -(* Used when we "free" the variable (otherwise, old handlers would apply to - * new usage of the variable) - *) -let rem_all_handles var = - try - let r = Hashtbl.find handles var in - List.iter (internal_untracevar var) !r; - Hashtbl.remove handles var - with - Not_found -> () - - -(* Variable trace *) -let handle vname ~callback:f = - let id = new_function_id() in - let wrapped _ = - clear_callback id; - rem_handle vname id; - f() in - Hashtbl.add callback_naming_table id wrapped; - add_handle vname id; - if !Protocol.debug then begin - prerr_cbid id; prerr_string " for variable "; prerr_endline vname - end; - internal_tracevar vname id - -(* Avoid space leak (all variables are global in Tcl) *) -module StringSet = - Set.Make(struct type t = string let compare = compare end) -let freelist = ref (StringSet.empty) -let memo = Hashtbl.create 101 - -(* Added a variable v referenced by widget w *) -let add w v = - let w = Widget.forget_type w in - let r = - try Hashtbl.find memo w - with - Not_found -> - let r = ref StringSet.empty in - Hashtbl.add memo w r; - r in - r := StringSet.add v !r - -(* to be used with care ! *) -let free v = - rem_all_handles v; - freelist := StringSet.add v !freelist - -(* Free variables associated with a widget *) -let freew w = - try - let r = Hashtbl.find memo w in - StringSet.iter free !r; - Hashtbl.remove memo w - with - Not_found -> () - -let _ = add_destroy_hook freew - -(* Allocate a new variable *) -let counter = ref 0 -let getv () = - let v = - if StringSet.is_empty !freelist then begin - incr counter; - "camlv("^ string_of_int !counter ^")" - end - else - let v = StringSet.choose !freelist in - freelist := StringSet.remove v !freelist; - v in - set v ""; - v - -let create ?on: w () = - let v = getv() in - begin - match w with - Some w -> add w v - | None -> () - end; - v - -(* to be used with care ! *) -let free v = - freelist := StringSet.add v !freelist - -let cCAMLtoTKtextVariable s = TkToken s - -let name s = s -let coerce s = s diff --git a/otherlibs/labltk/support/textvariable.mli b/otherlibs/labltk/support/textvariable.mli deleted file mode 100644 index f18f6cc86c95..000000000000 --- a/otherlibs/labltk/support/textvariable.mli +++ /dev/null @@ -1,45 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Support for Tk -textvariable option *) -open Widget -open Protocol - -type textVariable - (* TextVariable is an abstract type *) - -val create : ?on: 'a widget -> unit -> textVariable - (* Allocation of a textVariable with lifetime associated to widget - if a widget is specified *) -val set : textVariable -> string -> unit - (* Setting the val of a textVariable *) -val get : textVariable -> string - (* Reading the val of a textVariable *) -val name : textVariable -> string - (* Its tcl name *) - -val cCAMLtoTKtextVariable : textVariable -> tkArgs - (* Internal conversion function *) - -val handle : textVariable -> callback:(unit -> unit) -> unit - (* Callbacks on variable modifications *) - -val coerce : string -> textVariable - -(*-*) -val free : textVariable -> unit diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml deleted file mode 100644 index d5bd176aa791..000000000000 --- a/otherlibs/labltk/support/timer.ml +++ /dev/null @@ -1,57 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Timers *) -open Support -open Protocol - -type tkTimer = int - -external internal_add_timer : int -> cbid -> tkTimer - = "camltk_add_timer" -external internal_rem_timer : tkTimer -> unit - = "camltk_rem_timer" - -type t = tkTimer * cbid (* the token and the cb id *) - -(* A timer is used only once, so we must clean the callback table *) -let add ~ms ~callback = - if !Protocol.debug then begin - prerr_string "Timer.add "; flush stderr; - end; - let id = new_function_id () in - if !Protocol.debug then begin - prerr_string "id="; prerr_cbid id; flush stderr; - end; - let wrapped _ = - clear_callback id; (* do it first in case f raises exception *) - callback() in - Hashtbl.add callback_naming_table id wrapped; - let t = internal_add_timer ms id in - if !Protocol.debug then begin - prerr_endline " done" - end; - t,id - -let set ~ms ~callback = ignore (add ~ms ~callback);; - -(* If the timer has never been used, there is a small space leak in - the C heap, where a copy of id has been stored *) -let remove (tkTimer, id) = - internal_rem_timer tkTimer; - clear_callback id diff --git a/otherlibs/labltk/support/timer.mli b/otherlibs/labltk/support/timer.mli deleted file mode 100644 index 4b31668c9cd5..000000000000 --- a/otherlibs/labltk/support/timer.mli +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type t - -val add : ms:int -> callback:(unit -> unit) -> t -val set : ms:int -> callback:(unit -> unit) -> unit -val remove : t -> unit diff --git a/otherlibs/labltk/support/tkthread.ml b/otherlibs/labltk/support/tkthread.ml deleted file mode 100644 index 5d0c24240bc6..000000000000 --- a/otherlibs/labltk/support/tkthread.ml +++ /dev/null @@ -1,67 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Jacques Garrigue, Nagoya University Mathematics Dept. *) -(* *) -(* Copyright 2004 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -let jobs : (unit -> unit) Queue.t = Queue.create () -let m = Mutex.create () -let with_jobs f = - Mutex.lock m; let y = f jobs in Mutex.unlock m; y - -let loop_id = ref None -let reset () = loop_id := None -let cannot_sync () = - match !loop_id with None -> true - | Some id -> Thread.id (Thread.self ()) = id - -let gui_safe () = - not (Sys.os_type = "Win32") || !loop_id = Some(Thread.id (Thread.self ())) - -let has_jobs () = not (with_jobs Queue.is_empty) -let n_jobs () = with_jobs Queue.length -let do_next_job () = with_jobs Queue.take () -let async j x = with_jobs (Queue.add (fun () -> j x)) -let sync f x = - if cannot_sync () then f x else - let m = Mutex.create () in - let res = ref None in - Mutex.lock m; - let c = Condition.create () in - let j x = - let y = f x in Mutex.lock m; res := Some y; Mutex.unlock m; - Condition.signal c - in - async j x; - Condition.wait c m; - match !res with Some y -> y | None -> assert false - -let rec job_timer () = - Timer.set ~ms:10 ~callback: - (fun () -> for i = 1 to n_jobs () do do_next_job () done; job_timer()) - -let thread_main () = - try - ignore (Protocol.openTk()); - job_timer(); - loop_id := Some (Thread.id (Thread.self ())); - Protocol.mainLoop(); - loop_id := None; - with exn -> - loop_id := None; - raise exn - -let start () = - Thread.create thread_main () - -let top = Widget.default_toplevel diff --git a/otherlibs/labltk/support/tkthread.mli b/otherlibs/labltk/support/tkthread.mli deleted file mode 100644 index 446e10b39a72..000000000000 --- a/otherlibs/labltk/support/tkthread.mli +++ /dev/null @@ -1,41 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Jacques Garrigue, Nagoya University Mathematics Dept. *) -(* *) -(* Copyright 2004 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Basic functions *) - -(** Start the main loop in a new GUI thread. Do not use recursively. *) -val start : unit -> Thread.t -(** The actual function executed in the new thread *) -val thread_main : unit -> unit -(** The toplevel widget (an alias of [Widget.default_toplevel]) *) -val top : Widget.toplevel Widget.widget - -(* Jobs are needed for Windows, as you cannot do GUI work from - another thread. - Even under Unix some calls need to come from the main thread. - The basic idea is to either use async (if you don't need a result) - or sync whenever you call a Tk related function from another thread - (for instance with the threaded toplevel). - With sync, beware of deadlocks! -*) - -(** Add an asynchronous job (to do in the main thread) *) -val async : ('a -> unit) -> 'a -> unit -(** Add a synchronous job (to do in the main thread) *) -val sync : ('a -> 'b) -> 'a -> 'b -(** Whether it is safe to call most Tk functions directly from - the current thread *) -val gui_safe : unit -> bool diff --git a/otherlibs/labltk/support/tkwait.ml b/otherlibs/labltk/support/tkwait.ml deleted file mode 100644 index 34f6908deb94..000000000000 --- a/otherlibs/labltk/support/tkwait.ml +++ /dev/null @@ -1,25 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -external internal_tracevis : string -> Protocol.cbid -> unit - = "camltk_wait_vis" -;; - -external internal_tracedestroy : string -> Protocol.cbid -> unit - = "camltk_wait_des" -;; diff --git a/otherlibs/labltk/support/widget.ml b/otherlibs/labltk/support/widget.ml deleted file mode 100644 index 083e4b96c338..000000000000 --- a/otherlibs/labltk/support/widget.ml +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Hack to permit having the different data type with the same name - [widget] for CamlTk and LablTk. *) -include Rawwidget -type 'a widget = 'a raw_widget -type any = raw_any diff --git a/otherlibs/labltk/support/widget.mli b/otherlibs/labltk/support/widget.mli deleted file mode 100644 index 7761f2f2c821..000000000000 --- a/otherlibs/labltk/support/widget.mli +++ /dev/null @@ -1,109 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of OCaml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the OCaml source tree. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Support for widget manipulations *) - -type 'a widget = 'a Rawwidget.raw_widget - (* widget is an abstract type *) - -type any = Rawwidget.raw_any -and button -and canvas -and checkbutton -and entry -and frame -and label -and listbox -and menu -and menubutton -and message -and radiobutton -and scale -and scrollbar -and text -and toplevel - -val forget_type : 'a widget -> any widget -val coe : 'a widget -> any widget - -val default_toplevel : toplevel widget - (* [default_toplevel] is "." in Tk, the toplevel widget that is - always existing during a Tk session. Destroying [default_toplevel] - ends the main loop - *) - -val atom : parent: 'a widget -> name: string -> any widget - (* [atom parent name] returns the widget [parent.name]. The widget is - not created. Only its name is returned. In a given parent, there may - only exist one children for a given name. - This function should only be used to check the existence of a widget - with a known name. It doesn't add the widget to the internal tables - of CamlTk. - *) - -val name : 'a widget -> string - (* [name w] returns the name (tk "path") of a widget *) - -(*--*) -(* The following functions are used internally. - There is normally no need for them in users programs - *) - -val known_class : 'a widget -> string - (* [known_class w] returns the class of a widget (e.g. toplevel, frame), - as known by the CamlTk interface. - Not equivalent to "winfo w" in Tk. - *) - -val dummy : any widget - (* [dummy] is a widget used as context when we don't have any. - It is *not* a real widget. - *) - -val new_atom : parent:'a widget -> ?name: string -> string -> 'b widget - -val get_atom : string -> any widget - (* [get_atom path] returns the widget with Tk path [path] *) - -val remove : 'a widget -> unit - (* [remove w] removes widget from the internal tables *) - -(* Subtypes tables *) -val widget_any_table : string list -val widget_button_table : string list -val widget_canvas_table : string list -val widget_checkbutton_table : string list -val widget_entry_table : string list -val widget_frame_table : string list -val widget_label_table : string list -val widget_listbox_table : string list -val widget_menu_table : string list -val widget_menubutton_table : string list -val widget_message_table : string list -val widget_radiobutton_table : string list -val widget_scale_table : string list -val widget_scrollbar_table : string list -val widget_text_table : string list -val widget_toplevel_table : string list - -val chk_sub : string -> 'a list -> 'a -> unit -val check_class : 'a widget -> string list -> unit - (* Widget subtyping *) - -exception IllegalWidgetType of string - (* Raised when widget command applied illegally*) diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend deleted file mode 100644 index 4ad5f0d117bf..000000000000 --- a/otherlibs/str/.depend +++ /dev/null @@ -1,10 +0,0 @@ -strstubs.o: strstubs.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h -str.cmi: -str.cmo: str.cmi -str.cmx: str.cmi ->>>>>>> .fusion-droit.r10497 diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile deleted file mode 100644 index 5367804afc13..000000000000 --- a/otherlibs/str/Makefile +++ /dev/null @@ -1,87 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the str library - -include ../../config/Makefile - -<<<<<<< .courant -# Compilation options -CC=$(BYTECC) -CFLAGS=-O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -CAMLC=../../ocamlcomp.sh -CAMLOPT=../../ocamlcompopt.sh -COMPFLAGS=-warn-error A -nojoin -g -COBJS=strstubs.o -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -======= -LIBNAME=str -COBJS=strstubs.$(O) -CLIBNAME=camlstr -CAMLOBJS=str.cmo ->>>>>>> .fusion-droit.r10497 - -all: libstr.a str.cmi str.cma - -allopt: libstr.a str.cmi str.cmxa - -<<<<<<< .courant -libstr.a: $(COBJS) - $(MKLIB) -o str $(COBJS) -======= -str.cmo: str.cmi -str.cmx: str.cmi ->>>>>>> .fusion-droit.r10497 - -str.cma: str.cmo - $(MKLIB) -ocamlc '$(CAMLC)' -o str str.cmo - -str.cmxa: str.cmx - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o str str.cmx - -str.cmx: ../../ocamlopt - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.a *.so *.o - -install: - if test -f dllstr.so; then cp dllstr.so $(STUBLIBDIR)/dllstr.so; fi - cp libstr.a $(LIBDIR)/libstr.a - cd $(LIBDIR); $(RANLIB) libstr.a - cp str.cma str.cmi str.mli $(LIBDIR) - -installopt: - cp str.cmx str.cmxa str.a $(LIBDIR) - cd $(LIBDIR); $(RANLIB) str.a - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: - gcc -MM $(CFLAGS) *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend - -include .depend diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt deleted file mode 100644 index 775f70752412..000000000000 --- a/otherlibs/str/Makefile.nt +++ /dev/null @@ -1,91 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -# Makefile for the str library - -<<<<<<< .courant -include ../../config/Makefile -======= -LIBNAME=str -COBJS=strstubs.$(O) -CLIBNAME=camlstr -CAMLOBJS=str.cmo ->>>>>>> .fusion-droit.r10497 - -# Compilation options -CC=$(BYTECC) -CFLAGS=-I../../byterun -CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../boot -CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -COMPFLAGS=-warn-error A -g -DCOBJS=strstubs.$(DO) -SCOBJS=strstubs.$(SO) - -all: dllstr.dll libstr.$(A) str.cmi str.cma - -allopt: libstr.$(A) str.cmi str.cmxa - -dllstr.dll: $(DCOBJS) - $(call MKDLL,dllstr.dll,tmp.$(A),$(DCOBJS) ../../byterun/ocamlrun.$(A)) - rm tmp.* - -libstr.$(A): $(SCOBJS) - $(call MKLIB,libstr.$(A),$(SCOBJS)) - -str.cma: str.cmo - $(CAMLC) -a -o str.cma str.cmo -dllib -lstr -cclib -lstr - -str.cmxa: str.cmx - $(CAMLOPT) -a -o str.cmxa str.cmx -cclib -lstr - -str.cmx: ../../ocamlopt - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.$(A) *.dll *.$(O) *.$(SO) - -install: - cp dllstr.dll $(STUBLIBDIR)/dllstr.dll - cp libstr.$(A) $(LIBDIR)/libstr.$(A) - cp str.cma str.cmi $(LIBDIR) - -installopt: - cp str.cmx str.cmxa str.$(A) $(LIBDIR) - -.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO) - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(SO) - -depend: - -str.cmo: str.cmi -str.cmx: str.cmi diff --git a/otherlibs/str/libstr.clib b/otherlibs/str/libstr.clib deleted file mode 100644 index 319e76017c80..000000000000 --- a/otherlibs/str/libstr.clib +++ /dev/null @@ -1 +0,0 @@ -strstubs.o diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml deleted file mode 100644 index 940254d21ec1..000000000000 --- a/otherlibs/str/str.ml +++ /dev/null @@ -1,754 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** String utilities *) - -let string_before s n = String.sub s 0 n - -let string_after s n = String.sub s n (String.length s - n) - -let first_chars s n = String.sub s 0 n - -let last_chars s n = String.sub s (String.length s - n) n - -(** Representation of character sets **) - -module Charset = - struct - type t = string (* of length 32 *) - - (*let empty = String.make 32 '\000'*) - let full = String.make 32 '\255' - - let make_empty () = String.make 32 '\000' - - let add s c = - let i = Char.code c in - s.[i lsr 3] <- Char.chr(Char.code s.[i lsr 3] lor (1 lsl (i land 7))) - - let add_range s c1 c2 = - for i = Char.code c1 to Char.code c2 do add s (Char.chr i) done - - let singleton c = - let s = make_empty () in add s c; s - - (*let range c1 c2 = - let s = make_empty () in add_range s c1 c2; s - *) - let complement s = - let r = String.create 32 in - for i = 0 to 31 do - r.[i] <- Char.chr(Char.code s.[i] lxor 0xFF) - done; - r - - let union s1 s2 = - let r = String.create 32 in - for i = 0 to 31 do - r.[i] <- Char.chr(Char.code s1.[i] lor Char.code s2.[i]) - done; - r - - let disjoint s1 s2 = - try - for i = 0 to 31 do - if Char.code s1.[i] land Char.code s2.[i] <> 0 then raise Exit - done; - true - with Exit -> - false - - let iter fn s = - for i = 0 to 31 do - let c = Char.code s.[i] in - if c <> 0 then - for j = 0 to 7 do - if c land (1 lsl j) <> 0 then fn (Char.chr ((i lsl 3) + j)) - done - done - - let expand s = - let r = String.make 256 '\000' in - iter (fun c -> r.[Char.code c] <- '\001') s; - r - - let fold_case s = - let r = make_empty() in - iter (fun c -> add r (Char.lowercase c); add r (Char.uppercase c)) s; - r - - end - -(** Abstract syntax tree for regular expressions *) - -type re_syntax = - Char of char - | String of string - | CharClass of Charset.t - | Seq of re_syntax list - | Alt of re_syntax * re_syntax - | Star of re_syntax - | Plus of re_syntax - | Option of re_syntax - | Group of int * re_syntax - | Refgroup of int - | Bol - | Eol - | Wordboundary - -(** Representation of compiled regular expressions *) - -type regexp = { - prog: int array; (* bytecode instructions *) - cpool: string array; (* constant pool (string literals) *) - normtable: string; (* case folding table (if any) *) - numgroups: int; (* number of \(...\) groups *) - numregisters: int; (* number of nullable Star or Plus *) - startchars: int (* index of set of starting chars, or -1 if none *) -} - -(** Opcodes for bytecode instructions; see strstubs.c for description *) - -let op_CHAR = 0 -let op_CHARNORM = 1 -let op_STRING = 2 -let op_STRINGNORM = 3 -let op_CHARCLASS = 4 -let op_BOL = 5 -let op_EOL = 6 -let op_WORDBOUNDARY = 7 -let op_BEGGROUP = 8 -let op_ENDGROUP = 9 -let op_REFGROUP = 10 -let op_ACCEPT = 11 -let op_SIMPLEOPT = 12 -let op_SIMPLESTAR = 13 -let op_SIMPLEPLUS = 14 -let op_GOTO = 15 -let op_PUSHBACK = 16 -let op_SETMARK = 17 -let op_CHECKPROGRESS = 18 - -(* Encoding of bytecode instructions *) - -let instr opc arg = opc lor (arg lsl 8) - -(* Computing relative displacements for GOTO and PUSHBACK instructions *) - -let displ dest from = dest - from - 1 - -(** Compilation of a regular expression *) - -(* Determine if a regexp can match the empty string *) - -let rec is_nullable = function - Char c -> false - | String s -> s = "" - | CharClass cl -> false - | Seq rl -> List.for_all is_nullable rl - | Alt (r1, r2) -> is_nullable r1 || is_nullable r2 - | Star r -> true - | Plus r -> is_nullable r - | Option r -> true - | Group(n, r) -> is_nullable r - | Refgroup n -> true - | Bol -> true - | Eol -> true - | Wordboundary -> true - -(* first r returns a set of characters C such that: - for all string s, s matches r => the first character of s is in C. - For convenience, return Charset.full if r is nullable. *) - -let rec first = function - Char c -> Charset.singleton c - | String s -> if s = "" then Charset.full else Charset.singleton s.[0] - | CharClass cl -> cl - | Seq rl -> first_seq rl - | Alt (r1, r2) -> Charset.union (first r1) (first r2) - | Star r -> Charset.full - | Plus r -> first r - | Option r -> Charset.full - | Group(n, r) -> first r - | Refgroup n -> Charset.full - | Bol -> Charset.full - | Eol -> Charset.full - | Wordboundary -> Charset.full - -and first_seq = function - [] -> Charset.full - | (Bol | Eol | Wordboundary) :: rl -> first_seq rl - | Star r :: rl -> Charset.union (first r) (first_seq rl) - | Option r :: rl -> Charset.union (first r) (first_seq rl) - | r :: rl -> first r - -(* Transform a Char or CharClass regexp into a character class *) - -let charclass_of_regexp fold_case re = - let cl = - match re with - Char c -> Charset.singleton c - | CharClass cl -> cl - | _ -> assert false in - if fold_case then Charset.fold_case cl else cl - -(* The case fold table: maps characters to their lowercase equivalent *) - -let fold_case_table = - let t = String.create 256 in - for i = 0 to 255 do t.[i] <- Char.lowercase(Char.chr i) done; - t - -module StringMap = Map.Make(struct type t = string let compare = compare end) - -(* Compilation of a regular expression *) - -let compile fold_case re = - - (* Instruction buffering *) - let prog = ref (Array.make 32 0) - and progpos = ref 0 - and cpool = ref StringMap.empty - and cpoolpos = ref 0 - and numgroups = ref 1 - and numregs = ref 0 in - (* Add a new instruction *) - let emit_instr opc arg = - if !progpos >= Array.length !prog then begin - let newlen = ref (Array.length !prog) in - while !progpos >= !newlen do newlen := !newlen * 2 done; - let nprog = Array.make !newlen 0 in - Array.blit !prog 0 nprog 0 (Array.length !prog); - prog := nprog - end; - (!prog).(!progpos) <- (instr opc arg); - incr progpos in - (* Reserve an instruction slot and return its position *) - let emit_hole () = - let p = !progpos in incr progpos; p in - (* Fill a reserved instruction slot with a GOTO or PUSHBACK instruction *) - let patch_instr pos opc dest = - (!prog).(pos) <- (instr opc (displ dest pos)) in - (* Return the cpool index for the given string, adding it if not - already there *) - let cpool_index s = - try - StringMap.find s !cpool - with Not_found -> - let p = !cpoolpos in - cpool := StringMap.add s p !cpool; - incr cpoolpos; - p in - (* Allocate fresh register if regexp is nullable *) - let allocate_register_if_nullable r = - if is_nullable r then begin - let n = !numregs in - if n >= 64 then failwith "too many r* or r+ where r is nullable"; - incr numregs; - n - end else - -1 in - (* Main recursive compilation function *) - let rec emit_code = function - Char c -> - if fold_case then - emit_instr op_CHARNORM (Char.code (Char.lowercase c)) - else - emit_instr op_CHAR (Char.code c) - | String s -> - begin match String.length s with - 0 -> () - | 1 -> - if fold_case then - emit_instr op_CHARNORM (Char.code (Char.lowercase s.[0])) - else - emit_instr op_CHAR (Char.code s.[0]) - | _ -> - try - (* null characters are not accepted by the STRING* instructions; - if one is found, split string at null character *) - let i = String.index s '\000' in - emit_code (String (string_before s i)); - emit_instr op_CHAR 0; - emit_code (String (string_after s (i+1))) - with Not_found -> - if fold_case then - emit_instr op_STRINGNORM (cpool_index (String.lowercase s)) - else - emit_instr op_STRING (cpool_index s) - end - | CharClass cl -> - let cl' = if fold_case then Charset.fold_case cl else cl in - emit_instr op_CHARCLASS (cpool_index cl') - | Seq rl -> - emit_seq_code rl - | Alt(r1, r2) -> - (* PUSHBACK lbl1 - - GOTO lbl2 - lbl1: - lbl2: ... *) - let pos_pushback = emit_hole() in - emit_code r1; - let pos_goto_end = emit_hole() in - let lbl1 = !progpos in - emit_code r2; - let lbl2 = !progpos in - patch_instr pos_pushback op_PUSHBACK lbl1; - patch_instr pos_goto_end op_GOTO lbl2 - | Star r -> - (* Implement longest match semantics for compatibility with old Str *) - (* General translation: - lbl1: PUSHBACK lbl2 - SETMARK regno - - CHECKPROGRESS regno - GOTO lbl1 - lbl2: - If r cannot match the empty string, code can be simplified: - lbl1: PUSHBACK lbl2 - - GOTO lbl1 - lbl2: - *) - let regno = allocate_register_if_nullable r in - let lbl1 = emit_hole() in - if regno >= 0 then emit_instr op_SETMARK regno; - emit_code r; - if regno >= 0 then emit_instr op_CHECKPROGRESS regno; - emit_instr op_GOTO (displ lbl1 !progpos); - let lbl2 = !progpos in - patch_instr lbl1 op_PUSHBACK lbl2 - | Plus r -> - (* Implement longest match semantics for compatibility with old Str *) - (* General translation: - lbl1: - CHECKPROGRESS regno - PUSHBACK lbl2 - SETMARK regno - GOTO lbl1 - lbl2: - If r cannot match the empty string, code can be simplified: - lbl1: - PUSHBACK lbl2 - GOTO_PLUS lbl1 - lbl2: - *) - let regno = allocate_register_if_nullable r in - let lbl1 = !progpos in - emit_code r; - if regno >= 0 then emit_instr op_CHECKPROGRESS regno; - let pos_pushback = emit_hole() in - if regno >= 0 then emit_instr op_SETMARK regno; - emit_instr op_GOTO (displ lbl1 !progpos); - let lbl2 = !progpos in - patch_instr pos_pushback op_PUSHBACK lbl2 - | Option r -> - (* Implement longest match semantics for compatibility with old Str *) - (* PUSHBACK lbl - - lbl: - *) - let pos_pushback = emit_hole() in - emit_code r; - let lbl = !progpos in - patch_instr pos_pushback op_PUSHBACK lbl - | Group(n, r) -> - if n >= 32 then failwith "too many \\(...\\) groups"; - emit_instr op_BEGGROUP n; - emit_code r; - emit_instr op_ENDGROUP n; - numgroups := max !numgroups (n+1) - | Refgroup n -> - emit_instr op_REFGROUP n - | Bol -> - emit_instr op_BOL 0 - | Eol -> - emit_instr op_EOL 0 - | Wordboundary -> - emit_instr op_WORDBOUNDARY 0 - - and emit_seq_code = function - [] -> () - | Star(Char _ | CharClass _ as r) :: rl - when disjoint_modulo_case (first r) (first_seq rl) -> - emit_instr op_SIMPLESTAR (cpool_index (charclass_of_regexp fold_case r)); - emit_seq_code rl - | Plus(Char _ | CharClass _ as r) :: rl - when disjoint_modulo_case (first r) (first_seq rl) -> - emit_instr op_SIMPLEPLUS (cpool_index (charclass_of_regexp fold_case r)); - emit_seq_code rl - | Option(Char _ | CharClass _ as r) :: rl - when disjoint_modulo_case (first r) (first_seq rl) -> - emit_instr op_SIMPLEOPT (cpool_index (charclass_of_regexp fold_case r)); - emit_seq_code rl - | r :: rl -> - emit_code r; - emit_seq_code rl - - and disjoint_modulo_case c1 c2 = - if fold_case - then Charset.disjoint (Charset.fold_case c1) (Charset.fold_case c2) - else Charset.disjoint c1 c2 - in - - emit_code re; - emit_instr op_ACCEPT 0; - let start = first re in - let start' = if fold_case then Charset.fold_case start else start in - let start_pos = - if start = Charset.full - then -1 - else cpool_index (Charset.expand start') in - let constantpool = Array.make !cpoolpos "" in - StringMap.iter (fun str idx -> constantpool.(idx) <- str) !cpool; - { prog = Array.sub !prog 0 !progpos; - cpool = constantpool; - normtable = if fold_case then fold_case_table else ""; - numgroups = !numgroups; - numregisters = !numregs; - startchars = start_pos } - -(** Parsing of a regular expression *) - -(* Efficient buffering of sequences *) - -module SeqBuffer = struct - - type t = { sb_chars: Buffer.t; mutable sb_next: re_syntax list } - - let create() = { sb_chars = Buffer.create 16; sb_next = [] } - - let flush buf = - let s = Buffer.contents buf.sb_chars in - Buffer.clear buf.sb_chars; - match String.length s with - 0 -> () - | 1 -> buf.sb_next <- Char s.[0] :: buf.sb_next - | _ -> buf.sb_next <- String s :: buf.sb_next - - let add buf re = - match re with - Char c -> Buffer.add_char buf.sb_chars c - | _ -> flush buf; buf.sb_next <- re :: buf.sb_next - - let extract buf = - flush buf; Seq(List.rev buf.sb_next) - -end - -(* The character class corresponding to `.' *) - -let dotclass = Charset.complement (Charset.singleton '\n') - -(* Parse a regular expression *) - -let parse s = - let len = String.length s in - let group_counter = ref 1 in - - let rec regexp0 i = - let (r, j) = regexp1 i in - regexp0cont r j - and regexp0cont r1 i = - if i + 2 <= len && s.[i] = '\\' && s.[i+1] = '|' then - let (r2, j) = regexp1 (i+2) in - regexp0cont (Alt(r1, r2)) j - else - (r1, i) - and regexp1 i = - regexp1cont (SeqBuffer.create()) i - and regexp1cont sb i = - if i >= len - || i + 2 <= len && s.[i] = '\\' && (let c = s.[i+1] in c = '|' || c = ')') - then - (SeqBuffer.extract sb, i) - else - let (r, j) = regexp2 i in - SeqBuffer.add sb r; - regexp1cont sb j - and regexp2 i = - let (r, j) = regexp3 i in - regexp2cont r j - and regexp2cont r i = - if i >= len then (r, i) else - match s.[i] with - '?' -> regexp2cont (Option r) (i+1) - | '*' -> regexp2cont (Star r) (i+1) - | '+' -> regexp2cont (Plus r) (i+1) - | _ -> (r, i) - and regexp3 i = - match s.[i] with - '\\' -> regexpbackslash (i+1) - | '[' -> let (c, j) = regexpclass0 (i+1) in (CharClass c, j) - | '^' -> (Bol, i+1) - | '$' -> (Eol, i+1) - | '.' -> (CharClass dotclass, i+1) - | c -> (Char c, i+1) - and regexpbackslash i = - if i >= len then (Char '\\', i) else - match s.[i] with - '|' | ')' -> - assert false - | '(' -> - let group_no = !group_counter in - if group_no < 32 then incr group_counter; - let (r, j) = regexp0 (i+1) in - if j + 1 < len && s.[j] = '\\' && s.[j+1] = ')' then - if group_no < 32 - then (Group(group_no, r), j + 2) - else (r, j + 2) - else - failwith "\\( group not closed by \\)" - | '1' .. '9' as c -> - (Refgroup(Char.code c - 48), i + 1) - | 'b' -> - (Wordboundary, i + 1) - | c -> - (Char c, i + 1) - and regexpclass0 i = - if i < len && s.[i] = '^' - then let (c, j) = regexpclass1 (i+1) in (Charset.complement c, j) - else regexpclass1 i - and regexpclass1 i = - let c = Charset.make_empty() in - let j = regexpclass2 c i i in - (c, j) - and regexpclass2 c start i = - if i >= len then failwith "[ class not closed by ]"; - if s.[i] = ']' && i > start then i+1 else begin - let c1 = s.[i] in - if i+2 < len && s.[i+1] = '-' && s.[i+2] <> ']' then begin - let c2 = s.[i+2] in - Charset.add_range c c1 c2; - regexpclass2 c start (i+3) - end else begin - Charset.add c c1; - regexpclass2 c start (i+1) - end - end in - - let (r, j) = regexp0 0 in - if j = len then r else failwith "spurious \\) in regular expression" - -(** Parsing and compilation *) - -let regexp e = compile false (parse e) - -let regexp_case_fold e = compile true (parse e) - -let quote s = - let len = String.length s in - let buf = String.create (2 * len) in - let pos = ref 0 in - for i = 0 to len - 1 do - match s.[i] with - '[' | ']' | '*' | '.' | '\\' | '?' | '+' | '^' | '$' as c -> - buf.[!pos] <- '\\'; buf.[!pos + 1] <- c; pos := !pos + 2 - | c -> - buf.[!pos] <- c; pos := !pos + 1 - done; - String.sub buf 0 !pos - -let regexp_string s = compile false (String s) - -let regexp_string_case_fold s = compile true (String s) - -(** Matching functions **) - -external re_string_match: regexp -> string -> int -> int array - = "re_string_match" -external re_partial_match: regexp -> string -> int -> int array - = "re_partial_match" -external re_search_forward: regexp -> string -> int -> int array - = "re_search_forward" -external re_search_backward: regexp -> string -> int -> int array - = "re_search_backward" - -let last_search_result = ref [||] - -let string_match re s pos = - let res = re_string_match re s pos in - last_search_result := res; - Array.length res > 0 - -let string_partial_match re s pos = - let res = re_partial_match re s pos in - last_search_result := res; - Array.length res > 0 - -let search_forward re s pos = - let res = re_search_forward re s pos in - last_search_result := res; - if Array.length res = 0 then raise Not_found else res.(0) - -let search_backward re s pos = - let res = re_search_backward re s pos in - last_search_result := res; - if Array.length res = 0 then raise Not_found else res.(0) - -let group_beginning n = - let n2 = n + n in - if n < 0 || n2 >= Array.length !last_search_result then - invalid_arg "Str.group_beginning" - else - let pos = !last_search_result.(n2) in - if pos = -1 then raise Not_found else pos - -let group_end n = - let n2 = n + n in - if n < 0 || n2 >= Array.length !last_search_result then - invalid_arg "Str.group_end" - else - let pos = !last_search_result.(n2 + 1) in - if pos = -1 then raise Not_found else pos - -let matched_group n txt = - let n2 = n + n in - if n < 0 || n2 >= Array.length !last_search_result then - invalid_arg "Str.matched_group" - else - let b = !last_search_result.(n2) - and e = !last_search_result.(n2 + 1) in - if b = -1 then raise Not_found else String.sub txt b (e - b) - -let match_beginning () = group_beginning 0 -and match_end () = group_end 0 -and matched_string txt = matched_group 0 txt - -(** Replacement **) - -external re_replacement_text: string -> int array -> string -> string - = "re_replacement_text" - -let replace_matched repl matched = - re_replacement_text repl !last_search_result matched - -let substitute_first expr repl_fun text = - try - let pos = search_forward expr text 0 in - String.concat "" [string_before text pos; - repl_fun text; - string_after text (match_end())] - with Not_found -> - text - -let global_substitute expr repl_fun text = -<<<<<<< .courant - let rec replace start last_was_empty = - try - let startpos = if last_was_empty then start + 1 else start in - if startpos > String.length text then raise Not_found; - let pos = search_forward expr text startpos in - let end_pos = match_end() in - let repl_text = repl_fun text in - String.sub text start (pos-start) :: - repl_text :: - replace end_pos (end_pos = pos) - with Not_found -> - [string_after text start] in - String.concat "" (replace 0 false) -======= - let rec replace accu start last_was_empty = - let startpos = if last_was_empty then start + 1 else start in - if startpos > String.length text then - string_after text start :: accu - else - match opt_search_forward expr text startpos with - | None -> - string_after text start :: accu - | Some pos -> - let end_pos = match_end() in - let repl_text = repl_fun text in - replace (repl_text :: String.sub text start (pos-start) :: accu) - end_pos (end_pos = pos) - in - String.concat "" (List.rev (replace [] 0 false)) ->>>>>>> .fusion-droit.r10497 - -let global_replace expr repl text = - global_substitute expr (replace_matched repl) text -and replace_first expr repl text = - substitute_first expr (replace_matched repl) text - -(** Splitting *) - -<<<<<<< .courant -let search_forward_progress expr text start = - let pos = search_forward expr text start in - if match_end() = start && start < String.length text - then search_forward expr text (start + 1) - else pos -======= -let opt_search_forward_progress expr text start = - match opt_search_forward expr text start with - | None -> None - | Some pos -> - if match_end() > start then - Some pos - else if start < String.length text then - opt_search_forward expr text (start + 1) - else None ->>>>>>> .fusion-droit.r10497 - -let bounded_split expr text num = - let start = - if string_match expr text 0 then match_end() else 0 in - let rec split start n = - if start >= String.length text then [] else - if n = 1 then [string_after text start] else - try - let pos = search_forward_progress expr text start in - String.sub text start (pos-start) :: split (match_end()) (n-1) - with Not_found -> - [string_after text start] in - split start num - -let split expr text = bounded_split expr text 0 - -let bounded_split_delim expr text num = - let rec split start n = - if start > String.length text then [] else - if n = 1 then [string_after text start] else - try - let pos = search_forward_progress expr text start in - String.sub text start (pos-start) :: split (match_end()) (n-1) - with Not_found -> - [string_after text start] in - if text = "" then [] else split 0 num - -let split_delim expr text = bounded_split_delim expr text 0 - -type split_result = Text of string | Delim of string - -let bounded_full_split expr text num = - let rec split start n = - if start >= String.length text then [] else - if n = 1 then [Text(string_after text start)] else - try - let pos = search_forward_progress expr text start in - let s = matched_string text in - if pos > start then - Text(String.sub text start (pos-start)) :: - Delim(s) :: - split (match_end()) (n-1) - else - Delim(s) :: - split (match_end()) (n-1) - with Not_found -> - [Text(string_after text start)] in - split 0 num - -let full_split expr text = bounded_full_split expr text 0 diff --git a/otherlibs/str/str.mli b/otherlibs/str/str.mli deleted file mode 100644 index a4d65b6aed40..000000000000 --- a/otherlibs/str/str.mli +++ /dev/null @@ -1,248 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file ../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Regular expressions and high-level string processing *) - - -(** {6 Regular expressions} *) - - -type regexp -(** The type of compiled regular expressions. *) - - -val regexp : string -> regexp -(** Compile a regular expression. The following constructs are - recognized: - - [. ] Matches any character except newline. - - [* ] (postfix) Matches the preceding expression zero, one or - several times - - [+ ] (postfix) Matches the preceding expression one or - several times - - [? ] (postfix) Matches the preceding expression once or - not at all - - [[..] ] Character set. Ranges are denoted with [-], as in [[a-z]]. - An initial [^], as in [[^0-9]], complements the set. - To include a [\]] character in a set, make it the first - character of the set. To include a [-] character in a set, - make it the first or the last character of the set. - - [^ ] Matches at beginning of line (either at the beginning of - the matched string, or just after a newline character). - - [$ ] Matches at end of line (either at the end of the matched - string, or just before a newline character). - - [\| ] (infix) Alternative between two expressions. - - [\(..\)] Grouping and naming of the enclosed expression. - - [\1 ] The text matched by the first [\(...\)] expression - ([\2] for the second expression, and so on up to [\9]). - - [\b ] Matches word boundaries. - - [\ ] Quotes special characters. The special characters - are [$^.*+?[]]. -*) - -val regexp_case_fold : string -> regexp -(** Same as [regexp], but the compiled expression will match text - in a case-insensitive way: uppercase and lowercase letters will - be considered equivalent. *) - -val quote : string -> string -(** [Str.quote s] returns a regexp string that matches exactly - [s] and nothing else. *) - -val regexp_string : string -> regexp -(** [Str.regexp_string s] returns a regular expression - that matches exactly [s] and nothing else.*) - -val regexp_string_case_fold : string -> regexp -(** [Str.regexp_string_case_fold] is similar to {!Str.regexp_string}, - but the regexp matches in a case-insensitive way. *) - - -(** {6 String matching and searching} *) - - -val string_match : regexp -> string -> int -> bool -(** [string_match r s start] tests whether a substring of [s] that - starts at position [start] matches the regular expression [r]. - The first character of a string has position [0], as usual. *) - -val search_forward : regexp -> string -> int -> int -(** [search_forward r s start] searches the string [s] for a substring - matching the regular expression [r]. The search starts at position - [start] and proceeds towards the end of the string. - Return the position of the first character of the matched - substring, or raise [Not_found] if no substring matches. *) - -val search_backward : regexp -> string -> int -> int -(** [search_backward r s last] searches the string [s] for a - substring matching the regular expression [r]. The search first - considers substrings that start at position [last] and proceeds - towards the beginning of string. Return the position of the first - character of the matched substring; raise [Not_found] if no - substring matches. *) - -val string_partial_match : regexp -> string -> int -> bool -(** Similar to {!Str.string_match}, but also returns true if - the argument string is a prefix of a string that matches. - This includes the case of a true complete match. *) - -val matched_string : string -> string -(** [matched_string s] returns the substring of [s] that was matched - by the latest {!Str.string_match}, {!Str.search_forward} or - {!Str.search_backward}. - The user must make sure that the parameter [s] is the same string - that was passed to the matching or searching function. *) - -val match_beginning : unit -> int -(** [match_beginning()] returns the position of the first character - of the substring that was matched by {!Str.string_match}, - {!Str.search_forward} or {!Str.search_backward}. *) - -val match_end : unit -> int -(** [match_end()] returns the position of the character following the - last character of the substring that was matched by [string_match], - [search_forward] or [search_backward]. *) - -val matched_group : int -> string -> string -(** [matched_group n s] returns the substring of [s] that was matched - by the [n]th group [\(...\)] of the regular expression during - the latest {!Str.string_match}, {!Str.search_forward} or - {!Str.search_backward}. - The user must make sure that the parameter [s] is the same string - that was passed to the matching or searching function. - [matched_group n s] raises [Not_found] if the [n]th group - of the regular expression was not matched. This can happen - with groups inside alternatives [\|], options [?] - or repetitions [*]. For instance, the empty string will match - [\(a\)*], but [matched_group 1 ""] will raise [Not_found] - because the first group itself was not matched. *) - -val group_beginning : int -> int -(** [group_beginning n] returns the position of the first character - of the substring that was matched by the [n]th group of - the regular expression. - @raise Not_found if the [n]th group of the regular expression - was not matched. - @raise Invalid_argument if there are fewer than [n] groups in - the regular expression. *) - -val group_end : int -> int -(** [group_end n] returns - the position of the character following the last character of - substring that was matched by the [n]th group of the regular expression. - @raise Not_found if the [n]th group of the regular expression - was not matched. - @raise Invalid_argument if there are fewer than [n] groups in - the regular expression. *) - - -(** {6 Replacement} *) - - -val global_replace : regexp -> string -> string -> string -(** [global_replace regexp templ s] returns a string identical to [s], - except that all substrings of [s] that match [regexp] have been - replaced by [templ]. The replacement template [templ] can contain - [\1], [\2], etc; these sequences will be replaced by the text - matched by the corresponding group in the regular expression. - [\0] stands for the text matched by the whole regular expression. *) - -val replace_first : regexp -> string -> string -> string -(** Same as {!Str.global_replace}, except that only the first substring - matching the regular expression is replaced. *) - -val global_substitute : regexp -> (string -> string) -> string -> string -(** [global_substitute regexp subst s] returns a string identical - to [s], except that all substrings of [s] that match [regexp] - have been replaced by the result of function [subst]. The - function [subst] is called once for each matching substring, - and receives [s] (the whole text) as argument. *) - -val substitute_first : regexp -> (string -> string) -> string -> string -(** Same as {!Str.global_substitute}, except that only the first substring - matching the regular expression is replaced. *) - -val replace_matched : string -> string -> string -(** [replace_matched repl s] returns the replacement text [repl] - in which [\1], [\2], etc. have been replaced by the text - matched by the corresponding groups in the most recent matching - operation. [s] must be the same string that was matched during - this matching operation. *) - - -(** {6 Splitting} *) - - -val split : regexp -> string -> string list -(** [split r s] splits [s] into substrings, taking as delimiters - the substrings that match [r], and returns the list of substrings. - For instance, [split (regexp "[ \t]+") s] splits [s] into - blank-separated words. An occurrence of the delimiter at the - beginning and at the end of the string is ignored. *) - -val bounded_split : regexp -> string -> int -> string list -(** Same as {!Str.split}, but splits into at most [n] substrings, - where [n] is the extra integer parameter. *) - -val split_delim : regexp -> string -> string list -(** Same as {!Str.split} but occurrences of the - delimiter at the beginning and at the end of the string are - recognized and returned as empty strings in the result. - For instance, [split_delim (regexp " ") " abc "] - returns [[""; "abc"; ""]], while [split] with the same - arguments returns [["abc"]]. *) - -val bounded_split_delim : regexp -> string -> int -> string list -(** Same as {!Str.bounded_split}, but occurrences of the - delimiter at the beginning and at the end of the string are - recognized and returned as empty strings in the result. *) - -type split_result = - Text of string - | Delim of string - -val full_split : regexp -> string -> split_result list -(** Same as {!Str.split_delim}, but returns - the delimiters as well as the substrings contained between - delimiters. The former are tagged [Delim] in the result list; - the latter are tagged [Text]. For instance, - [full_split (regexp "[{}]") "{ab}"] returns - [[Delim "{"; Text "ab"; Delim "}"]]. *) - -val bounded_full_split : regexp -> string -> int -> split_result list -(** Same as {!Str.bounded_split_delim}, but returns - the delimiters as well as the substrings contained between - delimiters. The former are tagged [Delim] in the result list; - the latter are tagged [Text]. *) - - -(** {6 Extracting substrings} *) - - -val string_before : string -> int -> string -(** [string_before s n] returns the substring of all characters of [s] - that precede position [n] (excluding the character at - position [n]). *) - -val string_after : string -> int -> string -(** [string_after s n] returns the substring of all characters of [s] - that follow position [n] (including the character at - position [n]). *) - -val first_chars : string -> int -> string -(** [first_chars s n] returns the first [n] characters of [s]. - This is the same function as {!Str.string_before}. *) - -val last_chars : string -> int -> string -(** [last_chars s n] returns the last [n] characters of [s]. *) diff --git a/otherlibs/str/strstubs.c b/otherlibs/str/strstubs.c deleted file mode 100644 index fb7c8fe70f27..000000000000 --- a/otherlibs/str/strstubs.c +++ /dev/null @@ -1,532 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include -#include -#include -#include - -/* The backtracking NFA interpreter */ - -union backtrack_point { - struct { - value * pc; /* with low bit set */ - unsigned char * txt; - } pos; - struct { - unsigned char ** loc; /* with low bit clear */ - unsigned char * val; - } undo; -}; - -#define Set_tag(p) ((value *) ((long)(p) | 1)) -#define Clear_tag(p) ((value *) ((long)(p) & ~1)) -#define Tag_is_set(p) ((long)(p) & 1) - -#define BACKTRACK_STACK_BLOCK_SIZE 500 - -struct backtrack_stack { - struct backtrack_stack * previous; - union backtrack_point point[BACKTRACK_STACK_BLOCK_SIZE]; -}; - -#define Opcode(x) ((x) & 0xFF) -#define Arg(x) ((unsigned long)(x) >> 8) -#define SignedArg(x) ((long)(x) >> 8) - -enum { - CHAR, /* match a single character */ - CHARNORM, /* match a single character, after normalization */ - STRING, /* match a character string */ - STRINGNORM, /* match a character string, after normalization */ - CHARCLASS, /* match a character class */ - BOL, /* match at beginning of line */ - EOL, /* match at end of line */ - WORDBOUNDARY, /* match on a word boundary */ - BEGGROUP, /* record the beginning of a group */ - ENDGROUP, /* record the end of a group */ - REFGROUP, /* match a previously matched group */ - ACCEPT, /* report success */ - SIMPLEOPT, /* match a character class 0 or 1 times */ - SIMPLESTAR, /* match a character class 0, 1 or several times */ - SIMPLEPLUS, /* match a character class 1 or several times */ - GOTO, /* unconditional branch */ - PUSHBACK, /* record a backtrack point -- - where to jump in case of failure */ - SETMARK, /* remember current position in given register # */ - CHECKPROGRESS /* backtrack if no progress was made w.r.t. reg # */ -}; - -/* Accessors in a compiled regexp */ -#define Prog(re) Field(re, 0) -#define Cpool(re) Field(re, 1) -#define Normtable(re) Field(re, 2) -#define Numgroups(re) Int_val(Field(re, 3)) -#define Numregisters(re) Int_val(Field(re, 4)) -#define Startchars(re) Int_val(Field(re, 5)) - -/* Record positions of matched groups */ -#define NUM_GROUPS 32 -struct re_group { - unsigned char * start; - unsigned char * end; -}; -static struct re_group re_group[NUM_GROUPS]; - -/* Record positions reached during matching; used to check progress - in repeated matching of a regexp. */ -#define NUM_REGISTERS 64 -static unsigned char * re_register[NUM_REGISTERS]; - -/* The initial backtracking stack */ -static struct backtrack_stack initial_stack = { NULL, }; - -/* Free a chained list of backtracking stacks */ -static void free_backtrack_stack(struct backtrack_stack * stack) -{ - struct backtrack_stack * prevstack; - while ((prevstack = stack->previous) != NULL) { - stat_free(stack); - stack = prevstack; - } -} - -/* Membership in a bit vector representing a set of booleans */ -#define In_bitset(s,i,tmp) (tmp = (i), ((s)[tmp >> 3] >> (tmp & 7)) & 1) - -/* Determine if a character is a word constituent */ -/* PR#4874: word constituent = letter, digit, underscore. */ - -static unsigned char re_word_letters[32] = { - 0x00, 0x00, 0x00, 0x00, /* 0x00-0x1F: none */ - 0x00, 0x00, 0xFF, 0x03, /* 0x20-0x3F: digits 0-9 */ - 0xFE, 0xFF, 0xFF, 0x87, /* 0x40-0x5F: A to Z, _ */ - 0xFE, 0xFF, 0xFF, 0x07, /* 0x60-0x7F: a to z */ - 0x00, 0x00, 0x00, 0x00, /* 0x80-0x9F: none */ - 0x00, 0x00, 0x00, 0x00, /* 0xA0-0xBF: none */ - 0xFF, 0xFF, 0x7F, 0xFF, /* 0xC0-0xDF: Latin-1 accented uppercase */ - 0xFF, 0xFF, 0x7F, 0xFF /* 0xE0-0xFF: Latin-1 accented lowercase */ -}; - -#define Is_word_letter(c) ((re_word_letters[(c) >> 3] >> ((c) & 7)) & 1) - -/* The bytecode interpreter for the NFA */ -static int re_match(value re, - unsigned char * starttxt, - register unsigned char * txt, - register unsigned char * endtxt, - int accept_partial_match) -{ - register value * pc; - long instr; - struct backtrack_stack * stack; - union backtrack_point * sp; - value cpool; - value normtable; - unsigned char c; - union backtrack_point back; - - { int i; - struct re_group * p; - unsigned char ** q; - for (p = &re_group[1], i = Numgroups(re); i > 1; i--, p++) - p->start = p->end = NULL; - for (q = &re_register[0], i = Numregisters(re); i > 0; i--, q++) - *q = NULL; - } - - pc = &Field(Prog(re), 0); - stack = &initial_stack; - sp = stack->point; - cpool = Cpool(re); - normtable = Normtable(re); - re_group[0].start = txt; - - while (1) { - instr = Long_val(*pc++); - switch (Opcode(instr)) { - case CHAR: - if (txt == endtxt) goto prefix_match; - if (*txt != Arg(instr)) goto backtrack; - txt++; - break; - case CHARNORM: - if (txt == endtxt) goto prefix_match; - if (Byte_u(normtable, *txt) != Arg(instr)) goto backtrack; - txt++; - break; - case STRING: { - unsigned char * s = - (unsigned char *) String_val(Field(cpool, Arg(instr))); - while ((c = *s++) != 0) { - if (txt == endtxt) goto prefix_match; - if (c != *txt) goto backtrack; - txt++; - } - break; - } - case STRINGNORM: { - unsigned char * s = - (unsigned char *) String_val(Field(cpool, Arg(instr))); - while ((c = *s++) != 0) { - if (txt == endtxt) goto prefix_match; - if (c != Byte_u(normtable, *txt)) goto backtrack; - txt++; - } - break; - } - case CHARCLASS: - if (txt == endtxt) goto prefix_match; - if (! In_bitset(String_val(Field(cpool, Arg(instr))), *txt, c)) - goto backtrack; - txt++; - break; - case BOL: - if (txt > starttxt && txt[-1] != '\n') goto backtrack; - break; - case EOL: - if (txt < endtxt && *txt != '\n') goto backtrack; - break; - case WORDBOUNDARY: - /* At beginning and end of text: no - At beginning of text: OK if current char is a letter - At end of text: OK if previous char is a letter - Otherwise: - OK if previous char is a letter and current char not a letter - or previous char is not a letter and current char is a letter */ - if (txt == starttxt) { - if (txt == endtxt) goto prefix_match; - if (Is_word_letter(txt[0])) break; - goto backtrack; - } else if (txt == endtxt) { - if (Is_word_letter(txt[-1])) break; - goto backtrack; - } else { - if (Is_word_letter(txt[-1]) != Is_word_letter(txt[0])) break; - goto backtrack; - } - case BEGGROUP: { - int group_no = Arg(instr); - struct re_group * group = &(re_group[group_no]); - back.undo.loc = &(group->start); - back.undo.val = group->start; - group->start = txt; - goto push; - } - case ENDGROUP: { - int group_no = Arg(instr); - struct re_group * group = &(re_group[group_no]); - back.undo.loc = &(group->end); - back.undo.val = group->end; - group->end = txt; - goto push; - } - case REFGROUP: { - int group_no = Arg(instr); - struct re_group * group = &(re_group[group_no]); - unsigned char * s; - if (group->start == NULL || group->end == NULL) goto backtrack; - for (s = group->start; s < group->end; s++) { - if (txt == endtxt) goto prefix_match; - if (*s != *txt) goto backtrack; - txt++; - } - break; - } - case ACCEPT: - goto accept; - case SIMPLEOPT: { - char * set = String_val(Field(cpool, Arg(instr))); - if (txt < endtxt && In_bitset(set, *txt, c)) txt++; - break; - } - case SIMPLESTAR: { - char * set = String_val(Field(cpool, Arg(instr))); - while (txt < endtxt && In_bitset(set, *txt, c)) - txt++; - break; - } - case SIMPLEPLUS: { - char * set = String_val(Field(cpool, Arg(instr))); - if (txt == endtxt) goto prefix_match; - if (! In_bitset(set, *txt, c)) goto backtrack; - txt++; - while (txt < endtxt && In_bitset(set, *txt, c)) - txt++; - break; - } - case GOTO: - pc = pc + SignedArg(instr); - break; - case PUSHBACK: - back.pos.pc = Set_tag(pc + SignedArg(instr)); - back.pos.txt = txt; - goto push; - case SETMARK: { - int reg_no = Arg(instr); - unsigned char ** reg = &(re_register[reg_no]); - back.undo.loc = reg; - back.undo.val = *reg; - *reg = txt; - goto push; - } - case CHECKPROGRESS: { - int reg_no = Arg(instr); - if (re_register[reg_no] == txt) - goto backtrack; - break; - } - default: - caml_fatal_error ("impossible case in re_match"); - } - /* Continue with next instruction */ - continue; - - push: - /* Push an item on the backtrack stack and continue with next instr */ - if (sp == stack->point + BACKTRACK_STACK_BLOCK_SIZE) { - struct backtrack_stack * newstack = - stat_alloc(sizeof(struct backtrack_stack)); - newstack->previous = stack; - stack = newstack; - sp = stack->point; - } - *sp = back; - sp++; - continue; - - prefix_match: - /* We get here when matching failed because the end of text - was encountered. */ - if (accept_partial_match) goto accept; - - backtrack: - /* We get here when matching fails. Backtrack to most recent saved - program point, undoing variable assignments on the way. */ - while (1) { - if (sp == stack->point) { - struct backtrack_stack * prevstack = stack->previous; - if (prevstack == NULL) return 0; - stat_free(stack); - stack = prevstack; - sp = stack->point + BACKTRACK_STACK_BLOCK_SIZE; - } - sp--; - if (Tag_is_set(sp->pos.pc)) { - pc = Clear_tag(sp->pos.pc); - txt = sp->pos.txt; - break; - } else { - *(sp->undo.loc) = sp->undo.val; - } - } - continue; - } - - accept: - /* We get here when the regexp was successfully matched */ - free_backtrack_stack(stack); - re_group[0].end = txt; - return 1; -} - -/* Allocate an integer array containing the positions of the matched groups. - Beginning of group #N is at 2N, end is at 2N+1. - Take position = -1 when group wasn't matched. */ - -static value re_alloc_groups(value re, value str) -{ - CAMLparam1(str); - CAMLlocal1(res); - unsigned char * starttxt = (unsigned char *) String_val(str); - int n = Numgroups(re); - int i; - struct re_group * group; - - res = alloc(n * 2, 0); - for (i = 0; i < n; i++) { - group = &(re_group[i]); - if (group->start == NULL || group->end == NULL) { - Field(res, i * 2) = Val_int(-1); - Field(res, i * 2 + 1) = Val_int(-1); - } else { - Field(res, i * 2) = Val_long(group->start - starttxt); - Field(res, i * 2 + 1) = Val_long(group->end - starttxt); - } - } - CAMLreturn(res); -} - -/* String matching and searching. All functions return the empty array - on failure, and an array of positions on success. */ - -CAMLprim value re_string_match(value re, value str, value pos) -{ - unsigned char * starttxt = &Byte_u(str, 0); - unsigned char * txt = &Byte_u(str, Long_val(pos)); - unsigned char * endtxt = &Byte_u(str, string_length(str)); - - if (txt < starttxt || txt > endtxt) - invalid_argument("Str.string_match"); - if (re_match(re, starttxt, txt, endtxt, 0)) { - return re_alloc_groups(re, str); - } else { - return Atom(0); - } -} - -CAMLprim value re_partial_match(value re, value str, value pos) -{ - unsigned char * starttxt = &Byte_u(str, 0); - unsigned char * txt = &Byte_u(str, Long_val(pos)); - unsigned char * endtxt = &Byte_u(str, string_length(str)); - - if (txt < starttxt || txt > endtxt) - invalid_argument("Str.string_partial_match"); - if (re_match(re, starttxt, txt, endtxt, 1)) { - return re_alloc_groups(re, str); - } else { - return Atom(0); - } -} - -CAMLprim value re_search_forward(value re, value str, value startpos) -{ - unsigned char * starttxt = &Byte_u(str, 0); - unsigned char * txt = &Byte_u(str, Long_val(startpos)); - unsigned char * endtxt = &Byte_u(str, string_length(str)); - unsigned char * startchars; - - if (txt < starttxt || txt > endtxt) - invalid_argument("Str.search_forward"); - if (Startchars(re) == -1) { - do { - if (re_match(re, starttxt, txt, endtxt, 0)) - return re_alloc_groups(re, str); - txt++; - } while (txt <= endtxt); - return Atom(0); - } else { - startchars = - (unsigned char *) String_val(Field(Cpool(re), Startchars(re))); - do { - while (txt < endtxt && startchars[*txt] == 0) txt++; - if (re_match(re, starttxt, txt, endtxt, 0)) - return re_alloc_groups(re, str); - txt++; - } while (txt <= endtxt); - return Atom(0); - } -} - -CAMLprim value re_search_backward(value re, value str, value startpos) -{ - unsigned char * starttxt = &Byte_u(str, 0); - unsigned char * txt = &Byte_u(str, Long_val(startpos)); - unsigned char * endtxt = &Byte_u(str, string_length(str)); - unsigned char * startchars; - - if (txt < starttxt || txt > endtxt) - invalid_argument("Str.search_backward"); - if (Startchars(re) == -1) { - do { - if (re_match(re, starttxt, txt, endtxt, 0)) - return re_alloc_groups(re, str); - txt--; - } while (txt >= starttxt); - return Atom(0); - } else { - startchars = - (unsigned char *) String_val(Field(Cpool(re), Startchars(re))); - do { - while (txt > starttxt && startchars[*txt] == 0) txt--; - if (re_match(re, starttxt, txt, endtxt, 0)) - return re_alloc_groups(re, str); - txt--; - } while (txt >= starttxt); - return Atom(0); - } -} - -/* Replacement */ - -CAMLprim value re_replacement_text(value repl, value groups, value orig) -{ - CAMLparam3(repl, groups, orig); - CAMLlocal1(res); - mlsize_t start, end, len, n; - char * p, * q; - int c; - - len = 0; - p = String_val(repl); - n = string_length(repl); - while (n > 0) { - c = *p++; n--; - if(c != '\\') - len++; - else { - if (n == 0) failwith("Str.replace: illegal backslash sequence"); - c = *p++; n--; - switch (c) { - case '\\': - len++; break; - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - c -= '0'; - if (c*2 >= Wosize_val(groups)) - failwith("Str.replace: reference to unmatched group"); - start = Long_val(Field(groups, c*2)); - end = Long_val(Field(groups, c*2 + 1)); - if (start == (mlsize_t) -1) - failwith("Str.replace: reference to unmatched group"); - len += end - start; - break; - default: - len += 2; break; - } - } - } - res = alloc_string(len); - p = String_val(repl); - q = String_val(res); - n = string_length(repl); - while (n > 0) { - c = *p++; n--; - if(c != '\\') - *q++ = c; - else { - c = *p++; n--; - switch (c) { - case '\\': - *q++ = '\\'; break; - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - c -= '0'; - start = Long_val(Field(groups, c*2)); - end = Long_val(Field(groups, c*2 + 1)); - len = end - start; - memmove (q, &Byte(orig, start), len); - q += len; - break; - default: - *q++ = '\\'; *q++ = c; break; - } - } - } - CAMLreturn(res); -} diff --git a/otherlibs/win32graph/.ignore b/otherlibs/win32graph/.ignore deleted file mode 100644 index 090a9a2537c0..000000000000 --- a/otherlibs/win32graph/.ignore +++ /dev/null @@ -1,2 +0,0 @@ -graphics.ml -graphics.mli diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt deleted file mode 100644 index d768d0d070f8..000000000000 --- a/otherlibs/win32graph/Makefile.nt +++ /dev/null @@ -1,94 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Xavier Leroy, projet Cristal, INRIA Rocquencourt # -# # -# Copyright 2001 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file ../../LICENSE. # -# # -######################################################################### - -# $Id$ - -include ../../config/Makefile - -# Compilation options -CC=$(BYTECC) -CFLAGS=-I../../byterun -CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -COMPFLAGS=-warn-error A -g - -COBJS=open.$(O) draw.$(O) events.$(O) dib.$(O) -CAMLOBJS=graphics.cmo -WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32) - -all: dllgraphics.dll libgraphics.$(A) graphics.cma - -allopt: libgraphics.$(A) graphics.cmxa - -dllgraphics.dll: $(COBJS:.$(O)=.$(DO)) - $(call MKDLL,dllgraphics.dll,tmp.$(A),\ - $(COBJS:.$(O)=.$(DO)) ../../byterun/ocamlrun.$(A) $(WIN32LIBS)) - rm tmp.* - -libgraphics.$(A): $(COBJS:.$(O)=.$(SO)) - $(call MKLIB,libgraphics.$(A),$(COBJS:.$(O)=.$(SO))) - -graphics.cma: $(CAMLOBJS) - $(CAMLC) -a -o graphics.cma $(CAMLOBJS) \ - -dllib -lgraphics -cclib -lgraphics -cclib "$(WIN32LIBS)" - -graphics.cmxa: $(CAMLOBJS:.cmo=.cmx) - $(CAMLOPT) -a -o graphics.cmxa $(CAMLOBJS:.cmo=.cmx) \ - -cclib -lgraphics -cclib "$(WIN32LIBS)" - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.$(A) *.dll *.exp *.$(O) - rm -f graphics.ml graphics.mli - rm -f io.h - -install: - cp dllgraphics.dll $(STUBLIBDIR)/dllgraphics.dll - cp libgraphics.$(A) $(LIBDIR)/libgraphics.$(A) - cp graphics.cmi graphics.cma $(LIBDIR) - -installopt: - cp graphics.cmxa graphics.cmx graphics.$(A) $(LIBDIR) - -graphics.ml: ../graph/graphics.ml - cp ../graph/graphics.ml graphics.ml -graphics.mli: ../graph/graphics.mli - cp ../graph/graphics.mli graphics.mli - -.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO) - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(SO) - -depend: - -graphics.cmo: graphics.cmi -graphics.cmx: graphics.cmi -draw.$(SO) draw.$(DO): libgraph.h -open.$(SO) open.$(DO): libgraph.h diff --git a/otherlibs/win32graph/dib.c b/otherlibs/win32graph/dib.c deleted file mode 100644 index 8acba6f13276..000000000000 --- a/otherlibs/win32graph/dib.c +++ /dev/null @@ -1,496 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Developed by Jacob Navia */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -//----------------------------------------------------------------------------- -// DIB.C -// -// This is a collection of useful DIB manipulation/information gathering -// functions. Many functions are supplied simply to take the burden -// of taking into account whether a DIB is a Win30 style or OS/2 style -// DIB away from the application. -// -// The functions in this module assume that the DIB pointers or handles -// passed to them point to a block of memory in one of two formats: -// -// a) BITMAPINFOHEADER + color table + DIB bits (3.0 style DIB) -// b) BITMAPCOREHEADER + color table + DIB bits (OS/2 PM style) -// -// The SDK Reference, Volume 2 describes these data structures. -// -// A number of functions in this module were lifted from SHOWDIB, -// and modified to handle OS/2 DIBs. -// -// The functions in this module could be streamlined (made faster and -// smaller) by removing the OS/2 DIB specific code, and assuming all -// DIBs passed to it are Win30 style DIBs. The DIB file reading code -// would need to be modified to always convert DIBs to Win30 style -// DIBs. The only reason this isn't done in DIBView is because DIBView -// was written to test display and printer drivers (which are supposed -// to support OS/2 DIBs wherever they support Win30 style DIBs). SHOWDIB -// is a great example of how to go about doing this. -//----------------------------------------------------------------------------- - - -#include -#include -#include -#include -#include - // Size of window extra bytes (we store a handle to a PALINFO structure). - -#define PAL_CBWNDEXTRA (1 * sizeof (WORD)) - - -typedef struct - { - HPALETTE hPal; // Handle to palette being displayed. - WORD wEntries; // # of entries in the palette. - int nSquareSize; // Size of palette square (see PAL_SIZE) - HWND hInfoWnd; // Handle to the info bar window. - int nRows, nCols; // # of Rows/Columns in window. - int cxSquare, cySquare; // Pixel width/height of palette square. - WORD wEntry; // Currently selected palette square. - } PALINFO, FAR *LPPALINFO; - // Window Words. -#define WW_PAL_HPALINFO 0 // Handle to PALINFO structure. - // The following define is for CopyPaletteChangingFlags(). -#define DONT_CHANGE_FLAGS -1 - // The following is the palette version that goes in a - // LOGPALETTE's palVersion field. -#define PALVERSION 0x300 -// This is an enumeration for the various ways we can display -// a palette in PaletteWndProc(). -enum PAL_SIZE - { - PALSIZE_TINY = 0, - PALSIZE_SMALL, - PALSIZE_MEDIUM, - PALSIZE_LARGE - }; -#define CopyPalette(hPal) CopyPaletteChangingFlags (hPal, DONT_CHANGE_FLAGS) -#define CopyPalForAnimation(hPal) CopyPaletteChangingFlags (hPal, PC_RESERVED) -// WIDTHBYTES takes # of bits in a scan line and rounds up to nearest -// word. -#define WIDTHBYTES(bits) (((bits) + 31) / 32 * 4) - - // Given a pointer to a DIB header, return TRUE if is a Windows 3.0 style - // DIB, false if otherwise (PM style DIB). -#define IS_WIN30_DIB(lpbi) ((*(LPDWORD) (lpbi)) == sizeof (BITMAPINFOHEADER)) - -static WORD PaletteSize (LPSTR lpbi); - -extern void ShowDbgMsg(char *); -static BOOL MyRead (int, LPSTR, DWORD); -/*-------------- DIB header Marker Define -------------------------*/ -#define DIB_HEADER_MARKER ((WORD) ('M' << 8) | 'B') -/*-------------- MyRead Function Define ---------------------------*/ - -// When we read in a DIB, we read it in in chunks. We read half a segment -// at a time. This way we insure that we don't cross any segment -// boundries in _lread() during a read. We don't read in a full segment -// at a time, since _lread takes some "int" type parms instead of -// WORD type params (it'd work, but the compiler would give you warnings)... - -#define BYTES_PER_READ 32767 - -/*-------------- Define for PM DIB -------------------------------*/ -// The constants for RGB, RLE4, RLE8 are already defined inside -// of Windows.h - -#define BI_PM 3L - - -/*-------------- Magic numbers -------------------------------------*/ -// Maximum length of a filename for DOS is 128 characters. - -#define MAX_FILENAME 129 - - -/*-------------- TypeDef Structures -------------------------------*/ - -typedef struct InfoStruct - { - char szName[13]; - char szType[15]; - DWORD cbWidth; - DWORD cbHeight; - DWORD cbColors; - char szCompress[5]; - } INFOSTRUCT; - -// Some macros. -#define RECTWIDTH(lpRect) ((lpRect)->right - (lpRect)->left) -#define RECTHEIGHT(lpRect) ((lpRect)->bottom - (lpRect)->top) -//--------------------------------------------------------------------- -// -// Function: FindDIBBits -// -// Purpose: Given a pointer to a DIB, returns a pointer to the -// DIB's bitmap bits. -// -// Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER -// or BITMAPCOREHEADER) -// -// History: Date Reason -// 6/01/91 Created -// -//--------------------------------------------------------------------- -static LPSTR FindDIBBits (LPSTR lpbi) -{ - return (lpbi + *(LPDWORD)lpbi + PaletteSize (lpbi)); -} - - -//--------------------------------------------------------------------- -// -// Function: DIBNumColors -// -// Purpose: Given a pointer to a DIB, returns a number of colors in -// the DIB's color table. -// -// Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER -// or BITMAPCOREHEADER) -// -// History: Date Reason -// 6/01/91 Created -// -//--------------------------------------------------------------------- -static WORD DIBNumColors (LPSTR lpbi) -{ - WORD wBitCount; - - - // If this is a Windows style DIB, the number of colors in the - // color table can be less than the number of bits per pixel - // allows for (i.e. lpbi->biClrUsed can be set to some value). - // If this is the case, return the appropriate value. - - if (IS_WIN30_DIB (lpbi)) - { - DWORD dwClrUsed; - - dwClrUsed = ((LPBITMAPINFOHEADER) lpbi)->biClrUsed; - - if (dwClrUsed) - return (WORD) dwClrUsed; - } - - - // Calculate the number of colors in the color table based on - // the number of bits per pixel for the DIB. - - if (IS_WIN30_DIB (lpbi)) - wBitCount = ((LPBITMAPINFOHEADER) lpbi)->biBitCount; - else - wBitCount = ((LPBITMAPCOREHEADER) lpbi)->bcBitCount; - - switch (wBitCount) - { - case 1: - return 2; - - case 4: - return 16; - - case 8: - return 256; - - default: - return 0; - } -} - -//--------------------------------------------------------------------- -// -// Function: PaletteSize -// -// Purpose: Given a pointer to a DIB, returns number of bytes -// in the DIB's color table. -// -// Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER -// or BITMAPCOREHEADER) -// -// History: Date Reason -// 6/01/91 Created -// -//--------------------------------------------------------------------- -static WORD PaletteSize (LPSTR lpbi) -{ - if (IS_WIN30_DIB (lpbi)) - return (DIBNumColors (lpbi) * sizeof (RGBQUAD)); - else - return (DIBNumColors (lpbi) * sizeof (RGBTRIPLE)); -} - -//--------------------------------------------------------------------- -// -// Function: DIBHeight -// -// Purpose: Given a pointer to a DIB, returns its height. Note -// that it returns a DWORD (since a Win30 DIB can have -// a DWORD in its height field), but under Win30, the -// high order word isn't used! -// -// Parms: lpDIB == pointer to DIB header (either BITMAPINFOHEADER -// or BITMAPCOREHEADER) -// -// History: Date Reason -// 6/01/91 Created -// -//--------------------------------------------------------------------- -static DWORD DIBHeight (LPSTR lpDIB) -{ - LPBITMAPINFOHEADER lpbmi; - LPBITMAPCOREHEADER lpbmc; - - lpbmi = (LPBITMAPINFOHEADER) lpDIB; - lpbmc = (LPBITMAPCOREHEADER) lpDIB; - - if (lpbmi->biSize == sizeof (BITMAPINFOHEADER)) - return lpbmi->biHeight; - else - return (DWORD) lpbmc->bcHeight; -} - -/************************************************************************* - - Function: ReadDIBFile (int) - - Purpose: Reads in the specified DIB file into a global chunk of - memory. - - Returns: A handle to a dib (hDIB) if successful. - NULL if an error occurs. - - Comments: BITMAPFILEHEADER is stripped off of the DIB. Everything - from the end of the BITMAPFILEHEADER structure on is - returned in the global memory handle. - - History: Date Author Reason - - 6/1/91 Created - 6/27/91 Removed PM bitmap conversion routines. - 6/31/91 Removed logic which overallocated memory - (to account for bad display drivers). - 11/08/91 Again removed logic which overallocated - memory (it had creeped back in!) - -*************************************************************************/ -static HANDLE ReadDIBFile (int hFile,int dwBitsSize) -{ - BITMAPFILEHEADER bmfHeader; - HANDLE hDIB; - LPSTR pDIB; - - - - // Go read the DIB file header and check if it's valid. - - if ((_lread (hFile, (LPSTR) &bmfHeader, sizeof (bmfHeader)) != sizeof (bmfHeader)) || - (bmfHeader.bfType != DIB_HEADER_MARKER)) - { - // ShowDbgMsg("Not a DIB file!"); - return NULL; - } - - // Allocate memory for DIB - - hDIB = GlobalAlloc (GMEM_SHARE|GMEM_MOVEABLE | GMEM_ZEROINIT, dwBitsSize - sizeof(BITMAPFILEHEADER)); - - if (hDIB == 0) - { - // ShowDbgMsg("Couldn't allocate memory!"); - return NULL; - } - - pDIB = GlobalLock (hDIB); - - // Go read the bits. - - if (!MyRead (hFile, pDIB, dwBitsSize - sizeof(BITMAPFILEHEADER))) - { - GlobalUnlock (hDIB); - GlobalFree (hDIB); - // ShowDbgMsg("Error reading file!"); - return NULL; - } - - - GlobalUnlock (hDIB); - return hDIB; -} - -/************************************************************************* - - Function: MyRead (int, LPSTR, DWORD) - - Purpose: Routine to read files greater than 64K in size. - - Returns: TRUE if successful. - FALSE if an error occurs. - - Comments: - - History: Date Reason - - 6/1/91 Created - -*************************************************************************/ -static BOOL MyRead (int hFile, LPSTR lpBuffer, DWORD dwSize) -{ - char *lpInBuf = (char *) lpBuffer; - int nBytes; - - - while (dwSize) - { - nBytes = (int) (dwSize > (DWORD) BYTES_PER_READ ? BYTES_PER_READ : - LOWORD (dwSize)); - - if (_lread (hFile, (LPSTR) lpInBuf, nBytes) != (WORD) nBytes) - return FALSE; - - dwSize -= nBytes; - lpInBuf += nBytes; - } - - return TRUE; -} - -//--------------------------------------------------------------------- -// -// Function: DIBPaint -// -// Purpose: Painting routine for a DIB. Calls StretchDIBits() or -// SetDIBitsToDevice() to paint the DIB. The DIB is -// output to the specified DC, at the coordinates given -// in lpDCRect. The area of the DIB to be output is -// given by lpDIBRect. The specified palette is used. -// -// Parms: hDC == DC to do output to. -// lpDCRect == Rectangle on DC to do output to. -// hDIB == Handle to global memory with a DIB spec -// in it (either a BITMAPINFO or BITMAPCOREINFO -// followed by the DIB bits). -// lpDIBRect == Rect of DIB to output into lpDCRect. -// hPal == Palette to be used. -// -// History: Date Reason -// 6/01/91 Created -// -//--------------------------------------------------------------------- -static void DIBPaint (HDC hDC,LPRECT lpDCRect,HANDLE hDIB) -{ - LPSTR lpDIBHdr, lpDIBBits; - - if (!hDIB) - return; - // Lock down the DIB, and get a pointer to the beginning of the bit - // buffer. - lpDIBHdr = GlobalLock (hDIB); - lpDIBBits = FindDIBBits (lpDIBHdr); - // Make sure to use the stretching mode best for color pictures. - SetStretchBltMode (hDC, COLORONCOLOR); - SetDIBitsToDevice (hDC, // hDC - lpDCRect->left, // DestX - lpDCRect->top, // DestY - RECTWIDTH (lpDCRect), // nDestWidth - RECTHEIGHT (lpDCRect), // nDestHeight - 0, // SrcX - 0, - // (int) DIBHeight (lpDIBHdr), // SrcY - 0, // nStartScan - (WORD) DIBHeight (lpDIBHdr), // nNumScans - lpDIBBits, // lpBits - (LPBITMAPINFO) lpDIBHdr, // lpBitsInfo - DIB_RGB_COLORS); // wUsage - - GlobalUnlock (hDIB); -} - -static unsigned int Getfilesize(char *name) -{ - FILE *f; - unsigned int size; - - f = fopen(name,"rb"); - if (f == NULL) - return 0; - fseek(f,0,SEEK_END); - size = ftell(f); - fclose(f); - return size; -} - - -HANDLE ChargerBitmap(char *FileName,POINT *lppt) -{ - HFILE hFile; - OFSTRUCT ofstruct; - HANDLE result; - LPSTR lpDIBHdr; - unsigned int size; - - size = Getfilesize(FileName); - hFile=OpenFile((LPSTR) FileName, &ofstruct, OF_READ | OF_SHARE_DENY_WRITE); - result = ReadDIBFile(hFile,size); - if (hFile) _lclose(hFile); - if (result) { - LPBITMAPINFOHEADER lpbmi; - LPBITMAPCOREHEADER lpbmc; - - lpDIBHdr = GlobalLock (result); - lpbmi = (LPBITMAPINFOHEADER) lpDIBHdr; - lpbmc = (LPBITMAPCOREHEADER) lpDIBHdr; - - if (lpbmi->biSize == sizeof (BITMAPINFOHEADER)) { - lppt->y = lpbmi->biHeight; - lppt->x = lpbmi->biWidth; - } - else { - lppt->y = lpbmc->bcHeight; - lppt->x = lpbmc->bcWidth; - } - GlobalUnlock(result); - } - return(result); -} - -void DessinerBitmap(HANDLE hDIB,HDC hDC,LPRECT lpDCRect) -{ - DIBPaint (hDC, - lpDCRect, - hDIB); -} - -void AfficheBitmap(char *filename,HDC hDC,int x,int y) -{ - RECT rc; - HANDLE hdib; - POINT pt; - char titi[60]; - - hdib = ChargerBitmap(filename,&pt); - if (hdib == NULL) { - return; - } - rc.top = y; - rc.left = x; - rc.right = pt.x+x; - rc.bottom = pt.y+y; - pt.y += GetSystemMetrics(SM_CYCAPTION); - DessinerBitmap(hdib,hDC,&rc); - GlobalFree(hdib); -} diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c deleted file mode 100644 index f089a01a32fa..000000000000 --- a/otherlibs/win32graph/draw.c +++ /dev/null @@ -1,650 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Developed by Jacob Navia, based on code by J-M Geffroy and X Leroy */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include "mlvalues.h" -#include "alloc.h" -#include "fail.h" -#include "libgraph.h" -#include "custom.h" -#include "memory.h" - -HDC gcMetaFile; -int grdisplay_mode; -int grremember_mode; -GR_WINDOW grwindow; - -static void GetCurrentPosition(HDC hDC,POINT *pt) -{ - MoveToEx(hDC,0,0,pt); - MoveToEx(hDC,pt->x,pt->y,0); -} - -static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry, - value vstart, value vend, BOOL fill); - -CAMLprim value caml_gr_plot(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - gr_check_open(); - if(grremember_mode) - SetPixel(grwindow.gcBitmap, x, Wcvt(y),grwindow.CurrentColor); - if(grdisplay_mode) { - SetPixel(grwindow.gc, x, Wcvt(y),grwindow.CurrentColor); - } - return Val_unit; -} - -CAMLprim value caml_gr_moveto(value vx, value vy) -{ - grwindow.grx = Int_val(vx); - grwindow.gry = Int_val(vy); - if(grremember_mode) - MoveToEx(grwindow.gcBitmap,grwindow.grx,Wcvt(grwindow.gry),0); - if (grdisplay_mode) - MoveToEx(grwindow.gc,grwindow.grx,Wcvt(grwindow.gry),0); - return Val_unit; -} - -CAMLprim value caml_gr_current_x(void) -{ - return Val_int(grwindow.grx); -} - -CAMLprim value caml_gr_current_y(void) -{ - return Val_int(grwindow.gry); -} - -CAMLprim value caml_gr_lineto(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - gr_check_open(); - SelectObject(grwindow.gc,grwindow.CurrentPen); - SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); - if (grremember_mode) - LineTo(grwindow.gcBitmap,x,Wcvt(y)); - if (grdisplay_mode) - LineTo(grwindow.gc, x, Wcvt(y)); - grwindow.grx = x; - grwindow.gry = y; - return Val_unit; -} - -CAMLprim value caml_gr_draw_rect(value vx, value vy, value vw, value vh) -{ - int x, y, w, h; - POINT pt[5]; - x=Int_val(vx); - y=Wcvt(Int_val(vy)); - w=Int_val(vw); - h=Int_val(vh); - - pt[0].x = x; pt[0].y = y - h; - pt[1].x = x + w; pt[1].y = y - h; - pt[2].x = x + w; pt[2].y = y; - pt[3].x = x; pt[3].y = y; - pt[4].x = x; pt[4].y = y - h; - if (grremember_mode) { - Polyline(grwindow.gcBitmap,pt, 5); - } - if (grdisplay_mode) { - Polyline(grwindow.gc,pt, 5); - } - return Val_unit; -} - -CAMLprim value caml_gr_draw_text(value text,value x) -{ - POINT pt; - int oldmode = SetBkMode(grwindow.gc,TRANSPARENT); - SetBkMode(grwindow.gcBitmap,TRANSPARENT); - SetTextAlign(grwindow.gcBitmap, TA_UPDATECP|TA_BOTTOM); - SetTextAlign(grwindow.gc, TA_UPDATECP|TA_BOTTOM); - if (grremember_mode) { - TextOut(grwindow.gcBitmap,0,0,(char *)text,x); - } - if(grdisplay_mode) { - TextOut(grwindow.gc,0,0,(char *)text,x); - } - GetCurrentPosition(grwindow.gc,&pt); - grwindow.grx = pt.x; - grwindow.gry = grwindow.height - pt.y; - SetBkMode(grwindow.gc,oldmode); - SetBkMode(grwindow.gcBitmap,oldmode); - return Val_unit; -} - -CAMLprim value caml_gr_fill_rect(value vx, value vy, value vw, value vh) -{ - int x = Int_val(vx); - int y = Int_val(vy); - int w = Int_val(vw); - int h = Int_val(vh); - RECT rc; - - gr_check_open(); - rc.left = x; - rc.top = Wcvt(y); - rc.right = x+w; - rc.bottom = Wcvt(y)-h; - if (grdisplay_mode) - FillRect(grwindow.gc,&rc,grwindow.CurrentBrush); - if (grremember_mode) - FillRect(grwindow.gcBitmap,&rc,grwindow.CurrentBrush); - return Val_unit; -} - -CAMLprim value caml_gr_sound(value freq, value vdur) -{ - Beep(freq,vdur); - return Val_unit; -} - -CAMLprim value caml_gr_point_color(value vx, value vy) -{ - int x = Int_val(vx); - int y = Int_val(vy); - COLORREF rgb; - unsigned long b,g,r; - - gr_check_open(); - rgb = GetPixel(grwindow.gcBitmap,x,Wcvt(y)); - b = (unsigned long)((rgb & 0xFF0000) >> 16); - g = (unsigned long)((rgb & 0x00FF00) >> 8); - r = (unsigned long)(rgb & 0x0000FF); - return Val_long((r<<16) + (g<<8) + b); -} - -CAMLprim value caml_gr_circle(value x,value y,value radius) -{ - int left,top,right,bottom; - - gr_check_open(); - left = x - radius/2; - top = Wcvt(y) - radius/2; - right = left+radius; - bottom = top+radius; - Ellipse(grwindow.gcBitmap,left,top,right,bottom); - return Val_unit; -} - -CAMLprim value caml_gr_set_window_title(value text) -{ - SetWindowText(grwindow.hwnd,(char *)text); - return Val_unit; -} - -CAMLprim value caml_gr_draw_arc(value *argv, int argc) -{ - return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5], FALSE); -} - -CAMLprim value caml_gr_draw_arc_nat(vx, vy, vrx, vry, vstart, vend) -{ - return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, FALSE); -} - -CAMLprim value caml_gr_set_line_width(value vwidth) -{ - int width = Int_val(vwidth); - HPEN oldPen,newPen; - - gr_check_open(); - oldPen = grwindow.CurrentPen; - newPen = CreatePen(PS_SOLID,width,grwindow.CurrentColor); - SelectObject(grwindow.gcBitmap,newPen); - SelectObject(grwindow.gc,newPen); - DeleteObject(oldPen); - grwindow.CurrentPen = newPen; - return Val_unit; -} - -CAMLprim value caml_gr_set_color(value vcolor) -{ - HBRUSH oldBrush, newBrush; - LOGBRUSH lb; - LOGPEN pen; - HPEN newPen; - int color = Long_val(vcolor); - - int r = (color & 0xFF0000) >> 16, - g = (color & 0x00FF00) >> 8 , - b = color & 0x0000FF; - COLORREF c = RGB(r,g,b); - memset(&lb,0,sizeof(lb)); - memset(&pen,0,sizeof(LOGPEN)); - gr_check_open(); - GetObject(grwindow.CurrentPen,sizeof(LOGPEN),&pen); - pen.lopnColor = c; - newPen = CreatePenIndirect(&pen); - SelectObject(grwindow.gcBitmap,newPen); - SelectObject(grwindow.gc,newPen); - DeleteObject(grwindow.CurrentPen); - grwindow.CurrentPen = newPen; - SetTextColor(grwindow.gc,c); - SetTextColor(grwindow.gcBitmap,c); - oldBrush = grwindow.CurrentBrush; - lb.lbStyle = BS_SOLID; - lb.lbColor = c; - newBrush = CreateBrushIndirect(&lb); - SelectObject(grwindow.gc,newBrush); - SelectObject(grwindow.gcBitmap,newBrush); - DeleteObject(oldBrush); - grwindow.CurrentBrush = newBrush; - grwindow.CurrentColor = c; - return Val_unit; -} - - -static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry, - value vstart, value vend, BOOL fill) -{ - int x, y, r_x, r_y, start, end; - int x1, y1, x2, y2, x3, y3, x4, y4; - double cvt = 3.141592653/180.0; - - r_x = Int_val(vrx); - r_y = Int_val(vry); - if ((r_x < 0) || (r_y < 0)) - invalid_argument("draw_arc: radius must be positive"); - x = Int_val(vx); - y = Int_val(vy); - start = Int_val(vstart); - end = Int_val(vend); - - // Upper-left corner of bounding rect. - x1= x - r_x; - y1= y + r_y; - // Lower-right corner of bounding rect. - x2= x + r_x; - y2= y - r_y; - // Starting point - x3=x + (int)(100.0*cos(cvt*start)); - y3=y + (int)(100.0*sin(cvt*start)); - // Ending point - x4=x + (int)(100.0*cos(cvt*end)); - y4=y + (int)(100.0*sin(cvt*end)); - - if (grremember_mode) { - SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - if( fill ) - Pie(grwindow.gcBitmap,x1, Wcvt(y1), x2, Wcvt(y2), - x3, Wcvt(y3), x4, Wcvt(y4)); - else - Arc(grwindow.gcBitmap,x1, Wcvt(y1), x2, Wcvt(y2), - x3, Wcvt(y3), x4, Wcvt(y4)); - } - if( grdisplay_mode ) { - SelectObject(grwindow.gc,grwindow.CurrentPen); - SelectObject(grwindow.gc,grwindow.CurrentBrush); - if (fill) - Pie(grwindow.gc,x1, Wcvt(y1), x2, Wcvt(y2), - x3, Wcvt(y3), x4, Wcvt(y4)); - else - Arc(grwindow.gc,x1, Wcvt(y1), x2, Wcvt(y2), - x3, Wcvt(y3), x4, Wcvt(y4)); - } - return Val_unit; -} - -CAMLprim value caml_gr_show_bitmap(value filename,int x,int y) -{ - AfficheBitmap(filename,grwindow.gcBitmap,x,Wcvt(y)); - AfficheBitmap(filename,grwindow.gc,x,Wcvt(y)); - return Val_unit; -} - - - -CAMLprim value caml_gr_get_mousex(void) -{ - POINT pt; - GetCursorPos(&pt); - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - return pt.x; -} - -CAMLprim value caml_gr_get_mousey(void) -{ - POINT pt; - GetCursorPos(&pt); - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - return grwindow.height - pt.y - 1; -} - - -static void gr_font(char *fontname) -{ - HFONT hf = CreationFont(fontname); - - if (hf && hf != INVALID_HANDLE_VALUE) { - HFONT oldFont = SelectObject(grwindow.gc,hf); - SelectObject(grwindow.gcBitmap,hf); - DeleteObject(grwindow.CurrentFont); - grwindow.CurrentFont = hf; - } -} - -CAMLprim value caml_gr_set_font(value fontname) -{ - gr_check_open(); - gr_font(String_val(fontname)); - return Val_unit; -} - -CAMLprim value caml_gr_set_text_size (value sz) -{ - return Val_unit; -} - -CAMLprim value caml_gr_draw_char(value chr) -{ - char str[1]; - gr_check_open(); - str[0] = Int_val(chr); - caml_gr_draw_text((value)str, 1); - return Val_unit; -} - -CAMLprim value caml_gr_draw_string(value str) -{ - gr_check_open(); - caml_gr_draw_text(str, string_length(str)); - return Val_unit; -} - -CAMLprim value caml_gr_text_size(value str) -{ - SIZE extent; - value res; - - mlsize_t len = string_length(str); - if (len > 32767) len = 32767; - - GetTextExtentPoint(grwindow.gc,String_val(str), len,&extent); - - res = alloc_tuple(2); - Field(res, 0) = Val_long(extent.cx); - Field(res, 1) = Val_long(extent.cy); - - return res; -} - -CAMLprim value caml_gr_fill_poly(value vect) -{ - int n_points, i; - POINT *p,*poly; - n_points = Wosize_val(vect); - if (n_points < 3) - gr_fail("fill_poly: not enough points",0); - - poly = (POINT *)malloc(n_points*sizeof(POINT)); - - p = poly; - for( i = 0; i < n_points; i++ ){ - p->x = Int_val(Field(Field(vect,i),0)); - p->y = Wcvt(Int_val(Field(Field(vect,i),1))); - p++; - } - if (grremember_mode) { - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - Polygon(grwindow.gcBitmap,poly,n_points); - } - if (grdisplay_mode) { - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - Polygon(grwindow.gc,poly,n_points); - } - free(poly); - - return Val_unit; -} - -CAMLprim value caml_gr_fill_arc(value *argv, int argc) -{ - return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3], - argv[4], argv[5], TRUE); -} - -CAMLprim value caml_gr_fill_arc_nat(vx, vy, vrx, vry, vstart, vend) -{ - return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, TRUE); -} - -// Image primitives -struct image { - int w; - int h; - HBITMAP data; - HBITMAP mask; -}; - -#define Width(i) (((struct image *)Data_custom_val(i))->w) -#define Height(i) (((struct image *)Data_custom_val(i))->h) -#define Data(i) (((struct image *)Data_custom_val(i))->data) -#define Mask(i) (((struct image *)Data_custom_val(i))->mask) -#define Max_image_mem 500000 - -static void finalize_image (value i) -{ - DeleteObject (Data(i)); - if (Mask(i) != NULL) DeleteObject(Mask(i)); -} - -static struct custom_operations image_ops = { - "_image", - finalize_image, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default, - custom_compare_ext_default -}; - -CAMLprim value caml_gr_create_image(value vw, value vh) -{ - HBITMAP cbm; - value res; - int w = Int_val(vw); - int h = Int_val(vh); - - if (w < 0 || h < 0) - gr_fail("create_image: width and height must be positive",0); - - cbm = CreateCompatibleBitmap(grwindow.gc, w, h); - if (cbm == NULL) - gr_fail("create_image: cannot create bitmap", 0); - res = alloc_custom(&image_ops, sizeof(struct image), - w * h, Max_image_mem); - if (res) { - Width (res) = w; - Height (res) = h; - Data (res) = cbm; - Mask (res) = NULL; - } - return res; -} - -CAMLprim value caml_gr_blit_image (value i, value x, value y) -{ - HBITMAP oldBmp = SelectObject(grwindow.tempDC,Data(i)); - int xsrc = Int_val(x); - int ysrc = Wcvt(Int_val(y) + Height(i) - 1); - BitBlt(grwindow.tempDC,0, 0, Width(i), Height(i), - grwindow.gcBitmap, xsrc, ysrc, SRCCOPY); - SelectObject(grwindow.tempDC,oldBmp); - return Val_unit; -} - - -CAMLprim value caml_gr_draw_image(value i, value x, value y) -{ - HBITMAP oldBmp; - - int xdst = Int_val(x); - int ydst = Wcvt(Int_val(y)+Height(i)-1); - if (Mask(i) == NULL) { - if (grremember_mode) { - oldBmp = SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCCOPY); - SelectObject(grwindow.tempDC,oldBmp); - } - if (grdisplay_mode) { - oldBmp = SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCCOPY); - SelectObject(grwindow.tempDC,oldBmp); - } - } - else { - if (grremember_mode) { - oldBmp = SelectObject(grwindow.tempDC,Mask(i)); - BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCAND); - SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCPAINT); - SelectObject(grwindow.tempDC,oldBmp); - } - if (grdisplay_mode) { - oldBmp = SelectObject(grwindow.tempDC,Mask(i)); - BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCAND); - SelectObject(grwindow.tempDC,Data(i)); - BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), - grwindow.tempDC, 0, 0, SRCPAINT); - SelectObject(grwindow.tempDC,oldBmp); - } - } - - return Val_unit; -} - -CAMLprim value caml_gr_make_image(value matrix) -{ - int width, height,has_transp,i,j; - value img; - HBITMAP oldBmp; - height = Wosize_val(matrix); - if (height == 0) { - width = 0; - } - else { - width = Wosize_val(Field(matrix, 0)); - for (i = 1; i < height; i++) { - if (width != (int) Wosize_val(Field(matrix, i))) - gr_fail("make_image: non-rectangular matrix",0); - } - } - Begin_roots1(matrix) - img = caml_gr_create_image(Val_int(width), Val_int(height)); - End_roots(); - has_transp = 0; - oldBmp = SelectObject(grwindow.tempDC,Data(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - int col = Long_val (Field (Field (matrix, i), j)); - if (col == -1){ - has_transp = 1; - SetPixel(grwindow.tempDC,j, i, 0); - } - else { - int red = (col >> 16) & 0xFF; - int green = (col >> 8) & 0xFF; - int blue = col & 0xFF; - SetPixel(grwindow.tempDC,j, i, RGB(red, green, blue)); - } - } - } - SelectObject(grwindow.tempDC,oldBmp); - if (has_transp) { - HBITMAP cbm; - cbm = CreateCompatibleBitmap(grwindow.gc, width, height); - Mask(img) = cbm; - oldBmp = SelectObject(grwindow.tempDC,Mask(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - int col = Long_val (Field (Field (matrix, i), j)); - SetPixel(grwindow.tempDC,j, i, col == -1 ? 0xFFFFFF : 0); - } - } - SelectObject(grwindow.tempDC,oldBmp); - } - return img; -} - -static value alloc_int_vect(mlsize_t size) -{ - value res; - mlsize_t i; - - if (size == 0) return Atom(0); - if (size <= Max_young_wosize) { - res = alloc(size, 0); - } - else { - res = alloc_shr(size, 0); - } - for (i = 0; i < size; i++) { - Field(res, i) = Val_long(0); - } - return res; -} - -CAMLprim value caml_gr_dump_image (value img) -{ - int height = Height(img); - int width = Width(img); - value matrix = Val_unit; - int i, j; - HBITMAP oldBmp; - - Begin_roots2(img, matrix) - matrix = alloc_int_vect (height); - for (i = 0; i < height; i++) { - modify (&Field (matrix, i), alloc_int_vect (width)); - } - End_roots(); - - oldBmp = SelectObject(grwindow.tempDC,Data(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - int col = GetPixel(grwindow.tempDC,j, i); - int blue = (col >> 16) & 0xFF; - int green = (col >> 8) & 0xFF; - int red = col & 0xFF; - Field(Field(matrix, i), j) = Val_long((red << 16) + - (green << 8) + blue); - } - } - SelectObject(grwindow.tempDC,oldBmp); - if (Mask(img) != NULL) { - oldBmp = SelectObject(grwindow.tempDC,Mask(img)); - for (i = 0; i < height; i++) { - for (j = 0; j < width; j++) { - if (GetPixel(grwindow.tempDC,j, i) != 0) - Field(Field(matrix, i), j) = - Val_long(-1); - } - } - SelectObject(grwindow.tempDC,oldBmp); - } - return matrix; -} diff --git a/otherlibs/win32graph/events.c b/otherlibs/win32graph/events.c deleted file mode 100755 index 29def467ffe5..000000000000 --- a/otherlibs/win32graph/events.c +++ /dev/null @@ -1,200 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2004 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include "mlvalues.h" -#include "alloc.h" -#include "libgraph.h" -#include - -enum { - EVENT_BUTTON_DOWN = 1, - EVENT_BUTTON_UP = 2, - EVENT_KEY_PRESSED = 4, - EVENT_MOUSE_MOTION = 8 -}; - -struct event_data { - short mouse_x, mouse_y; - unsigned char kind; - unsigned char button; - unsigned char key; -}; - -static struct event_data caml_gr_queue[SIZE_QUEUE]; -static unsigned int caml_gr_head = 0; /* position of next read */ -static unsigned int caml_gr_tail = 0; /* position of next write */ - -static int caml_gr_event_mask = EVENT_KEY_PRESSED; -static int last_button = 0; -static LPARAM last_pos = 0; - -HANDLE caml_gr_queue_semaphore = NULL; -CRITICAL_SECTION caml_gr_queue_mutex; - -void caml_gr_init_event_queue(void) -{ - if (caml_gr_queue_semaphore == NULL) { - caml_gr_queue_semaphore = CreateSemaphore(NULL, 0, SIZE_QUEUE, NULL); - InitializeCriticalSection(&caml_gr_queue_mutex); - } -} - -#define QueueIsEmpty (caml_gr_tail == caml_gr_head) - -static void caml_gr_enqueue_event(int kind, LPARAM mouse_xy, - int button, int key) -{ - struct event_data * ev; - - if ((caml_gr_event_mask & kind) == 0) return; - EnterCriticalSection(&caml_gr_queue_mutex); - ev = &(caml_gr_queue[caml_gr_tail]); - ev->kind = kind; - ev->mouse_x = GET_X_LPARAM(mouse_xy); - ev->mouse_y = GET_Y_LPARAM(mouse_xy); - ev->button = (button != 0); - ev->key = key; - caml_gr_tail = (caml_gr_tail + 1) % SIZE_QUEUE; - /* If queue was full, it now appears empty; - drop oldest entry from queue. */ - if (QueueIsEmpty) { - caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE; - } else { - /* One more event in queue */ - ReleaseSemaphore(caml_gr_queue_semaphore, 1, NULL); - } - LeaveCriticalSection(&caml_gr_queue_mutex); -} - -void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam) -{ - switch (msg) { - case WM_LBUTTONDOWN: - case WM_RBUTTONDOWN: - case WM_MBUTTONDOWN: - last_button = 1; - last_pos = lParam; - caml_gr_enqueue_event(EVENT_BUTTON_DOWN, lParam, 1, 0); - break; - - case WM_LBUTTONUP: - case WM_RBUTTONUP: - case WM_MBUTTONUP: - last_button = 0; - last_pos = lParam; - caml_gr_enqueue_event(EVENT_BUTTON_UP, lParam, 0, 0); - break; - - case WM_CHAR: - caml_gr_enqueue_event(EVENT_KEY_PRESSED, last_pos, last_button, wParam); - break; - - case WM_MOUSEMOVE: - last_pos = lParam; - caml_gr_enqueue_event(EVENT_MOUSE_MOTION, lParam, last_button, 0); - break; - } -} - -static value caml_gr_wait_allocate_result(int mouse_x, int mouse_y, - int button, - int keypressed, int key) -{ - value res = alloc_small(5, 0); - Field(res, 0) = Val_int(mouse_x); - Field(res, 1) = Val_int(grwindow.height - 1 - mouse_y); - Field(res, 2) = Val_bool(button); - Field(res, 3) = Val_bool(keypressed); - Field(res, 4) = Val_int(key & 0xFF); - return res; -} - -static value caml_gr_wait_event_poll(void) -{ - int key, keypressed, i; - - /* Look inside event queue for pending KeyPress events */ - EnterCriticalSection(&caml_gr_queue_mutex); - key = 0; - keypressed = 0; - for (i = caml_gr_head; i != caml_gr_tail; i = (i + 1) % SIZE_QUEUE) { - if (caml_gr_queue[i].kind == EVENT_KEY_PRESSED) { - keypressed = 1; - key = caml_gr_queue[i].key; - break; - } - } - LeaveCriticalSection(&caml_gr_queue_mutex); - /* Use global vars for mouse position and buttons */ - return caml_gr_wait_allocate_result(GET_X_LPARAM(last_pos), - GET_Y_LPARAM(last_pos), - last_button, - keypressed, key); -} - -static value caml_gr_wait_event_blocking(int mask) -{ - struct event_data ev; - - /* Increase the selected events if needed */ - caml_gr_event_mask |= mask; - /* Pop events from queue until one matches */ - do { - /* Wait for event queue to be non-empty */ - WaitForSingleObject(caml_gr_queue_semaphore, INFINITE); - /* Pop oldest event in queue */ - EnterCriticalSection(&caml_gr_queue_mutex); - ev = caml_gr_queue[caml_gr_head]; - /* Queue should never be empty at this point, but just in case... */ - if (QueueIsEmpty) { - ev.kind = 0; - } else { - caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE; - } - LeaveCriticalSection(&caml_gr_queue_mutex); - /* Check if it matches */ - } while ((ev.kind & mask) == 0); - return caml_gr_wait_allocate_result(ev.mouse_x, ev.mouse_y, ev.button, - ev.kind == EVENT_KEY_PRESSED, - ev.key); -} - -CAMLprim value caml_gr_wait_event(value eventlist) /* ML */ -{ - int mask, poll; - - gr_check_open(); - mask = 0; - poll = 0; - while (eventlist != Val_int(0)) { - switch (Int_val(Field(eventlist, 0))) { - case 0: /* Button_down */ - mask |= EVENT_BUTTON_DOWN; break; - case 1: /* Button_up */ - mask |= EVENT_BUTTON_UP; break; - case 2: /* Key_pressed */ - mask |= EVENT_KEY_PRESSED; break; - case 3: /* Mouse_motion */ - mask |= EVENT_MOUSE_MOTION; break; - case 4: /* Poll */ - poll = 1; break; - } - eventlist = Field(eventlist, 1); - } - if (poll) - return caml_gr_wait_event_poll(); - else - return caml_gr_wait_event_blocking(mask); -} diff --git a/otherlibs/win32graph/libgraph.h b/otherlibs/win32graph/libgraph.h deleted file mode 100644 index bae4b1162350..000000000000 --- a/otherlibs/win32graph/libgraph.h +++ /dev/null @@ -1,78 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Jacob Navia, after Xavier Leroy */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include - -struct canvas { - int w, h; /* Dimensions of the drawable */ - HWND win; /* The drawable itself */ - HDC gc; /* The associated graphics context */ -}; - -extern HWND grdisplay; /* The display connection */ -extern COLORREF grbackground; -extern BOOL grdisplay_mode; /* Display-mode flag */ -extern BOOL grremember_mode; /* Remember-mode flag */ -extern int grx, gry; /* Coordinates of the current point */ -extern int grcolor; /* Current *CAML* drawing color (can be -1) */ -extern HFONT * grfont; /* Current font */ - -extern BOOL direct_rgb; -extern int byte_order; -extern int bitmap_unit; -extern int bits_per_pixel; - -#define Wcvt(y) (grwindow.height - 1 - (y)) -#define Bcvt(y) (grwindow.height - 1 - (y)) -#define WtoB(y) ((y) + WindowRect.bottom - grwindow.h) - -#define DEFAULT_SCREEN_WIDTH 1024 -#define DEFAULT_SCREEN_HEIGHT 768 -#define BORDER_WIDTH 2 -#define WINDOW_NAME "OCaml graphics" -#define ICON_NAME "OCaml graphics" -#define SIZE_QUEUE 256 - -void gr_fail(char *fmt, char *arg); -void gr_check_open(void); -CAMLprim value caml_gr_set_color(value vcolor); - -// Windows specific definitions -extern RECT WindowRect; -extern int grCurrentColor; - -typedef struct tagWindow { - HDC gc; - HDC gcBitmap; - HWND hwnd; - HBRUSH CurrentBrush; - HPEN CurrentPen; - DWORD CurrentColor; - int width; - int height; - int grx; - int gry; - HBITMAP hBitmap; - HFONT CurrentFont; - int CurrentFontSize; - HDC tempDC; // For image operations; -} GR_WINDOW; - -extern GR_WINDOW grwindow; -HFONT CreationFont(char *name); -extern void caml_gr_init_event_queue(void); -extern void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam); diff --git a/otherlibs/win32graph/libgraphics.clib b/otherlibs/win32graph/libgraphics.clib deleted file mode 100644 index 5084c973c5ab..000000000000 --- a/otherlibs/win32graph/libgraphics.clib +++ /dev/null @@ -1 +0,0 @@ -open.o draw.o events.o dib.o diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c deleted file mode 100644 index bd78acdf2f8e..000000000000 --- a/otherlibs/win32graph/open.c +++ /dev/null @@ -1,365 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Developed by Jacob Navia, based on code by J-M Geffroy and X Leroy */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -#include -#include -#include "mlvalues.h" -#include "fail.h" -#include "libgraph.h" -#include - -static value gr_reset(void); -static long tid; -static HANDLE threadHandle; -HWND grdisplay = NULL; -int grscreen; -COLORREF grwhite, grblack; -COLORREF grbackground; -int grCurrentColor; -struct canvas grbstore; -BOOL grdisplay_mode; -BOOL grremember_mode; -int grx, gry; -int grcolor; -extern HFONT * grfont; -MSG msg; - -static char *szOcamlWindowClass = "OcamlWindowClass"; -static BOOL gr_initialized = 0; -CAMLprim value caml_gr_clear_graph(void); -HANDLE hInst; - -HFONT CreationFont(char *name) -{ - LOGFONT CurrentFont; - memset(&CurrentFont, 0, sizeof(LOGFONT)); - CurrentFont.lfCharSet = ANSI_CHARSET; - CurrentFont.lfWeight = FW_NORMAL; - CurrentFont.lfHeight = grwindow.CurrentFontSize; - CurrentFont.lfPitchAndFamily = (BYTE) (FIXED_PITCH | FF_MODERN); - strcpy(CurrentFont.lfFaceName, name); /* Courier */ - return (CreateFontIndirect(&CurrentFont)); -} - -void SetCoordinates(HWND hwnd) -{ - RECT rc; - - GetClientRect(hwnd,&rc); - grwindow.width = rc.right; - grwindow.height = rc.bottom; - gr_reset(); -} - -void ResetForClose(HWND hwnd) -{ - DeleteDC(grwindow.tempDC); - DeleteDC(grwindow.gcBitmap); - DeleteObject(grwindow.hBitmap); - memset(&grwindow,0,sizeof(grwindow)); - gr_initialized = 0; -} - - - -static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam) -{ - PAINTSTRUCT ps; - HDC hdc; - - switch (msg) { - // Create the MDI client invisible window - case WM_CREATE: - break; - case WM_PAINT: - hdc = BeginPaint(hwnd,&ps); - BitBlt(hdc,0,0,grwindow.width,grwindow.height, - grwindow.gcBitmap,0,0,SRCCOPY); - EndPaint(hwnd,&ps); - break; - // Move the child windows - case WM_SIZE: - // Position the MDI client window between the tool and status bars - if (wParam != SIZE_MINIMIZED) { - SetCoordinates(hwnd); - } - - return 0; - // End application - case WM_DESTROY: - ResetForClose(hwnd); - break; - } - caml_gr_handle_event(msg, wParam, lParam); - return DefWindowProc(hwnd, msg, wParam, lParam); -} - -int DoRegisterClass(void) -{ - WNDCLASS wc; - - memset(&wc,0,sizeof(WNDCLASS)); - wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS|CS_OWNDC ; - wc.lpfnWndProc = (WNDPROC)GraphicsWndProc; - wc.hInstance = hInst; - wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1); - wc.lpszClassName = szOcamlWindowClass; - wc.lpszMenuName = 0; - wc.hCursor = LoadCursor(NULL,IDC_ARROW); - wc.hIcon = 0; - return RegisterClass(&wc); -} - -static value gr_reset(void) -{ - RECT rc; - int screenx,screeny; - - screenx = GetSystemMetrics(SM_CXSCREEN); - screeny = GetSystemMetrics(SM_CYSCREEN); - GetClientRect(grwindow.hwnd,&rc); - grwindow.gc = GetDC(grwindow.hwnd); - grwindow.width = rc.right; - grwindow.height = rc.bottom; - if (grwindow.gcBitmap == (HDC)0) { - grwindow.hBitmap = CreateCompatibleBitmap(grwindow.gc,screenx,screeny); - grwindow.gcBitmap = CreateCompatibleDC(grwindow.gc); - grwindow.tempDC = CreateCompatibleDC(grwindow.gc); - SelectObject(grwindow.gcBitmap,grwindow.hBitmap); - SetMapMode(grwindow.gcBitmap,MM_TEXT); - MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0); - BitBlt(grwindow.gcBitmap,0,0,screenx,screeny, - grwindow.gcBitmap,0,0,WHITENESS); - grwindow.CurrentFontSize = 15; - grwindow.CurrentFont = CreationFont("Courier"); - } - grwindow.CurrentColor = GetSysColor(COLOR_WINDOWTEXT); - grwindow.grx = 0; - grwindow.gry = 0; - grwindow.CurrentPen = SelectObject(grwindow.gc,GetStockObject(WHITE_PEN)); - SelectObject(grwindow.gc,grwindow.CurrentPen); - SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); - grwindow.CurrentBrush = SelectObject(grwindow.gc,GetStockObject(WHITE_BRUSH)); - SelectObject(grwindow.gc,grwindow.CurrentBrush); - SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); - caml_gr_set_color(Val_long(0)); - SelectObject(grwindow.gc,grwindow.CurrentFont); - SelectObject(grwindow.gcBitmap,grwindow.CurrentFont); - grdisplay_mode = grremember_mode = 1; - MoveToEx(grwindow.gc,0,grwindow.height-1,0); - MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0); - SetTextAlign(grwindow.gcBitmap,TA_BOTTOM); - SetTextAlign(grwindow.gc,TA_BOTTOM); - return Val_unit; -} - -void SuspendGraphicThread(void) -{ - SuspendThread(threadHandle); -} - -void ResumeGraphicThread(void) -{ - ResumeThread(threadHandle); -} - -/* For handshake between the event handling thread and the main thread */ -static char * open_graph_errmsg; -static HANDLE open_graph_event; - -static DWORD WINAPI gr_open_graph_internal(value arg) -{ - RECT rc; - int ret; - int event; - int x, y, w, h; - int screenx,screeny; - int attributes; - static int registered; - MSG msg; - - gr_initialized = TRUE; - hInst = GetModuleHandle(NULL); - x = y = w = h = CW_USEDEFAULT; - sscanf(String_val(arg), "%dx%d+%d+%d", &w, &h, &x, &y); - - /* Open the display */ - if (grwindow.hwnd == NULL || !IsWindow(grwindow.hwnd)) { - if (!registered) { - registered = DoRegisterClass(); - if (!registered) { - open_graph_errmsg = "Cannot register the window class"; - SetEvent(open_graph_event); - return 1; - } - } - grwindow.hwnd = CreateWindow(szOcamlWindowClass, - WINDOW_NAME, - WS_OVERLAPPEDWINDOW, - x,y, - w,h, - NULL,0,hInst,NULL); - if (grwindow.hwnd == NULL) { - open_graph_errmsg = "Cannot create window"; - SetEvent(open_graph_event); - return 1; - } -#if 0 - if (x != CW_USEDEFAULT) { - rc.left = 0; - rc.top = 0; - rc.right = w; - rc.bottom = h; - AdjustWindowRect(&rc,GetWindowLong(grwindow.hwnd,GWL_STYLE),0); - MoveWindow(grwindow.hwnd,x,y,rc.right-rc.left,rc.bottom-rc.top,1); - } -#endif - } - gr_reset(); - ShowWindow(grwindow.hwnd,SW_SHOWNORMAL); - - /* Position the current point at origin */ - grwindow.grx = 0; - grwindow.gry = 0; - - caml_gr_init_event_queue(); - - /* The global data structures are now correctly initialized. - Restart the OCaml main thread. */ - open_graph_errmsg = NULL; - SetEvent(open_graph_event); - - /* Enter the message handling loop */ - while (GetMessage(&msg,NULL,0,0)) { - TranslateMessage(&msg); // Translates virtual key codes - DispatchMessage(&msg); // Dispatches message to window - if (!IsWindow(grwindow.hwnd)) - break; - } - return 0; -} - -CAMLprim value caml_gr_open_graph(value arg) -{ - long tid; - if (gr_initialized) return Val_unit; - open_graph_event = CreateEvent(NULL, FALSE, FALSE, NULL); - threadHandle = - CreateThread(NULL,0, - (LPTHREAD_START_ROUTINE)gr_open_graph_internal,(void **)arg, - 0, - &tid); - WaitForSingleObject(open_graph_event, INFINITE); - CloseHandle(open_graph_event); - if (open_graph_errmsg != NULL) gr_fail("%s", open_graph_errmsg); - return Val_unit; -} - -CAMLprim value caml_gr_close_graph(void) -{ - if (gr_initialized) { - PostMessage(grwindow.hwnd, WM_CLOSE, 0, 0); - WaitForSingleObject(threadHandle, INFINITE); - } - return Val_unit; -} - -CAMLprim value caml_gr_clear_graph(void) -{ - gr_check_open(); - if(grremember_mode) { - BitBlt(grwindow.gcBitmap,0,0,grwindow.width,grwindow.height, - grwindow.gcBitmap,0,0,WHITENESS); - } - if(grdisplay_mode) { - BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, - grwindow.gc,0,0,WHITENESS); - } - return Val_unit; -} - -CAMLprim value caml_gr_size_x(void) -{ - gr_check_open(); - return Val_int(grwindow.width); -} - -CAMLprim value caml_gr_size_y(void) -{ - gr_check_open(); - return Val_int(grwindow.height); -} - -CAMLprim value caml_gr_resize_window (value vx, value vy) -{ - caml_gr_check_open (); - - /* FIXME TODO implement this function... */ - - return Val_unit; -} - -CAMLprim value caml_gr_synchronize(void) -{ - gr_check_open(); - BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, - grwindow.gcBitmap,0,0,SRCCOPY); - return Val_unit ; -} - -CAMLprim value caml_gr_display_mode(value flag) -{ - grdisplay_mode = (Int_val(flag)) ? 1 : 0; - return Val_unit ; -} - -CAMLprim value caml_gr_remember_mode(value flag) -{ - grremember_mode = (Int_val(flag)) ? 1 : 0; - return Val_unit ; -} - -CAMLprim value caml_gr_sigio_signal(value unit) -{ - return Val_unit; -} - -CAMLprim value caml_gr_sigio_handler(void) -{ - return Val_unit; -} - - -/* Processing of graphic errors */ - -value * caml_named_value (char * name); -static value * graphic_failure_exn = NULL; -void gr_fail(char *fmt, char *arg) -{ - char buffer[1024]; - - if (graphic_failure_exn == NULL) { - graphic_failure_exn = caml_named_value("Graphics.Graphic_failure"); - if (graphic_failure_exn == NULL) - invalid_argument("Exception Graphics.Graphic_failure not initialized, must link graphics.cma"); - } - sprintf(buffer, fmt, arg); - raise_with_string(*graphic_failure_exn, buffer); -} - -void gr_check_open(void) -{ - if (!gr_initialized) gr_fail("graphic screen not opened", NULL); -}