diff options
| -rw-r--r-- | emacs/caml-types.el | 103 | ||||
| -rw-r--r-- | emacs/caml.el | 13 | ||||
| -rw-r--r-- | typing/annot.mli | 2 | ||||
| -rw-r--r-- | typing/env.ml | 11 | ||||
| -rw-r--r-- | typing/stypes.ml | 16 | ||||
| -rw-r--r-- | typing/stypes.mli | 2 | ||||
| -rw-r--r-- | typing/typecore.ml | 5 | ||||
| -rw-r--r-- | typing/typemod.ml | 2 |
8 files changed, 79 insertions, 75 deletions
diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 763edca7e..ef1a386c0 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -17,7 +17,7 @@ ;; XEmacs compatibility (eval-and-compile - (if (and (boundp 'running-xemacs) running-xemacs) + (if (and (boundp 'running-xemacs) running-xemacs) (require 'caml-xemacs) (require 'caml-emacs))) @@ -135,7 +135,7 @@ type call ident" 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. +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. @@ -182,7 +182,7 @@ See `caml-types-location-re' for annotation file format. 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. +displayed when the command is called with Prefix argument 4. See `caml-types-location-re' for annotation file format. " @@ -223,14 +223,14 @@ See `caml-types-location-re' for annotation file format. ))) (defun caml-types-show-ident (arg) - "Show the kind of identifier at point. + "Show the binding of identifier at point. The identifier 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. + 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 kind is also displayed in the buffer *caml-types*, which is -displayed when the command is called with Prefix argument 4. +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. " @@ -260,50 +260,55 @@ See `caml-types-location-re' for annotation file format. (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 "internal_ref " loc-re)) - (external-re "external_ref \\(.*\\)")) + (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 ((l-file (file-name-nondirectory (match-string 1 kind))) - (l-line (string-to-int (match-string 3 kind))) - (l-bol (string-to-int (match-string 4 kind))) - (l-cnum (string-to-int (match-string 5 kind))) - (r-file (file-name-nondirectory (match-string 6 kind))) - (r-line (string-to-int (match-string 8 kind))) - (r-bol (string-to-int (match-string 9 kind))) - (r-cnum (string-to-int (match-string 10 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 ((l-file (file-name-nondirectory (match-string 1 kind))) - (l-line (string-to-int (match-string 3 kind))) - (l-bol (string-to-int (match-string 4 kind))) - (l-cnum (string-to-int (match-string 5 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 ((l-file (file-name-nondirectory (match-string 1 kind))) - (l-line (string-to-int (match-string 3 kind))) - (l-bol (string-to-int (match-string 4 kind))) - (l-cnum (string-to-int (match-string 5 kind))) - (r-file (file-name-nondirectory (match-string 6 kind))) - (r-line (string-to-int (match-string 8 kind))) - (r-bol (string-to-int (match-string 9 kind))) - (r-cnum (string-to-int (match-string 10 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 "this variable is bound at line %d char %d" - l-line (- l-cnum l-bol)))))) + (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 @@ -336,7 +341,7 @@ See `caml-types-location-re' for annotation file format. (tree (with-current-buffer type-buf (widen) (goto-char (point-min)) - (caml-types-build-tree + (caml-types-build-tree (file-name-nondirectory target-path))))) (setq caml-types-annotation-tree tree caml-types-annotation-date type-date) @@ -351,8 +356,8 @@ See `caml-types-location-re' for annotation file format. (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 + (while (not (file-exists-p + (setq type-path (expand-file-name (file-relative-name sibling project-dir) (expand-file-name "_build" project-dir))))) @@ -361,7 +366,7 @@ See `caml-types-location-re' for annotation file format. "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)) @@ -586,12 +591,12 @@ See `caml-types-location-re' for annotation file format. (defun caml-types-explore (event) "Explore type annotations by mouse dragging. -The expression under the mouse is highlighted and its type is displayed +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. +The function uses two overlays. - . One overlay delimits the largest region whose all subnodes - are well-typed. + . 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). " @@ -620,7 +625,7 @@ The function uses two overlays. (caml-track-mouse (while event (cond - ;; we ignore non mouse events + ;; 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) @@ -638,7 +643,7 @@ The function uses two overlays. ) (while (and (caml-sit-for 0 (/ 500 speed)) - (setq time (caml-types-time)) + (setq time (caml-types-time)) (> (- time last-time) (/ 500 speed)) (setq mouse (caml-mouse-vertical-position)) (or (< mouse top) (>= mouse bottom)) @@ -655,7 +660,7 @@ The function uses two overlays. (condition-case nil (scroll-up 1) (error (message "End of buffer!")))) - ) + ) (setq speed (* speed speed)) ))) ;; main action, when the motion is inside the window @@ -667,7 +672,7 @@ The function uses two overlays. (<= (car region) cnum) (< cnum (cdr region))) ;; mouse remains in outer region nil - ;; otherwise, reset the outer region + ;; otherwise, reset the outer region (setq region (caml-types-typed-make-overlay target-buf (caml-event-point-start event)))) @@ -730,7 +735,7 @@ The function uses two overlays. ;; 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. + ;; occured, as is done for exploration. ;; So far, we just ignore next event. (Next line also be uncommenting.) (if event (caml-read-event)) ))) @@ -758,7 +763,7 @@ The function uses two overlays. (defun caml-types-version () "internal version number of caml-types.el" (interactive) - (message "3") + (message "4") ) (provide 'caml-types) diff --git a/emacs/caml.el b/emacs/caml.el index e5cef21d6..113fce058 100644 --- a/emacs/caml.el +++ b/emacs/caml.el @@ -296,9 +296,9 @@ have caml-electric-indent on, which see.") (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) - (define-key caml-mode-map [?\C-c?\C-s] 'caml-types-show-call) - (define-key caml-mode-map [?\C-c?\C-i] 'caml-types-show-ident) + (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 @@ -813,6 +813,9 @@ from an error message produced by camlc.") (defvar caml-error-overlay nil) (defvar caml-next-error-skip-warnings-flag nil) +(defun caml-string-to-int (x) + (if boundp 'string-to-number (string-to-number x) (string-to-int x))) + ;;itz 04-21-96 somebody didn't get the documetation for next-error ;;right. When the optional argument is a number n, it should move ;;forward n errors, not reparse. @@ -838,10 +841,10 @@ possible." (goto-char (window-point (get-buffer-window (current-buffer)))) (if (looking-at caml-error-chars-regexp) (setq beg - (string-to-int + (caml-string-to-int (buffer-substring (match-beginning 1) (match-end 1))) end - (string-to-int + (caml-string-to-int (buffer-substring (match-beginning 2) (match-end 2))))) (next-line) (beginning-of-line) diff --git a/typing/annot.mli b/typing/annot.mli index 79100c558..92b2f6ec6 100644 --- a/typing/annot.mli +++ b/typing/annot.mli @@ -18,6 +18,6 @@ type call = Tail | Stack | Inline;; type ident = | Iref_internal of Location.t (* defining occurrence *) - | Iref_external of string (* fully qualified name *) + | Iref_external | Idef of Location.t (* scope *) ;; diff --git a/typing/env.ml b/typing/env.ml index a02b700a3..05f489613 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -412,12 +412,7 @@ let lookup_simple proj1 proj2 lid env = let lookup_value = lookup (fun env -> env.values) (fun sc -> sc.comp_values) let lookup_annot id e = - let (path, annot) = - lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e - in - match annot with - | Annot.Iref_external "" -> (path, Annot.Iref_external (Path.name path)) - | _ -> (path, annot) + lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e and lookup_constructor = lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) and lookup_label = @@ -525,7 +520,7 @@ let rec components_of_module env sub path mty = Tbl.add (Ident.name id) (decl', !pos) c.comp_values; if !Clflags.annotations then begin c.comp_annotations <- - Tbl.add (Ident.name id) (Annot.Iref_external "", !pos) + Tbl.add (Ident.name id) (Annot.Iref_external, !pos) c.comp_annotations; end; begin match decl.val_kind with @@ -752,7 +747,7 @@ let open_signature root sg env = Tsig_value(id, decl) -> let e1 = store_value (Ident.hide id) p (Subst.value_description sub decl) env - in store_annot (Ident.hide id) p (Annot.Iref_external "") e1 + in store_annot (Ident.hide id) p (Annot.Iref_external) e1 | Tsig_type(id, decl, _) -> store_type (Ident.hide id) p (Subst.type_declaration sub decl) env diff --git a/typing/stypes.ml b/typing/stypes.ml index a0f7aa3c8..4d1166fe5 100644 --- a/typing/stypes.ml +++ b/typing/stypes.ml @@ -33,7 +33,7 @@ type annotation = | Ti_class of class_expr | Ti_mod of module_expr | An_call of Location.t * Annot.call - | An_ident of Location.t * Annot.ident + | An_ident of Location.t * string * Annot.ident ;; let get_location ti = @@ -43,7 +43,7 @@ let get_location ti = | Ti_class c -> c.cl_loc | Ti_mod m -> m.mod_loc | An_call (l, k) -> l - | An_ident (l, k) -> l + | An_ident (l, s, k) -> l ;; let annotations = ref ([] : annotation list);; @@ -115,11 +115,11 @@ let call_kind_string k = | Inline -> "inline" ;; -let print_ident_annot pp k = +let print_ident_annot pp str k = match k with - | Idef l -> fprintf pp "def %a@." print_location l; - | Iref_internal l -> fprintf pp "internal_ref %a@." print_location l; - | Iref_external s -> fprintf pp "external_ref %s@." s; + | Idef l -> fprintf pp "def %s %a@." str print_location l; + | Iref_internal l -> fprintf pp "int_ref %s %a@." str print_location l; + | Iref_external -> fprintf pp "ext_ref %s@." str; ;; (* The format of the annotation file is documented in emacs/caml-types.el. *) @@ -140,10 +140,10 @@ let print_info pp prev_loc ti = if loc <> prev_loc then fprintf pp "%a@." print_location loc; fprintf pp "call(@. %s@.)@." (call_kind_string k); loc - | An_ident (loc, k) -> + | An_ident (loc, str, k) -> if loc <> prev_loc then fprintf pp "%a@." print_location loc; fprintf pp "ident(@. "; - print_ident_annot pp k; + print_ident_annot pp str k; fprintf pp ")@."; loc ;; diff --git a/typing/stypes.mli b/typing/stypes.mli index 399c04131..32f92c1d7 100644 --- a/typing/stypes.mli +++ b/typing/stypes.mli @@ -24,7 +24,7 @@ type annotation = | Ti_class of class_expr | Ti_mod of module_expr | An_call of Location.t * Annot.call - | An_ident of Location.t * Annot.ident + | An_ident of Location.t * string * Annot.ident ;; val record : annotation -> unit;; diff --git a/typing/typecore.ml b/typing/typecore.ml index 93dbd6fa9..ada6cacf8 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -207,7 +207,7 @@ let enter_variable loc name ty = pattern_variables := (id, ty, loc) :: !pattern_variables; begin match !pattern_scope with | None -> () - | Some s -> Stypes.record (Stypes.An_ident (loc, s)); + | Some s -> Stypes.record (Stypes.An_ident (loc, name, s)); end; id @@ -934,7 +934,8 @@ let rec type_exp env sexp = begin try if !Clflags.annotations then begin try let (path, annot) = Env.lookup_annot lid env in - Stypes.record (Stypes.An_ident (sexp.pexp_loc, annot)); + Stypes.record (Stypes.An_ident (sexp.pexp_loc, Path.name path, + annot)); with _ -> () end; let (path, desc) = Env.lookup_value lid env in diff --git a/typing/typemod.ml b/typing/typemod.ml index 21248ed40..7a94b1652 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -660,7 +660,7 @@ and type_structure anchor env sstr scope = Location.loc_start = loc.Location.loc_start}) | Nonrecursive -> let start = match srem with - | [] -> scope.Location.loc_end + | [] -> loc.Location.loc_end | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start in Some (Annot.Idef {scope with Location.loc_start = start}) | Default -> None |