[nongnu] externals/caml b1eaaab 115/197: merge changes 3.10.0 -> 3.10.1

[Stefan Monnier]

branch: externals/caml
commit b1eaaab7edbe63bea1f7e8dffc391b46eac7b699
Author: Damien Doligez <damien.doligez-inria.fr>
Commit: Damien Doligez <damien.doligez-inria.fr>

    merge changes 3.10.0 -> 3.10.1
    
    
    git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@8768 
f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
---
 README                           |  10 +-
 caml-font.el => caml-font-old.el |  25 ++---
 caml-font.el                     | 215 +++++++++++++++++----------------------
 caml-types.el                    |  43 +++++---
 4 files changed, 145 insertions(+), 148 deletions(-)

diff --git a/README b/README
index f6bf63e..7ddb362 100644
--- a/README
+++ b/README
@@ -63,6 +63,14 @@ 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:
 -------------
@@ -195,4 +203,4 @@ in other cases may confuse the phrase selection function.
 
 Comments and bug reports to
 
-    Jacques Garrigue <garrigue@kurims.kyoto-u.ac.jp>
+    Jacques Garrigue <garrigue@math.nagoya-u.ac.jp>
diff --git a/caml-font.el b/caml-font-old.el
similarity index 91%
copy from caml-font.el
copy to caml-font-old.el
index a04d5c9..fe57213 100644
--- a/caml-font.el
+++ b/caml-font-old.el
@@ -109,18 +109,19 @@
    caml-font-lock-keywords))
 
 ;; font-lock commands are similar for caml-mode and inferior-caml-mode
-(add-hook 'caml-mode-hook
-      '(lambda ()
-         (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)))
+(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
diff --git a/caml-font.el b/caml-font.el
index a04d5c9..2914fdf 100644
--- a/caml-font.el
+++ b/caml-font.el
@@ -1,140 +1,113 @@
-;(***********************************************************************)
-;(*                                                                     *)
-;(*                           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.                 *)
-;(*                                                                     *)
-;(***********************************************************************)
+;; 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
 
-;(* $Id$ *)
 
-;; useful colors
+(require 'font-lock)
 
-(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)
-))
+(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))
 
-; 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.")
+(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
-  (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)
+    ("'\\(.\\|\\\\\\([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)
+   ("`?\\<[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)
+   (,(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
-   '("\\<\\(begin\\|end\\|object\\|s\\(ig\\|truct\\)\\)\\>"
-     . font-lock-keyword-face)
+   (,(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
-   (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)
+   (,(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)))
+   ("\\(\\([~?]\\|\\<\\)[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
-(add-hook 'caml-mode-hook
-      '(lambda ()
-         (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)))
+(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
+      (goto-char start)
+      (cond
+       ((looking-at "(\\*\\*/\\*\\*)") 'caml-font-stop-face)
+       ((looking-at "(\\*\\*[^*]")     'caml-font-doccomment-face)
+       (t                              'font-lock-comment-face))))))
 
-(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 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)
 
-(add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-font-hook)
+
+
+(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/caml-types.el b/caml-types.el
index 71d47a5..763edca 100644
--- a/caml-types.el
+++ b/caml-types.el
@@ -146,10 +146,8 @@ See `caml-types-location-re' for annotation file format.
          (target-line (1+ (count-lines (point-min)
                                        (caml-line-beginning-position))))
          (target-bol (caml-line-beginning-position))
-         (target-cnum (point))
-         (type-file (concat (file-name-sans-extension (buffer-file-name))
-                            ".annot")))
-    (caml-types-preprocess type-file)
+         (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" ()
@@ -323,28 +321,47 @@ See `caml-types-location-re' for annotation file format.
       (delete-overlay caml-types-scope-ovl)
       )))
 
-(defun caml-types-preprocess (type-file)
-  (let* ((type-date (nth 5 (file-attributes type-file)))
-         (target-file (file-name-nondirectory (buffer-file-name)))
+(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-file type-file)))
+          (error (format "`%s' is more recent than `%s'" target-path 
type-path)))
       (message "Reading annotation file...")
-      (let* ((type-buf (caml-types-find-file type-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 target-file))))
+                    (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 \"-dtypes\".")))
+         (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))
@@ -553,7 +570,7 @@ See `caml-types-location-re' for annotation file format.
      (with-current-buffer buf (toggle-read-only 1))
      )
    (t
-    (error "No annotation file. You should compile with option \"-annot\"."))
+    (error (format "Can't read the annotation file `%s'" name)))
     )
   buf))
 
@@ -582,8 +599,6 @@ The function uses two overlays.
   (set-buffer (window-buffer (caml-event-window event)))
   (let* ((target-buf (current-buffer))
          (target-file (file-name-nondirectory (buffer-file-name)))
-         (type-file (concat (file-name-sans-extension (buffer-file-name))
-                            ".annot"))
          (target-line) (target-bol)
          target-pos
          Left Right limits cnum node mes type
@@ -597,7 +612,7 @@ The function uses two overlays.
     (select-window window)
     (unwind-protect
         (progn
-          (caml-types-preprocess type-file)
+          (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")