diff options
Diffstat (limited to 'ocaml-binary-annot/emacs')
| -rw-r--r-- | ocaml-binary-annot/emacs/.cvsignore | 1 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/COPYING | 340 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/Makefile | 76 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/README | 206 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/README.itz | 177 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/caml-compat.el | 41 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/caml-emacs.el | 43 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/caml-font-old.el | 141 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/caml-font.el | 114 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/caml-help.el | 855 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/caml-hilit.el | 67 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/caml-types.el | 765 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/caml-xemacs.el | 53 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/caml.el | 1932 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/camldebug.el | 793 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/inf-caml.el | 363 | ||||
| -rw-r--r-- | ocaml-binary-annot/emacs/ocamltags.in | 142 |
17 files changed, 6109 insertions, 0 deletions
diff --git a/ocaml-binary-annot/emacs/.cvsignore b/ocaml-binary-annot/emacs/.cvsignore new file mode 100644 index 0000000000..ea6381f91b --- /dev/null +++ b/ocaml-binary-annot/emacs/.cvsignore @@ -0,0 +1 @@ +ocamltags diff --git a/ocaml-binary-annot/emacs/COPYING b/ocaml-binary-annot/emacs/COPYING new file mode 100644 index 0000000000..5b6e7c66c2 --- /dev/null +++ b/ocaml-binary-annot/emacs/COPYING @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + <signature of Ty Coon>, 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/ocaml-binary-annot/emacs/Makefile b/ocaml-binary-annot/emacs/Makefile new file mode 100644 index 0000000000..9519b396a5 --- /dev/null +++ b/ocaml-binary-annot/emacs/Makefile @@ -0,0 +1,76 @@ +######################################################################### +# # +# Objective Caml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 1997 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU General Public License. # +# # +######################################################################### + +# $Id$ + +include ../config/Makefile + +# Files to install +FILES= caml-font.el caml-hilit.el caml.el camldebug.el \ + inf-caml.el caml-compat.el caml-help.el caml-types.el \ + caml-xemacs.el caml-emacs.el + +# Where to install. If empty, automatically determined. +#EMACSDIR= + +# Name of Emacs executable +EMACS=emacs + +# Where to install ocamltags script +SCRIPTDIR = $(BINDIR) + +# Command for byte-compiling the files +COMPILECMD=(progn \ + (setq load-path (cons "." load-path)) \ + (byte-compile-file "caml-xemacs.el") \ + (byte-compile-file "caml-emacs.el") \ + (byte-compile-file "caml.el") \ + (byte-compile-file "inf-caml.el") \ + (byte-compile-file "caml-help.el") \ + (byte-compile-file "caml-types.el") \ + (byte-compile-file "camldebug.el")) + +install: + @if test "$(EMACSDIR)" = ""; then \ + set xxx `($(EMACS) --batch --eval "(mapcar 'print load-path)") \ + 2>/dev/null | \ + sed -n -e '/\/site-lisp/s/"//gp'`; \ + if test "$$2" = ""; then \ + echo "Cannot determine Emacs site-lisp directory"; \ + exit 2; \ + fi; \ + $(MAKE) EMACSDIR="$$2" simple-install; \ + else \ + $(MAKE) simple-install; \ + fi + +# install the .el files, but do not compile them. +install-el: + $(MAKE) NOCOMPILE=true install + +simple-install: + @echo "Installing in $(EMACSDIR)..." + if test -d $(EMACSDIR); then : ; else mkdir -p $(EMACSDIR); fi + cp $(FILES) $(EMACSDIR) + if [ -z "$(NOCOMPILE)" ]; then \ + cd $(EMACSDIR); $(EMACS) --batch --eval '$(COMPILECMD)'; \ + fi + +ocamltags: ocamltags.in + sed -e 's:@EMACS@:$(EMACS):' ocamltags.in >ocamltags + chmod a+x ocamltags + +install-ocamltags: ocamltags + cp ocamltags $(SCRIPTDIR)/ocamltags + +clean: + rm -f ocamltags *~ #*# diff --git a/ocaml-binary-annot/emacs/README b/ocaml-binary-annot/emacs/README new file mode 100644 index 0000000000..7ddb362b4e --- /dev/null +++ b/ocaml-binary-annot/emacs/README @@ -0,0 +1,206 @@ + O'Caml emacs mode, snapshot of $Date$ + +The files in this archive define a caml-mode for emacs, for editing +Objective Caml and Objective Label programs, as well as an +inferior-caml-mode, to run a toplevel. + +Caml-mode supports indentation, compilation and error retrieving, +sending phrases to the toplevel. Moreover support for hilit, +font-lock and imenu was added. + +This package is based on the original caml-mode for caml-light by +Xavier Leroy, extended with indentation by Ian Zimmerman. For details +see README.itz, which is the README from Ian Zimmerman's package. + +To use it, just put the .el files in your path, and add the following +three lines in your .emacs. + + (setq auto-mode-alist + (cons '("\\.ml[iylp]?$" . caml-mode) auto-mode-alist)) + (autoload 'caml-mode "caml" "Major mode for editing Caml code." t) + (autoload 'run-caml "inf-caml" "Run an inferior Caml process." t) + +I added camldebug.el from the original distribution, since there will +soon be a debugger for Objective Caml, but I do not know enough about +it. + +To install the mode itself, edit the Makefile and do + + % make install + +To install ocamltags, do + + % make install-ocamltags + +To use highlighting capabilities, add ONE of the following two lines +to your .emacs. The second one works better on recent versions of +emacs. + + (if window-system (require 'caml-hilit)) + (if window-system (require 'caml-font)) + +caml.el and inf-caml.el can be used collectively, but it might be a +good idea to copy caml-hilit.el or caml-font.el to you own directory, +and edit it to your taste and colors. + +Main key bindings: + +TAB indent current line +M-C-q indent phrase +M-C-h mark phrase +C-c C-a switch between interface and implementation +C-c C-c compile (usually make) +C-x` goto next error (also mouse button 2 in the compilation log) + +Once you have started caml by M-x run-caml: + +M-C-x send phrase to inferior caml process +C-c C-r send region to inferior caml process +C-c C-s show inferior caml process +C-c` goto error in expression sent by M-C-x + +For other bindings, see C-h b. + +Changes log: +----------- +Version 3.10.1: +--------------- +* use caml-font.el from Olivier Andrieu + old version is left as caml-font-old.el for compatibility + +Version 3.07: +------------- +* support for showing type information <Damien Doligez> + +Version 3.05: +------------- +* improved interaction with inferior caml mode + +* access help from the source + +* fixes in indentation code + +Version 3.03: +------------- +* process ;; properly + +Version 3.00: +------------- +* adapt to new label syntax + +* intelligent indentation of parenthesis + +Version 2.02: +------------- +* improved ocamltags <ITZ and JG> + +* added support for multibyte characters in emacs 20 + +Version 2.01+: +-------------- +* corrected a bug in caml-font.el <Adam P. Jenkins> + +* corrected abbreviations and added ocamltags script <Ian T Zimmerman> + +Version 2.01: +------------ +* code for interactive errors added by ITZ + +Version 2.00: +------------ +* changed the algorithm to skip comments + +* adapted for the new object syntax + +Version 1.07: +------------ +* next-error bug fix by John Malecki + +* camldebug.el modified by Xavier Leroy + +Version 1.06: +------------ +* new keywords in O'Caml 1.06 + +* compatibility with GNU Emacs 20 + +* changed from caml-imenu-disable to caml-imenu-enable (off by default) + +Version 1.05: +------------ +* a few indentation bugs corrected. let, val ... are now indented + correctly even when you write them at the beginning of a line. + +* added a Caml menu, and Imenu support. Imenu menu can be disabled + by setting the variable caml-imenu-disable to t. + Xemacs support for the Menu, but no Imenu. + +* key bindings closer to lisp-mode. + +* O'Labl compatibility (":" is part of words) may be switched off by + setting caml-olabl-disable to t. + +* camldebug.el was updated by Xavier Leroy. + +Version 1.03b: +------------- +* many bugs corrected. + +* (partial) compatibility with Caml-Light added. + (setq caml-quote-char "`") + (setq inferior-caml-program "camllight") + Literals will be correctly understood and highlighted. However, + indentation rules are still Objective Caml's: this just happens to + work well in most cases, but is only intended for occasional use. + +* as many people asked for it, application is now indented. This seems + to work well: this time differences in indentation between the + compiler's source and this mode are really exceptionnal. On the + other hand, you may think that some special cases are strange. No + miracle. + +* nicer behaviour when sending a phrase/region to the inferior caml + process. + +Version 1.03: +------------ +* support of Objective Caml and Objective Label. + +* an indentation very close to mine, which happens to be the same as + Xavier's, since the sources of the Objective Caml compiler do not + change if you indent them in this mode. + +* highlighting. + +Some remarks about the style supported: +-------------------------------------- + +Since Objective Caml's syntax is very liberal (more than 100 +shift-reduce conflicts with yacc), automatic indentation is far from +easy. Moreover, you expect the indentation to be not purely syntactic, +but also semantic: reflecting the meaning of your program. + +This mode tries to be intelligent. For instance some operators are +indented differently in the middle and at the end of a line (thanks to +Ian Zimmerman). Also, we do not indent after if .. then .. else, when +else is on the same line, to reflect that this idiom is equivalent to +a return instruction in a more imperative language, or after the in of +let .. in, since you may see that as an assignment. + +However, you may want to use a different indentation style. This is +made partly possible by a number of variables at the beginning of +caml.el. Try to set them. However this only changes the size of +indentations, not really the look of your program. This is enough to +disable the two idioms above, but to do anything more you will have to +edit the code... Enjoy! + +This mode does not force you to put ;; in your program. This means +that we had to use a heuristic to decide where a phrase starts and +stops, to speed up the code. A phrase starts when any of the keywords +let, type, class, module, functor, exception, val, external, appears +at the beginning of a line. Using the first column for such keywords +in other cases may confuse the phrase selection function. + +Comments and bug reports to + + Jacques Garrigue <garrigue@math.nagoya-u.ac.jp> diff --git a/ocaml-binary-annot/emacs/README.itz b/ocaml-binary-annot/emacs/README.itz new file mode 100644 index 0000000000..8e1366f478 --- /dev/null +++ b/ocaml-binary-annot/emacs/README.itz @@ -0,0 +1,177 @@ +DESCRIPTION: + +This directory contains files to help editing Caml code, running a +Caml toplevel, and running the Caml debugger under the Gnu Emacs editor. + +AUTHORS: + +Ian T Zimmerman <itz@rahul.net> added indentation to caml mode, beefed +up camldebug to work much like gud/gdb. + +Xavier Leroy (Xavier.Leroy@inria.fr), Jerome Vouillon (Jerome.Vouillon@ens.fr). +camldebug.el is derived from FSF code. + +CONTENTS: + + caml.el A major mode for editing Caml code in Gnu Emacs + inf-caml.el To run a Caml toplevel under Emacs, with input and + output in an Emacs buffer. + camldebug.el To run the Caml debugger under Emacs. + + +NOTE FOR EMACS 18 USERS: + +This package will no longer work with Emacs 18.x. Sorry. You really +should consider upgrading to Emacs 19. + +USAGE: + +Add the following lines to your .emacs file: + +(setq auto-mode-alist (cons '("\\.ml[iylp]?" . caml-mode) auto-mode-alist)) +(autoload 'caml-mode "caml" "Major mode for editing Caml code." t) +(autoload 'run-caml "inf-caml" "Run an inferior Caml process." t) +(autoload 'camldebug "camldebug" "Run the Caml debugger." t) + +The Caml major mode is triggered by visiting a file with extension .ml, +.mli, .mly. .mll or .mlp, or manually by M-x caml-mode. It gives you the +correct syntax table for the Caml language. For a brief description of +the indentation capabilities, see below under NEWS. + +The Caml mode also allows you to run batch Caml compilations from +Emacs (using M-x compile) and browse the errors (C-x `). Typing C-x ` +sets the point at the beginning of the erroneous program fragment, and +the mark at the end. Under Emacs 19, the program fragment is +temporarily highlighted. + +M-x run-caml starts a Caml toplevel with input and output in an Emacs +buffer named *inferior-caml*. This gives you the full power of Emacs +to edit the input to the Caml toplevel. This mode is based on comint +so you get all the usual comint features, including command history. + +After M-x run-caml, typing C-c C-e or M-C-x in a buffer in Caml mode +sends the current phrase (containing the point) to the Caml toplevel, +and evaluates it. + +M-x camldebug FILE starts the Caml debugger camldebug on the executable +FILE, with input and output in an Emacs buffer named *camldebug-FILE*. +For a brief description of the commands available in this buffer, see +NEWS below. + +NEWS: + +Ok, so this is the really important part of this file :-) I took the +original package from the contrib subdirectory of the caml-light +distribution, and hacked on it. First, I added real syntax dependent +indentation to caml mode. Like Xavier has said, it was hard (and I +knew it would be), but I refused to believe it was impossible, partly +because I knew of a Standard ML mode with indentation (written by +Matthew Morley). + +Indentation works pretty much like in other programming modes. C-j at +the end of a line starts a new line properly indented. M-C-\ indents +the current region (this may take a while :-)). I incorporated a +slightly different TAB function, one that I use in other modes: if TAB +is pressed while the point is not in line indentation, the line is +indented to the column where point is (instead of just inserting a TAB +character - you can always to that with C-q C-i). This way, you can +indent a line any time, regardless of where the point lies, by hitting +TAB twice in succession. If you don't like this behaviour (but you +should), it's quite easy to add to your startup code like this: + +(defun caml-old-style-indent () + (if (caml-in-indentation) + (caml-indent-command) + (insert "\t"))) + +(add-hook 'caml-mode-hook + (function (lambda () + (define-key 'caml-mode-map "\t" + caml-old-style-indent)))) + +You can customize the appearance of your caml code by twiddling the +variables listed at the start of caml.el. Good luck. :-) + +Other news in caml mode are the various caml-insert-*-form commands. I +believe they are self-explanatory - just do a C-h m in a caml buffer +to see what you've got. + +The ohter major news is that I changed camldebug mode considerably. I +took many clues from the gud "Grand Unified Debugger" mode distributed +with modern versions of Emacs. The main benefit here is that you can +do debugger commands _from your caml source buffer_. Commands with the +C-c prefix in the debugger buffer have counterparts which do the same +thing (well, a similar thing) in the source buffer, with the C-x C-a +prefix. + +I made the existing debugger commands smarter in that they now attempt +to guess the correct parameter to the underlying camldebug command. A +numeric argument will always override that guess. For example, the +guess for C-c C-b (camldebug-break) is to set a breakpoint at the +current event (which was the only behaviour provided with the old +camldebug.el). But C-u 1 C-c C-b will now send "break 1" to the +camldebug process, setting a break at code address 1. + +This also allowed me to add many more commands for which the +underlying camldebug commands require a parameter. The best way to +learn about them is to do C-h m in the camldebug buffer, and then C-h +f for the commands you'll see listed. + +Finally, I added command completion. To use it, you'll have to apply +the provided patch to the debugger itself +(contrib/debugger/command_line_interpreter.ml), and recompile it +(you'll get one warning from the compiler; it is safe to ignore +it). Then hitting TAB in the following situation, for example: + +(cdb) pri_ + +will complete the "pri" to "print". + +CAVEATS: + +I don't use X and haven't tested this stuff under the X mode of +emacs. It is entirely possible (though not very probable) that I +introduced some undesirable interaction between X (fontification, +highlighting,...) and caml mode. I will welcome reports of such +problems (see REPORTING below), but I won't be able to do much about +them unless you also provide a patch. + +I don't know if the informational messages produced by camldebug are +internationalized. If they are, the debugger mode won't work unless +you set the language to English. The mode uses the messages to +synchronize with camldebug, and looks for fixed Emacs regular +expressions that match them. This may be fixed (if necessary) in a +future release. + +BUGS: + +In the debugger buffer, it's possible to overflow your mental stack by +asking for help on help on help on help on help on help on help on +help... + +THANKS: + +Xavier Leroy <Xavier.Leroy@inria.fr> for Caml-light. Used together with the +Emacs interface, it is about the most pleasant programming environment +I've known on any platform. + +Eric Raymond <esr@thyrsus.com> for gud, which camldebug mode apes. + +Barry Warsaw <bwarsaw@cen.com> for elp, without which I wouldn't have +been able to get the indentation code to perform acceptably. + +Gareth Rees <Gareth.Rees@cl.cam.ac.uk> for suggestions how to speed up +Emacs regular expression search, even if I didn't use them in the end. + +Bill Dubuque <wgd@martigny.ai.mit.edu> for alerting me to the +necessity of guarding against C-g inside Emacs code which modifies +syntax tables. + +REPORTING: + +Bug reports (preferably with patches), suggestions, donations etc. to: + +Ian T Zimmerman +-------------------------------------------+ +Box 13445 I With so many executioners available, I +Berkeley CA 94712 USA I suicide is a really foolish thing to do. I +mailto:itz@rahul.net +-------------------------------------------+ diff --git a/ocaml-binary-annot/emacs/caml-compat.el b/ocaml-binary-annot/emacs/caml-compat.el new file mode 100644 index 0000000000..8ba7a99c7e --- /dev/null +++ b/ocaml-binary-annot/emacs/caml-compat.el @@ -0,0 +1,41 @@ +;(***********************************************************************) +;(* *) +;(* Objective Caml *) +;(* *) +;(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +;(* *) +;(* Copyright 1998 Institut National de Recherche en Informatique et *) +;(* en Automatique. All rights reserved. This file is distributed *) +;(* under the terms of the GNU General Public License. *) +;(* *) +;(***********************************************************************) + +;(* $Id$ *) + +;; function definitions for old versions of emacs + +;; indent-line-to + +(if (not (fboundp 'indent-line-to)) + (defun indent-line-to (column) + "Indent current line to COLUMN. + +This function removes or adds spaces and tabs at beginning of line +only if necessary. It leaves point at end of indentation." + (if (= (current-indentation) column) + (back-to-indentation) + (beginning-of-line 1) + (delete-horizontal-space) + (indent-to column)))) + +;; buffer-substring-no-properties + +(cond + ((fboundp 'buffer-substring-no-properties)) + ((fboundp 'buffer-substring-without-properties) + (defalias 'buffer-substring-no-properties + 'buffer-substring-without-properties)) + (t + (defalias 'buffer-substring-no-properties 'buffer-substring))) + +(provide 'caml-compat) diff --git a/ocaml-binary-annot/emacs/caml-emacs.el b/ocaml-binary-annot/emacs/caml-emacs.el new file mode 100644 index 0000000000..d034ff304a --- /dev/null +++ b/ocaml-binary-annot/emacs/caml-emacs.el @@ -0,0 +1,43 @@ +;(***********************************************************************) +;(* *) +;(* Objective Caml *) +;(* *) +;(* Didier Remy, projet Cristal, INRIA Rocquencourt *) +;(* *) +;(* Copyright 2003 Institut National de Recherche en Informatique et *) +;(* en Automatique. All rights reserved. This file is distributed *) +;(* under the terms of the GNU General Public License. *) +;(* *) +;(***********************************************************************) + +;(* $Id$ *) + +;; for caml-help.el +(defalias 'caml-info-other-window 'info-other-window) + +;; for caml-types.el + +(defalias 'caml-line-beginning-position 'line-beginning-position) + +(defalias 'caml-read-event 'read-event) +(defalias 'caml-window-edges 'window-edges) +(defun caml-mouse-vertical-position () + (cddr (mouse-position))) +(defalias 'caml-ignore-event-p 'integer-or-marker-p) +(defalias 'caml-mouse-movement-p 'mouse-movement-p) +(defalias 'caml-sit-for 'sit-for) + +(defmacro caml-track-mouse (&rest body) (cons 'track-mouse body)) + +(defun caml-event-window (e) (posn-window (event-start e))) +(defun caml-event-point-start (e) (posn-point (event-start e))) +(defun caml-event-point-end (e) (posn-point (event-end e))) + +(defun caml-release-event-p (original event) + (and (equal (event-basic-type original) (event-basic-type event)) + (let ((modifiers (event-modifiers event))) + (or (member 'drag modifiers) + (member 'click modifiers))))) + + +(provide 'caml-emacs) diff --git a/ocaml-binary-annot/emacs/caml-font-old.el b/ocaml-binary-annot/emacs/caml-font-old.el new file mode 100644 index 0000000000..8faa542f05 --- /dev/null +++ b/ocaml-binary-annot/emacs/caml-font-old.el @@ -0,0 +1,141 @@ +;(***********************************************************************) +;(* *) +;(* Objective Caml *) +;(* *) +;(* Jacques Garrigue and Ian T Zimmerman *) +;(* *) +;(* Copyright 1997 Institut National de Recherche en Informatique et *) +;(* en Automatique. All rights reserved. This file is distributed *) +;(* under the terms of the GNU General Public License. *) +;(* *) +;(***********************************************************************) + +;(* $Id$ *) + +;; useful colors + +(cond + ((x-display-color-p) + (require 'font-lock) + (cond + ((not (boundp 'font-lock-type-face)) + ; make the necessary faces + (make-face 'Firebrick) + (set-face-foreground 'Firebrick "Firebrick") + (make-face 'RosyBrown) + (set-face-foreground 'RosyBrown "RosyBrown") + (make-face 'Purple) + (set-face-foreground 'Purple "Purple") + (make-face 'MidnightBlue) + (set-face-foreground 'MidnightBlue "MidnightBlue") + (make-face 'DarkGoldenRod) + (set-face-foreground 'DarkGoldenRod "DarkGoldenRod") + (make-face 'DarkOliveGreen) + (set-face-foreground 'DarkOliveGreen "DarkOliveGreen4") + (make-face 'CadetBlue) + (set-face-foreground 'CadetBlue "CadetBlue") + ; assign them as standard faces + (setq font-lock-comment-face 'Firebrick) + (setq font-lock-string-face 'RosyBrown) + (setq font-lock-keyword-face 'Purple) + (setq font-lock-function-name-face 'MidnightBlue) + (setq font-lock-variable-name-face 'DarkGoldenRod) + (setq font-lock-type-face 'DarkOliveGreen) + (setq font-lock-reference-face 'CadetBlue))) + ; extra faces for documention + (make-face 'Stop) + (set-face-foreground 'Stop "White") + (set-face-background 'Stop "Red") + (make-face 'Doc) + (set-face-foreground 'Doc "Red") + (setq font-lock-stop-face 'Stop) + (setq font-lock-doccomment-face 'Doc) +)) + +; The same definition is in caml.el: +; we don't know in which order they will be loaded. +(defvar caml-quote-char "'" + "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.") + +(defconst caml-font-lock-keywords + (list +;stop special comments + '("\\(^\\|[^\"]\\)\\((\\*\\*/\\*\\*)\\)" + 2 font-lock-stop-face) +;doccomments + '("\\(^\\|[^\"]\\)\\((\\*\\*[^*]*\\([^)*][^*]*\\*+\\)*)\\)" + 2 font-lock-doccomment-face) +;comments + '("\\(^\\|[^\"]\\)\\((\\*[^*]*\\*+\\([^)*][^*]*\\*+\\)*)\\)" + 2 font-lock-comment-face) +;character literals + (cons (concat caml-quote-char "\\(\\\\\\([ntbr" caml-quote-char "\\]\\|" + "[0-9][0-9][0-9]\\)\\|.\\)" caml-quote-char + "\\|\"[^\"\\]*\\(\\\\\\(.\\|\n\\)[^\"\\]*\\)*\"") + 'font-lock-string-face) +;modules and constructors + '("`?\\<[A-Z][A-Za-z0-9_']*\\>" . font-lock-function-name-face) +;definition + (cons (concat + "\\<\\(a\\(nd\\|s\\)\\|c\\(onstraint\\|lass\\)" + "\\|ex\\(ception\\|ternal\\)\\|fun\\(ct\\(ion\\|or\\)\\)?" + "\\|in\\(herit\\|itializer\\)?\\|let" + "\\|m\\(ethod\\|utable\\|odule\\)" + "\\|of\\|p\\(arser\\|rivate\\)\\|rec\\|type" + "\\|v\\(al\\|irtual\\)\\)\\>") + 'font-lock-type-face) +;blocking + '("\\<\\(begin\\|end\\|object\\|s\\(ig\\|truct\\)\\)\\>" + . font-lock-keyword-face) +;control + (cons (concat + "\\<\\(do\\(ne\\|wnto\\)?\\|else\\|for\\|i\\(f\\|gnore\\)" + "\\|lazy\\|match\\|new\\|or\\|t\\(hen\\|o\\|ry\\)" + "\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\)\\>" + "\\|\|\\|->\\|&\\|#") + 'font-lock-reference-face) + '("\\<raise\\>" . font-lock-comment-face) +;labels (and open) + '("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" 1 + font-lock-variable-name-face) + '("\\<\\(assert\\|open\\|include\\)\\>\\|[~?][ (]*[a-z][a-zA-Z0-9_']*" + . font-lock-variable-name-face))) + +(defconst inferior-caml-font-lock-keywords + (append + (list +;inferior + '("^[#-]" . font-lock-comment-face)) + caml-font-lock-keywords)) + +;; font-lock commands are similar for caml-mode and inferior-caml-mode +(defun caml-mode-font-hook () + (cond + ((fboundp 'global-font-lock-mode) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults + '(caml-font-lock-keywords nil nil ((?' . "w") (?_ . "w"))))) + (t + (setq font-lock-keywords caml-font-lock-keywords))) + (make-local-variable 'font-lock-keywords-only) + (setq font-lock-keywords-only t) + (font-lock-mode 1)) + +(add-hook 'caml-mode-hook 'caml-mode-font-hook) + +(defun inferior-caml-mode-font-hook () + (cond + ((fboundp 'global-font-lock-mode) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults + '(inferior-caml-font-lock-keywords + nil nil ((?' . "w") (?_ . "w"))))) + (t + (setq font-lock-keywords inferior-caml-font-lock-keywords))) + (make-local-variable 'font-lock-keywords-only) + (setq font-lock-keywords-only t) + (font-lock-mode 1)) + +(add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-font-hook) + +(provide 'caml-font) diff --git a/ocaml-binary-annot/emacs/caml-font.el b/ocaml-binary-annot/emacs/caml-font.el new file mode 100644 index 0000000000..f287ffa045 --- /dev/null +++ b/ocaml-binary-annot/emacs/caml-font.el @@ -0,0 +1,114 @@ +;; caml-font: font-lock support for OCaml files +;; +;; rewrite and clean-up. +;; Changes: +;; - fontify strings and comments using syntactic font lock +;; - define a `font-lock-syntactic-face-function' to fontify ocamldoc comments +;; - fontify infix operators like mod, land, lsl, etc. +;; - fontify line number directives +;; - fontify "failwith" and "invalid_arg" like "raise" +;; - fontify '\x..' character constants +;; - use the regexp-opt function to build regexps (more readable) +;; - use backquote and comma in sexp (more readable) +;; - drop the `caml-quote-char' variable (I don't use caml-light :)) +;; - stop doing weird things with faces + + +(require 'font-lock) + +(defvar caml-font-stop-face + (progn + (make-face 'caml-font-stop-face) + (set-face-foreground 'caml-font-stop-face "White") + (set-face-background 'caml-font-stop-face "Red") + 'caml-font-stop-face)) + +(defvar caml-font-doccomment-face + (progn + (make-face 'caml-font-doccomment-face) + (set-face-foreground 'caml-font-doccomment-face "Red") + 'caml-font-doccomment-face)) + +(unless (facep 'font-lock-preprocessor-face) + (defvar font-lock-preprocessor-face + (copy-face 'font-lock-builtin-face + 'font-lock-preprocessor-face))) + +(defconst caml-font-lock-keywords + `( +;character literals + ("'\\(.\\|\\\\\\([ntbr\"'\\\\]\\|[0-9]\\{3\\}\\|x[0-9A-Fa-f]\\{2\\}\\)\\)'" + . font-lock-string-face) +;modules and constructors + ("`?\\<[A-Z][A-Za-z0-9_']*\\>" . font-lock-function-name-face) +;definition + (,(regexp-opt '("and" "as" "constraint" "class" + "exception" "external" "fun" "function" "functor" + "in" "inherit" "initializer" "let" + "method" "mutable" "module" "of" "private" "rec" + "type" "val" "virtual") + 'words) + . font-lock-type-face) +;blocking + (,(regexp-opt '("begin" "end" "object" "sig" "struct") 'words) + . font-lock-keyword-face) +;linenums + ("# *[0-9]+" . font-lock-preprocessor-face) +;infix operators + (,(regexp-opt '("asr" "land" "lor" "lsl" "lsr" "lxor" "mod") 'words) + . font-lock-builtin-face) +;control + (,(concat "[|#&]\\|->\\|" + (regexp-opt '("do" "done" "dowto" "else" "for" "if" "ignore" + "lazy" "match" "new" "or" "then" "to" "try" + "when" "while" "with") + 'words)) + . font-lock-constant-face) + ("\\<raise\\|failwith\\|invalid_arg\\>" + . font-lock-comment-face) +;labels (and open) + ("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" + 1 font-lock-variable-name-face) + ("\\<\\(assert\\|open\\|include\\)\\>\\|[~?][ (]*[a-z][a-zA-Z0-9_']*" + . font-lock-variable-name-face))) + + +(defun caml-font-syntactic-face (s) + (let ((in-string (nth 3 s)) + (in-comment (nth 4 s)) + (start (nth 8 s))) + (cond + (in-string 'font-lock-string-face) + (in-comment + (save-excursion + (goto-char start) + (cond + ((looking-at "(\\*\\*/\\*\\*)") 'caml-font-stop-face) + ((looking-at "(\\*\\*[^*]") 'caml-font-doccomment-face) + (t 'font-lock-comment-face))))))) + + +;; font-lock commands are similar for caml-mode and inferior-caml-mode +(defun caml-font-set-font-lock () + (setq font-lock-defaults + '(caml-font-lock-keywords + nil nil nil nil + (font-lock-syntactic-face-function . caml-font-syntactic-face))) + (font-lock-mode 1)) +(add-hook 'caml-mode-hook 'caml-font-set-font-lock) + + + +(defconst inferior-caml-font-lock-keywords + `(("^[#-]" . font-lock-comment-face) + ,@caml-font-lock-keywords)) + +(defun inferior-caml-set-font-lock () + (setq font-lock-defaults + '(inferior-caml-font-lock-keywords + nil nil nil nil + (font-lock-syntactic-face-function . caml-font-syntactic-face))) + (font-lock-mode 1)) +(add-hook 'inferior-caml-mode-hooks 'inferior-caml-set-font-lock) + +(provide 'caml-font) diff --git a/ocaml-binary-annot/emacs/caml-help.el b/ocaml-binary-annot/emacs/caml-help.el new file mode 100644 index 0000000000..59d8a3b0c5 --- /dev/null +++ b/ocaml-binary-annot/emacs/caml-help.el @@ -0,0 +1,855 @@ +;(***********************************************************************) +;(* *) +;(* Objective Caml *) +;(* *) +;(* Didier Remy, 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 General Public License. *) +;(* *) +;(***********************************************************************) + +;(* $Id$ *) + +;; caml-info.el --- contextual completion and help to caml-mode + +;; Didier Remy, November 2001. + +;; This provides two functions completion and help +;; look for caml-complete and caml-help + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This is a preliminary version. +;; +;; Possible improvements? +;; - dump some databaes: Info, Lib, ... +;; - accept a search path for local libraries instead of current dir +;; (then distinguish between different modules lying in different +;; directories) +;; - improve the construction for info files. +;; +;; Abstract over +;; - the viewing method and the database, so that the documentation for +;; and identifier could be search in +;; * info / html / man / mli's sources +;; * viewed in emacs or using an external previewer. +;; +;; Take all identifiers (labels, Constructors, exceptions, etc.) +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(eval-and-compile + (if (and (boundp 'running-xemacs) running-xemacs) + (require 'caml-xemacs) + (require 'caml-emacs))) + +;; Loading or building databases. +;; + +;; variables to be customized + +(defvar ocaml-lib-path 'lazy + "Path list for ocaml lib sources (mli files) + +'lazy means ask ocaml to find it for your at first use.") +(defun ocaml-lib-path () + "Computes if necessary and returns the path for ocaml libs" + (if (listp ocaml-lib-path) nil + (setq ocaml-lib-path + (split-string + (shell-command-to-string + (or + (and (boundp 'inferior-caml-program) + (string-match "\\([^ ]*/ocaml\\)\\( \\|$\\)" + inferior-caml-program) + (let ((file + (concat (match-string 1 inferior-caml-program) + "c"))) + (and (file-executable-p file) + (concat file " -where")))) + "ocamlc -where"))))) + ocaml-lib-path) + + + +;; General purpose auxiliary functions + +(defun ocaml-capitalize (s) + (concat (capitalize (substring s 0 1)) (substring s 1))) + +(defun ocaml-uncapitalize (s) + (if (> (length s) 0) + (concat (downcase (substring s 0 1)) (substring s 1)) + s)) + +(defun iter (f l) (while (consp l) (apply f (list (car l))) (setq l (cdr l)))) + +(defun ocaml-find-files (path filter &optional depth split) + (let* ((path-string + (if (stringp path) + (if (file-directory-p path) path nil) + (mapconcat '(lambda (d) (if (file-directory-p d) d)) + path " "))) + (command + (and path-string + (concat "find " path-string + " '(' " filter " ')' " + (if depth (concat " -maxdepth " (int-to-string depth))) + (if split nil " -printf '%\p '") + ))) + (files + (and command (shell-command-to-string command)))) + (if (and split (stringp files)) (split-string files "\n") files) + )) + +;; Specialized auxiliary functions + + +;; Global table of modules contents of modules loaded lazily. + +(defvar ocaml-module-alist 'lazy + "A-list of modules with how and where to find help information. + 'delay means non computed yet") + +(defun ocaml-add-mli-modules (modules tag &optional path) + (let ((files + (ocaml-find-files (or path (ocaml-lib-path)) + "-type f -name '*.mli'" 1 t))) + (while (consp files) + (if (string-match "\\([^/]*\\).mli" (car files)) + (let* ((module (ocaml-capitalize (match-string 1 (car files)))) + (dir (file-name-directory (car files))) + (dirp (member dir (ocaml-lib-path)))) + (if (and (consp dirp) (string-equal dir (car dirp))) + (setq dir (car dirp))) + (if (assoc module modules) nil + (setq modules + (cons (cons module (cons (cons tag dir) 'lazy)) modules)) + ))) + (setq files (cdr files))) + modules)) + +(defun ocaml-add-path (dir &optional path) + "Extend ocaml-module-alist with modules of DIR relative to PATH" + (interactive "D") + (let* ((old (ocaml-lib-path)) + (new + (if (file-name-absolute-p dir) dir + (concat + (or (find-if '(lambda (p) (file-directory-p (concat p "/" dir))) + (cons default-directory old)) + (error "Directory not found")) + "/" dir)))) + (setq ocaml-lib-path (cons (car old) (cons new (cdr old)))) + (setq ocaml-module-alist + (ocaml-add-mli-modules (ocaml-module-alist) 'lib new)))) + +(defun ocaml-module-alist () + "Call by need value of variable ocaml-module-alist" + (if (listp ocaml-module-alist) + nil + ;; build list of mli files + (setq ocaml-module-alist (ocaml-add-mli-modules nil 'lib)) + ;; dumping information ? TODO + ) + ocaml-module-alist) + +(defun ocaml-get-or-make-module (module &optional tag) + (let ((info (assoc module (ocaml-module-alist)))) + (if info nil + (setq info (cons module (cons (cons 'local default-directory) 'lazy))) + (setq ocaml-module-alist (cons info ocaml-module-alist)) + ) + info)) + +;; Symbols of module are lazily computed + +(defun ocaml-module-filename (module) + (let ((module (ocaml-uncapitalize module)) (name)) + (if (file-exists-p (setq name (concat module ".mli"))) nil + (let ((tmp (ocaml-lib-path))) + (while (consp tmp) + (setq name (concat (car tmp) "/" module ".mli")) + (if (file-exists-p name) (setq tmp nil) + (setq name nil))))) + name)) + +(defun ocaml-module-symbols (module-info) + (let* ((module (car module-info)) + (tail (and module-info (cdr module-info))) + (tag (caar tail)) + (dir (cdar tail)) + (file) + (alist)) + (if (listp (cdr tail)) + (cdr tail) + (if (equal tag 'info) + (setq dir (car ocaml-lib-path)) ; XXX to be fixed + ) + (setq file (concat dir "/" (ocaml-uncapitalize module) ".mli")) + (message file) + (save-window-excursion + (set-buffer (get-buffer-create "*caml-help*")) + (if (and file (file-exists-p file)) + (progn + (message "Scanning module %s" file) + (insert-file-contents file)) + (message "Module %s not found" module)) + (while (re-search-forward + "\\([ \t]*val\\|let\\|exception\\|external\\| [|]\\) \\([a-zA-Z_0-9'][a-zA-Z_0-9']*\\)\\|^ *[{]* \\([a-z_][A-Za-z_0-9]*\\) : [^;\n][^;\n]*;" + (point-max) 'move) + (pop-to-buffer (current-buffer)) + (setq alist (cons (or (match-string 2) (match-string 3)) alist))) + (erase-buffer) + ) + (setcdr tail alist) + alist) + )) + +;; Local list of visible modules. + +(defvar ocaml-visible-modules 'lazy + "A-list of open modules, local to every file.") +(make-variable-buffer-local 'ocaml-visible-modules) +(defun ocaml-visible-modules () + (if (listp ocaml-visible-modules) nil + (progn + (setq ocaml-visible-modules + (list (ocaml-get-or-make-module "Pervasives"))) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^ *open *\\([A-Z][a-zA-Z'_0-9]*\\)" + (point-max) t) + (let ((module (match-string 1))) + (if (assoc module ocaml-visible-modules) nil + (setq ocaml-visible-modules + (cons (ocaml-get-or-make-module module) + ocaml-visible-modules))))) + ))) + ocaml-visible-modules) + +(defun ocaml-open-module (arg) + "*Make module of name ARG visible whe ARG is a string. +When call interactively, make completion over known modules." + (interactive "P") + (if (not (stringp arg)) + (let ((modules (ocaml-module-alist))) + (setq arg + (completing-read "Open module: " modules)))) + (if (and (stringp arg) (not (equal arg ""))) + (progn + (if (assoc arg (ocaml-visible-modules)) + (ocaml-close-module arg)) + (setq ocaml-visible-modules + (cons (ocaml-get-or-make-module arg) (ocaml-visible-modules))) + )) + (message "%S" (mapcar 'car (ocaml-visible-modules)))) + +(defun ocaml-close-module (arg) + "*Close module of name ARG when ARG is a string. +When call interactively, make completion over visible modules. +Otherwise if ARG is true, close all modules and reset to default. " + (interactive "P") + (if (= (prefix-numeric-value arg) 4) + (setq ocaml-visible-modules 'lazy) + (let* ((modules (ocaml-visible-modules))) + (if (null modules) (error "No visible module to close")) + (unless (stringp arg) + (setq arg + (completing-read + (concat "Close module [" (caar modules) "] : ") + modules)) + (if (equal arg "") (setq arg (caar modules)))) + (setq ocaml-visible-modules + (remove-if '(lambda (m) (equal (car m) arg)) + ocaml-visible-modules)) + )) + (message "%S" (mapcar 'car (ocaml-visible-modules)))) + + +;; Look for identifiers around point + +(defun ocaml-qualified-identifier (&optional show) + "Search for a qualified identifier (Path. entry) around point. + +Entry may be nil. +Currently, the path may only be nil or a single Module. +For paths is of the form Module.Path', it returns Module +and always nil for entry. + +If defined Module and Entry are represented by a region in the buffer, +and are nil otherwise. + +For debugging purposes, it returns the string Module.entry if called +with an optional non-nil argument. +" + (save-excursion + (let ((module) (entry)) + (if (looking-at "[ \n]") (skip-chars-backward " ")) + (if (re-search-backward + "\\([^A-Za-z0-9_.']\\|\\`\\)\\([A-Za-z0-9_']*[.]\\)*[A-Za-z0-9_']*\\=" + (- (point) 100) t) + (progn + (or (looking-at "\\`[A-Za-z)-9_.]") (forward-char 1)) + (if (looking-at "\\<\\([A-Za-z_][A-Za-z0-9_']*\\)[.]") + (progn + (setq module (cons (match-beginning 1) (match-end 1))) + (goto-char (match-end 0)))) + (if (looking-at "\\<\\([A-Za-z_][A-Za-z0-9_']*\\)\\>") + (setq entry (cons (match-beginning 1) (match-end 1)))))) + (if show + (concat + (and module (buffer-substring (car module) (cdr module))) + "." + (and entry (buffer-substring (car entry) (cdr entry)))) + (cons module entry)) + ))) + +;; completion around point + +(defun ocaml-completion (pattern module) + (let ((list + (or + (and module + (list + (or (assoc module (ocaml-module-alist)) + (error "Unknown module %s" module)))) + (ocaml-visible-modules)))) + (message "Completion from %s" (mapconcat 'car list " ")) + (if (null pattern) + (apply 'append (mapcar 'ocaml-module-symbols list)) + (let ((pat (concat "^" (regexp-quote pattern))) (res)) + (iter + '(lambda (l) + (iter '(lambda (x) + (if (string-match pat (car l)) + (if (member x res) nil (setq res (cons x res))))) + (ocaml-module-symbols l))) + list) + res) + ))) + +(defun caml-complete (arg) + "Does completion for OCaml identifiers qualified. + +It attemps to recognize an qualified identifier Module . entry +around point using function \\[ocaml-qualified-identifier]. + +If Module is defined, it does completion for identifier in Module. + +If Module is undefined, it does completion in visible modules. +Then, if completion fails, it does completion among all modules +where identifier is defined." + (interactive "p") + (let* ((module-entry (ocaml-qualified-identifier)) (entry) + (module) + (beg) (end) (pattern)) + (if (car module-entry) + (progn + (setq module + (buffer-substring (caar module-entry) (cdar module-entry))) + (or (assoc module (ocaml-module-alist)) + (and (setq module + (completing-read "Module: " (ocaml-module-alist) + nil nil module)) + (save-excursion + (goto-char (caar module-entry)) + (delete-region (caar module-entry) (cdar module-entry)) + (insert module) t) + (setq module-entry (ocaml-qualified-identifier)) + (car module-entry) + (progn (setq entry (cdr module-entry)) t)) + (error "Unknown module %s" module)))) + (if (consp (cdr module-entry)) + (progn + (setq beg (cadr module-entry)) + (setq end (cddr module-entry))) + (if (and module + (save-excursion + (goto-char (cdar module-entry)) + (looking-at " *[.]"))) + (progn + (setq beg (match-end 0)) + (setq end beg)))) + (if (not (and beg end)) + (error "Did not find anything to complete around point") + + (setq pattern (buffer-substring beg end)) + (let* ((all-completions (ocaml-completion pattern module)) + (completion + (try-completion pattern (mapcar 'list all-completions)))) + (cond ((eq completion t)) + + ((null completion) + (let* + ((modules (ocaml-find-module pattern)) + (visible (intersection modules (ocaml-visible-modules))) + (hist) + (module + (cond + ((null modules) + nil) + ((equal (length modules) 1) + (caar modules)) + ((equal (length visible) 1) + (caar visible)) + (t + (setq hist (mapcar 'car modules)) + (completing-read "Module: " modules nil t + "" (cons hist 0))) + ))) + (if (null module) + (error "Can't find completion for \"%s\"" pattern) + (message "Completion found in module %s" module) + (if (and (consp module-entry) (consp (cdr module-entry))) + (delete-region (caar module-entry) end) + (delete-region beg end)) + (insert module "." pattern)))) + + ((not (string-equal pattern completion)) + (delete-region beg end) + (goto-char beg) + (insert completion)) + + (t + (with-output-to-temp-buffer "*Completions*" + (display-completion-list all-completions)) + )) + )))) + + +;; Info files (only in ocamldoc style) + + +(defvar ocaml-info-prefix "ocaml-lib" + "Prefix of ocaml info files describing library modules. +Suffix .info will be added to info files. +Additional suffix .gz may be added if info files are compressed. +") +;; + +(defun ocaml-hevea-info-add-entries (entries dir name) + (let* + ((filter + (concat "-type f -regex '.*/" name + "\\(.info\\|\\)\\(-[0-9]*\\|\\)\\([.]gz\\|\\)'" + )) + (section-regexp + "\\* \\(Section [1-9][0-9--]*\\)::[ \t][ \t]*Module *\\([A-Z][A-Za-z_0-9]*\\)") + (files (ocaml-find-files dir filter)) + (command)) + ;; scanning info files + (if (or (null files) + (not (stringp files)) + (string-match files "^ *$")) + (message "No info file found: %s." (mapconcat 'identity files " ")) + (message "Scanning info files %s." files) + (save-window-excursion + (set-buffer (get-buffer-create "*caml-help*")) + (setq command + (concat "zcat -f " files + " | grep -e '" section-regexp "'")) + (message "Scanning files with: %s" command) + (or (shell-command command (current-buffer)) + (error "Error while scanning")) + (goto-char (point-min)) + (while (re-search-forward section-regexp (point-max) t) + (let* ((module (match-string 2)) + (section (match-string 1))) + ;; (message "%s %s" module section) + (if (assoc module entries) nil + (setq entries + (cons (cons module (concat "(" name ")" section)) + entries)) + ))) + (let ((buf (get-buffer "*caml-help*"))) + (if buf (kill-buffer buf))))) + entries)) + +(defun ocaml-hevea-info () + "The default way to create an info data base from the value +of \\[Info-default-directory-list] and the base name \\[ocaml-info-name] +of files to look for. + +This uses info files produced by HeVeA. +" + (let ((collect) (seen)) + (iter '(lambda (d) + (if (member d seen) nil + (setq collect + (ocaml-hevea-info-add-entries + collect d ocaml-info-prefix)) + (setq done (cons d seen)))) + Info-directory-list) + collect)) + +(defun ocaml-ocamldoc-info-add-entries (entries dir name) + (let* + ((module-regexp "^Node: \\([A-Z][A-Za-z_0-9]*\\)[^ ]") + (command + (concat + "find " dir " -type f -regex '.*/" name + "\\(.info\\|\\)\\([.]gz\\|\\)' -print0" + " | xargs -0 zcat -f | grep '" module-regexp "'"))) + (message "Scanning info files in %s" dir) + (save-window-excursion + (set-buffer (get-buffer-create "*caml-help*")) + (or (shell-command command (current-buffer)) + (error "Could not run:%s" command)) + (goto-char (point-min)) + (while (re-search-forward module-regexp (point-max) t) + (if (equal (char-after (match-end 1)) 127) + (let* ((module (match-string 1))) + (if (assoc module entries) nil + (setq entries + (cons (cons module (concat "(" name ")" module)) + entries)) + )))) + ; (kill-buffer (current-buffer)) + ) + entries)) + +(defun ocaml-ocamldoc-info () + "The default way to create an info data base from the value +of \\[Info-default-directory-list] and the base name \\[ocaml-info-name] +of files to look for. + +This uses info files produced by ocamldoc." + (require 'info) + (let ((collect) (seen)) + (iter '(lambda (d) + (if (member d seen) nil + (setq collect + (ocaml-ocamldoc-info-add-entries collect d + ocaml-info-prefix)) + (setq done (cons d seen)))) + Info-directory-list) + collect)) + +;; Continuing + +(defvar ocaml-info-alist 'ocaml-ocamldoc-info + "A-list binding module names to info entries: + + nil means do not use info. + + A function to build the list lazily (at the first call). The result of +the function call will be assign permanently to this variable for future +uses. We provide two default functions \\[ocaml-info-default-function] +(info produced by HeVeA is the default) and \\[ocaml-info-default-function] +(info produced by ocamldoc). + + Otherwise, this value should be an alist binding module names to info +entries of the form to \"(entry)section\" be taken by the \\[info] +command. An entry may be an info module or a complete file name." +) + +(defun ocaml-info-alist () + "Call by need value of variable ocaml-info-alist" + (cond + ((listp ocaml-info-alist)) + ((functionp ocaml-info-alist) + (setq ocaml-info-alist (apply ocaml-info-alist nil))) + (t + (error "wrong type for ocaml-info-alist"))) + ocaml-info-alist) + +;; help around point + +(defun ocaml-find-module (symbol &optional module-list) + (let ((list (or module-list (ocaml-module-alist))) + (collect)) + (while (consp list) + (if (member symbol (ocaml-module-symbols (car list))) + (setq collect (cons (car list) collect))) + (setq list (cdr list))) + (nreverse collect) + )) + +(defun ocaml-buffer-substring (region) + (and region (buffer-substring-no-properties (car region) (cdr region)))) + +;; Help function. + + +(defun ocaml-goto-help (&optional module entry same-window) + "Searches info manual for MODULE and ENTRY in MODULE. +If unspecified, MODULE and ENTRY are inferred from the position in the +current buffer using \\[ocaml-qualified-identifier]." + (interactive) + (let ((window (selected-window)) + (info-section (assoc module (ocaml-info-alist)))) + (if info-section + (caml-info-other-window (cdr info-section)) + (ocaml-visible-modules) + (let* ((module-info + (or (assoc module (ocaml-module-alist)) + (and (file-exists-p + (concat (ocaml-uncapitalize module) ".mli")) + (ocaml-get-or-make-module module)))) + (location (cdr (cadr module-info)))) + (cond + (location + (let ((file (concat location (ocaml-uncapitalize module) ".mli"))) + (if (window-live-p same-window) + (progn (select-window same-window) + (view-mode-exit view-return-to-alist view-exit-action)) + ;; (view-buffer (find-file-noselect file) 'view)) + ) + (view-file-other-window file) + (bury-buffer (current-buffer)))) + (info-section (error "Aborted")) + (t (error "No help for module %s" module)))) + ) + (if (stringp entry) + (let ((here (point)) + (regex (regexp-quote entry)) + (case-fold-search nil)) + (goto-char (point-min)) + (if (or (re-search-forward + (concat "\\(val\\|exception\\|type\\|external\\|[|{;]\\) +" + regex) + ;; (concat "\\(val\\|exception\\|external\\) +\\(" + ;; regex "\\|( *" regex " *)\\)") + (point-max) t) + (re-search-forward + (concat "type [^{]*{[^}]*" regex " :") + ;; (concat "\\(type\\|[|{;]\\) +" regex) + (point-max) t) + (progn + (if (window-live-p window) (select-window window)) + (error "Entry %s not found in module %s" + entry module)) + ;; (search-forward entry (point-max) t) + ) + (ocaml-help-show -1) + (progn + (message "Help for entry %s not found in module %s" + entry module) + (goto-char here))) + )) + (ocaml-link-activate (cdr info-section)) + (if (window-live-p window) (select-window window)) + )) + +(defun caml-help (arg) + "Find documentation for OCaml qualified identifiers. + +It attemps to recognize an qualified identifier of the form +``Module . entry'' around point using function `ocaml-qualified-identifier'. + +If Module is undetermined it is temptatively guessed from the identifier name +and according to visible modules. If this is still unsucessful, the user is +then prompted for a Module name. + +The documentation for Module is first seach in the info manual if available, +then in the ``module.mli'' source file. The entry is then searched in the +documentation. + +Visible modules are computed only once, at the first call. +Modules can be made visible explicitly with `ocaml-open-module' and +hidden with `ocaml-close-module'. + +Prefix arg 0 forces recompilation of visible modules (and their content) +from the file content. + +Prefix arg 4 prompts for Module and identifier instead of guessing values +from the possition of point in the current buffer. +" + (interactive "p") + (delete-overlay ocaml-help-ovl) + (let ((module) (entry) (module-entry)) + (cond + ((= arg 4) + (or (and + (setq module + (completing-read "Module: " (ocaml-module-alist) + nil t "" (cons 'hist 0))) + (not (string-equal module ""))) + (error "Quit")) + (let ((symbols + (mapcar 'list + (ocaml-module-symbols + (assoc module (ocaml-module-alist)))))) + (setq entry + (completing-read (format "Value: %s." module) symbols nil t))) + (if (string-equal entry "") (setq entry nil)) + ) + (t + (if (= arg 0) (setq ocaml-visible-modules 'lazy)) + (setq module-entry (ocaml-qualified-identifier)) + (setq entry (ocaml-buffer-substring (cdr module-entry))) + (setq module + (or (ocaml-buffer-substring (car module-entry)) + (let ((modules + (or (ocaml-find-module entry (ocaml-visible-modules)) + (ocaml-find-module entry))) + (hist) (default)) + (cond + ((null modules) + (error "No module found for entry %s" entry)) + ((equal (length modules) 1) + (caar modules)) + (t + (setq hist (mapcar 'car modules)) + (setq default (car hist)) + (setq module + (completing-read + (concat "Module: " + (and default (concat "[" default "] "))) + modules nil t "" (cons 'hist 0))) + (if (string-equal module "") default module)) + )))) + )) + (message "Help for %s%s%s" module (if entry "." "") (or entry "")) + (ocaml-goto-help module entry) + )) + +;; auto-links + +(defconst ocaml-link-regexp + "\\(type\\|and\\) \\('[a-z] +\\|(\\('[a-z], *\\)*'[a-z])\\|\\) *\\([a-zA-Z0-9_]*\\)\\( *$\\| =\\)") +(defconst ocaml-longident-regexp + "\\([A-Z][a-zA-Z_0]*\\)[.]\\([a-zA-Z][A-Za-z0-9_]*\\)") + +(defvar ocaml-links nil + "Local links in the current of last info node or interface file. + +The car of the list is a key that indentifies the module to prevent +recompilation when next help command is relative to the same module. +The cdr is a list of elments, each of which is an string and a pair of +buffer positions." +) +(make-variable-buffer-local 'ocaml-links) + +(defun ocaml-info-links (section) + (cdr + (if (and ocaml-links section (equal (car ocaml-links) section)) + ocaml-links + (save-excursion + (goto-char (point-min)) + (let ((regexp (concat (if (equal major-mode 'Info-mode) "^ - " "^") + ocaml-link-regexp)) + (all)) + (while (re-search-forward regexp (point-max) t) + (setq all + (cons (cons (match-string 4) + (cons (match-beginning 4) + (match-end 4))) + all))) + (setq ocaml-links (cons section all)) + ))))) + +(defvar ocaml-link-map (make-sparse-keymap)) +(define-key ocaml-link-map [mouse-2] 'ocaml-link-goto) + +(defvar ocaml-help-ovl (make-overlay 1 1)) +(make-face 'ocaml-help-face) +(set-face-doc-string 'ocaml-help-face + "face for hilighting expressions and types") +(if (not (face-differs-from-default-p 'ocaml-help-face)) + (set-face-background 'ocaml-help-face "#88FF44")) +(overlay-put ocaml-help-ovl 'face 'ocaml-help-face) + +(defun ocaml-help-show (arg) + (let ((right (point)) + (left (progn (forward-word arg) (point)))) + (goto-char right) + (move-overlay ocaml-help-ovl left right (current-buffer)) + (recenter 1) + )) + +(defun ocaml-link-goto (click) + (interactive "e") + (let* ((pos (caml-event-point-start click)) + (win (caml-event-window click)) + (buf (window-buffer win)) + (window (selected-window)) + (link)) + (setq link + (with-current-buffer buf + (buffer-substring + (previous-single-property-change (+ pos 1) 'local-map + buf (- pos 100)) + (next-single-property-change pos 'local-map + buf (+ pos 100))))) + (if (string-match (concat "^" ocaml-longident-regexp "$") link) + (ocaml-goto-help (match-string 1 link) (match-string 2 link) win) + (if (not (equal (window-buffer window) buf)) + (switch-to-buffer-other-window buf)) + (if (setq link (assoc link (cdr ocaml-links))) + (progn + (goto-char (cadr link)) + (ocaml-help-show 1))) + (if (window-live-p window) (select-window window)) + ))) + +(cond + ((and (x-display-color-p) + (not (memq 'ocaml-link-face (face-list)))) + (make-face 'ocaml-link-face) + (set-face-foreground 'ocaml-link-face "Purple"))) + + +(defun ocaml-link-activate (section) + (let ((links (ocaml-info-links section))) + (if links + (let ((regexp (concat "[^A-Za-z0-9'_]\\(" + ocaml-longident-regexp "\\|" + (mapconcat 'car links "\\|") + "\\)[^A-Za-z0-9'_]")) + (case-fold-search nil)) + (save-excursion + (goto-char (point-min)) + (let ((buffer-read-only nil) + ;; use of dynamic scoping, need not be restored! + (modified-p (buffer-modified-p))) + (unwind-protect + (save-excursion + (goto-char (point-min)) + (while (re-search-forward regexp (point-max) t) + (put-text-property (match-beginning 1) (match-end 1) + 'mouse-face 'highlight) + (put-text-property (match-beginning 1) (match-end 1) + 'local-map ocaml-link-map) + (if (x-display-color-p) + (put-text-property (match-beginning 1) (match-end 1) + 'face 'ocaml-link-face))) + ) + ;; need to restore flag if buffer was unmodified. + (unless modified-p (set-buffer-modified-p nil)) + )) + ))))) + + + +;; bindings ---now in caml.el + +; (and +; (boundp 'caml-mode-map) +; (keymapp caml-mode-map) +; (progn +; (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path) +; (define-key caml-mode-map [?\C-c?]] 'ocaml-close-module) +; (define-key caml-mode-map [?\C-c?[] 'ocaml-open-module) +; (define-key caml-mode-map [?\C-c?\C-h] 'caml-help) +; (define-key caml-mode-map [?\C-c?\t] 'caml-complete) +; (let ((map (lookup-key caml-mode-map [menu-bar caml]))) +; (and +; (keymapp map) +; (progn +; (define-key map [separator-help] '("---")) +; (define-key map [open] '("Open add path" . ocaml-add-path )) +; (define-key map [close] +; '("Close module for help" . ocaml-close-module)) +; (define-key map [open] '("Open module for help" . ocaml-open-module)) +; (define-key map [help] '("Help for identifier" . caml-help)) +; (define-key map [complete] '("Complete identifier" . caml-complete)) +; ) +; )))) + + +(provide 'caml-help) diff --git a/ocaml-binary-annot/emacs/caml-hilit.el b/ocaml-binary-annot/emacs/caml-hilit.el new file mode 100644 index 0000000000..697e58173d --- /dev/null +++ b/ocaml-binary-annot/emacs/caml-hilit.el @@ -0,0 +1,67 @@ +;(***********************************************************************) +;(* *) +;(* Objective Caml *) +;(* *) +;(* Jacques Garrigue and Ian T Zimmerman *) +;(* *) +;(* Copyright 1997 Institut National de Recherche en Informatique et *) +;(* en Automatique. All rights reserved. This file is distributed *) +;(* under the terms of the GNU General Public License. *) +;(* *) +;(***********************************************************************) + +;(* $Id$ *) + +; Highlighting patterns for hilit19 under caml-mode + +; defined also in caml.el +(defvar caml-quote-char "'" + "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.") + +(defconst caml-mode-patterns + (list +;comments + '("\\(^\\|[^\"]\\)\\((\\*[^*]*\\*+\\([^)*][^*]*\\*+\\)*)\\)" + 2 comment) +;string + (list 'hilit-string-find (string-to-char caml-quote-char) 'string) + (list (concat caml-quote-char "\\(\\\\\\([ntbr" caml-quote-char "\\]\\|" + "[0-9][0-9][0-9]\\)\\|.\\)" caml-quote-char) + nil + 'string) +;labels + '("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" 1 brown) + '("[~?][ (]*[a-z][a-zA-Z0-9_']*" nil brown) +;modules + '("\\<\\(assert\\|open\\|include\\)\\>" nil brown) + '("`?\\<[A-Z][A-Za-z0-9_\']*\\>" nil MidnightBlue) +;definition + (list (concat + "\\<\\(a\\(nd\\|s\\)\\|c\\(onstraint\\|lass\\)" + "\\|ex\\(ception\\|ternal\\)\\|fun\\(ct\\(ion\\|or\\)\\)?" + "\\|in\\(herit\\)?\\|let\\|m\\(ethod\\|utable\\|odule\\)" + "\\|of\\|p\\(arser\\|rivate\\)\\|rec\\|type" + "\\|v\\(al\\|irtual\\)\\)\\>") + nil 'ForestGreen) +;blocking + '("\\<\\(object\\|struct\\|sig\\|begin\\|end\\)\\>" 2 include) +;control + (list (concat + "\\<\\(do\\(ne\\|wnto\\)?\\|else\\|for\\|i\\(f\\|gnore\\)" + "\\|lazy\\|match\\|new\\|or\\|t\\(hen\\|o\\|ry\\)" + "\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\)\\>" + "\\|\|\\|->\\|&\\|#") + nil 'keyword) + '(";" nil struct)) + "Hilit19 patterns used for Caml mode") + +(hilit-set-mode-patterns 'caml-mode caml-mode-patterns) +(hilit-set-mode-patterns + 'inferior-caml-mode + (append + (list +;inferior + '("^[#-]" nil firebrick)) + caml-mode-patterns)) + +(provide 'caml-hilit) diff --git a/ocaml-binary-annot/emacs/caml-types.el b/ocaml-binary-annot/emacs/caml-types.el new file mode 100644 index 0000000000..05b1a2c0a6 --- /dev/null +++ b/ocaml-binary-annot/emacs/caml-types.el @@ -0,0 +1,765 @@ +;(***********************************************************************) +;(* *) +;(* Objective Caml *) +;(* *) +;(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) +;(* *) +;(* Copyright 2003 Institut National de Recherche en Informatique et *) +;(* en Automatique. All rights reserved. This file is distributed *) +;(* under the terms of the GNU General Public License. *) +;(* *) +;(***********************************************************************) + +;(* $Id$ *) + +; An emacs-lisp complement to the "-annot" option of ocamlc and ocamlopt. + +;; XEmacs compatibility + +(eval-and-compile + (if (and (boundp 'running-xemacs) running-xemacs) + (require 'caml-xemacs) + (require 'caml-emacs))) + + + +(defvar caml-types-location-re nil "Regexp to parse *.annot files. + +Annotation files *.annot may be generated with the \"-annot\" option +of ocamlc and ocamlopt. + +Their format is: + + file ::= block * + block ::= position <SP> position <LF> annotation * + position ::= filename <SP> num <SP> num <SP> num + annotation ::= keyword open-paren <LF> <SP> <SP> data <LF> close-paren <LF> + + <SP> is a space character (ASCII 0x20) + <LF> is a line-feed character (ASCII 0x0A) + num is a sequence of decimal digits + filename is a string with the lexical conventions of O'Caml + open-paren is an open parenthesis (ASCII 0x28) + close-paren is a closed parenthesis (ASCII 0x29) + data is any sequence of characters where <LF> is always followed by + at least two space characters. + +- in each block, the two positions are respectively the start and the + end of the range described by the block. +- in a position, the filename is the name of the file, the first num + is the line number, the second num is the offset of the beginning + of the line, the third num is the offset of the position itself. +- the char number within the line is the difference between the third + and second nums. + +The current list of keywords is: +type call ident" +) + +(let* ((caml-types-filename-re "\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"") + (caml-types-number-re "\\([0-9]*\\)")) + (setq caml-types-position-re + (concat caml-types-filename-re " " + caml-types-number-re " " + caml-types-number-re " " + caml-types-number-re)) + (setq caml-types-location-re + (concat "^" caml-types-position-re " " caml-types-position-re))) + +(defvar caml-types-expr-ovl (make-overlay 1 1)) +(make-face 'caml-types-expr-face) +(set-face-doc-string 'caml-types-expr-face + "face for hilighting expressions and types") +(if (not (face-differs-from-default-p 'caml-types-expr-face)) + (set-face-background 'caml-types-expr-face "#88FF44")) +(overlay-put caml-types-expr-ovl 'face 'caml-types-expr-face) + +(defvar caml-types-typed-ovl (make-overlay 1 1)) +(make-face 'caml-types-typed-face) +(set-face-doc-string 'caml-types-typed-face + "face for hilighting typed expressions") +(if (not (face-differs-from-default-p 'caml-types-typed-face)) + (set-face-background 'caml-types-typed-face "#FF8844")) +(overlay-put caml-types-typed-ovl 'face 'caml-types-typed-face) + +(defvar caml-types-scope-ovl (make-overlay 1 1)) +(make-face 'caml-types-scope-face) +(set-face-doc-string 'caml-types-scope-face + "face for hilighting variable scopes") +(if (not (face-differs-from-default-p 'caml-types-scope-face)) + (set-face-background 'caml-types-scope-face "#BBFFFF")) +(overlay-put caml-types-scope-ovl 'face 'caml-types-scope-face) + +(defvar caml-types-def-ovl (make-overlay 1 1)) +(make-face 'caml-types-def-face) +(set-face-doc-string 'caml-types-def-face + "face for hilighting binding occurrences") +(if (not (face-differs-from-default-p 'caml-types-def-face)) + (set-face-background 'caml-types-def-face "#FF4444")) +(overlay-put caml-types-def-ovl 'face 'caml-types-def-face) + +(defvar caml-types-occ-ovl (make-overlay 1 1)) +(make-face 'caml-types-occ-face) +(set-face-doc-string 'caml-types-occ-face + "face for hilighting variable occurrences") +(if (not (face-differs-from-default-p 'caml-types-occ-face)) + (set-face-background 'caml-types-occ-face "#44FF44")) +(overlay-put caml-types-occ-ovl 'face 'caml-types-occ-face) + + +(defvar caml-types-annotation-tree nil) +(defvar caml-types-annotation-date nil) +(make-variable-buffer-local 'caml-types-annotation-tree) +(make-variable-buffer-local 'caml-types-annotation-date) + +(defvar caml-types-buffer-name "*caml-types*" + "Name of buffer for diplaying caml types") +(defvar caml-types-buffer nil + "buffer for diplaying caml types") + +(defun caml-types-show-type (arg) + "Show the type of expression or pattern at point. + The smallest expression or pattern that contains point is + temporarily highlighted. Its type is highlighted in the .annot + file and the mark is set to the beginning of the type. + The type is also displayed in the mini-buffer. + + Hints on using the type display: + . If you want the type of an identifier, put point within any + occurrence of this identifier. + . If you want the result type of a function application, put point + at the first space after the function name. + . If you want the type of a list, put point on a bracket, on a + semicolon, or on the :: constructor. + . Even if type checking fails, you can still look at the types + in the file, up to where the type checker failed. + +Types are also displayed in the buffer *caml-types*, which is +displayed when the command is called with Prefix argument 4. + +See also `caml-types-explore' for exploration by mouse dragging. +See `caml-types-location-re' for annotation file format. +" + (interactive "p") + (let* ((target-buf (current-buffer)) + (target-file (file-name-nondirectory (buffer-file-name))) + (target-line (1+ (count-lines (point-min) + (caml-line-beginning-position)))) + (target-bol (caml-line-beginning-position)) + (target-cnum (point))) + (caml-types-preprocess (buffer-file-name)) + (setq caml-types-buffer (get-buffer-create caml-types-buffer-name)) + (let* ((targ-loc (vector target-file target-line target-bol target-cnum)) + (node (caml-types-find-location targ-loc "type" () + caml-types-annotation-tree))) + (cond + ((null node) + (delete-overlay caml-types-expr-ovl) + (message "Point is not within a typechecked expression or pattern.")) + (t + (let ((left (caml-types-get-pos target-buf (elt node 0))) + (right (caml-types-get-pos target-buf (elt node 1))) + (type (cdr (assoc "type" (elt node 2))))) + (move-overlay caml-types-expr-ovl left right target-buf) + (with-current-buffer caml-types-buffer + (erase-buffer) + (insert type) + (message (format "type: %s" type))) + )))) + (if (and (= arg 4) + (not (window-live-p (get-buffer-window caml-types-buffer)))) + (display-buffer caml-types-buffer)) + (unwind-protect + (caml-sit-for 60) + (delete-overlay caml-types-expr-ovl) + ))) + +(defun caml-types-show-call (arg) + "Show the kind of call at point. + The smallest function call that contains point is + temporarily highlighted. Its kind is highlighted in the .annot + file and the mark is set to the beginning of the kind. + The kind is also displayed in the mini-buffer. + +The kind is also displayed in the buffer *caml-types*, which is +displayed when the command is called with Prefix argument 4. + +See `caml-types-location-re' for annotation file format. +" + (interactive "p") + (let* ((target-buf (current-buffer)) + (target-file (file-name-nondirectory (buffer-file-name))) + (target-line (1+ (count-lines (point-min) + (caml-line-beginning-position)))) + (target-bol (caml-line-beginning-position)) + (target-cnum (point))) + (caml-types-preprocess (buffer-file-name)) + (setq caml-types-buffer (get-buffer-create caml-types-buffer-name)) + (let* ((targ-loc (vector target-file target-line target-bol target-cnum)) + (node (caml-types-find-location targ-loc "call" () + caml-types-annotation-tree))) + (cond + ((null node) + (delete-overlay caml-types-expr-ovl) + (message "Point is not within a function call.")) + (t + (let ((left (caml-types-get-pos target-buf (elt node 0))) + (right (caml-types-get-pos target-buf (elt node 1))) + (kind (cdr (assoc "call" (elt node 2))))) + (move-overlay caml-types-expr-ovl left right target-buf) + (with-current-buffer caml-types-buffer + (erase-buffer) + (insert kind) + (message (format "%s call" kind))) + )))) + (if (and (= arg 4) + (not (window-live-p (get-buffer-window caml-types-buffer)))) + (display-buffer caml-types-buffer)) + (unwind-protect + (caml-sit-for 60) + (delete-overlay caml-types-expr-ovl) + ))) + +(defun caml-types-show-ident (arg) + "Show the binding of identifier at point. + The identifier that contains point is + temporarily highlighted. Its binding is highlighted in the .annot + file and the mark is set to the beginning of the binding. + The binding is also displayed in the mini-buffer. + +The binding is also displayed in the buffer *caml-types*, which is +displayed when the command is called with Prefix argument 4. + +See `caml-types-location-re' for annotation file format. +" + (interactive "p") + (let* ((target-buf (current-buffer)) + (target-file (file-name-nondirectory (buffer-file-name))) + (target-line (1+ (count-lines (point-min) + (caml-line-beginning-position)))) + (target-bol (caml-line-beginning-position)) + (target-cnum (point))) + (caml-types-preprocess (buffer-file-name)) + (setq caml-types-buffer (get-buffer-create caml-types-buffer-name)) + (let* ((targ-loc (vector target-file target-line target-bol target-cnum)) + (node (caml-types-find-location targ-loc "ident" () + caml-types-annotation-tree))) + (cond + ((null node) + (delete-overlay caml-types-expr-ovl) + (message "Point is not within an identifier.")) + (t + (let ((left (caml-types-get-pos target-buf (elt node 0))) + (right (caml-types-get-pos target-buf (elt node 1))) + (kind (cdr (assoc "ident" (elt node 2))))) + (move-overlay caml-types-expr-ovl left right target-buf) + (let* ((loc-re (concat caml-types-position-re " " + caml-types-position-re)) + (end-re (concat caml-types-position-re " --")) + (def-re (concat "def \\([^ ]*\\) " loc-re)) + (def-end-re (concat "def \\([^ ]*\\) " end-re)) + (internal-re (concat "int_ref \\([^ ]*\\) " loc-re)) + (external-re "ext_ref \\(.*\\)")) + (cond + ((string-match def-re kind) + (let ((var-name (match-string 1 kind)) + (l-file (file-name-nondirectory (match-string 2 kind))) + (l-line (string-to-int (match-string 4 kind))) + (l-bol (string-to-int (match-string 5 kind))) + (l-cnum (string-to-int (match-string 6 kind))) + (r-file (file-name-nondirectory (match-string 7 kind))) + (r-line (string-to-int (match-string 9 kind))) + (r-bol (string-to-int (match-string 10 kind))) + (r-cnum (string-to-int (match-string 11 kind)))) + (let* ((lpos (vector l-file l-line l-bol l-cnum)) + (rpos (vector r-file r-line r-bol r-cnum)) + (left (caml-types-get-pos target-buf lpos)) + (right (caml-types-get-pos target-buf rpos))) + (message (format "local variable %s is bound here" var-name)) + (move-overlay caml-types-scope-ovl left right target-buf)))) + ((string-match def-end-re kind) + (let ((var-name (match-string 1 kind)) + (l-file (file-name-nondirectory (match-string 2 kind))) + (l-line (string-to-int (match-string 4 kind))) + (l-bol (string-to-int (match-string 5 kind))) + (l-cnum (string-to-int (match-string 6 kind)))) + (let* ((lpos (vector l-file l-line l-bol l-cnum)) + (left (caml-types-get-pos target-buf lpos)) + (right (buffer-size target-buf))) + (message (format "global variable %s is bound here" var-name)) + (move-overlay caml-types-scope-ovl left right target-buf)))) + ((string-match internal-re kind) + (let ((var-name (match-string 1 kind)) + (l-file (file-name-nondirectory (match-string 2 kind))) + (l-line (string-to-int (match-string 4 kind))) + (l-bol (string-to-int (match-string 5 kind))) + (l-cnum (string-to-int (match-string 6 kind))) + (r-file (file-name-nondirectory (match-string 7 kind))) + (r-line (string-to-int (match-string 9 kind))) + (r-bol (string-to-int (match-string 10 kind))) + (r-cnum (string-to-int (match-string 11 kind)))) + (let* ((lpos (vector l-file l-line l-bol l-cnum)) + (rpos (vector r-file r-line r-bol r-cnum)) + (left (caml-types-get-pos target-buf lpos)) + (right (caml-types-get-pos target-buf rpos))) + (move-overlay caml-types-def-ovl left right target-buf) + (message (format "%s is bound at line %d char %d" + var-name l-line (- l-cnum l-bol)))))) + ((string-match external-re kind) + (let ((fullname (match-string 1 kind))) + (with-current-buffer caml-types-buffer + (erase-buffer) + (insert fullname) + (message (format "external ident: %s" fullname))))))) + )))) + (if (and (= arg 4) + (not (window-live-p (get-buffer-window caml-types-buffer)))) + (display-buffer caml-types-buffer)) + (unwind-protect + (caml-sit-for 60) + (delete-overlay caml-types-expr-ovl) + (delete-overlay caml-types-def-ovl) + (delete-overlay caml-types-scope-ovl) + ))) + +(defun caml-types-preprocess (target-path) + (let* ((type-path (caml-types-locate-type-file target-path)) + (type-date (nth 5 (file-attributes (file-chase-links type-path)))) + (target-date (nth 5 (file-attributes target-file)))) + (unless (and caml-types-annotation-tree + type-date + caml-types-annotation-date + (not (caml-types-date< caml-types-annotation-date type-date))) + (if (and type-date target-date (caml-types-date< type-date target-date)) + (error (format "`%s' is more recent than `%s'" target-path type-path))) + (message "Reading annotation file...") + (let* ((type-buf (caml-types-find-file type-path)) + (tree (with-current-buffer type-buf + (widen) + (goto-char (point-min)) + (caml-types-build-tree + (file-name-nondirectory target-path))))) + (setq caml-types-annotation-tree tree + caml-types-annotation-date type-date) + (kill-buffer type-buf) + (message "done")) + ))) + +(defun caml-types-locate-type-file (target-path) + (let ((sibling (concat (file-name-sans-extension target-path) ".annot"))) + (if (file-exists-p sibling) + sibling + (defun parent-dir (d) (file-name-directory (directory-file-name d))) + (let ((project-dir (file-name-directory sibling)) + type-path) + (while (not (file-exists-p + (setq type-path + (expand-file-name + (file-relative-name sibling project-dir) + (expand-file-name "_build" project-dir))))) + (if (equal project-dir (parent-dir project-dir)) + (error (concat "No annotation file. " + "You should compile with option \"-annot\"."))) + (setq project-dir (parent-dir project-dir))) + type-path)))) + +(defun caml-types-date< (date1 date2) + (or (< (car date1) (car date2)) + (and (= (car date1) (car date2)) + (< (nth 1 date1) (nth 1 date2))))) + + +; we use an obarray for hash-consing the strings within each tree + +(defun caml-types-make-hash-table () + (make-vector 255 0)) + +(defun caml-types-hcons (elem table) + (symbol-name (intern elem table))) + + +(defun next-annotation () + (forward-char 1) + (if (re-search-forward "^[a-z\"]" () t) + (forward-char -1) + (goto-char (point-max))) + (looking-at "[a-z]") +) + +; tree of intervals +; each node is a vector +; [ pos-left pos-right annotation child child child... ] +; annotation is a list of: +; (kind . info) where kind = "type" "call" etc. +; and info = the contents of the annotation + +(defun caml-types-build-tree (target-file) + (let ((stack ()) + (accu ()) + (table (caml-types-make-hash-table)) + (annotation ())) + (while (re-search-forward caml-types-location-re () t) + (let ((l-file (file-name-nondirectory (match-string 1))) + (l-line (string-to-int (match-string 3))) + (l-bol (string-to-int (match-string 4))) + (l-cnum (string-to-int (match-string 5))) + (r-file (file-name-nondirectory (match-string 6))) + (r-line (string-to-int (match-string 8))) + (r-bol (string-to-int (match-string 9))) + (r-cnum (string-to-int (match-string 10)))) + (unless (caml-types-not-in-file l-file r-file target-file) + (setq annotation ()) + (while (next-annotation) + (cond ((looking-at + "^\\([a-z]+\\)(\n \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)") + (let ((kind (caml-types-hcons (match-string 1) table)) + (info (caml-types-hcons (match-string 2) table))) + (setq annotation (cons (cons kind info) annotation)))))) + (setq accu ()) + (while (and stack + (caml-types-pos-contains l-cnum r-cnum (car stack))) + (setq accu (cons (car stack) accu)) + (setq stack (cdr stack))) + (let* ((left-pos (vector l-file l-line l-bol l-cnum)) + (right-pos (vector r-file r-line r-bol r-cnum)) + (node (caml-types-make-node left-pos right-pos annotation + accu))) + (setq stack (cons node stack)))))) + (if (null stack) + (error "no annotations found for this source file") + (let* ((left-pos (elt (car (last stack)) 0)) + (right-pos (elt (car stack) 1))) + (if (null (cdr stack)) + (car stack) + (caml-types-make-node left-pos right-pos () (nreverse stack))))))) + +(defun caml-types-not-in-file (l-file r-file target-file) + (or (and (not (string= l-file target-file)) + (not (string= l-file ""))) + (and (not (string= r-file target-file)) + (not (string= r-file ""))))) + +(defun caml-types-make-node (left-pos right-pos annotation children) + (let ((result (make-vector (+ 3 (length children)) ())) + (i 3)) + (aset result 0 left-pos) + (aset result 1 right-pos) + (aset result 2 annotation) + (while children + (aset result i (car children)) + (setq children (cdr children)) + (setq i (1+ i))) + result)) + +(defun caml-types-pos-contains (l-cnum r-cnum node) + (and (<= l-cnum (elt (elt node 0) 3)) + (>= r-cnum (elt (elt node 1) 3)))) + +(defun caml-types-find-location (targ-pos kind curr node) + (if (not (caml-types-pos-inside targ-pos node)) + curr + (if (and (elt node 2) (assoc kind (elt node 2))) + (setq curr node)) + (let ((i (caml-types-search node targ-pos))) + (if (and (> i 3) + (caml-types-pos-inside targ-pos (elt node (1- i)))) + (caml-types-find-location targ-pos kind curr (elt node (1- i))) + curr)))) + +; trouve le premier fils qui commence apres la position +; ou (length node) si tous commencent avant +(defun caml-types-search (node pos) + (let ((min 3) + (max (length node)) + med) + (while (< min max) + (setq med (/ (+ min max) 2)) + (if (caml-types-pos<= (elt (elt node med) 0) pos) + (setq min (1+ med)) + (setq max med))) + min)) + +(defun caml-types-pos-inside (pos node) + (let ((left-pos (elt node 0)) + (right-pos (elt node 1))) + (and (caml-types-pos<= left-pos pos) + (caml-types-pos> right-pos pos)))) + +(defun caml-types-find-interval (buf targ-pos node) + (let ((nleft (elt node 0)) + (nright (elt node 1)) + (left ()) + (right ()) + i) + (cond + ((not (caml-types-pos-inside targ-pos node)) + (if (not (caml-types-pos<= nleft targ-pos)) + (setq right nleft)) + (if (not (caml-types-pos> nright targ-pos)) + (setq left nright))) + (t + (setq left nleft + right nright) + (setq i (caml-types-search node targ-pos)) + (if (< i (length node)) + (setq right (elt (elt node i) 0))) + (if (> i 3) + (setq left (elt (elt node (1- i)) 1))))) + (cons (if left + (caml-types-get-pos buf left) + (with-current-buffer buf (point-min))) + (if right + (caml-types-get-pos buf right) + (with-current-buffer buf (point-max)))))) + + +;; Warning: these comparison functions are not symmetric. +;; The first argument determines the format: +;; when its file component is empty, only the cnum is compared. + +(defun caml-types-pos<= (pos1 pos2) + (let ((file1 (elt pos1 0)) + (line1 (elt pos1 1)) + (bol1 (elt pos1 2)) + (cnum1 (elt pos1 3)) + (file2 (elt pos2 0)) + (line2 (elt pos2 1)) + (bol2 (elt pos2 2)) + (cnum2 (elt pos2 3))) + (if (string= file1 "") + (<= cnum1 cnum2) + (and (string= file1 file2) + (or (< line1 line2) + (and (= line1 line2) + (<= (- cnum1 bol1) (- cnum2 bol2)))))))) + +(defun caml-types-pos> (pos1 pos2) + (let ((file1 (elt pos1 0)) + (line1 (elt pos1 1)) + (bol1 (elt pos1 2)) + (cnum1 (elt pos1 3)) + (file2 (elt pos2 0)) + (line2 (elt pos2 1)) + (bol2 (elt pos2 2)) + (cnum2 (elt pos2 3))) + (if (string= file1 "") + (> cnum1 cnum2) + (and (string= file1 file2) + (or (> line1 line2) + (and (= line1 line2) + (> (- cnum1 bol1) (- cnum2 bol2)))))))) + +(defun caml-types-get-pos (buf pos) + (save-excursion + (set-buffer buf) + (goto-line (elt pos 1)) + (forward-char (- (elt pos 3) (elt pos 2))) + (point))) + +; find-file-read-only-noselect seems to be missing from emacs... +(defun caml-types-find-file (name) + (let (buf) + (cond + ((setq buf (get-file-buffer name)) + (unless (verify-visited-file-modtime buf) + (if (buffer-modified-p buf) + (find-file-noselect name) + (with-current-buffer buf (revert-buffer t t))) + )) + ((and (file-readable-p name) + (setq buf (find-file-noselect name))) + (with-current-buffer buf (toggle-read-only 1)) + ) + (t + (error (format "Can't read the annotation file `%s'" name))) + ) + buf)) + +(defun caml-types-mouse-ignore (event) + (interactive "e") + nil) + +(defun caml-types-time () + (let ((time (current-time))) + (+ (* (mod (cadr time) 1000) 1000) + (/ (cadr (cdr time)) 1000)))) + +(defun caml-types-explore (event) + "Explore type annotations by mouse dragging. + +The expression under the mouse is highlighted and its type is displayed +in the minibuffer, until the move is released, much as `caml-types-show-type'. +The function uses two overlays. + + . One overlay delimits the largest region whose all subnodes + are well-typed. + . Another overlay delimits the current node under the mouse (whose type + annotation is beeing displayed). +" + (interactive "e") + (set-buffer (window-buffer (caml-event-window event))) + (let* ((target-buf (current-buffer)) + (target-file (file-name-nondirectory (buffer-file-name))) + (target-line) (target-bol) + target-pos + Left Right limits cnum node mes type + region + (window (caml-event-window event)) + target-tree + (speed 100) + (last-time (caml-types-time)) + (original-event event) + ) + (select-window window) + (unwind-protect + (progn + (caml-types-preprocess (buffer-file-name)) + (setq target-tree caml-types-annotation-tree) + (setq caml-types-buffer (get-buffer-create caml-types-buffer-name)) + ;; (message "Drag the mouse to explore types") + (unwind-protect + (caml-track-mouse + (while event + (cond + ;; we ignore non mouse events + ((caml-ignore-event-p event)) + ;; we stop when the original button is released + ((caml-release-event-p original-event event) + (setq event nil)) + ;; we scroll when the motion is outside the window + ((and (caml-mouse-movement-p event) + (not (and (equal window (caml-event-window event)) + (integer-or-marker-p + (caml-event-point-end event))))) + (let* ((win (caml-window-edges window)) + (top (nth 1 win)) + (bottom (- (nth 3 win) 1)) + mouse + time + ) + (while (and + (caml-sit-for 0 (/ 500 speed)) + (setq time (caml-types-time)) + (> (- time last-time) (/ 500 speed)) + (setq mouse (caml-mouse-vertical-position)) + (or (< mouse top) (>= mouse bottom)) + ) + (setq last-time time) + (cond + ((< mouse top) + (setq speed (- top mouse)) + (condition-case nil + (scroll-down 1) + (error (message "Beginning of buffer!")))) + ((>= mouse bottom) + (setq speed (+ 1 (- mouse bottom))) + (condition-case nil + (scroll-up 1) + (error (message "End of buffer!")))) + ) + (setq speed (* speed speed)) + ))) + ;; main action, when the motion is inside the window + ;; or on orginal button down event + ((or (caml-mouse-movement-p event) + (equal original-event event)) + (setq cnum (caml-event-point-end event)) + (if (and region + (<= (car region) cnum) (< cnum (cdr region))) + ;; mouse remains in outer region + nil + ;; otherwise, reset the outer region + (setq region + (caml-types-typed-make-overlay + target-buf (caml-event-point-start event)))) + (if + (and limits + (>= cnum (car limits)) (< cnum (cdr limits))) + ;; inner region is unchanged + nil + ;; recompute the inner region and type annotation + (setq target-bol + (save-excursion + (goto-char cnum) (caml-line-beginning-position)) + target-line (1+ (count-lines (point-min) + target-bol)) + target-pos + (vector target-file target-line target-bol cnum)) + (save-excursion + (setq node (caml-types-find-location "type" + target-pos () target-tree)) + (set-buffer caml-types-buffer) + (erase-buffer) + (cond + (node + (setq Left + (caml-types-get-pos target-buf (elt node 0)) + Right + (caml-types-get-pos target-buf (elt node 1))) + (move-overlay + caml-types-expr-ovl Left Right target-buf) + (setq limits + (caml-types-find-interval target-buf + target-pos node) + type (elt node 2)) + ) + (t + (delete-overlay caml-types-expr-ovl) + (setq type "*no type information*") + (setq limits + (caml-types-find-interval + target-buf target-pos target-tree)) + )) + (setq mes (format "type: %s" type)) + (insert type) + )) + (message mes) + ) + ) + ;; we read next event, unless it is nil, and loop back. + (if event (setq event (caml-read-event))) + ) + ) + ;; delete overlays at end of exploration + (delete-overlay caml-types-expr-ovl) + (delete-overlay caml-types-typed-ovl) + )) + ;; When an error occurs, the mouse release event has not been read. + ;; We could wait for mouse release to prevent execution of + ;; a binding of mouse release, such as cut or paste. + ;; In most common cases, next event will be the mouse release. + ;; However, it could also be a key stroke before mouse release. + ;; Emacs does not allow to test whether mouse is up or down. + ;; Not sure it is robust to loop for mouse release after an error + ;; occured, as is done for exploration. + ;; So far, we just ignore next event. (Next line also be uncommenting.) + (if event (caml-read-event)) + ))) + +(defun caml-types-typed-make-overlay (target-buf pos) + (interactive "p") + (let ((start pos) (end pos) len node left right) + (setq len (length caml-types-annotation-tree)) + (while (> len 3) + (setq len (- len 1)) + (setq node (aref caml-types-annotation-tree len)) + (if (and (equal target-buf (current-buffer)) + (setq left (caml-types-get-pos target-buf (elt node 0)) + right (caml-types-get-pos target-buf (elt node 1))) + (<= left pos) (> right pos) + ) + (setq start (min start left) + end (max end right)) + )) + (move-overlay caml-types-typed-ovl + (max (point-min) (- start 1)) + (min (point-max) (+ end 1)) target-buf) + (cons start end))) + +(defun caml-types-version () + "internal version number of caml-types.el" + (interactive) + (message "4") +) + +(provide 'caml-types) diff --git a/ocaml-binary-annot/emacs/caml-xemacs.el b/ocaml-binary-annot/emacs/caml-xemacs.el new file mode 100644 index 0000000000..fe141c5ce2 --- /dev/null +++ b/ocaml-binary-annot/emacs/caml-xemacs.el @@ -0,0 +1,53 @@ +;(***********************************************************************) +;(* *) +;(* Objective Caml *) +;(* *) +;(* Didier Remy, projet Cristal, INRIA Rocquencourt *) +;(* *) +;(* Copyright 2003 Institut National de Recherche en Informatique et *) +;(* en Automatique. All rights reserved. This file is distributed *) +;(* under the terms of the GNU General Public License. *) +;(* *) +;(***********************************************************************) + +;(* $Id$ *) + +(require 'overlay) + +;; for caml-help.el +(defun caml-info-other-window (arg) + (save-excursion (info arg)) + (view-buffer-other-window "*info*")) + +;; for caml-types.el +(defun caml-line-beginning-position () + (save-excursion (beginning-of-line) (point))) + +(defalias 'caml-read-event 'next-event) +(defalias 'caml-window-edges 'window-pixel-edges) +(defun caml-mouse-vertical-position () + (let ((e (mouse-position-as-motion-event))) + (and e (event-y-pixel e)))) +(defalias 'caml-mouse-movement-p 'motion-event-p) +(defun caml-event-window (e) + (and (mouse-event-p e) (event-window e))) +(defun caml-event-point-start (e) (event-closest-point e)) +(defun caml-event-point-end (e) (event-closest-point e)) +(defun caml-ignore-event-p (e) + (if (and (key-press-event-p e) (equal (key-binding e) 'keyboard-quit)) + (keyboard-quit)) + (not (mouse-event-p e))) + + +(defun caml-sit-for (sec &optional mili) + (sit-for (+ sec (if mili (* 0.001 mili) 0)))) + + + +(defmacro caml-track-mouse (&rest body) (cons 'progn body)) + +(defun caml-release-event-p (original event) + (and (button-release-event-p event) + (equal (event-button original) (event-button event)))) + +(provide 'caml-xemacs) diff --git a/ocaml-binary-annot/emacs/caml.el b/ocaml-binary-annot/emacs/caml.el new file mode 100644 index 0000000000..4f03b5a582 --- /dev/null +++ b/ocaml-binary-annot/emacs/caml.el @@ -0,0 +1,1932 @@ +;(***********************************************************************) +;(* *) +;(* Objective Caml *) +;(* *) +;(* Jacques Garrigue and Ian T Zimmerman *) +;(* *) +;(* Copyright 1997 Institut National de Recherche en Informatique et *) +;(* en Automatique. All rights reserved. This file is distributed *) +;(* under the terms of the GNU General Public License. *) +;(* *) +;(***********************************************************************) + +;(* $Id$ *) + +;;; caml.el --- O'Caml code editing commands for Emacs + +;; Xavier Leroy, july 1993. + +;;indentation code is Copyright (C) 1996 by Ian T Zimmerman <itz@rahul.net> +;;copying: covered by the current FSF General Public License. + +;; indentation code adapted for Objective Caml by Jacques Garrigue, +;; july 1997. <garrigue@kurims.kyoto-u.ac.jp> + +;;user customizable variables +(defvar caml-quote-char "'" + "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.") + +(defvar caml-imenu-enable nil + "*Enable Imenu support.") + +(defvar caml-mode-indentation 2 + "*Used for \\[caml-unindent-command].") + +(defvar caml-lookback-limit 5000 + "*How far to look back for syntax things in caml mode.") + +(defvar caml-max-indent-priority 8 + "*Bounds priority of operators permitted to affect caml indentation. + +Priorities are assigned to `interesting' caml operators as follows: + + all keywords 0 to 7 8 + type, val, ... + 0 7 + :: ^ 6 + @ 5 + := <- 4 + if 3 + fun, let, match ... 2 + module 1 + opening keywords 0.") + +(defvar caml-apply-extra-indent 2 + "*How many spaces to add to indentation for an application in caml mode.") +(make-variable-buffer-local 'caml-apply-extra-indent) + +(defvar caml-begin-indent 2 + "*How many spaces to indent from a begin keyword in caml mode.") +(make-variable-buffer-local 'caml-begin-indent) + +(defvar caml-class-indent 2 + "*How many spaces to indent from a class keyword in caml mode.") +(make-variable-buffer-local 'caml-class-indent) + +(defvar caml-exception-indent 2 + "*How many spaces to indent from a exception keyword in caml mode.") +(make-variable-buffer-local 'caml-exception-indent) + +(defvar caml-for-indent 2 + "*How many spaces to indent from a for keyword in caml mode.") +(make-variable-buffer-local 'caml-for-indent) + +(defvar caml-fun-indent 2 + "*How many spaces to indent from a fun keyword in caml mode.") +(make-variable-buffer-local 'caml-fun-indent) + +(defvar caml-function-indent 4 + "*How many spaces to indent from a function keyword in caml mode.") +(make-variable-buffer-local 'caml-function-indent) + +(defvar caml-if-indent 2 + "*How many spaces to indent from a if keyword in caml mode.") +(make-variable-buffer-local 'caml-if-indent) + +(defvar caml-if-else-indent 0 + "*How many spaces to indent from an if .. else line in caml mode.") +(make-variable-buffer-local 'caml-if-else-indent) + +(defvar caml-inherit-indent 2 + "*How many spaces to indent from a inherit keyword in caml mode.") +(make-variable-buffer-local 'caml-inherit-indent) + +(defvar caml-initializer-indent 2 + "*How many spaces to indent from a initializer keyword in caml mode.") +(make-variable-buffer-local 'caml-initializer-indent) + +(defvar caml-include-indent 2 + "*How many spaces to indent from a include keyword in caml mode.") +(make-variable-buffer-local 'caml-include-indent) + +(defvar caml-let-indent 2 + "*How many spaces to indent from a let keyword in caml mode.") +(make-variable-buffer-local 'caml-let-indent) + +(defvar caml-let-in-indent 0 + "*How many spaces to indent from a let .. in keyword in caml mode.") +(make-variable-buffer-local 'caml-let-in-indent) + +(defvar caml-match-indent 2 + "*How many spaces to indent from a match keyword in caml mode.") +(make-variable-buffer-local 'caml-match-indent) + +(defvar caml-method-indent 2 + "*How many spaces to indent from a method keyword in caml mode.") +(make-variable-buffer-local 'caml-method-indent) + +(defvar caml-module-indent 2 + "*How many spaces to indent from a module keyword in caml mode.") +(make-variable-buffer-local 'caml-module-indent) + +(defvar caml-object-indent 2 + "*How many spaces to indent from a object keyword in caml mode.") +(make-variable-buffer-local 'caml-object-indent) + +(defvar caml-of-indent 2 + "*How many spaces to indent from a of keyword in caml mode.") +(make-variable-buffer-local 'caml-of-indent) + +(defvar caml-parser-indent 4 + "*How many spaces to indent from a parser keyword in caml mode.") +(make-variable-buffer-local 'caml-parser-indent) + +(defvar caml-sig-indent 2 + "*How many spaces to indent from a sig keyword in caml mode.") +(make-variable-buffer-local 'caml-sig-indent) + +(defvar caml-struct-indent 2 + "*How many spaces to indent from a struct keyword in caml mode.") +(make-variable-buffer-local 'caml-struct-indent) + +(defvar caml-try-indent 2 + "*How many spaces to indent from a try keyword in caml mode.") +(make-variable-buffer-local 'caml-try-indent) + +(defvar caml-type-indent 4 + "*How many spaces to indent from a type keyword in caml mode.") +(make-variable-buffer-local 'caml-type-indent) + +(defvar caml-val-indent 2 + "*How many spaces to indent from a val keyword in caml mode.") +(make-variable-buffer-local 'caml-val-indent) + +(defvar caml-while-indent 2 + "*How many spaces to indent from a while keyword in caml mode.") +(make-variable-buffer-local 'caml-while-indent) + +(defvar caml-::-indent 2 + "*How many spaces to indent from a :: operator in caml mode.") +(make-variable-buffer-local 'caml-::-indent) + +(defvar caml-@-indent 2 + "*How many spaces to indent from a @ operator in caml mode.") +(make-variable-buffer-local 'caml-@-indent) + +(defvar caml-:=-indent 2 + "*How many spaces to indent from a := operator in caml mode.") +(make-variable-buffer-local 'caml-:=-indent) + +(defvar caml-<--indent 2 + "*How many spaces to indent from a <- operator in caml mode.") +(make-variable-buffer-local 'caml-<--indent) + +(defvar caml-->-indent 2 + "*How many spaces to indent from a -> operator in caml mode.") +(make-variable-buffer-local 'caml-->-indent) + +(defvar caml-lb-indent 2 + "*How many spaces to indent from a \[ operator in caml mode.") +(make-variable-buffer-local 'caml-lb-indent) + +(defvar caml-lc-indent 2 + "*How many spaces to indent from a \{ operator in caml mode.") +(make-variable-buffer-local 'caml-lc-indent) + +(defvar caml-lp-indent 1 + "*How many spaces to indent from a \( operator in caml mode.") +(make-variable-buffer-local 'caml-lp-indent) + +(defvar caml-and-extra-indent nil + "*Extra indent for caml lines starting with the and keyword. +Usually negative. nil is align on master.") +(make-variable-buffer-local 'caml-and-extra-indent) + +(defvar caml-do-extra-indent nil + "*Extra indent for caml lines starting with the do keyword. +Usually negative. nil is align on master.") +(make-variable-buffer-local 'caml-do-extra-indent) + +(defvar caml-done-extra-indent nil + "*Extra indent for caml lines starting with the done keyword. +Usually negative. nil is align on master.") +(make-variable-buffer-local 'caml-done-extra-indent) + +(defvar caml-else-extra-indent nil + "*Extra indent for caml lines starting with the else keyword. +Usually negative. nil is align on master.") +(make-variable-buffer-local 'caml-else-extra-indent) + +(defvar caml-end-extra-indent nil + "*Extra indent for caml lines starting with the end keyword. +Usually negative. nil is align on master.") +(make-variable-buffer-local 'caml-end-extra-indent) + +(defvar caml-in-extra-indent nil + "*Extra indent for caml lines starting with the in keyword. +Usually negative. nil is align on master.") +(make-variable-buffer-local 'caml-in-extra-indent) + +(defvar caml-then-extra-indent nil + "*Extra indent for caml lines starting with the then keyword. +Usually negative. nil is align on master.") +(make-variable-buffer-local 'caml-then-extra-indent) + +(defvar caml-to-extra-indent -1 + "*Extra indent for caml lines starting with the to keyword. +Usually negative. nil is align on master.") +(make-variable-buffer-local 'caml-to-extra-indent) + +(defvar caml-with-extra-indent nil + "*Extra indent for caml lines starting with the with keyword. +Usually negative. nil is align on master.") +(make-variable-buffer-local 'caml-with-extra-indent) + +(defvar caml-comment-indent 3 + "*Indent inside comments.") +(make-variable-buffer-local 'caml-comment-indent) + +(defvar caml-|-extra-indent -2 + "*Extra indent for caml lines starting with the | operator. +Usually negative. nil is align on master.") +(make-variable-buffer-local 'caml-|-extra-indent) + +(defvar caml-rb-extra-indent -2 + "*Extra indent for caml lines statring with ]. +Usually negative. nil is align on master.") + +(defvar caml-rc-extra-indent -2 + "*Extra indent for caml lines starting with }. +Usually negative. nil is align on master.") + +(defvar caml-rp-extra-indent -1 + "*Extra indent for caml lines starting with ). +Usually negative. nil is align on master.") + +(defvar caml-electric-indent t + "*Non-nil means electrically indent lines starting with |, ] or }. + +Many people find eletric keys irritating, so you can disable them if +you are one.") + +(defvar caml-electric-close-vector t + "*Non-nil means electrically insert a | before a vector-closing ]. + +Many people find eletric keys irritating, so you can disable them if +you are one. You should probably have this on, though, if you also +have caml-electric-indent on, which see.") + +;;code +(if (or (not (fboundp 'indent-line-to)) + (not (fboundp 'buffer-substring-no-properties))) + (require 'caml-compat)) + +(defvar caml-shell-active nil + "Non nil when a subshell is running.") + +(defvar running-xemacs (string-match "XEmacs" emacs-version) + "Non-nil if we are running in the XEmacs environment.") + +(defvar caml-mode-map nil + "Keymap used in Caml mode.") +(if caml-mode-map + () + (setq caml-mode-map (make-sparse-keymap)) + (define-key caml-mode-map "|" 'caml-electric-pipe) + (define-key caml-mode-map "}" 'caml-electric-pipe) + (define-key caml-mode-map "]" 'caml-electric-rb) + (define-key caml-mode-map "\t" 'caml-indent-command) + (define-key caml-mode-map [backtab] 'caml-unindent-command) + +;itz 04-21-96 instead of defining a new function, use defadvice +;that way we get out effect even when we do \C-x` in compilation buffer +; (define-key caml-mode-map "\C-x`" 'caml-next-error) + + (if running-xemacs + (define-key caml-mode-map 'backspace 'backward-delete-char-untabify) + (define-key caml-mode-map "\177" 'backward-delete-char-untabify)) + + ;; caml-types + (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type) ; "type" + (define-key caml-mode-map [?\C-c?\C-f] 'caml-types-show-call) ; "function" + (define-key caml-mode-map [?\C-c?\C-l] 'caml-types-show-ident) ; "let" + ;; must be a mouse-down event. Can be any button and any prefix + (define-key caml-mode-map [?\C-c down-mouse-1] 'caml-types-explore) + ;; caml-help + (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path) + (define-key caml-mode-map [?\C-c?]] 'ocaml-close-module) + (define-key caml-mode-map [?\C-c?[] 'ocaml-open-module) + (define-key caml-mode-map [?\C-c?\C-h] 'caml-help) + (define-key caml-mode-map [?\C-c?\t] 'caml-complete) + ;; others + (define-key caml-mode-map "\C-cb" 'caml-insert-begin-form) + (define-key caml-mode-map "\C-cf" 'caml-insert-for-form) + (define-key caml-mode-map "\C-ci" 'caml-insert-if-form) + (define-key caml-mode-map "\C-cl" 'caml-insert-let-form) + (define-key caml-mode-map "\C-cm" 'caml-insert-match-form) + (define-key caml-mode-map "\C-ct" 'caml-insert-try-form) + (define-key caml-mode-map "\C-cw" 'caml-insert-while-form) + (define-key caml-mode-map "\C-c`" 'caml-goto-phrase-error) + (define-key caml-mode-map "\C-c\C-a" 'caml-find-alternate-file) + (define-key caml-mode-map "\C-c\C-c" 'compile) + (define-key caml-mode-map "\C-c\C-e" 'caml-eval-phrase) + (define-key caml-mode-map "\C-c\C-\[" 'caml-backward-to-less-indent) + (define-key caml-mode-map "\C-c\C-\]" 'caml-forward-to-less-indent) + (define-key caml-mode-map "\C-c\C-q" 'caml-indent-phrase) + (define-key caml-mode-map "\C-c\C-r" 'caml-eval-region) + (define-key caml-mode-map "\C-c\C-s" 'caml-show-subshell) + (define-key caml-mode-map "\M-\C-h" 'caml-mark-phrase) + (define-key caml-mode-map "\M-\C-q" 'caml-indent-phrase) + (define-key caml-mode-map "\M-\C-x" 'caml-eval-phrase) + + (if running-xemacs nil ; if not running xemacs + (let ((map (make-sparse-keymap "Caml")) + (forms (make-sparse-keymap "Forms"))) + (define-key caml-mode-map "\C-c\C-d" 'caml-show-imenu) + (define-key caml-mode-map [menu-bar] (make-sparse-keymap)) + (define-key caml-mode-map [menu-bar caml] (cons "Caml" map)) + ;; caml-help + + (define-key map [open] '("Open add path" . ocaml-add-path )) + (define-key map [close] + '("Close module for help" . ocaml-close-module)) + (define-key map [open] '("Open module for help" . ocaml-open-module)) + (define-key map [help] '("Help for identifier" . caml-help)) + (define-key map [complete] '("Complete identifier" . caml-complete)) + (define-key map [separator-help] '("---")) + + ;; caml-types + (define-key map [show-type] + '("Show type at point" . caml-types-show-type )) + (define-key map [separator-types] '("---")) + + ;; others + (define-key map [camldebug] '("Call debugger..." . camldebug)) + (define-key map [run-caml] '("Start subshell..." . run-caml)) + (define-key map [compile] '("Compile..." . compile)) + (define-key map [switch-view] + '("Switch view" . caml-find-alternate-file)) + (define-key map [separator-format] '("--")) + (define-key map [forms] (cons "Forms" forms)) + (define-key map [show-imenu] '("Show index" . caml-show-imenu)) + (put 'caml-show-imenu 'menu-enable '(not caml-imenu-shown)) + (define-key map [show-subshell] '("Show subshell" . caml-show-subshell)) + (put 'caml-show-subshell 'menu-enable 'caml-shell-active) + (define-key map [eval-phrase] '("Eval phrase" . caml-eval-phrase)) + (put 'caml-eval-phrase 'menu-enable 'caml-shell-active) + (define-key map [indent-phrase] '("Indent phrase" . caml-indent-phrase)) + (define-key forms [while] + '("while .. do .. done" . caml-insert-while-form)) + (define-key forms [try] '("try .. with .." . caml-insert-try-form)) + (define-key forms [match] '("match .. with .." . caml-insert-match-form)) + (define-key forms [let] '("let .. in .." . caml-insert-let-form)) + (define-key forms [if] '("if .. then .. else .." . caml-insert-if-form)) + (define-key forms [begin] '("for .. do .. done" . caml-insert-for-form)) + (define-key forms [begin] '("begin .. end" . caml-insert-begin-form))))) + +(defvar caml-mode-xemacs-menu + (if running-xemacs + '("Caml" + [ "Indent phrase" caml-indent-phrase :keys "C-M-q" ] + [ "Eval phrase" caml-eval-phrase + :active caml-shell-active :keys "C-M-x" ] + [ "Show subshell" caml-show-subshell caml-shell-active ] + ("Forms" + [ "while .. do .. done" caml-insert-while-form t] + [ "try .. with .." caml-insert-try-form t ] + [ "match .. with .." caml-insert-match-form t ] + [ "let .. in .." caml-insert-let-form t ] + [ "if .. then .. else .." caml-insert-if-form t ] + [ "for .. do .. done" caml-insert-for-form t ] + [ "begin .. end" caml-insert-begin-form t ]) + "---" + [ "Switch view" caml-find-alternate-file t ] + [ "Compile..." compile t ] + [ "Start subshell..." run-caml t ] + "---" + [ "Show type at point" caml-types-show-type t ] + "---" + [ "Complete identifier" caml-complete t ] + [ "Help for identifier" caml-help t ] + [ "Add path for documentation" ocaml-add-path t ] + [ "Open module for documentation" ocaml-open t ] + [ "Close module for documentation" ocaml-close t ] + )) + "Menu to add to the menubar when running Xemacs") + +(defvar caml-mode-syntax-table nil + "Syntax table in use in Caml mode buffers.") +(if caml-mode-syntax-table + () + (setq caml-mode-syntax-table (make-syntax-table)) + ; backslash is an escape sequence + (modify-syntax-entry ?\\ "\\" caml-mode-syntax-table) + ; ( is first character of comment start + (modify-syntax-entry ?\( "()1n" caml-mode-syntax-table) + ; * is second character of comment start, + ; and first character of comment end + (modify-syntax-entry ?* ". 23n" caml-mode-syntax-table) + ; ) is last character of comment end + (modify-syntax-entry ?\) ")(4" caml-mode-syntax-table) + ; backquote was a string-like delimiter (for character literals) + ; (modify-syntax-entry ?` "\"" caml-mode-syntax-table) + ; quote and underscore are part of words + (modify-syntax-entry ?' "w" caml-mode-syntax-table) + (modify-syntax-entry ?_ "w" caml-mode-syntax-table) + ; ISO-latin accented letters and EUC kanjis are part of words + (let ((i 160)) + (while (< i 256) + (modify-syntax-entry i "w" caml-mode-syntax-table) + (setq i (1+ i))))) + +(defvar caml-mode-abbrev-table nil + "Abbrev table used for Caml mode buffers.") +(if caml-mode-abbrev-table nil + (setq caml-mode-abbrev-table (make-abbrev-table)) + (define-abbrev caml-mode-abbrev-table "and" "and" 'caml-abbrev-hook) + (define-abbrev caml-mode-abbrev-table "do" "do" 'caml-abbrev-hook) + (define-abbrev caml-mode-abbrev-table "done" "done" 'caml-abbrev-hook) + (define-abbrev caml-mode-abbrev-table "else" "else" 'caml-abbrev-hook) + (define-abbrev caml-mode-abbrev-table "end" "end" 'caml-abbrev-hook) + (define-abbrev caml-mode-abbrev-table "in" "in" 'caml-abbrev-hook) + (define-abbrev caml-mode-abbrev-table "then" "then" 'caml-abbrev-hook) + (define-abbrev caml-mode-abbrev-table "with" "with" 'caml-abbrev-hook)) + +;; Other internal variables + +(defvar caml-last-noncomment-pos nil + "Caches last buffer position determined not inside a caml comment.") +(make-variable-buffer-local 'caml-last-noncomment-pos) + +;;last-noncomment-pos can be a simple position, because we nil it +;;anyway whenever buffer changes upstream. last-comment-start and -end +;;have to be markers, because we preserve them when the changes' end +;;doesn't overlap with the comment's start. + +(defvar caml-last-comment-start nil + "A marker caching last determined caml comment start.") +(make-variable-buffer-local 'caml-last-comment-start) + +(defvar caml-last-comment-end nil + "A marker caching last determined caml comment end.") +(make-variable-buffer-local 'caml-last-comment-end) + +(make-variable-buffer-local 'before-change-function) + +(defvar caml-imenu-shown nil + "True if we have computed definition list.") +(make-variable-buffer-local 'caml-imenu-shown) + +(defconst caml-imenu-search-regexp + (concat "\\<in\\>\\|" + "^[ \t]*\\(let\\|class\\|type\\|m\\(odule\\|ethod\\)" + "\\|functor\\|and\\|val\\)[ \t]+" + "\\(\\('[a-zA-Z0-9]+\\|([^)]+)" + "\\|mutable\\|private\\|rec\\|type\\)[ \t]+\\)?" + "\\([a-zA-Z][a-zA-Z0-9_']*\\)")) + +;;; The major mode +(eval-when-compile + (if (and (boundp 'running-xemacs) running-xemacs) nil + (require 'imenu))) + +;; +(defvar caml-mode-hook nil + "Hook for caml-mode") + +(defun caml-mode () + "Major mode for editing Caml code. + +\\{caml-mode-map}" + + (interactive) + (kill-all-local-variables) + (setq major-mode 'caml-mode) + (setq mode-name "caml") + (use-local-map caml-mode-map) + (set-syntax-table caml-mode-syntax-table) + (setq local-abbrev-table caml-mode-abbrev-table) + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat "^$\\|" page-delimiter)) + (make-local-variable 'paragraph-separate) + (setq paragraph-separate paragraph-start) + (make-local-variable 'paragraph-ignore-fill-prefix) + (setq paragraph-ignore-fill-prefix t) + (make-local-variable 'require-final-newline) + (setq require-final-newline t) + (make-local-variable 'comment-start) + (setq comment-start "(*") + (make-local-variable 'comment-end) + (setq comment-end "*)") + (make-local-variable 'comment-column) + (setq comment-column 40) + (make-local-variable 'comment-start-skip) + (setq comment-start-skip "(\\*+ *") + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments nil) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'caml-indent-command) + ;itz Fri Sep 25 13:23:49 PDT 1998 + (make-local-variable 'add-log-current-defun-function) + (setq add-log-current-defun-function 'caml-current-defun) + ;itz 03-25-96 + (setq before-change-function 'caml-before-change-function) + (setq caml-last-noncomment-pos nil) + (setq caml-last-comment-start (make-marker)) + (setq caml-last-comment-end (make-marker)) + ;garrigue 27-11-96 + (setq case-fold-search nil) + ;garrigue july 97 + (if running-xemacs ; from Xemacs lisp mode + (if (and (featurep 'menubar) + current-menubar) + (progn + ;; make a local copy of the menubar, so our modes don't + ;; change the global menubar + (set-buffer-menubar current-menubar) + (add-submenu nil caml-mode-xemacs-menu))) + ;imenu support (not for Xemacs) + (make-local-variable 'imenu-create-index-function) + (setq imenu-create-index-function 'caml-create-index-function) + (make-local-variable 'imenu-generic-expression) + (setq imenu-generic-expression caml-imenu-search-regexp) + (if (and caml-imenu-enable (< (buffer-size) 10000)) + (caml-show-imenu))) + (run-hooks 'caml-mode-hook)) + +(defun caml-set-compile-command () + "Hook to set compile-command locally, unless there is a Makefile or + a _build directory or a _tags file in the current directory." + (interactive) + (unless (or (null buffer-file-name) + (file-exists-p "makefile") + (file-exists-p "Makefile") + (file-exists-p "_build") + (file-exists-p "_tags")) + (let* ((filename (file-name-nondirectory buffer-file-name)) + (basename (file-name-sans-extension filename)) + (command nil)) + (cond + ((string-match ".*\\.mli\$" filename) + (setq command "ocamlc -c")) + ((string-match ".*\\.ml\$" filename) + (setq command "ocamlc -c") ; (concat "ocamlc -o " basename) + ) + ((string-match ".*\\.mll\$" filename) + (setq command "ocamllex")) + ((string-match ".*\\.mll\$" filename) + (setq command "ocamlyacc")) + ) + (if command + (progn + (make-local-variable 'compile-command) + (setq compile-command (concat command " " filename)))) + ))) + +(add-hook 'caml-mode-hook 'caml-set-compile-command) + +;;; Auxiliary function. Garrigue 96-11-01. + +(defun caml-find-alternate-file () + (interactive) + (let ((name (buffer-file-name))) + (if (string-match "^\\(.*\\)\\.\\(ml\\|mli\\)$" name) + (find-file + (concat + (caml-match-string 1 name) + (if (string= "ml" (caml-match-string 2 name)) ".mli" ".ml")))))) + +;;; subshell support + +(defun caml-eval-region (start end) + "Send the current region to the inferior Caml process." + (interactive"r") + (require 'inf-caml) + (inferior-caml-eval-region start end)) + +;; old version ---to be deleted later +; +; (defun caml-eval-phrase () +; "Send the current Caml phrase to the inferior Caml process." +; (interactive) +; (save-excursion +; (let ((bounds (caml-mark-phrase))) +; (inferior-caml-eval-region (car bounds) (cdr bounds))))) + +(defun caml-eval-phrase (arg &optional min max) + "Send the phrase containing the point to the CAML process. +With prefix-arg send as many phrases as its numeric value, +If an error occurs during evalutaion, stop at this phrase and +repport the error. + +Return nil if noerror and position of error if any. + +If arg's numeric value is zero or negative, evaluate the current phrase +or as many as prefix arg, ignoring evaluation errors. +This allows to jump other erroneous phrases. + +Optional arguments min max defines a region within which the phrase +should lies." + (interactive "p") + (require 'inf-caml) + (inferior-caml-eval-phrase arg min max)) + +(defun caml-eval-buffer (arg) + "Evaluate the buffer from the beginning to the phrase under the point. +With prefix arg, evaluate past the whole buffer, no stopping at +the current point." + (interactive "p") + (let ((here (point)) err) + (goto-char (point-min)) + (setq err + (caml-eval-phrase 500 (point-min) (if arg (point-max) here))) + (if err (set-mark err)) + (goto-char here))) + +(defun caml-show-subshell () + (interactive) + (require 'inf-caml) + (inferior-caml-show-subshell)) + + +;;; Imenu support +(defun caml-show-imenu () + (interactive) + (require 'imenu) + (switch-to-buffer (current-buffer)) + (imenu-add-to-menubar "Defs") + (setq caml-imenu-shown t)) + +(defun caml-prev-index-position-function () + (let (found data) + (while (and (setq found + (re-search-backward caml-imenu-search-regexp nil 'move)) + (progn (setq data (match-data)) t) + (or (caml-in-literal-p) + (caml-in-comment-p) + (if (looking-at "in") (caml-find-in-match))))) + (set-match-data data) + found)) +(defun caml-create-index-function () + (let (value-alist + type-alist + class-alist + method-alist + module-alist + and-alist + all-alist + menu-alist + (prev-pos (point-max)) + index) + (goto-char prev-pos) + (imenu-progress-message prev-pos 0 t) + ;; collect definitions + (while (caml-prev-index-position-function) + (setq index (cons (caml-match-string 5) (point))) + (imenu-progress-message prev-pos nil t) + (setq all-alist (cons index all-alist)) + (cond + ((looking-at "[ \t]*and") + (setq and-alist (cons index and-alist))) + ((looking-at "[ \t]*let") + (setq value-alist (cons index (append and-alist value-alist))) + (setq and-alist nil)) + ((looking-at "[ \t]*type") + (setq type-alist (cons index (append and-alist type-alist))) + (setq and-alist nil)) + ((looking-at "[ \t]*class") + (setq class-alist (cons index (append and-alist class-alist))) + (setq and-alist nil)) + ((looking-at "[ \t]*val") + (setq value-alist (cons index value-alist))) + ((looking-at "[ \t]*\\(module\\|functor\\)") + (setq module-alist (cons index module-alist))) + ((looking-at "[ \t]*method") + (setq method-alist (cons index method-alist))))) + ;; build menu + (mapcar + '(lambda (pair) + (if (symbol-value (cdr pair)) + (setq menu-alist + (cons + (cons (car pair) + (sort (symbol-value (cdr pair)) 'imenu--sort-by-name)) + menu-alist)))) + '(("Values" . value-alist) + ("Types" . type-alist) + ("Modules" . module-alist) + ("Methods" . method-alist) + ("Classes" . class-alist))) + (if all-alist (setq menu-alist (cons (cons "Index" all-alist) menu-alist))) + (imenu-progress-message prev-pos 100 t) + menu-alist)) + +;;; Indentation stuff + +(defun caml-in-indentation () + "Tests whether all characters between beginning of line and point +are blanks." + (save-excursion + (skip-chars-backward " \t") + (bolp))) + +;;; The command +;;; Sorry, I didn't like the previous behaviour... Garrigue 96/11/01 + +(defun caml-indent-command (&optional p) + "Indent the current line in Caml mode. + +Compute new indentation based on caml syntax. If prefixed, indent +the line all the way to where point is." + + (interactive "*p") + (cond + ((and p (> p 1)) (indent-line-to (current-column))) + ((caml-in-indentation) (indent-line-to (caml-compute-final-indent))) + (t (save-excursion + (indent-line-to + (caml-compute-final-indent)))))) + +(defun caml-unindent-command () + + "Decrease indentation by one level in Caml mode. + +Works only if the point is at the beginning of an indented line +\(i.e. all characters between beginning of line and point are +blanks\). Does nothing otherwise. The unindent size is given by the +variable caml-mode-indentation." + + (interactive "*") + (let* ((begline + (save-excursion + (beginning-of-line) + (point))) + (current-offset + (- (point) begline))) + (if (and (>= current-offset caml-mode-indentation) + (caml-in-indentation)) + (backward-delete-char-untabify caml-mode-indentation)))) + +;;; +;;; Error processing +;;; + +;; Error positions are given in bytes, not in characters +;; This function switches to monobyte mode + +(if (not (fboundp 'char-bytes)) + (defalias 'forward-byte 'forward-char) + (defun caml-char-bytes (ch) + (let ((l (char-bytes ch))) + (if (> l 1) (- l 1) l))) + (defun forward-byte (count) + (if (> count 0) + (while (> count 0) + (let ((char (char-after))) + (if (null char) + (setq count 0) + (setq count (- count (caml-char-bytes (char-after)))) + (forward-char)))) + (while (< count 0) + (let ((char (char-after))) + (if (null char) + (setq count 0) + (setq count (+ count (caml-char-bytes (char-before)))) + (backward-char)))) + ))) + +(require 'compile) + +;; In Emacs 19, the regexps in compilation-error-regexp-alist do not +;; match the error messages when the language is not English. +;; Hence we add a regexp. + +(defconst caml-error-regexp + "^[ A-\377]+ \"\\([^\"\n]+\\)\", [A-\377]+ \\([0-9]+\\)[-,:]" + "Regular expression matching the error messages produced by camlc.") + +(if (boundp 'compilation-error-regexp-alist) + (or (assoc caml-error-regexp + compilation-error-regexp-alist) + (setq compilation-error-regexp-alist + (cons (list caml-error-regexp 1 2) + compilation-error-regexp-alist)))) + +;; A regexp to extract the range info + +(defconst caml-error-chars-regexp + ".*, .*, [A-\377]+ \\([0-9]+\\)-\\([0-9]+\\):?" + "Regular expression extracting the character numbers +from an error message produced by camlc.") + +;; Wrapper around next-error. + +(defvar caml-error-overlay nil) +(defvar caml-next-error-skip-warnings-flag nil) + +(defun caml-string-to-int (x) + (if (fboundp 'string-to-number) (string-to-number x) (string-to-int x))) + +;;itz 04-21-96 somebody didn't get the documentation for next-error +;;right. When the optional argument is a number n, it should move +;;forward n errors, not reparse. + +;itz 04-21-96 instead of defining a new function, use defadvice +;that way we get our effect even when we do \C-x` in compilation buffer + +(defadvice next-error (after caml-next-error activate) + "Reads the extra positional information provided by the Caml compiler. + +Puts the point and the mark exactly around the erroneous program +fragment. The erroneous fragment is also temporarily highlighted if +possible." + + (if (eq major-mode 'caml-mode) + (let (skip bol beg end) + (save-excursion + (set-buffer + (if (boundp 'compilation-last-buffer) + compilation-last-buffer ;Emacs 19 + "*compilation*")) ;Emacs 18 + (save-excursion + (goto-char (window-point (get-buffer-window (current-buffer)))) + (if (looking-at caml-error-chars-regexp) + (setq beg + (caml-string-to-int + (buffer-substring (match-beginning 1) (match-end 1))) + end + (caml-string-to-int + (buffer-substring (match-beginning 2) (match-end 2))))) + (next-line) + (beginning-of-line) + (if (and (looking-at "Warning") + caml-next-error-skip-warnings-flag) + (setq skip 't)))) + (cond + (skip (next-error)) + (beg + (setq end (- end beg)) + (beginning-of-line) + (forward-byte beg) + (setq beg (point)) + (forward-byte end) + (setq end (point)) + (goto-char beg) + (push-mark end t) + (cond ((fboundp 'make-overlay) + (if caml-error-overlay () + (setq caml-error-overlay (make-overlay 1 1)) + (overlay-put caml-error-overlay 'face 'region)) + (unwind-protect + (progn + (move-overlay caml-error-overlay + beg end (current-buffer)) + (sit-for 60)) + (delete-overlay caml-error-overlay))))))))) + +(defun caml-next-error-skip-warnings (&rest args) + (let ((old-flag caml-next-error-skip-warnings-flag)) + (unwind-protect + (progn (setq caml-next-error-skip-warnings-flag 't) + (apply 'next-error args)) + (setq caml-next-error-skip-warnings-flag old-flag)))) + + +;; Usual match-string doesn't work properly with font-lock-mode +;; on some emacs. + +(defun caml-match-string (num &optional string) + + "Return string of text matched by last search, without properties. + +NUM specifies which parenthesized expression in the last regexp. +Value is nil if NUMth pair didn't match, or there were less than NUM +pairs. Zero means the entire text matched by the whole regexp or +whole string." + + (let* ((data (match-data)) + (begin (nth (* 2 num) data)) + (end (nth (1+ (* 2 num)) data))) + (if string (substring string begin end) + (buffer-substring-no-properties begin end)))) + +;; itz Thu Sep 24 19:02:42 PDT 1998 this is to have some level of +;; comfort when sending phrases to the toplevel and getting errors. +(defun caml-goto-phrase-error () + "Find the error location in current Caml phrase." + (interactive) + (require 'inf-caml) + (let ((bounds (save-excursion (caml-mark-phrase)))) + (inferior-caml-goto-error (car bounds) (cdr bounds)))) + +;;; Phrases + +;itz the heuristics used to see if we're `between two phrases' +;didn't seem right to me. + +(defconst caml-phrase-start-keywords + (concat "\\<\\(class\\|ex\\(ternal\\|ception\\)\\|functor" + "\\|let\\|module\\|open\\|type\\|val\\)\\>") + "Keywords starting phrases in files") + +;; a phrase starts when a toplevel keyword is at the beginning of a line +(defun caml-at-phrase-start-p () + (and (bolp) + (or (looking-at "#") + (looking-at caml-phrase-start-keywords)))) + +(defun caml-skip-comments-forward () + (skip-chars-forward " \n\t") + (while (or (looking-at comment-start-skip) (caml-in-comment-p)) + (if (= (following-char) ?\)) (forward-char) + (search-forward comment-end)) + (skip-chars-forward " \n\t"))) + +(defun caml-skip-comments-backward () + (skip-chars-backward " \n\t") + (while (and (eq (preceding-char) ?\)) (eq (char-after (- (point) 2)) ?*)) + (backward-char) + (while (caml-in-comment-p) (search-backward comment-start)) + (skip-chars-backward " \n\t"))) + +(defconst caml-phrase-sep-keywords (concat ";;\\|" caml-phrase-start-keywords)) + +(defun caml-find-phrase (&optional min-pos max-pos) + "Find the CAML phrase containing the point. +Return the position of the beginning of the phrase, and move point +to the end. +" + (interactive) + (if (not min-pos) (setq min-pos (point-min))) + (if (not max-pos) (setq max-pos (point-max))) + (let (beg end use-semi kwop) + ;(caml-skip-comments-backward) + (cond + ; shall we have special processing for semicolons? + ;((and (eq (char-before (- (point) 1)) ?\;) (eq (char-before) ?\;)) + ; (forward-char) + ; (caml-skip-comments-forward) + ; (setq beg (point)) + ; (while (and (search-forward ";;" max-pos 'move) + ; (or (caml-in-comment-p) (caml-in-literal-p))))) + (t + (caml-skip-comments-forward) + (if (caml-at-phrase-start-p) (forward-char)) + (while (and (cond + ((re-search-forward caml-phrase-sep-keywords max-pos 'move) + (goto-char (match-beginning 0)) t)) + (or (not (or (bolp) (looking-at ";;"))) + (caml-in-comment-p) + (caml-in-literal-p))) + (forward-char)) + (setq end (+ (point) (if (looking-at ";;") 2 0))) + (while (and + (setq kwop (caml-find-kwop caml-phrase-sep-keywords min-pos)) + (not (string= kwop ";;")) + (not (bolp)))) + (if (string= kwop ";;") (forward-char 2)) + (if (not kwop) (goto-char min-pos)) + (caml-skip-comments-forward) + (setq beg (point)) + (if (>= beg end) (error "no phrase before point")) + (goto-char end))) + (caml-skip-comments-forward) + beg)) + +(defun caml-mark-phrase (&optional min-pos max-pos) + "Put mark at end of this Caml phrase, point at beginning. +" + (interactive) + (let* ((beg (caml-find-phrase min-pos max-pos)) (end (point))) + (push-mark) + (goto-char beg) + (cons beg end))) + +;;itz Fri Sep 25 12:58:13 PDT 1998 support for adding change-log entries +(defun caml-current-defun () + (save-excursion + (caml-mark-phrase) + (if (not (looking-at caml-phrase-start-keywords)) nil + (re-search-forward caml-phrase-start-keywords) + (let ((done nil)) + (while (not done) + (cond + ((looking-at "\\s ") + (skip-syntax-forward " ")) + ((char-equal (following-char) ?\( ) + (forward-sexp 1)) + ((char-equal (following-char) ?') + (skip-syntax-forward "w_")) + (t (setq done t))))) + (re-search-forward "\\(\\sw\\|\\s_\\)+") + (match-string 0)))) + +(defun caml-overlap (b1 e1 b2 e2) + (<= (max b1 b2) (min e1 e2))) + +;this clears the last comment cache if necessary +(defun caml-before-change-function (begin end) + (if (and caml-last-noncomment-pos + (> caml-last-noncomment-pos begin)) + (setq caml-last-noncomment-pos nil)) + (if (and (marker-position caml-last-comment-start) + (marker-position caml-last-comment-end) + (caml-overlap begin end + caml-last-comment-start + caml-last-comment-end)) + (prog2 + (set-marker caml-last-comment-start nil) + (set-marker caml-last-comment-end nil))) + (let ((orig-function (default-value 'before-change-function))) + (if orig-function (funcall orig-function begin end)))) + +(defun caml-in-literal-p () + "Returns non-nil if point is inside a caml literal." + (let* ((start-literal (concat "[\"" caml-quote-char "]")) + (char-literal + (concat "\\([^\\]\\|\\\\\\.\\|\\\\[0-9][0-9][0-9]\\)" + caml-quote-char)) + (pos (point)) + (eol (progn (end-of-line 1) (point))) + state in-str) + (beginning-of-line 1) + (while (and (not state) + (re-search-forward start-literal eol t) + (<= (point) pos)) + (cond + ((string= (caml-match-string 0) "\"") + (setq in-str t) + (while (and in-str (not state) + (re-search-forward "\"\\|\\\\\"" eol t)) + (if (> (point) pos) (setq state t)) + (if (string= (caml-match-string 0) "\"") (setq in-str nil))) + (if in-str (setq state t))) + ((looking-at char-literal) + (if (and (>= pos (match-beginning 0)) (< pos (match-end 0))) + (setq state t) + (goto-char (match-end 0)))))) + (goto-char pos) + state)) + +(defun caml-forward-comment () + "Skip one (eventually nested) comment." + (let ((count 1) match) + (while (> count 0) + (if (not (re-search-forward "(\\*\\|\\*)" nil 'move)) + (setq count -1) + (setq match (caml-match-string 0)) + (cond + ((caml-in-literal-p) + nil) + ((string= match comment-start) + (setq count (1+ count))) + (t + (setq count (1- count)))))) + (= count 0))) + +(defun caml-backward-comment () + "Skip one (eventually nested) comment." + (let ((count 1) match) + (while (> count 0) + (if (not (re-search-backward "(\\*\\|\\*)" nil 'move)) + (setq count -1) + (setq match (caml-match-string 0)) + (cond + ((caml-in-literal-p) + nil) + ((string= match comment-start) + (setq count (1- count))) + (t + (setq count (1+ count)))))) + (= count 0))) + +(defun caml-in-comment-p () + "Returns non-nil if point is inside a caml comment. +Returns nil for the parenthesis openning a comment." + ;;we look for comments differently than literals. there are two + ;;reasons for this. first, caml has nested comments and it is not so + ;;clear that parse-partial-sexp supports them; second, if proper + ;;style is used, literals are never split across lines, so we don't + ;;have to worry about bogus phrase breaks inside literals, while we + ;;have to account for that possibility in comments. + (if caml-last-comment-start + (save-excursion + (let* ((cached-pos caml-last-noncomment-pos) + (cached-begin (marker-position caml-last-comment-start)) + (cached-end (marker-position caml-last-comment-end))) + (cond + ((and cached-begin cached-end + (< cached-begin (point)) (< (point) cached-end)) t) + ((and cached-pos (= cached-pos (point))) nil) + ((and cached-pos (> cached-pos (point)) + (< (abs (- cached-pos (point))) caml-lookback-limit)) + (let (end found (here (point))) + ; go back to somewhere sure + (goto-char cached-pos) + (while (> (point) here) + ; look for the end of a comment + (while (and (if (search-backward comment-end (1- here) 'move) + (setq end (match-end 0)) + (setq end nil)) + (caml-in-literal-p))) + (if end (setq found (caml-backward-comment)))) + (if (and found (= (point) here)) (setq end nil)) + (if (not end) + (setq caml-last-noncomment-pos here) + (set-marker caml-last-comment-start (point)) + (set-marker caml-last-comment-end end)) + end)) + (t + (let (begin found (here (point))) + ;; go back to somewhere sure (or far enough) + (goto-char + (if cached-pos cached-pos (- (point) caml-lookback-limit))) + (while (< (point) here) + ;; look for the beginning of a comment + (while (and (if (search-forward comment-start (1+ here) 'move) + (setq begin (match-beginning 0)) + (setq begin nil)) + (caml-in-literal-p))) + (if begin (setq found (caml-forward-comment)))) + (if (and found (= (point) here)) (setq begin nil)) + (if (not begin) + (setq caml-last-noncomment-pos here) + (set-marker caml-last-comment-start begin) + (set-marker caml-last-comment-end (point))) + begin))))))) + +;; Various constants and regexps + +(defconst caml-before-expr-prefix + (concat "\\<\\(asr\\|begin\\|class\\|do\\(wnto\\)?\\|else" + "\\|i\\(f\\|n\\(herit\\|itializer\\)?\\)" + "\\|f\\(or\\|un\\(ct\\(ion\\|or\\)\\)?\\)" + "\\|l\\(and\\|or\\|s[lr]\\|xor\\)\\|m\\(atch\\|od\\)" + "\\|o[fr]\\|parser\\|s\\(ig\\|truct\\)\\|t\\(hen\\|o\\|ry\\)" + "\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\)\\>\\|:begin\\>" + "\\|[=<>@^|&+-*/$%][!$%*+-./:<=>?@^|~]*\\|:[:=]\\|[[({,;]") + + "Keywords that may appear immediately before an expression. +Used to distinguish it from toplevel let construct.") + +(defconst caml-matching-kw-regexp + (concat + "\\<\\(and\\|do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in\\|t\\(hen\\|o\\)" + "\\|with\\)\\>\\|[^[|]|") + "Regexp used in caml mode for skipping back over nested blocks.") + +(defconst caml-matching-kw-alist + '(("|" . caml-find-pipe-match) + (";" . caml-find-semi-match) + ("," . caml-find-comma-match) + ("end" . caml-find-end-match) + ("done" . caml-find-done-match) + ("in" . caml-find-in-match) + ("with" . caml-find-with-match) + ("else" . caml-find-else-match) + ("then" . caml-find-then-match) + ("to" . caml-find-done-match) + ("do" . caml-find-done-match) + ("and" . caml-find-and-match)) + + "Association list used in caml mode for skipping back over nested blocks.") + +(defconst caml-kwop-regexps (make-vector 9 nil) + "Array of regexps representing caml keywords of different priorities.") + +(defun caml-in-expr-p () + (let ((pos (point)) (in-expr t)) + (caml-find-kwop + (concat caml-before-expr-prefix "\\|" + caml-matching-kw-regexp "\\|" + (aref caml-kwop-regexps caml-max-indent-priority))) + (cond + ; special case for ;; + ((and (> (point) 1) (= (preceding-char) ?\;) (= (following-char) ?\;)) + (setq in-expr nil)) + ((looking-at caml-before-expr-prefix) + (if (not (looking-at "(\\*")) (goto-char (match-end 0))) + (skip-chars-forward " \t\n") + (while (looking-at "(\\*") + (forward-char) + (caml-forward-comment) + (skip-chars-forward " \t\n")) + (if (<= pos (point)) (setq in-expr nil)))) + (goto-char pos) + in-expr)) + +(defun caml-at-sexp-close-p () + (or (char-equal ?\) (following-char)) + (char-equal ?\] (following-char)) + (char-equal ?} (following-char)))) + +(defun caml-find-kwop (kwop-regexp &optional min-pos) + "Look back for a caml keyword or operator matching KWOP-REGEXP. +Second optional argument MIN-POS bounds the search. + +Ignore occurences inside literals. If found, return a list of two +values: the actual text of the keyword or operator, and a boolean +indicating whether the keyword was one we looked for explicitly +{non-nil}, or on the other hand one of the block-terminating +keywords." + + (let ((start-literal (concat "[\"" caml-quote-char "]")) + found kwop) + (while (and (> (point) 1) (not found) + (re-search-backward kwop-regexp min-pos 'move)) + (setq kwop (caml-match-string 0)) + (cond + ((looking-at "(\\*") + (if (> (point) 1) (backward-char))) + ((caml-in-comment-p) + (search-backward "(" min-pos 'move)) + ((looking-at start-literal)) + ((caml-in-literal-p) + (re-search-backward start-literal min-pos 'move)) ;ugly hack + ((setq found t)))) + (if found + (if (not (string-match "\\`[^|[]|[^]|]?\\'" kwop)) ;arrrrgh!! + kwop + (forward-char 1) "|") nil))) + +; Association list of indentation values based on governing keywords. +; +;Each element is of the form (KEYWORD OP-TYPE PRIO INDENT). OP-TYPE is +;non-nil for operator-type nodes, which affect indentation in a +;different way from keywords: subsequent lines are indented to the +;actual occurrence of an operator, but relative to the indentation of +;the line where the governing keyword occurs. + +(defconst caml-no-indent 0) + +(defconst caml-kwop-alist + '(("begin" nil 6 caml-begin-indent) + (":begin" nil 6 caml-begin-indent) ; hack + ("class" nil 0 caml-class-indent) + ("constraint" nil 0 caml-val-indent) + ("sig" nil 1 caml-sig-indent) + ("struct" nil 1 caml-struct-indent) + ("exception" nil 0 caml-exception-indent) + ("for" nil 6 caml-for-indent) + ("fun" nil 3 caml-fun-indent) + ("function" nil 3 caml-function-indent) + ("if" nil 6 caml-if-indent) + ("if-else" nil 6 caml-if-else-indent) + ("include" nil 0 caml-include-indent) + ("inherit" nil 0 caml-inherit-indent) + ("initializer" nil 0 caml-initializer-indent) + ("let" nil 6 caml-let-indent) + ("let-in" nil 6 caml-let-in-indent) + ("match" nil 6 caml-match-indent) + ("method" nil 0 caml-method-indent) + ("module" nil 0 caml-module-indent) + ("object" nil 6 caml-object-indent) + ("of" nil 7 caml-of-indent) + ("open" nil 0 caml-no-indent) + ("parser" nil 3 caml-parser-indent) + ("try" nil 6 caml-try-indent) + ("type" nil 0 caml-type-indent) + ("val" nil 0 caml-val-indent) + ("when" nil 2 caml-if-indent) + ("while" nil 6 caml-while-indent) + ("::" t 5 caml-::-indent) + ("@" t 4 caml-@-indent) + ("^" t 4 caml-@-indent) + (":=" nil 3 caml-:=-indent) + ("<-" nil 3 caml-<--indent) + ("->" nil 2 caml-->-indent) + ("\[" t 8 caml-lb-indent) + ("{" t 8 caml-lc-indent) + ("\(" t 8 caml-lp-indent) + ("|" nil 2 caml-no-indent) + (";;" nil 0 caml-no-indent)) +; if-else and let-in are not keywords but idioms +; "|" is not in the regexps +; all these 3 values correspond to hard-coded names + +"Association list of indentation values based on governing keywords. + +Each element is of the form (KEYWORD OP-TYPE PRIO INDENT). OP-TYPE is +non-nil for operator-type nodes, which affect indentation in a +different way from keywords: subsequent lines are indented to the +actual occurrence of an operator, but relative to the indentation of +the line where the governing keyword occurs.") + +;;Originally, we had caml-kwop-regexp create these at runtime, from an +;;additional field in caml-kwop-alist. That proved way too slow, +;;although I still can't understand why. itz + +(aset caml-kwop-regexps 0 + (concat + "\\<\\(begin\\|object\\|for\\|s\\(ig\\|truct\\)\\|while\\)\\>" + "\\|:begin\\>\\|[[({]\\|;;")) +(aset caml-kwop-regexps 1 + (concat (aref caml-kwop-regexps 0) "\\|\\<\\(class\\|module\\)\\>")) +(aset caml-kwop-regexps 2 + (concat + (aref caml-kwop-regexps 1) + "\\|\\<\\(fun\\(ction\\)?\\|initializer\\|let\\|m\\(atch\\|ethod\\)" + "\\|parser\\|try\\|val\\)\\>\\|->")) +(aset caml-kwop-regexps 3 + (concat (aref caml-kwop-regexps 2) "\\|\\<if\\|when\\>")) +(aset caml-kwop-regexps 4 + (concat (aref caml-kwop-regexps 3) "\\|:=\\|<-")) +(aset caml-kwop-regexps 5 + (concat (aref caml-kwop-regexps 4) "\\|@")) +(aset caml-kwop-regexps 6 + (concat (aref caml-kwop-regexps 5) "\\|::\\|\\^")) +(aset caml-kwop-regexps 7 + (concat + (aref caml-kwop-regexps 0) + "\\|\\<\\(constraint\\|exception\\|in\\(herit\\|clude\\)" + "\\|o\\(f\\|pen\\)\\|type\\|val\\)\\>")) +(aset caml-kwop-regexps 8 + (concat (aref caml-kwop-regexps 6) + "\\|\\<\\(constraint\\|exception\\|in\\(herit\\|clude\\)" + "\\|o\\(f\\|pen\\)\\|type\\)\\>")) + +(defun caml-find-done-match () + (let ((unbalanced 1) (kwop t)) + (while (and (not (= 0 unbalanced)) kwop) + (setq kwop (caml-find-kwop "\\<\\(done\\|for\\|while\\)\\>")) + (cond + ((not kwop)) + ((string= kwop "done") (setq unbalanced (1+ unbalanced))) + (t (setq unbalanced (1- unbalanced))))) + kwop)) + +(defun caml-find-end-match () + (let ((unbalanced 1) (kwop t)) + (while (and (not (= 0 unbalanced)) kwop) + (setq kwop + (caml-find-kwop + "\\<\\(end\\|begin\\|object\\|s\\(ig\\|truct\\)\\)\\>\\|:begin\\>\\|;;")) + (cond + ((not kwop)) + ((string= kwop ";;") (setq kwop nil) (forward-line 1)) + ((string= kwop "end") (setq unbalanced (1+ unbalanced))) + ( t (setq unbalanced (1- unbalanced))))) + (if (string= kwop ":begin") "begin" + kwop))) + +(defun caml-find-in-match () + (let ((unbalanced 1) (kwop t)) + (while (and (not (= 0 unbalanced)) kwop) + (setq kwop (caml-find-kwop "\\<\\(in\\|let\\|end\\)\\>")) + (cond + ((not kwop)) + ((string= kwop "end") (caml-find-end-match)) + ((string= kwop "in") (setq unbalanced (1+ unbalanced))) + (t (setq unbalanced (1- unbalanced))))) + kwop)) + +(defun caml-find-with-match () + (let ((unbalanced 1) (kwop t)) + (while (and (not (= 0 unbalanced)) kwop) + (setq kwop + (caml-find-kwop + "\\<\\(with\\|try\\|m\\(atch\\|odule\\)\\|functor\\)\\>\\|[{}()]")) + (cond + ((not kwop)) + ((caml-at-sexp-close-p) + (caml-find-paren-match (following-char))) + ((string= kwop "with") + (setq unbalanced (1+ unbalanced))) + ((or (string= kwop "module") + (string= kwop "functor") + (string= kwop "{") + (string= kwop "(")) + (setq unbalanced 0)) + (t (setq unbalanced (1- unbalanced))))) + kwop)) + +(defun caml-find-paren-match (close) + (let ((unbalanced 1) + (regexp (cond ((= close ?\)) "[()]") + ((= close ?\]) "[][]") + ((= close ?\}) "[{}]")))) + (while (and (> unbalanced 0) + (caml-find-kwop regexp)) + (if (= close (following-char)) + (setq unbalanced (1+ unbalanced)) + (setq unbalanced (1- unbalanced)))))) + +(defun caml-find-then-match (&optional from-else) + (let ((bol (if from-else + (save-excursion + (progn (beginning-of-line) (point))))) + kwop done matching-fun) + (while (not done) + (setq kwop + (caml-find-kwop + "\\<\\(e\\(nd\\|lse\\)\\|done\\|then\\|if\\|with\\)\\>\\|[])};]")) + (cond + ((not kwop) (setq done t)) + ((caml-at-sexp-close-p) + (caml-find-paren-match (following-char))) + ((string= kwop "if") (setq done t)) + ((string= kwop "then") + (if (not from-else) (setq kwop (caml-find-then-match)))) + ((setq matching-fun (cdr-safe (assoc kwop caml-matching-kw-alist))) + (setq kwop (funcall matching-fun))))) + (if (and bol (>= (point) bol)) + "if-else" + kwop))) + +(defun caml-find-pipe-match () + (let ((done nil) (kwop) + (re (concat + "\\<\\(try\\|match\\|with\\|function\\|parser\\|type" + "\\|e\\(nd\\|lse\\)\\|done\\|then\\|in\\)\\>" + "\\|[^[|]|\\|[])}]"))) + (while (not done) + (setq kwop (caml-find-kwop re)) + (cond + ((not kwop) (setq done t)) + ((looking-at "[^[|]\\(|\\)") + (goto-char (match-beginning 1)) + (setq kwop "|") + (setq done t)) + ((caml-at-sexp-close-p) + (caml-find-paren-match (following-char))) + ((string= kwop "with") + (setq kwop (caml-find-with-match)) + (setq done t)) + ((string= kwop "parser") + (if (re-search-backward "\\<with\\>" (- (point) 5) t) + (setq kwop (caml-find-with-match))) + (setq done t)) + ((string= kwop "done") (caml-find-done-match)) + ((string= kwop "end") (caml-find-end-match)) + ((string= kwop "then") (caml-find-then-match)) + ((string= kwop "else") (caml-find-else-match)) + ((string= kwop "in") (caml-find-in-match)) + (t (setq done t)))) + kwop)) + +(defun caml-find-and-match () + (let ((done nil) (kwop)) + (while (not done) + (setq kwop (caml-find-kwop + "\\<\\(object\\|exception\\|let\\|type\\|end\\|in\\)\\>")) + (cond + ((not kwop) (setq done t)) + ((string= kwop "end") (caml-find-end-match)) + ((string= kwop "in") (caml-find-in-match)) + (t (setq done t)))) + kwop)) + +(defun caml-find-else-match () + (caml-find-then-match t)) + +(defun caml-find-semi-match () + (caml-find-kwop-skipping-blocks 2)) + +(defun caml-find-comma-match () + (caml-find-kwop-skipping-blocks 3)) + +(defun caml-find-kwop-skipping-blocks (prio) + "Look back for a caml keyword matching caml-kwop-regexps [PRIO]. + + Skip nested blocks." + + (let ((done nil) (kwop nil) (matching-fun) + (kwop-list (aref caml-kwop-regexps prio))) + (while (not done) + (setq kwop (caml-find-kwop + (concat caml-matching-kw-regexp + (cond ((> prio 3) "\\|[])},;]\\|") + ((> prio 2) "\\|[])};]\\|") + (t "\\|[])}]\\|")) + kwop-list))) + (cond + ((not kwop) (setq done t)) + ((caml-at-sexp-close-p) + (caml-find-paren-match (following-char))) + ((or (string= kwop ";;") + (and (string= kwop ";") (= (preceding-char) ?\;))) + (forward-line 1) + (setq kwop ";;") + (setq done t)) + ((and (>= prio 2) (string= kwop "|")) (setq done t)) + ((string= kwop "end") (caml-find-end-match)) + ((string= kwop "done") (caml-find-done-match)) + ((string= kwop "in") + (cond ((and (caml-find-in-match) (>= prio 2)) + (setq kwop "let-in") + (setq done t)))) + ((and (string= kwop "parser") (>= prio 2) + (re-search-backward "\\<with\\>" (- (point) 5) t)) + (setq kwop (caml-find-with-match)) + (setq done t)) + ((setq matching-fun (cdr-safe (assoc kwop caml-matching-kw-alist))) + (setq kwop (funcall matching-fun)) + (if (looking-at kwop-list) (setq done t))) + (t (let* ((kwop-info (assoc kwop caml-kwop-alist)) + (is-op (and (nth 1 kwop-info) + ; check that we are not at beginning of line + (let ((pos (point)) bti) + (back-to-indentation) + (setq bti (point)) + (goto-char pos) + (< bti pos))))) + (if (and is-op (looking-at + (concat (regexp-quote kwop) + "|?[ \t]*\\(\n\\|(\\*\\)"))) + (setq kwop-list + (aref caml-kwop-regexps (nth 2 kwop-info))) + (setq done t)))))) + kwop)) + +(defun caml-compute-basic-indent (prio) + "Compute indent of current caml line, ignoring leading keywords. + +Find the `governing node' for current line. Compute desired +indentation based on the node and the indentation alists. +Assumes point is exactly at line indentation. +Does not preserve point." + + (let* (in-expr + (kwop (cond + ((looking-at ";;") + (beginning-of-line 1)) + ((looking-at "|\\([^]|]\\|\\'\\)") + (caml-find-pipe-match)) + ((and (looking-at caml-phrase-start-keywords) + (caml-in-expr-p)) + (caml-find-end-match)) + ((and (looking-at caml-matching-kw-regexp) + (assoc (caml-match-string 0) caml-matching-kw-alist)) + (funcall (cdr-safe (assoc (caml-match-string 0) + caml-matching-kw-alist)))) + ((looking-at + (aref caml-kwop-regexps caml-max-indent-priority)) + (let* ((kwop (caml-match-string 0)) + (kwop-info (assoc kwop caml-kwop-alist)) + (prio (if kwop-info (nth 2 kwop-info) + caml-max-indent-priority))) + (if (and (looking-at (aref caml-kwop-regexps 0)) + (not (looking-at "object")) + (caml-in-expr-p)) + (setq in-expr t)) + (caml-find-kwop-skipping-blocks prio))) + (t + (if (and (= prio caml-max-indent-priority) (caml-in-expr-p)) + (setq in-expr t)) + (caml-find-kwop-skipping-blocks prio)))) + (kwop-info (assoc kwop caml-kwop-alist)) + (indent-diff + (cond + ((not kwop-info) (beginning-of-line 1) 0) + ((looking-at "[[({][|<]?[ \t]*") + (length (caml-match-string 0))) + ((nth 1 kwop-info) (symbol-value (nth 3 kwop-info))) + (t + (let ((pos (point))) + (back-to-indentation) +; (if (looking-at "\\<let\\>") (goto-char pos)) + (- (symbol-value (nth 3 kwop-info)) + (if (looking-at "|") caml-|-extra-indent 0)))))) + (extra (if in-expr caml-apply-extra-indent 0))) + (+ indent-diff extra (current-column)))) + +(defconst caml-leading-kwops-regexp + (concat + "\\<\\(and\\|do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in" + "\\|t\\(hen\\|o\\)\\|with\\)\\>\\|[]|})]") + + "Regexp matching caml keywords which need special indentation.") + +(defconst caml-leading-kwops-alist + '(("and" caml-and-extra-indent 2) + ("do" caml-do-extra-indent 0) + ("done" caml-done-extra-indent 0) + ("else" caml-else-extra-indent 3) + ("end" caml-end-extra-indent 0) + ("in" caml-in-extra-indent 2) + ("then" caml-then-extra-indent 3) + ("to" caml-to-extra-indent 0) + ("with" caml-with-extra-indent 2) + ("|" caml-|-extra-indent 2) + ("]" caml-rb-extra-indent 0) + ("}" caml-rc-extra-indent 0) + (")" caml-rp-extra-indent 0)) + + "Association list of special caml keyword indent values. + +Each member is of the form (KEYWORD EXTRA-INDENT PRIO) where +EXTRA-INDENT is the variable holding extra indentation amount for +KEYWORD (usually negative) and PRIO is upper bound on priority of +matching nodes to determine KEYWORD's final indentation.") + +(defun caml-compute-final-indent () + (save-excursion + (back-to-indentation) + (cond + ((and (bolp) (looking-at comment-start-skip)) (current-column)) + ((caml-in-comment-p) + (let ((closing (looking-at "\\*)")) + (comment-mark (looking-at "\\*"))) + (caml-backward-comment) + (looking-at comment-start-skip) + (+ (current-column) + (cond + (closing 1) + (comment-mark 1) + (t (- (match-end 0) (match-beginning 0))))))) + (t (let* ((leading (looking-at caml-leading-kwops-regexp)) + (assoc-val (if leading (assoc (caml-match-string 0) + caml-leading-kwops-alist))) + (extra (if leading (symbol-value (nth 1 assoc-val)) 0)) + (prio (if leading (nth 2 assoc-val) + caml-max-indent-priority)) + (basic (caml-compute-basic-indent prio))) + (max 0 (if extra (+ extra basic) (current-column)))))))) + + + +(defun caml-split-string () + "Called whenever a line is broken inside a caml string literal." + (insert-before-markers "\"^\"") + (backward-char 1)) + +(defadvice indent-new-comment-line (around + caml-indent-new-comment-line + activate) + + "Handle multi-line strings in caml mode." + +;this advice doesn't make sense in other modes. I wish there were a +;cleaner way to do this: I haven't found one. + + (let ((hooked (and (eq major-mode 'caml-mode) (caml-in-literal-p))) + (split-mark)) + (if (not hooked) nil + (setq split-mark (set-marker (make-marker) (point))) + (caml-split-string)) + ad-do-it + (if (not hooked) nil + (goto-char split-mark) + (set-marker split-mark nil)))) + +(defadvice newline-and-indent (around + caml-newline-and-indent + activate) + + "Handle multi-line strings in caml mode." + + (let ((hooked (and (eq major-mode 'caml-mode) (caml-in-literal-p))) + (split-mark)) + (if (not hooked) nil + (setq split-mark (set-marker (make-marker) (point))) + (caml-split-string)) + ad-do-it + (if (not hooked) nil + (goto-char split-mark) + (set-marker split-mark nil)))) + +(defun caml-electric-pipe () + "If inserting a | or } operator at beginning of line, reindent the line. + +Unfortunately there is a situation where this mechanism gets +confused. It's when | is the first character of a |] sequence. This is +a misfeature of caml syntax and cannot be fixed, however, as a +workaround, the electric ] inserts | itself if the matching [ is +followed by |." + + (interactive "*") + (let ((electric (and caml-electric-indent + (caml-in-indentation) + (not (caml-in-comment-p))))) + (self-insert-command 1) + (if electric (save-excursion (caml-indent-command))))) + +(defun caml-electric-rb () + "If inserting a ] operator at beginning of line, reindent the line. + +Also, if the matching [ is followed by a | and this ] is not preceded +by |, insert one." + + (interactive "*") + (let* ((prec (preceding-char)) + (use-pipe (and caml-electric-close-vector + (not (caml-in-comment-p)) + (not (caml-in-literal-p)) + (or (not (numberp prec)) + (not (char-equal ?| prec))))) + (electric (and caml-electric-indent + (caml-in-indentation) + (not (caml-in-comment-p))))) + (self-insert-command 1) + (if electric (save-excursion (caml-indent-command))) + (if (and use-pipe + (save-excursion + (condition-case nil + (prog2 + (backward-list 1) + (looking-at "\\[|")) + (error "")))) + (save-excursion + (backward-char 1) + (insert "|"))))) + +(defun caml-abbrev-hook () + "If inserting a leading keyword at beginning of line, reindent the line." + ;itz unfortunately we need a special case + (if (and (not (caml-in-comment-p)) (not (= last-command-char ?_))) + (let* ((bol (save-excursion (beginning-of-line) (point))) + (kw (save-excursion + (and (re-search-backward "^[ \t]*\\(\\sw+\\)\\=" bol t) + (caml-match-string 1))))) + (if kw + (let ((indent (save-excursion + (goto-char (match-beginning 1)) + (caml-indent-command) + (current-column))) + (abbrev-correct (if (= last-command-char ?\ ) 1 0))) + (indent-to (- indent + (or + (symbol-value + (nth 1 + (assoc kw caml-leading-kwops-alist))) + 0) + abbrev-correct))))))) + +; (defun caml-indent-phrase () +; (interactive "*") +; (let ((bounds (caml-mark-phrase))) +; (indent-region (car bounds) (cdr bounds) nil))) + +;;; Additional commands by Didier to report errors in toplevel mode + +(defun caml-skip-blank-forward () + (if (looking-at "[ \t\n]*\\((\\*\\([^*]\\|[^(]\\*[^)]\\)*\\*)[ \t\n]*\\)*") + (goto-char (match-end 0)))) + +;; to mark phrases, so that repeated calls will take several of them +;; knows little about Ocaml appart literals and comments, so it should work +;; with other dialects as long as ;; marks the end of phrase. + +(defun caml-indent-phrase (arg) + "Indent current phrase +with prefix arg, indent that many phrases starting with the current phrase." + (interactive "p") + (save-excursion + (let ((beg (caml-find-phrase))) + (while (progn (setq arg (- arg 1)) (> arg 0)) (caml-find-phrase)) + (indent-region beg (point) nil)))) + +(defun caml-indent-buffer () + (interactive) + (indent-region (point-min) (point-max) nil)) + +(defun caml-backward-to-less-indent (&optional n) + "Move cursor back N lines with less or same indentation." + (interactive "p") + (beginning-of-line 1) + (if (< n 0) (caml-forward-to-less-indent (- n)) + (while (> n 0) + (let ((i (current-indentation))) + (forward-line -1) + (while (or (> (current-indentation) i) + (caml-in-comment-p) + (looking-at + (concat "[ \t]*\\(\n\\|" comment-start-skip "\\)"))) + (forward-line -1))) + (setq n (1- n)))) + (back-to-indentation)) + +(defun caml-forward-to-less-indent (&optional n) + "Move cursor back N lines with less or same indentation." + (interactive "p") + (beginning-of-line 1) + (if (< n 0) (caml-backward-to-less-indent (- n)) + (while (> n 0) + (let ((i (current-indentation))) + (forward-line 1) + (while (or (> (current-indentation) i) + (caml-in-comment-p) + (looking-at + (concat "[ \t]*\\(\n\\|" comment-start-skip "\\)"))) + (forward-line 1))) + (setq n (1- n)))) + (back-to-indentation)) + +(defun caml-insert-begin-form () + "Inserts a nicely formatted begin-end form, leaving a mark after end." + (interactive "*") + (let ((prec (preceding-char))) + (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) + (insert " "))) + (let* ((c (current-indentation)) (i (+ caml-begin-indent c))) + (insert "begin\n\nend") + (push-mark) + (indent-line-to c) + (forward-line -1) + (indent-line-to i))) + +(defun caml-insert-for-form () + "Inserts a nicely formatted for-do-done form, leaving a mark after do(ne)." + (interactive "*") + (let ((prec (preceding-char))) + (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) + (insert " "))) + (let* ((c (current-indentation)) (i (+ caml-for-indent c))) + (insert "for do\n\ndone") + (push-mark) + (indent-line-to c) + (forward-line -1) + (indent-line-to i) + (push-mark) + (beginning-of-line 1) + (backward-char 4))) + +(defun caml-insert-if-form () + "Insert nicely formatted if-then-else form leaving mark after then, else." + (interactive "*") + (let ((prec (preceding-char))) + (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) + (insert " "))) + (let* ((c (current-indentation)) (i (+ caml-if-indent c))) + (insert "if\n\nthen\n\nelse\n") + (indent-line-to i) + (push-mark) + (forward-line -1) + (indent-line-to c) + (forward-line -1) + (indent-line-to i) + (push-mark) + (forward-line -1) + (indent-line-to c) + (forward-line -1) + (indent-line-to i))) + +(defun caml-insert-match-form () + "Insert nicely formatted match-with form leaving mark after with." + (interactive "*") + (let ((prec (preceding-char))) + (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) + (insert " "))) + (let* ((c (current-indentation)) (i (+ caml-match-indent c))) + (insert "match\n\nwith\n") + (indent-line-to i) + (push-mark) + (forward-line -1) + (indent-line-to c) + (forward-line -1) + (indent-line-to i))) + +(defun caml-insert-let-form () + "Insert nicely formatted let-in form leaving mark after in." + (interactive "*") + (let ((prec (preceding-char))) + (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) + (insert " "))) + (let* ((c (current-indentation))) + (insert "let in\n") + (indent-line-to c) + (push-mark) + (forward-line -1) + (forward-char (+ c 4)))) + +(defun caml-insert-try-form () + "Insert nicely formatted try-with form leaving mark after with." + (interactive "*") + (let ((prec (preceding-char))) + (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) + (insert " "))) + (let* ((c (current-indentation)) (i (+ caml-try-indent c))) + (insert "try\n\nwith\n") + (indent-line-to i) + (push-mark) + (forward-line -1) + (indent-line-to c) + (forward-line -1) + (indent-line-to i))) + +(defun caml-insert-while-form () + "Insert nicely formatted while-do-done form leaving mark after do, done." + (interactive "*") + (let ((prec (preceding-char))) + (if (and (numberp prec) (not (char-equal ?\ (char-syntax prec)))) + (insert " "))) + (let* ((c (current-indentation)) (i (+ caml-if-indent c))) + (insert "while do\n\ndone") + (push-mark) + (indent-line-to c) + (forward-line -1) + (indent-line-to i) + (push-mark) + (beginning-of-line 1) + (backward-char 4))) + +(autoload 'run-caml "inf-caml" "Run an inferior Caml process." t) + +(autoload 'caml-types-show-type "caml-types" + "Show the type of expression or pattern at point." t) +(autoload 'caml-types-explore "caml-types" + "Explore type annotations by mouse dragging." t) + +(autoload 'caml-help "caml-help" + "Show documentation for qualilifed OCaml identifier." t) +(autoload 'caml-complete "caml-help" + "Does completion for documented qualified OCaml identifier." t) +(autoload 'ocaml-open-module "caml-help" + "Add module in documentation search path." t) +(autoload 'ocaml-close-module "caml-help" + "Remove module from documentation search path." t) +(autoload 'ocaml-add-path "caml-help" + "Add search path for documentation." t) + +;;; caml.el ends here + +(provide 'caml) diff --git a/ocaml-binary-annot/emacs/camldebug.el b/ocaml-binary-annot/emacs/camldebug.el new file mode 100644 index 0000000000..d5ba599cc7 --- /dev/null +++ b/ocaml-binary-annot/emacs/camldebug.el @@ -0,0 +1,793 @@ +;(***********************************************************************) +;(* *) +;(* Objective Caml *) +;(* *) +;(* Jacques Garrigue and Ian T Zimmerman *) +;(* *) +;(* Copyright 1997 Institut National de Recherche en Informatique et *) +;(* en Automatique. All rights reserved. This file is distributed *) +;(* under the terms of the GNU General Public License. *) +;(* *) +;(***********************************************************************) + +;(* $Id$ *) + +;;; Run camldebug under Emacs +;;; Derived from gdb.el. +;;; gdb.el is Copyright (C) 1988 Free Software Foundation, Inc, and is part +;;; of GNU Emacs +;;; Modified by Jerome Vouillon, 1994. +;;; Modified by Ian T. Zimmerman, 1996. +;;; Modified by Xavier Leroy, 1997. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;;itz 04-06-96 I pondered basing this on gud. The potential advantages +;;were: automatic bugfix , keymaps and menus propagation. +;;Disadvantages: gud is not so clean itself, there is little common +;;functionality it abstracts (most of the stuff is done in the +;;debugger specific parts anyway), and, most seriously, gud sees it +;;fit to add C-x C-a bindings to the _global_ map, so there would be a +;;conflict between camldebug and gdb, for instance. While it's OK to +;;assume that a sane person doesn't use gdb and dbx at the same time, +;;it's not so OK (IMHO) for gdb and camldebug. + +;; Xavier Leroy, 21/02/97: adaptation to ocamldebug. + +(require 'comint) +(require 'shell) +(require 'caml) +(require 'derived) +(require 'thingatpt) + +;;; Variables. + +(defvar camldebug-last-frame) +(defvar camldebug-delete-prompt-marker) +(defvar camldebug-filter-accumulator nil) +(defvar camldebug-last-frame-displayed-p) +(defvar camldebug-filter-function) + +(defvar camldebug-prompt-pattern "^(ocd) *" + "A regexp to recognize the prompt for ocamldebug.") + +(defvar camldebug-overlay-event nil + "Overlay for displaying the current event.") +(defvar camldebug-overlay-under nil + "Overlay for displaying the current event.") +(defvar camldebug-event-marker nil + "Marker for displaying the current event.") + +(defvar camldebug-track-frame t + "*If non-nil, always display current frame position in another window.") + +(cond + (window-system + (make-face 'camldebug-event) + (make-face 'camldebug-underline) + (if (not (face-differs-from-default-p 'camldebug-event)) + (invert-face 'camldebug-event)) + (if (not (face-differs-from-default-p 'camldebug-underline)) + (set-face-underline-p 'camldebug-underline t)) + (setq camldebug-overlay-event (make-overlay 1 1)) + (overlay-put camldebug-overlay-event 'face 'camldebug-event) + (setq camldebug-overlay-under (make-overlay 1 1)) + (overlay-put camldebug-overlay-under 'face 'camldebug-underline)) + (t + (setq camldebug-event-marker (make-marker)) + (setq overlay-arrow-string "=>"))) + +;;; Camldebug mode. + +(define-derived-mode camldebug-mode comint-mode "Inferior CDB" + + "Major mode for interacting with an inferior Camldebug process. + +The following commands are available: + +\\{camldebug-mode-map} + +\\[camldebug-display-frame] displays in the other window +the last line referred to in the camldebug buffer. + +\\[camldebug-step], \\[camldebug-back] and \\[camldebug-next], in the camldebug window, +call camldebug to step, backstep or next and then update the other window +with the current file and position. + +If you are in a source file, you may select a point to break +at, by doing \\[camldebug-break]. + +Commands: +Many commands are inherited from comint mode. +Additionally we have: + +\\[camldebug-display-frame] display frames file in other window +\\[camldebug-step] advance one line in program +C-x SPACE sets break point at current line." + + (mapcar 'make-local-variable + '(camldebug-last-frame-displayed-p camldebug-last-frame + camldebug-delete-prompt-marker camldebug-filter-function + camldebug-filter-accumulator paragraph-start)) + (setq + camldebug-last-frame nil + camldebug-delete-prompt-marker (make-marker) + camldebug-filter-accumulator "" + camldebug-filter-function 'camldebug-marker-filter + comint-prompt-regexp camldebug-prompt-pattern + comint-dynamic-complete-functions (cons 'camldebug-complete + comint-dynamic-complete-functions) + paragraph-start comint-prompt-regexp + camldebug-last-frame-displayed-p t) + (make-local-variable 'shell-dirtrackp) + (setq shell-dirtrackp t) + (setq comint-input-sentinel 'shell-directory-tracker)) + +;;; Keymaps. + +(defun camldebug-numeric-arg (arg) + (and arg (prefix-numeric-value arg))) + +(defmacro def-camldebug (name key &optional doc args) + + "Define camldebug-NAME to be a command sending NAME ARGS and bound +to KEY, with optional doc string DOC. Certain %-escapes in ARGS are +interpreted specially if present. These are: + + %m module name of current module. + %d directory of current source file. + %c number of current character position + %e text of the caml variable surrounding point. + + The `current' source file is the file of the current buffer (if +we're in a caml buffer) or the source file current at the last break +or step (if we're in the camldebug buffer), and the `current' module +name is the filename stripped of any *.ml* suffixes (this assumes the +usual correspondence between module and file naming is observed). The +`current' position is that of the current buffer (if we're in a source +file) or the position of the last break or step (if we're in the +camldebug buffer). + +If a numeric is present, it overrides any ARGS flags and its string +representation is simply concatenated with the COMMAND." + + (let* ((fun (intern (format "camldebug-%s" name)))) + (list 'progn + (if doc + (list 'defun fun '(arg) + doc + '(interactive "P") + (list 'camldebug-call name args + '(camldebug-numeric-arg arg)))) + (list 'define-key 'camldebug-mode-map + (concat "\C-c" key) + (list 'quote fun)) + (list 'define-key 'caml-mode-map + (concat "\C-x\C-a" key) + (list 'quote fun))))) + +(def-camldebug "step" "\C-s" "Step one event forward.") +(def-camldebug "backstep" "\C-k" "Step one event backward.") +(def-camldebug "run" "\C-r" "Run the program.") +(def-camldebug "reverse" "\C-v" "Run the program in reverse.") +(def-camldebug "last" "\C-l" "Go to latest time in execution history.") +(def-camldebug "backtrace" "\C-t" "Print the call stack.") +(def-camldebug "finish" "\C-f" "Finish executing current function.") +(def-camldebug "print" "\C-p" "Print value of symbol at point." "%e") +(def-camldebug "display" "\C-d" "Display value of symbol at point." "%e") +(def-camldebug "next" "\C-n" "Step one event forward (skip functions)") +(def-camldebug "up" "<" "Go up N stack frames (numeric arg) with display") +(def-camldebug "down" ">" "Go down N stack frames (numeric arg) with display") +(def-camldebug "break" "\C-b" "Set breakpoint at current line." + "@ \"%m\" # %c") + +(defun camldebug-mouse-display (click) + "Display value of $NNN clicked on." + (interactive "e") + (let* ((start (event-start click)) + (window (car start)) + (pos (car (cdr start))) + symb) + (save-excursion + (select-window window) + (goto-char pos) + (setq symb (thing-at-point 'symbol)) + (if (string-match "^\\$[0-9]+$" symb) + (camldebug-call "display" symb))))) + +(define-key camldebug-mode-map [mouse-2] 'camldebug-mouse-display) + +(defun camldebug-kill-filter (string) + ;gob up stupid questions :-) + (setq camldebug-filter-accumulator + (concat camldebug-filter-accumulator string)) + (if (not (string-match "\\(.* \\)(y or n) " + camldebug-filter-accumulator)) nil + (setq camldebug-kill-output + (cons t (match-string 1 camldebug-filter-accumulator))) + (setq camldebug-filter-accumulator "")) + (if (string-match comint-prompt-regexp camldebug-filter-accumulator) + (let ((output (substring camldebug-filter-accumulator + (match-beginning 0)))) + (setq camldebug-kill-output + (cons nil (substring camldebug-filter-accumulator 0 + (1- (match-beginning 0))))) + (setq camldebug-filter-accumulator "") + output) + "")) + +(def-camldebug "kill" "\C-k") + +(defun camldebug-kill () + "Kill the program." + (interactive) + (let ((camldebug-kill-output)) + (save-excursion + (set-buffer current-camldebug-buffer) + (let ((proc (get-buffer-process (current-buffer))) + (camldebug-filter-function 'camldebug-kill-filter)) + (camldebug-call "kill") + (while (not (and camldebug-kill-output + (zerop (length camldebug-filter-accumulator)))) + (accept-process-output proc)))) + (if (not (car camldebug-kill-output)) + (error (cdr camldebug-kill-output)) + (sit-for 0 300) + (camldebug-call-1 (if (y-or-n-p (cdr camldebug-kill-output)) "y" "n"))))) +;;FIXME: camldebug doesn't output the Hide marker on kill + +(defun camldebug-goto-filter (string) + ;accumulate onto previous output + (setq camldebug-filter-accumulator + (concat camldebug-filter-accumulator string)) + (if (not (or (string-match (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+" + camldebug-goto-position + "-[0-9]+[ \t]*\\(before\\).*\n") + camldebug-filter-accumulator) + (string-match (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+[0-9]+-" + camldebug-goto-position + "[ \t]*\\(after\\).*\n") + camldebug-filter-accumulator))) + nil + (setq camldebug-goto-output + (match-string 2 camldebug-filter-accumulator)) + (setq camldebug-filter-accumulator + (substring camldebug-filter-accumulator (1- (match-end 0))))) + (if (not (string-match comint-prompt-regexp + camldebug-filter-accumulator)) nil + (setq camldebug-goto-output (or camldebug-goto-output 'fail)) + (setq camldebug-filter-accumulator "")) + (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator) + (setq camldebug-filter-accumulator + (match-string 1 camldebug-filter-accumulator))) + "") + +(def-camldebug "goto" "\C-g") +(defun camldebug-goto (&optional time) + + "Go to the execution time TIME. + +Without TIME, the command behaves as follows: In the camldebug buffer, +if the point at buffer end, goto time 0\; otherwise, try to obtain the +time from context around point. In a caml mode buffer, try to find the +time associated in execution history with the current point location. + +With a negative TIME, move that many lines backward in the camldebug +buffer, then try to obtain the time from context around point." + + (interactive "P") + (cond + (time + (let ((ntime (camldebug-numeric-arg time))) + (if (>= ntime 0) (camldebug-call "goto" nil ntime) + (save-selected-window + (select-window (get-buffer-window current-camldebug-buffer)) + (save-excursion + (if (re-search-backward "^Time : [0-9]+ - pc : [0-9]+ " + nil t (- 1 ntime)) + (camldebug-goto nil) + (error "I don't have %d times in my history" + (- 1 ntime)))))))) + ((eq (current-buffer) current-camldebug-buffer) + (let ((time (cond + ((eobp) 0) + ((save-excursion + (beginning-of-line 1) + (looking-at "^Time : \\([0-9]+\\) - pc : [0-9]+ ")) + (string-to-int (match-string 1))) + ((string-to-int (camldebug-format-command "%e")))))) + (camldebug-call "goto" nil time))) + (t + (let ((module (camldebug-module-name (buffer-file-name))) + (camldebug-goto-position (int-to-string (1- (point)))) + (camldebug-goto-output) (address)) + ;get a list of all events in the current module + (save-excursion + (set-buffer current-camldebug-buffer) + (let* ((proc (get-buffer-process (current-buffer))) + (camldebug-filter-function 'camldebug-goto-filter)) + (camldebug-call-1 (concat "info events " module)) + (while (not (and camldebug-goto-output + (zerop (length camldebug-filter-accumulator)))) + (accept-process-output proc)) + (setq address (if (eq camldebug-goto-output 'fail) nil + (re-search-backward + (concat "^Time : \\([0-9]+\\) - pc : " + camldebug-goto-output + " - module " + module "$") nil t) + (match-string 1))))) + (if address (camldebug-call "goto" nil (string-to-int address)) + (error "No time at %s at %s" module camldebug-goto-position)))))) + + +(defun camldebug-delete-filter (string) + (setq camldebug-filter-accumulator + (concat camldebug-filter-accumulator string)) + (if (not (string-match + (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+[0-9]+[ \t]*in " + (regexp-quote camldebug-delete-file) + ", character " + camldebug-delete-position "\n") + camldebug-filter-accumulator)) nil + (setq camldebug-delete-output + (match-string 2 camldebug-filter-accumulator)) + (setq camldebug-filter-accumulator + (substring camldebug-filter-accumulator (1- (match-end 0))))) + (if (not (string-match comint-prompt-regexp + camldebug-filter-accumulator)) nil + (setq camldebug-delete-output (or camldebug-delete-output 'fail)) + (setq camldebug-filter-accumulator "")) + (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator) + (setq camldebug-filter-accumulator + (match-string 1 camldebug-filter-accumulator))) + "") + + +(def-camldebug "delete" "\C-d") + +(defun camldebug-delete (&optional arg) + "Delete the breakpoint numbered ARG. + +Without ARG, the command behaves as follows: In the camldebug buffer, +try to obtain the time from context around point. In a caml mode +buffer, try to find the breakpoint associated with the current point +location. + +With a negative ARG, look for the -ARGth breakpoint pattern in the +camldebug buffer, then try to obtain the breakpoint info from context +around point." + + (interactive "P") + (cond + (arg + (let ((narg (camldebug-numeric-arg arg))) + (if (> narg 0) (camldebug-call "delete" nil narg) + (save-excursion + (set-buffer current-camldebug-buffer) + (if (re-search-backward "^Breakpoint [0-9]+ at [0-9]+ : file " + nil t (- 1 narg)) + (camldebug-delete nil) + (error "I don't have %d breakpoints in my history" + (- 1 narg))))))) + ((eq (current-buffer) current-camldebug-buffer) + (let* ((bpline "^Breakpoint \\([0-9]+\\) at [0-9]+ : file ") + (arg (cond + ((eobp) + (save-excursion (re-search-backward bpline nil t)) + (string-to-int (match-string 1))) + ((save-excursion + (beginning-of-line 1) + (looking-at bpline)) + (string-to-int (match-string 1))) + ((string-to-int (camldebug-format-command "%e")))))) + (camldebug-call "delete" nil arg))) + (t + (let ((camldebug-delete-file + (concat (camldebug-format-command "%m") ".ml")) + (camldebug-delete-position (camldebug-format-command "%c"))) + (save-excursion + (set-buffer current-camldebug-buffer) + (let ((proc (get-buffer-process (current-buffer))) + (camldebug-filter-function 'camldebug-delete-filter) + (camldebug-delete-output)) + (camldebug-call-1 "info break") + (while (not (and camldebug-delete-output + (zerop (length + camldebug-filter-accumulator)))) + (accept-process-output proc)) + (if (eq camldebug-delete-output 'fail) + (error "No breakpoint in %s at %s" + camldebug-delete-file + camldebug-delete-position) + (camldebug-call "delete" nil + (string-to-int camldebug-delete-output))))))))) + +(defun camldebug-complete-filter (string) + (setq camldebug-filter-accumulator + (concat camldebug-filter-accumulator string)) + (while (string-match "\\(\n\\|\\`\\)\\(.+\\)\n" + camldebug-filter-accumulator) + (setq camldebug-complete-list + (cons (match-string 2 camldebug-filter-accumulator) + camldebug-complete-list)) + (setq camldebug-filter-accumulator + (substring camldebug-filter-accumulator + (1- (match-end 0))))) + (if (not (string-match comint-prompt-regexp + camldebug-filter-accumulator)) nil + (setq camldebug-complete-list + (or camldebug-complete-list 'fail)) + (setq camldebug-filter-accumulator "")) + (if (string-match "\n\\(.*\\)\\'" camldebug-filter-accumulator) + (setq camldebug-filter-accumulator + (match-string 1 camldebug-filter-accumulator))) + "") + +(defun camldebug-complete () + + "Perform completion on the camldebug command preceding point." + + (interactive) + (let* ((end (point)) + (command (save-excursion + (beginning-of-line) + (and (looking-at comint-prompt-regexp) + (goto-char (match-end 0))) + (buffer-substring (point) end))) + (camldebug-complete-list nil) (command-word)) + + ;; Find the word break. This match will always succeed. + (string-match "\\(\\`\\| \\)\\([^ ]*\\)\\'" command) + (setq command-word (match-string 2 command)) + + ;itz 04-21-96 if we are trying to complete a word of nonzero + ;length, chop off the last character. This is a nasty hack, but it + ;works - in general, not just for this set of words: the comint + ;call below will weed out false matches - and it avoids further + ;mucking with camldebug's lexer. + (if (> (length command-word) 0) + (setq command (substring command 0 (1- (length command))))) + + (let ((camldebug-filter-function 'camldebug-complete-filter)) + (camldebug-call-1 (concat "complete " command)) + (set-marker camldebug-delete-prompt-marker nil) + (while (not (and camldebug-complete-list + (zerop (length camldebug-filter-accumulator)))) + (accept-process-output (get-buffer-process + (current-buffer))))) + (if (eq camldebug-complete-list 'fail) + (setq camldebug-complete-list nil)) + (setq camldebug-complete-list + (sort camldebug-complete-list 'string-lessp)) + (comint-dynamic-simple-complete command-word camldebug-complete-list))) + +(define-key camldebug-mode-map "\C-l" 'camldebug-refresh) +(define-key camldebug-mode-map "\t" 'comint-dynamic-complete) +(define-key camldebug-mode-map "\M-?" 'comint-dynamic-list-completions) + +(define-key caml-mode-map "\C-x " 'camldebug-break) + + +(defvar current-camldebug-buffer nil) + + +;;;###autoload +(defvar camldebug-command-name "ocamldebug" + "*Pathname for executing camldebug.") + +;;;###autoload +(defun camldebug (path) + "Run camldebug on program FILE in buffer *camldebug-FILE*. +The directory containing FILE becomes the initial working directory +and source-file directory for camldebug. If you wish to change this, use +the camldebug commands `cd DIR' and `directory'." + (interactive "fRun ocamldebug on file: ") + (setq path (expand-file-name path)) + (let ((file (file-name-nondirectory path))) + (pop-to-buffer (concat "*camldebug-" file "*")) + (setq default-directory (file-name-directory path)) + (message "Current directory is %s" default-directory) + (make-comint (concat "camldebug-" file) + (substitute-in-file-name camldebug-command-name) + nil + "-emacs" "-cd" default-directory file) + (set-process-filter (get-buffer-process (current-buffer)) + 'camldebug-filter) + (set-process-sentinel (get-buffer-process (current-buffer)) + 'camldebug-sentinel) + (camldebug-mode) + (camldebug-set-buffer))) + +(defun camldebug-set-buffer () + (if (eq major-mode 'camldebug-mode) + (setq current-camldebug-buffer (current-buffer)) + (save-selected-window (pop-to-buffer current-camldebug-buffer)))) + +;;; Filter and sentinel. + +(defun camldebug-marker-filter (string) + (setq camldebug-filter-accumulator + (concat camldebug-filter-accumulator string)) + (let ((output "") (begin)) + ;; Process all the complete markers in this chunk. + (while (setq begin + (string-match + "\032\032\\(H\\|M\\(.+\\):\\(.+\\):\\(.+\\):\\(before\\|after\\)\\)\n" + camldebug-filter-accumulator)) + (setq camldebug-last-frame + (if (char-equal ?H (aref camldebug-filter-accumulator + (1+ (1+ begin)))) nil + (let ((isbefore + (string= "before" + (match-string 5 camldebug-filter-accumulator))) + (startpos (string-to-int + (match-string 3 camldebug-filter-accumulator))) + (endpos (string-to-int + (match-string 4 camldebug-filter-accumulator)))) + (list (match-string 2 camldebug-filter-accumulator) + (if isbefore startpos endpos) + isbefore + startpos + endpos + ))) + output (concat output + (substring camldebug-filter-accumulator + 0 begin)) + ;; Set the accumulator to the remaining text. + camldebug-filter-accumulator (substring + camldebug-filter-accumulator + (match-end 0)) + camldebug-last-frame-displayed-p nil)) + + + ;; Does the remaining text look like it might end with the + ;; beginning of another marker? If it does, then keep it in + ;; camldebug-filter-accumulator until we receive the rest of it. Since we + ;; know the full marker regexp above failed, it's pretty simple to + ;; test for marker starts. + (if (string-match "\032.*\\'" camldebug-filter-accumulator) + (progn + ;; Everything before the potential marker start can be output. + (setq output (concat output (substring camldebug-filter-accumulator + 0 (match-beginning 0)))) + + ;; Everything after, we save, to combine with later input. + (setq camldebug-filter-accumulator + (substring camldebug-filter-accumulator (match-beginning 0)))) + + (setq output (concat output camldebug-filter-accumulator) + camldebug-filter-accumulator "")) + + output)) + +(defun camldebug-filter (proc string) + (let ((output)) + (if (buffer-name (process-buffer proc)) + (let ((process-window)) + ;; it does not seem necessary to save excursion here, + ;; since set-buffer as a temporary effect. + ;; comint-output-filter explicitly avoids it. + ;; in version 23, it prevents the marker to stay at end of buffer + ;; (save-excursion + (set-buffer (process-buffer proc)) + ;; If we have been so requested, delete the debugger prompt. + (if (marker-buffer camldebug-delete-prompt-marker) + (progn + (delete-region (process-mark proc) + camldebug-delete-prompt-marker) + (set-marker camldebug-delete-prompt-marker nil))) + (setq output (funcall camldebug-filter-function string)) + ;; Don't display the specified file unless + ;; (1) point is at or after the position where output appears + ;; and (2) this buffer is on the screen. + (setq process-window (and camldebug-track-frame + (not camldebug-last-frame-displayed-p) + (>= (point) (process-mark proc)) + (get-buffer-window (current-buffer)))) + ;; Insert the text, moving the process-marker. + (comint-output-filter proc output) + ;; ) + ;; this was the end of save-excursion. + ;; if save-excursion is used (comint-next-prompt 1) would be needed + ;; to move the mark past then next prompt, but this is not as good + ;; as solution. + (if process-window + (save-selected-window + (select-window process-window) + (camldebug-display-frame))))))) + +(defun camldebug-sentinel (proc msg) + (cond ((null (buffer-name (process-buffer proc))) + ;; buffer killed + ;; Stop displaying an arrow in a source file. + (camldebug-remove-current-event) + (set-process-buffer proc nil)) + ((memq (process-status proc) '(signal exit)) + ;; Stop displaying an arrow in a source file. + (camldebug-remove-current-event) + ;; Fix the mode line. + (setq mode-line-process + (concat ": " + (symbol-name (process-status proc)))) + (let* ((obuf (current-buffer))) + ;; save-excursion isn't the right thing if + ;; process-buffer is current-buffer + (unwind-protect + (progn + ;; Write something in *compilation* and hack its mode line, + (set-buffer (process-buffer proc)) + ;; Force mode line redisplay soon + (set-buffer-modified-p (buffer-modified-p)) + (if (eobp) + (insert ?\n mode-name " " msg) + (save-excursion + (goto-char (point-max)) + (insert ?\n mode-name " " msg))) + ;; If buffer and mode line will show that the process + ;; is dead, we can delete it now. Otherwise it + ;; will stay around until M-x list-processes. + (delete-process proc)) + ;; Restore old buffer, but don't restore old point + ;; if obuf is the cdb buffer. + (set-buffer obuf)))))) + + +(defun camldebug-refresh (&optional arg) + "Fix up a possibly garbled display, and redraw the mark." + (interactive "P") + (camldebug-display-frame) + (recenter arg)) + +(defun camldebug-display-frame () + "Find, obey and delete the last filename-and-line marker from CDB. +The marker looks like \\032\\032Mfilename:startchar:endchar:beforeflag\\n. +Obeying it means displaying in another window the specified file and line." + (interactive) + (camldebug-set-buffer) + (if (not camldebug-last-frame) + (camldebug-remove-current-event) + (camldebug-display-line (nth 0 camldebug-last-frame) + (nth 3 camldebug-last-frame) + (nth 4 camldebug-last-frame) + (nth 2 camldebug-last-frame))) + (setq camldebug-last-frame-displayed-p t)) + +;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen +;; and that its character CHARACTER is visible. +;; Put the mark on this character in that buffer. + +(defun camldebug-display-line (true-file schar echar kind) + (let* ((pre-display-buffer-function nil) ; screw it, put it all in one screen + (pop-up-windows t) + (buffer (find-file-noselect true-file)) + (window (display-buffer buffer t)) + (spos) (epos) (pos)) + (save-excursion + (set-buffer buffer) + (save-restriction + (widen) + (setq spos (+ (point-min) schar)) + (setq epos (+ (point-min) echar)) + (setq pos (if kind spos epos)) + (camldebug-set-current-event spos epos (current-buffer) kind)) + (cond ((or (< pos (point-min)) (> pos (point-max))) + (widen) + (goto-char pos)))) + (set-window-point window pos))) + +;;; Events. + +(defun camldebug-remove-current-event () + (if window-system + (progn + (delete-overlay camldebug-overlay-event) + (delete-overlay camldebug-overlay-under)) + (setq overlay-arrow-position nil))) + +(defun camldebug-set-current-event (spos epos buffer before) + (if window-system + (if before + (progn + (move-overlay camldebug-overlay-event spos (1+ spos) buffer) + (move-overlay camldebug-overlay-under + (+ spos 1) epos buffer)) + (move-overlay camldebug-overlay-event (1- epos) epos buffer) + (move-overlay camldebug-overlay-under spos (- epos 1) buffer)) + (save-excursion + (set-buffer buffer) + (goto-char pos) + (beginning-of-line) + (move-marker camldebug-event-marker (point)) + (setq overlay-arrow-position camldebug-event-marker)))) + +;;; Miscellaneous. + +(defun camldebug-module-name (filename) + (substring filename (string-match "\\([^/]*\\)\\.ml$" filename) (match-end 1))) + +;;; The camldebug-call function must do the right thing whether its +;;; invoking keystroke is from the camldebug buffer itself (via +;;; major-mode binding) or a caml buffer. In the former case, we want +;;; to supply data from camldebug-last-frame. Here's how we do it: + +(defun camldebug-format-command (str) + (let* ((insource (not (eq (current-buffer) current-camldebug-buffer))) + (frame (if insource nil camldebug-last-frame)) (result)) + (while (and str (string-match "\\([^%]*\\)%\\([mdcep]\\)" str)) + (let ((key (string-to-char (substring str (match-beginning 2)))) + (cmd (substring str (match-beginning 1) (match-end 1))) + (subst)) + (setq str (substring str (match-end 2))) + (cond + ((eq key ?m) + (setq subst (camldebug-module-name + (if insource (buffer-file-name) (nth 0 frame))))) + ((eq key ?d) + (setq subst (file-name-directory + (if insource (buffer-file-name) (nth 0 frame))))) + ((eq key ?c) + (setq subst (int-to-string + (if insource (1- (point)) (nth 1 frame))))) + ((eq key ?e) + (setq subst (thing-at-point 'symbol)))) + (setq result (concat result cmd subst)))) + ;; There might be text left in STR when the loop ends. + (concat result str))) + +(defun camldebug-call (command &optional fmt arg) + "Invoke camldebug COMMAND displaying source in other window. + +Certain %-escapes in FMT are interpreted specially if present. +These are: + + %m module name of current module. + %d directory of current source file. + %c number of current character position + %e text of the caml variable surrounding point. + + The `current' source file is the file of the current buffer (if +we're in a caml buffer) or the source file current at the last break +or step (if we're in the camldebug buffer), and the `current' module +name is the filename stripped of any *.ml* suffixes (this assumes the +usual correspondence between module and file naming is observed). The +`current' position is that of the current buffer (if we're in a source +file) or the position of the last break or step (if we're in the +camldebug buffer). + +If ARG is present, it overrides any FMT flags and its string +representation is simply concatenated with the COMMAND." + + ;; Make sure debugger buffer is displayed in a window. + (camldebug-set-buffer) + (message "Command: %s" (camldebug-call-1 command fmt arg))) + +(defun camldebug-call-1 (command &optional fmt arg) + + ;; Record info on the last prompt in the buffer and its position. + (save-excursion + (set-buffer current-camldebug-buffer) + (goto-char (process-mark (get-buffer-process current-camldebug-buffer))) + (let ((pt (point))) + (beginning-of-line) + (if (looking-at comint-prompt-regexp) + (set-marker camldebug-delete-prompt-marker (point))))) + (let ((cmd (cond + (arg (concat command " " (int-to-string arg))) + (fmt (camldebug-format-command + (concat command " " fmt))) + (command)))) + (process-send-string (get-buffer-process current-camldebug-buffer) + (concat cmd "\n")) + cmd)) + + +(provide 'camldebug) diff --git a/ocaml-binary-annot/emacs/inf-caml.el b/ocaml-binary-annot/emacs/inf-caml.el new file mode 100644 index 0000000000..ba2eb0390b --- /dev/null +++ b/ocaml-binary-annot/emacs/inf-caml.el @@ -0,0 +1,363 @@ +;(***********************************************************************) +;(* *) +;(* Objective Caml *) +;(* *) +;(* Xavier Leroy and Jacques Garrigue *) +;(* *) +;(* Copyright 1997 Institut National de Recherche en Informatique et *) +;(* en Automatique. All rights reserved. This file is distributed *) +;(* under the terms of the GNU General Public License. *) +;(* *) +;(***********************************************************************) + +;(* $Id$ *) + +;;; inf-caml.el --- run the Caml toplevel in an Emacs buffer + +;; Xavier Leroy, july 1993. + +;; modified by Jacques Garrigue, july 1997. + +(require 'comint) +(require 'caml) + +;; User modifiable variables + +;; Whether you want the output buffer to be diplayed when you send a phrase + +(defvar caml-display-when-eval t + "*If true, display the inferior caml buffer when evaluating expressions.") + + +;; End of User modifiable variables + + +(defvar inferior-caml-mode-map nil) +(if inferior-caml-mode-map nil + (setq inferior-caml-mode-map + (copy-keymap comint-mode-map))) + +;; Augment Caml mode, so you can process Caml code in the source files. + +(defvar inferior-caml-program "ocaml" + "*Program name for invoking an inferior Caml from Emacs.") + +(defun inferior-caml-mode () + "Major mode for interacting with an inferior Caml process. +Runs a Caml toplevel as a subprocess of Emacs, with I/O through an +Emacs buffer. A history of input phrases is maintained. Phrases can +be sent from another buffer in Caml mode. + +\\{inferior-caml-mode-map}" + (interactive) + (comint-mode) + (setq comint-prompt-regexp "^# ?") + (setq major-mode 'inferior-caml-mode) + (setq mode-name "Inferior Caml") + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat "^$\\|" page-delimiter)) + (make-local-variable 'paragraph-separate) + (setq paragraph-separate paragraph-start) + (make-local-variable 'paragraph-ignore-fill-prefix) + (setq paragraph-ignore-fill-prefix t) + (make-local-variable 'require-final-newline) + (setq require-final-newline t) + (make-local-variable 'comment-start) + (setq comment-start "(*") + (make-local-variable 'comment-end) + (setq comment-end "*)") + (make-local-variable 'comment-column) + (setq comment-column 40) + (make-local-variable 'comment-start-skip) + (setq comment-start-skip "(\\*+ *") + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments nil) + (use-local-map inferior-caml-mode-map) + (run-hooks 'inferior-caml-mode-hooks)) + + +(defconst inferior-caml-buffer-subname "inferior-caml") +(defconst inferior-caml-buffer-name + (concat "*" inferior-caml-buffer-subname "*")) + +;; for compatibility with xemacs + +(defun caml-sit-for (second &optional mili redisplay) + (if (and (boundp 'running-xemacs) running-xemacs) + (sit-for (if mili (+ second (* mili 0.001)) second) redisplay) + (sit-for second mili redisplay))) + +;; To show result of evaluation at toplevel + +(defvar inferior-caml-output nil) +(defun inferior-caml-signal-output (s) + (if (string-match "[^ ]" s) (setq inferior-caml-output t))) + +(defun inferior-caml-mode-output-hook () + (set-variable 'comint-output-filter-functions + (list (function inferior-caml-signal-output)) + t)) +(add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-output-hook) + +;; To launch ocaml whenever needed + +(defun caml-run-process-if-needed (&optional cmd) + (if (comint-check-proc inferior-caml-buffer-name) nil + (if (not cmd) + (if (comint-check-proc inferior-caml-buffer-name) + (setq cmd inferior-caml-program) + (setq cmd (read-from-minibuffer "Caml toplevel to run: " + inferior-caml-program)))) + (setq inferior-caml-program cmd) + (let ((cmdlist (inferior-caml-args-to-list cmd)) + (process-connection-type nil)) + (set-buffer (apply (function make-comint) + inferior-caml-buffer-subname + (car cmdlist) nil (cdr cmdlist))) + (inferior-caml-mode) + (display-buffer inferior-caml-buffer-name) + t) + (setq caml-shell-active t) + )) + +;; patched to from original run-caml sharing code with +;; caml-run-process-when-needed + +(defun run-caml (&optional cmd) + "Run an inferior Caml process. +Input and output via buffer `*inferior-caml*'." + (interactive + (list (if (not (comint-check-proc inferior-caml-buffer-name)) + (read-from-minibuffer "Caml toplevel to run: " + inferior-caml-program)))) + (caml-run-process-if-needed cmd) + (switch-to-buffer-other-window inferior-caml-buffer-name)) + + +(defun inferior-caml-args-to-list (string) + (let ((where (string-match "[ \t]" string))) + (cond ((null where) (list string)) + ((not (= where 0)) + (cons (substring string 0 where) + (inferior-caml-args-to-list (substring string (+ 1 where) + (length string))))) + (t (let ((pos (string-match "[^ \t]" string))) + (if (null pos) + nil + (inferior-caml-args-to-list (substring string pos + (length string))))))))) + +(defun inferior-caml-show-subshell () + (interactive) + (caml-run-process-if-needed) + (display-buffer inferior-caml-buffer-name) + ; Added by Didier to move the point of inferior-caml to end of buffer + (let ((buf (current-buffer)) + (caml-buf (get-buffer inferior-caml-buffer-name)) + (count 0)) + (while + (and (< count 10) + (not (equal (buffer-name (current-buffer)) + inferior-caml-buffer-name))) + (next-multiframe-window) + (setq count (+ count 1))) + (if (equal (buffer-name (current-buffer)) + inferior-caml-buffer-name) + (end-of-buffer)) + (while + (> count 0) + (previous-multiframe-window) + (setq count (- count 1))) + ) +) + +;; patched by Didier to move cursor after evaluation + +(defun inferior-caml-eval-region (start end) + "Send the current region to the inferior Caml process." + (interactive "r") + (save-excursion (caml-run-process-if-needed)) + (save-excursion + (goto-char end) + (caml-skip-comments-backward) + (comint-send-region inferior-caml-buffer-name start (point)) + ;; normally, ";;" are part of the region + (if (and (>= (point) 2) + (prog2 (backward-char 2) (looking-at ";;"))) + (comint-send-string inferior-caml-buffer-name "\n") + (comint-send-string inferior-caml-buffer-name ";;\n")) + ;; the user may not want to see the output buffer + (if caml-display-when-eval + (display-buffer inferior-caml-buffer-name t)))) + +;; jump to errors produced by ocaml compiler + +(defun inferior-caml-goto-error (start end) + "Jump to the location of the last error as indicated by inferior toplevel." + (interactive "r") + (let ((loc (+ start + (save-excursion + (set-buffer (get-buffer inferior-caml-buffer-name)) + (re-search-backward + (concat comint-prompt-regexp + "[ \t]*Characters[ \t]+\\([0-9]+\\)-[0-9]+:$")) + (string-to-int (match-string 1)))))) + (goto-char loc))) + + +;;; orgininal inf-caml.el ended here + +;; as eval-phrase, but ignores errors. + +(defun inferior-caml-just-eval-phrase (arg &optional min max) + "Send the phrase containing the point to the CAML process. +With prefix-arg send as many phrases as its numeric value, +ignoring possible errors during evaluation. + +Optional arguments min max defines a region within which the phrase +should lies." + (interactive "p") + (let ((beg)) + (while (> arg 0) + (setq arg (- arg 1)) + (setq beg (caml-find-phrase min max)) + (caml-eval-region beg (point))) + beg)) + +(defvar caml-previous-output nil + "tells the beginning of output in the shell-output buffer, so that the +output can be retreived later, asynchronously.") + +;; enriched version of eval-phrase, to repport errors. + +(defun inferior-caml-eval-phrase (arg &optional min max) + "Send the phrase containing the point to the CAML process. +With prefix-arg send as many phrases as its numeric value, +If an error occurs during evalutaion, stop at this phrase and +repport the error. + +Return nil if noerror and position of error if any. + +If arg's numeric value is zero or negative, evaluate the current phrase +or as many as prefix arg, ignoring evaluation errors. +This allows to jump other erroneous phrases. + +Optional arguments min max defines a region within which the phrase +should lies." + (interactive "p") + (if (save-excursion (caml-run-process-if-needed)) + (progn + (setq inferior-caml-output nil) + (caml-wait-output 10 1))) + (if (< arg 1) (inferior-caml-just-eval-phrase (max 1 (- 0 arg)) min max) + (let ((proc (get-buffer-process inferior-caml-buffer-name)) + (buf (current-buffer)) + previous-output orig beg end err) + (save-window-excursion + (while (and (> arg 0) (not err)) + (setq previous-output (marker-position (process-mark proc))) + (setq caml-previous-output previous-output) + (setq inferior-caml-output nil) + (setq orig (inferior-caml-just-eval-phrase 1 min max)) + (caml-wait-output) + (switch-to-buffer inferior-caml-buffer-name nil) + (goto-char previous-output) + (cond ((re-search-forward + " *Characters \\([01-9][01-9]*\\)-\\([1-9][01-9]*\\):\n[^W]" + (point-max) t) + (setq beg (string-to-int (caml-match-string 1))) + (setq end (string-to-int (caml-match-string 2))) + (switch-to-buffer buf) + (goto-char orig) + (forward-byte end) + (setq end (point)) + (goto-char orig) + (forward-byte beg) + (setq beg (point)) + (setq err beg) + ) + ((looking-at + "Toplevel input:\n[>]\\([^\n]*\\)\n[>]\\(\\( *\\)^*\\)\n") + (let ((expr (caml-match-string 1)) + (column (- (match-end 3) (match-beginning 3))) + (width (- (match-end 2) (match-end 3)))) + (if (string-match "^\\(.*\\)[<]EOF[>]$" expr) + (setq expr (substring expr (match-beginning 1) (match-end 1)))) + (switch-to-buffer buf) + (re-search-backward + (concat "^" (regexp-quote expr) "$") + (- orig 10)) + (goto-char (+ (match-beginning 0) column)) + (setq end (+ (point) width))) + (setq err beg)) + ((looking-at + "Toplevel input:\n>[.]*\\([^.].*\n\\)\\([>].*\n\\)*[>]\\(.*[^.]\\)[.]*\n") + (let* ((e1 (caml-match-string 1)) + (e2 (caml-match-string 3)) + (expr + (concat + (regexp-quote e1) "\\(.*\n\\)*" (regexp-quote e2)))) + (switch-to-buffer buf) + (re-search-backward expr orig 'move) + (setq end (match-end 0))) + (setq err beg)) + (t + (switch-to-buffer buf))) + (setq arg (- arg 1)) + ) + (pop-to-buffer inferior-caml-buffer-name) + (if err + (goto-char (point-max)) + (goto-char previous-output) + (goto-char (point-max))) + (pop-to-buffer buf)) + (if err (progn (beep) (caml-overlay-region (point) end)) + (if inferior-caml-output + (message "No error") + (message "No output yet...") + )) + err))) + +(defun caml-overlay-region (beg end &optional wait) + (interactive "%r") + (cond ((fboundp 'make-overlay) + (if caml-error-overlay () + (setq caml-error-overlay (make-overlay 1 1)) + (overlay-put caml-error-overlay 'face 'region)) + (unwind-protect + (progn + (move-overlay caml-error-overlay beg end (current-buffer)) + (beep) (if wait (read-event) (caml-sit-for 60))) + (delete-overlay caml-error-overlay))))) + +;; wait some amount for ouput, that is, until inferior-caml-output is set +;; to true. Hence, interleaves sitting for shorts delays and checking the +;; flag. Give up after some time. Typing into the source buffer will cancel +;; waiting, i.e. may report 'No result yet' + +(defun caml-wait-output (&optional before after) + (let ((c 1)) + (caml-sit-for 0 (or before 1)) + (let ((c 1)) + (while (and (not inferior-caml-output) (< c 99) (caml-sit-for 0 c t)) + (setq c (+ c 1)))) + (caml-sit-for (or after 0) 1))) + +;; To insert the last output from caml at point +(defun caml-insert-last-output () + "Insert the result of the evaluation of previous phrase" + (interactive) + (let ((pos (process-mark (get-buffer-process inferior-caml-buffer-name)))) + (insert-buffer-substring inferior-caml-buffer-name + caml-previous-output (- pos 2)))) + +;; additional bindings + +;(let ((map (lookup-key caml-mode-map [menu-bar caml]))) +; (define-key map [indent-buffer] '("Indent buffer" . caml-indent-buffer)) +; (define-key map [eval-buffer] '("Eval buffer" . caml-eval-buffer)) +;) +;(define-key caml-mode-map "\C-c\C-b" 'caml-eval-buffer) + + +(provide 'inf-caml) diff --git a/ocaml-binary-annot/emacs/ocamltags.in b/ocaml-binary-annot/emacs/ocamltags.in new file mode 100644 index 0000000000..aa3f8df1d2 --- /dev/null +++ b/ocaml-binary-annot/emacs/ocamltags.in @@ -0,0 +1,142 @@ +":" ; @EMACS@ -batch -l $0 "$@" ; status=$? ; : '--*-Emacs-Lisp-*--' <<';' + +;(***********************************************************************) +;(* *) +;(* Objective Caml *) +;(* *) +;(* Jacques Garrigue and Ian T Zimmerman *) +;(* *) +;(* Copyright 1998 Institut National de Recherche en Informatique et *) +;(* en Automatique. All rights reserved. This file is distributed *) +;(* under the terms of the GNU General Public License. *) +;(* *) +;(***********************************************************************) + +;(* $Id$ *) + +;; Copyright (C) 1998 Ian Zimmerman <itz@transbay.net> +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of the +;; License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; $Id$ + +(require 'caml) + +;;itz Fri Oct 30 13:08:37 PST 1998 support for creating TAGS files +;; itz Sun Dec 27 10:26:08 PST 1998 adapted very slightly from +;; Jacques' caml-create-index-function +(defun caml-tags-create-index-function () + (let (all-alist index) + (goto-char (point-max)) + ;; collect definitions + (while (caml-prev-index-position-function) + (if (looking-at "[ \t]*val") nil + (setq index (cons (caml-match-string 5) (point))) + (setq all-alist (cons index all-alist)))) + all-alist)) + +(defun caml-tags-file (filename) + (let* ((output-buffer (current-buffer)) + (basename (file-name-nondirectory filename)) + (backpatch (prog2 + (insert " \n" basename) + (point)))) + (find-file-read-only filename) + (caml-mode) + (let ((all-alist (caml-tags-create-index-function)) + (done nil) + (current-line 1) + (last-point (point-min))) + (mapcar + (lambda (pair) + (let ((tag-name (car pair)) (tag-pos (cdr pair))) + (goto-char tag-pos) + (setq current-line + (+ current-line (count-lines last-point (point)))) + (setq last-point (point)) + (end-of-line 1) + (let ((output-line (format "%s%s%d,%d\n" + (buffer-substring last-point (point)) + tag-name current-line tag-pos))) + (save-excursion + (set-buffer output-buffer) + (insert output-line))))) + all-alist)) + (kill-buffer (current-buffer)) + (set-buffer output-buffer) + (let ((index-size (- (point) backpatch))) + (goto-char backpatch) + (insert "," (int-to-string index-size) "\n") + (goto-char (point-max))))) + +(defsubst prefix-p (prefix str) + (and (<= (length prefix) (length str)) + (string= prefix (substring str 0 (length prefix))))) + +(defsubst eat-args (n) + (setq command-line-args-left (nthcdr n command-line-args-left))) + +;; see Emacs source file print.c +(defun print-error-message (data) + (let ((errname (car data)) errmsg is-file-error tail i) + (if (eq errname 'error) + (progn + (setq data (cdr data)) + (if (not (consp data)) (setq data nil)) + (setq errmsg (car data)) + (setq is-file-error nil)) + (setq errmsg (get errname 'error-message)) + (setq is-file-error (memq 'file-error (get errname 'error-conditions)))) + (setq tail (cdr-safe data)) + (if (and is-file-error tail) + (setq errmsg (car tail) tail (cdr tail))) + (if (stringp errmsg) (princ errmsg) + (princ "peculiar error")) + (setq i 0) + (while (consp tail) + (princ (if (eq i 0) ": " ", ")) + (if is-file-error (princ (car tail)) + (prin1 (car tail))) + (setq tail (cdr tail) i (1+ i))) + (princ "\n"))) + + +(setq gc-cons-threshold 1000000) + +(setq output-file "TAGS") +(setq append-flag nil) +(setq status 0) + +(condition-case foobar + (progn + (while (and command-line-args-left + (let ((arg (car command-line-args-left))) + (cond + ((prefix-p arg "-output-file") + (setq output-file (nth 1 command-line-args-left)) + (eat-args 2) t) + ((prefix-p arg "-append") + (setq append-flag t) + (eat-args 1) t) + (t nil))))) + + (find-file output-file) + (if append-flag (goto-char (point-max)) + (erase-buffer)) + (while command-line-args-left + (caml-tags-file (car command-line-args-left)) + (setq command-line-args-left (cdr command-line-args-left))) + (save-buffer 0)) + (error (setq status 1) (print-error-message foobar))) + +(kill-emacs status) + +; + +":" ; exit $status |