code.delx.au - gnu-emacs-elpa/blob - packages/f90-interface-browser/f90-interface-browser.el

   1 ;;; f90-interface-browser.el --- Parse and browse f90 interfaces
   2
   3 ;; Copyright (C) 2011, 2012  Free Software Foundation, Inc
   4
   5 ;; Author: Lawrence Mitchell <wence@gmx.li>
   6 ;; Created: 2011-07-06
   7 ;; Available-from: http://github.com/wence-/f90-iface/
   8 ;; Version: 1.1
   9
  10 ;; COPYRIGHT NOTICE
  11
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26 ;; You write (or work on) large, modern fortran code bases.  These
  27 ;; make heavy use of function overloading and generic interfaces.  Your
  28 ;; brain is too small to remember what all the specialisers are
  29 ;; called.  Therefore, your editor should help you.
  30
  31 ;; Load this file and tell it to parse all the fortran files in your
  32 ;; code base.  You can do this one directory at a time by calling
  33 ;; `f90-parse-interfaces-in-dir' (M-x f90-parse-interfaces-in-dir
  34 ;; RET).  Or you can parse all the fortran files in a directory and
  35 ;; recursively in its subdirectories by calling
  36 ;; `f90-parse-all-interfaces'.
  37
  38 ;; Now you are able to browse (with completion) all defined interfaces
  39 ;; in your code by calling `f90-browse-interface-specialisers'.
  40 ;; Alternatively, if `point' is on a procedure call, you can call
  41 ;; `f90-find-tag-interface' and you'll be shown a list of the
  42 ;; interfaces that match the (possibly typed) argument list of the
  43 ;; current procedure.  This latter hooks into the `find-tag' machinery
  44 ;; so that you can use it on the M-.  keybinding and it will fall back
  45 ;; to completing tag names if you don't want to look for an interface
  46 ;; definition.
  47 ;; In addition, if you're in a large procedure and want the list of
  48 ;; the variables in scope (perhaps you want to define a new loop
  49 ;; variable), you can use `f90-list-in-scope-vars' to pop up a buffer
  50 ;; giving a reasonable guess.  Note this doesn't give you module
  51 ;; variables, or the variables of parent procedures if the current
  52 ;; subroutine is contained within another.
  53
  54 ;; Derived types are also parsed, so that slot types of derived types
  55 ;; are given the correct type (rather than a UNION-TYPE) when arglist
  56 ;; matching.  You can show the definition of a known derived type by
  57 ;; calling `f90-show-type-definition' which prompts (with completion)
  58 ;; for a typename to show.
  59
  60 ;; The parser assumes you write Fortran in the style espoused in
  61 ;; Metcalf, Reid and Cohen.  Particularly, variable declarations use a
  62 ;; double colon to separate the type from the name list.
  63
  64 ;; Here's an example of a derived type definition
  65 ;;     type foo
  66 ;;        real, allocatable, dimension(:) :: a
  67 ;;        integer, pointer :: b, c(:)
  68 ;;        type(bar) :: d
  69 ;;     end type
  70
  71 ;; Here's a subroutine declaration
  72 ;;     subroutine foo(a, b)
  73 ;;        integer, intent(in) :: a
  74 ;;        real, intent(inout), dimension(:,:) :: b
  75 ;;        ...
  76 ;;     end subroutine foo
  77
  78 ;; Local procedures whose names conflict with global ones will likely
  79 ;; confuse the parser.  For example
  80
  81 ;;    subroutine foo(a, b)
  82 ;;       ...
  83 ;;    end subroutine foo
  84 ;;
  85 ;;    subroutine bar(a, b)
  86 ;;       ...
  87 ;;       call subroutine foo
  88 ;;       ...
  89 ;;     contains
  90 ;;       subroutine foo
  91 ;;          ...
  92 ;;       end subroutine foo
  93 ;;    end subroutine bar
  94
  95 ;; Also not handled are overloaded operators, scalar precision
  96 ;; modifiers, like integer(kind=c_int), for which the precision is
  97 ;; just ignored, and many other aspects.
  98
  99 ;; Some tests of the parser are available in f90-tests.el (in the same
 100 ;; repository as this file).
 101
 102 ;;; Code:
 103
 104 ;;; Preamble
 105 (eval-when-compile
 106   (require 'cl))
 107 (require 'thingatpt)
 108 (require 'f90)
 109 (require 'etags)
 110
 111 (defgroup f90-iface nil
 112   "Static parser for Fortran 90 code"
 113   :prefix "f90-"
 114   :group 'f90)
 115
 116 (defcustom f90-file-extensions (list "f90" "F90" "fpp")
 117   "Extensions to consider when looking for Fortran 90 files."
 118   :type '(repeat string)
 119   :group 'f90-iface)
 120
 121 (defcustom f90-file-name-check-functions '(f90-check-fluidity-refcount)
 122   "List of functions to call to check if a file should be parsed.
 123
 124 In addition to checking if a file exists and is readable, you can
 125 add extra checks before deciding to parse a file.  Each function
 126 will be called with one argument, the fully qualified name of the
 127 file to test, it should return non-nil if the file should be
 128 parsed.  For an example test function see
 129 `f90-check-fluidity-refcount'."
 130   :type '(repeat function)
 131   :group 'f90-iface)
 132
 133 (defcustom f90-extra-file-functions '(f90-insert-fluidity-refcount)
 134   "List of functions to call to insert extra files to parse.
 135
 136 Each function should be a function of two arguments, the first is the
 137 fully qualified filename (with directory) the second is the
 138 unqualified filename."
 139   :type '(repeat function)
 140   :group 'f90-iface)
 141
 142 ;;; Internal variables
 143 (defvar f90-interface-type nil)
 144 (make-variable-buffer-local 'f90-interface-type)
 145
 146 (defvar f90-buffer-to-switch-to nil)
 147 (make-variable-buffer-local 'f90-buffer-to-switch-to)
 148
 149 (defvar f90-invocation-marker nil)
 150 (make-variable-buffer-local 'f90-invocation-marker)
 151
 152 ;; Data types for storing interface and specialiser definitions
 153 (defstruct f90-interface
 154   (name "" :read-only t)
 155   (publicp nil)
 156   specialisers)
 157
 158 (defstruct f90-specialiser
 159   (name "" :read-only t)
 160   (type "")
 161   (arglist "")
 162   location)
 163
 164 (defvar f90-all-interfaces (make-hash-table :test 'equal)
 165   "Hash table populated with all known f90 interfaces.")
 166
 167 (defvar f90-types (make-hash-table :test 'equal)
 168   "Hash table populated with all known f90 derived types.")
 169
 170 ;;; Inlineable utility functions
 171 (defsubst f90-specialisers (name interfaces)
 172   "Return all specialisers for NAME in INTERFACES."
 173   (f90-interface-specialisers (f90-get-interface name interfaces)))
 174
 175 (defsubst f90-valid-interface-name (name)
 176   "Return non-nil if NAME is an interface name."
 177   (gethash name f90-all-interfaces))
 178
 179 (defsubst f90-count-commas (str &optional level)
 180   "Count commas in STR.
 181
 182 If LEVEL is non-nil, only count commas up to the specified nesting
 183 level.  For example, a LEVEL of 0 counts top-level commas."
 184   (1- (length (f90-split-arglist str level))))
 185
 186 (defsubst f90-get-parsed-type-varname (type)
 187   "Return the variable name of TYPE."
 188   (car type))
 189
 190 (defsubst f90-get-parsed-type-typename (type)
 191   "Return the type name of TYPE."
 192   (cadr type))
 193
 194 (defsubst f90-get-parsed-type-modifiers (type)
 195   "Return the modifiers of TYPE."
 196   (cddr type))
 197
 198 (defsubst f90-get-type (type)
 199   "Return the struct definition corresponding to TYPE."
 200   (gethash (f90-get-parsed-type-typename type) f90-types))
 201
 202 (defsubst f90-get-slot-type (slot type)
 203   "Get the type of SLOT in TYPE."
 204   (let ((fn (intern-soft (format "f90-type.%s.%s"
 205                                  (f90-get-parsed-type-typename type) slot))))
 206     (when fn
 207       (funcall fn (f90-get-type type)))))
 208
 209 (defun f90-lazy-completion-table ()
 210   "Lazily produce a completion table of all interfaces and tag names."
 211   (lexical-let ((buf (current-buffer)))
 212     (lambda (string pred action)
 213       (with-current-buffer buf
 214         (save-excursion
 215           ;; If we need to ask for the tag table, allow that.
 216           (let ((enable-recursive-minibuffers t))
 217             (visit-tags-table-buffer))
 218           (complete-with-action action (f90-merge-into-tags-completion-table f90-all-interfaces) string pred))))))
 219
 220
 221 (defsubst f90-merge-into-tags-completion-table (ctable)
 222   "Merge completions in CTABLE into the tags completion table."
 223   (if (or tags-file-name tags-table-list)
 224       (let ((table (tags-completion-table)))
 225         (maphash (lambda (k v)
 226                    (ignore v)
 227                    (intern k table))
 228                  ctable)
 229         table)
 230     ctable))
 231
 232 (defsubst f90-extract-type-name (name)
 233   "Return the typename from NAME.
 234
 235 If NAME is like type(TYPENAME) return TYPENAME, otherwise just NAME."
 236   (if (and name (string-match "\\`type(\\([^)]+\\))\\'" name))
 237       (match-string 1 name)
 238     name))
 239
 240 ;;; User-visible routines
 241
 242 (defun f90-parse-all-interfaces (dir)
 243   "Parse all interfaces found in DIR and its subdirectories.
 244
 245 Recurse over all (non-hidden) directories below DIR and parse
 246 interfaces found within them using `f90-parse-interfaces-in-dir',
 247 a directory is considered hidden if it's name doesn't start with
 248 an alphanumeric character."
 249   (interactive "DParse files in tree: ")
 250   (let (dirs
 251         attrs
 252         seen
 253         (pending (list (expand-file-name dir))))
 254     (while pending
 255       (push (pop pending) dirs)
 256       (let* ((this-dir (car dirs))
 257              (contents (directory-files this-dir))
 258              (default-directory this-dir))
 259         (setq attrs (nthcdr 10 (file-attributes this-dir)))
 260         (unless (member attrs seen)
 261           (push attrs seen)
 262           (dolist (file contents)
 263             ;; Ignore hidden directories
 264             (and (string-match "\\`[[:alnum:]]" file)
 265                  (file-directory-p file)
 266                  (setq pending (nconc pending
 267                                       (list (expand-file-name file)))))))))
 268     (mapc 'f90-parse-interfaces-in-dir dirs)))
 269
 270 (defun f90-parse-interfaces-in-dir (dir)
 271   "Parse all Fortran 90 files in DIR to populate `f90-all-interfaces'."
 272   (interactive "DParse files in directory: ")
 273   (loop for file in (directory-files dir t
 274                                      (rx-to-string
 275                                       `(and "." (or ,@f90-file-extensions)
 276                                             eos) t))
 277         do (f90-parse-interfaces file f90-all-interfaces)))
 278
 279 (defun f90-find-tag-interface (name &optional match-sublist)
 280   "List all interfaces matching NAME.
 281
 282 Restricts list to those matching the (possibly typed) arglist of
 283 the word at point.  If MATCH-SUBLIST is non-nil, only check if
 284 the arglist is a sublist of the specialiser's arglist.  For more
 285 details see `f90-approx-arglist-match' and
 286 `f90-browse-interface-specialisers'."
 287   (interactive (let ((def (word-at-point)))
 288                  (list (completing-read
 289                         (format "Find interface/tag (default %s): " def)
 290                         (f90-lazy-completion-table)
 291                         nil t nil nil def)
 292                        current-prefix-arg)))
 293   (if (f90-valid-interface-name name)
 294       (f90-browse-interface-specialisers name (f90-arglist-types)
 295                                          match-sublist
 296                                          (point-marker))
 297     (find-tag name match-sublist)))
 298
 299 (defun f90-browse-interface-specialisers (name &optional arglist-to-match
 300                                                match-sublist
 301                                                invocation-point)
 302   "Browse all interfaces matching NAME.
 303
 304 If ARGLIST-TO-MATCH is non-nil restrict to those interfaces that match
 305 it.
 306 If MATCH-SUBLIST is non-nil only restrict to those interfaces for
 307 which ARGLIST-TO-MATCH is a sublist of the specialiser's arglist.
 308
 309 If INVOCATION-POINT is non-nil it should be a `point-marker'
 310 indicating where we were called from, for jumping back to with
 311 `pop-tag-mark'."
 312   (interactive (let ((def (word-at-point)))
 313                  (list (completing-read
 314                         (format "Interface%s: "
 315                                 (if def
 316                                     (format " (default %s)" def)
 317                                   ""))
 318                         f90-all-interfaces
 319                         nil t nil nil def))))
 320   (let ((buf (current-buffer)))
 321     (or invocation-point (setq invocation-point (point-marker)))
 322     (with-current-buffer (get-buffer-create "*Interface Browser*")
 323       (let ((interface (f90-get-interface name f90-all-interfaces))
 324             (type nil)
 325             (n-specs 0))
 326         (setq buffer-read-only nil)
 327         (erase-buffer)
 328         (setq n-specs
 329               (loop for s being the hash-values of
 330                     (f90-interface-specialisers interface)
 331                     do (setq type (f90-specialiser-type s))
 332                     when (or (null arglist-to-match)
 333                              (f90-approx-arglist-match
 334                               arglist-to-match s match-sublist))
 335                     do (insert
 336                         (propertize
 337                          (concat
 338                           (propertize
 339                            (format "%s [defined in %s]\n    (%s)\n"
 340                                    (propertize (f90-specialiser-name s)
 341                                                'face 'bold)
 342                                    (let ((f (car
 343                                              (f90-specialiser-location s))))
 344                                      (format "%s/%s"
 345                                              (file-name-nondirectory
 346                                               (directory-file-name
 347                                                (file-name-directory f)))
 348                                              (file-name-nondirectory f)))
 349                                    (f90-fontify-arglist
 350                                     (f90-specialiser-arglist s)))
 351                            'f90-specialiser-location
 352                            (f90-specialiser-location s)
 353                            'f90-specialiser-name (f90-specialiser-name s)
 354                            'mouse-face 'highlight
 355                            'help-echo
 356                            "mouse-1: find definition in other window")
 357                           "\n")
 358                          'f90-specialiser-extent (f90-specialiser-name s)))
 359                     and count 1))
 360         (goto-char (point-min))
 361         (insert (format "Interfaces for %s:\n\n"
 362                         (f90-interface-name interface)))
 363         (when arglist-to-match
 364           (insert (format "%s\n%s\n\n"
 365                           (if (zerop n-specs)
 366                               "No interfaces matching arglist (intrinsic?):"
 367                             "Only showing interfaces matching arglist:")
 368                           (f90-fontify-arglist arglist-to-match))))
 369         (f90-interface-browser-mode)
 370         (setq f90-buffer-to-switch-to buf)
 371         (setq f90-interface-type type)
 372         (setq f90-invocation-marker invocation-point)
 373         (pop-to-buffer (current-buffer))))))
 374
 375 (defun f90-next-definition (&optional arg)
 376   "Go to the next ARG'th specialiser definition."
 377   (interactive "p")
 378   (unless arg
 379     (setq arg 1))
 380   (while (> arg 0)
 381     (goto-char (next-single-property-change
 382                 (point)
 383                 'f90-specialiser-extent
 384                 nil (point-max)))
 385     (decf arg)))
 386
 387 (defun f90-previous-definition (&optional arg)
 388   "Go to the previous ARG'th specialiser definition."
 389   (interactive "p")
 390   (unless arg
 391     (setq arg 1))
 392   (while (> arg 0)
 393     (loop repeat 2
 394           do (goto-char (previous-single-property-change
 395                          (point)
 396                          'f90-specialiser-extent
 397                          nil (point-min))))
 398     (f90-next-definition 1)
 399     (decf arg)))
 400
 401 (defun f90-mouse-find-definition (e)
 402   "Visit the definition at the position of the event E."
 403   (interactive "e")
 404   (let ((win (posn-window (event-end e)))
 405         (point (posn-point (event-end e))))
 406     (when (not (windowp win))
 407       (error "No definition here"))
 408     (with-current-buffer (window-buffer win)
 409       (goto-char point)
 410       (f90-find-definition))))
 411
 412 (defun f90-quit-browser ()
 413   "Quit the interface browser."
 414   (interactive)
 415   (let ((buf f90-buffer-to-switch-to))
 416     (kill-buffer (current-buffer))
 417     (pop-to-buffer buf)))
 418
 419 (defun f90-find-definition ()
 420   "Visit the definition at `point'."
 421   (interactive)
 422   (let ((location (get-text-property (point) 'f90-specialiser-location))
 423         (name (get-text-property (point) 'f90-specialiser-name))
 424         (type f90-interface-type)
 425         (buf (current-buffer))
 426         buf-to)
 427     (if location
 428         (progn (ring-insert find-tag-marker-ring f90-invocation-marker)
 429                (find-file-other-window (car location))
 430                (setq buf-to (current-buffer))
 431                (goto-char (cadr location))
 432                ;; Try forwards then backwards near the recorded
 433                ;; location
 434                (or (re-search-forward (format "%s[ \t]+%s[ \t]*("
 435                                               type name) nil t)
 436                    (re-search-backward (format "%s[ \t]+%s[ \t]*("
 437                                                type name) nil t))
 438                (beginning-of-line)
 439                (recenter 0)
 440                (pop-to-buffer buf)
 441                (setq f90-buffer-to-switch-to buf-to))
 442       (error "No definition at point"))))
 443
 444 (defvar f90-interface-browser-mode-map
 445   (let ((map (make-sparse-keymap)))
 446     (define-key map (kbd "RET") 'f90-find-definition)
 447     (define-key map (kbd "<down>") 'f90-next-definition)
 448     (define-key map (kbd "TAB") 'f90-next-definition)
 449     (define-key map (kbd "<up>") 'f90-previous-definition)
 450     (define-key map (kbd "<backtab>") 'f90-previous-definition)
 451     (define-key map (kbd "q") 'f90-quit-browser)
 452     (define-key map (kbd "<mouse-1>") 'f90-mouse-find-definition)
 453     map)
 454   "Keymap for `f90-interface-browser-mode'.")
 455
 456 (define-derived-mode f90-interface-browser-mode fundamental-mode "IBrowse"
 457   "Major mode for browsing f90 interfaces."
 458   (setq buffer-read-only t)
 459   (set-buffer-modified-p nil))
 460
 461 ;;; Type definitions
 462
 463 (defun f90-type-at-point ()
 464   "Return a guess for the type of the thing at `point'.
 465
 466 If `point' is currently on a line containing a variable declaration,
 467 return the typename of the declaration.  Otherwise try and figure out
 468 the typename of the variable at point (possibly including slot
 469 references)."
 470   (let ((name (or
 471                ;; Are we on a line with type(TYPENAME)?
 472                (save-excursion
 473                  (forward-line 0)
 474                  (f90-parse-single-type-declaration))
 475                ;; No, try and derive the type of the variable at point
 476                (save-excursion
 477                  (let ((syntax (copy-syntax-table f90-mode-syntax-table)))
 478                    (modify-syntax-entry ?% "w" syntax)
 479                    (with-syntax-table syntax
 480                      (skip-syntax-backward "w")
 481                      (f90-arg-types
 482                       (list
 483                        (buffer-substring-no-properties
 484                         (point)
 485                         (progn (skip-syntax-forward "w") (point)))))))))))
 486     (f90-extract-type-name (f90-get-parsed-type-typename (car name)))))
 487
 488 (defun f90-show-type-definition (type)
 489   "Show the definition of TYPE.
 490
 491 This formats the parsed definition of TYPE, rather than jumping to the
 492 existing definition.
 493
 494 When called interactively, default to the type of the thing at `point'.
 495 If `point' is on a type declaration line, the default is the
 496 declaration type.
 497 If `point' is on a variable name (possibly with slot references) the
 498 default is the type of the variable."
 499   (interactive (list (let ((def (f90-type-at-point)))
 500                        (completing-read
 501                         (if def (format "Type (default %s): " def) "Type: ")
 502                         (loop for type being the hash-keys of f90-types
 503                               collect (f90-extract-type-name type))
 504                         nil t nil nil def))))
 505   (with-current-buffer (get-buffer-create "*Type definition*")
 506     (setq buffer-read-only nil)
 507     (fundamental-mode)
 508     (erase-buffer)
 509     (let* ((tname (format "type(%s)" type))
 510            (type-struct (f90-get-type (list nil tname)))
 511            fns)
 512       (when type-struct
 513         (setq fns (loop for name in (funcall (intern-soft
 514                                               (format "f90-type.%s.-varnames"
 515                                                       tname))
 516                                              type-struct)
 517                         collect (intern-soft (format "f90-type.%s.%s"
 518                                                      tname name)))))
 519       (if (null type-struct)
 520           (insert (format "The type %s is not a known derived type."
 521                           type))
 522         (insert (format "type %s\n" type))
 523         (loop for fn in fns
 524               for parsed = (funcall fn type-struct)
 525               then (funcall fn type-struct)
 526               do
 527               (insert (format "  %s :: %s\n"
 528                               (f90-format-parsed-slot-type parsed)
 529                               (f90-get-parsed-type-varname parsed))))
 530         (insert (format "end type %s\n" type))
 531         (f90-mode))
 532       (goto-char (point-min))
 533       (view-mode)
 534       (pop-to-buffer (current-buffer)))))
 535
 536 ;;; Arglist matching/formatting
 537
 538 (defun f90-format-parsed-slot-type (type)
 539   "Turn a parsed TYPE into a valid f90 type declaration."
 540   (if (null type)
 541       "UNION-TYPE"
 542     ;; Ignore name
 543     (setq type (cdr type))
 544     (mapconcat 'identity (loop for a in type
 545                                if (and (consp a)
 546                                        (string= (car a) "dimension"))
 547                                collect (format "dimension(%s)"
 548                                                (mapconcat 'identity
 549                                                           (make-list (cdr a)
 550                                                                      ":")
 551                                                           ","))
 552                                else if (not
 553                                         (string-match
 554                                          "\\`intent(\\(?:in\\|out\\|inout\\))"
 555                                          a))
 556                                collect a)
 557                ", ")))
 558
 559 (defun f90-fontify-arglist (arglist)
 560   "Fontify ARGLIST using `f90-mode'."
 561   (with-temp-buffer
 562     (if (stringp arglist)
 563         (insert (format "%s :: foo\n" arglist))
 564       (insert (mapconcat (lambda (x)
 565                            (format "%s :: foo" (f90-format-parsed-slot-type x)))
 566                          arglist "\n")))
 567     (f90-mode)
 568     (font-lock-fontify-buffer)
 569     (goto-char (point-min))
 570     (mapconcat 'identity
 571                (loop while (not (eobp))
 572                      collect (buffer-substring (line-beginning-position)
 573                                                (- (line-end-position)
 574                                                   (length " :: foo")))
 575                      do (forward-line 1))
 576                "; ")))
 577
 578 (defun f90-count-non-optional-args (arglist)
 579   "Count non-optional args in ARGLIST."
 580   (loop for arg in arglist
 581         count (not (member "optional" (f90-get-parsed-type-modifiers arg)))))
 582
 583 (defun f90-approx-arglist-match (arglist specialiser &optional match-sub-list)
 584   "Return non-nil if ARGLIST matches the arglist of SPECIALISER.
 585
 586 If MATCH-SUB-LIST is non-nil just require that ARGLIST matches the
 587 first (length ARGLIST) args of SPECIALISER."
 588   (let* ((n-passed-args (length arglist))
 589          (spec-arglist (f90-specialiser-arglist specialiser))
 590          (n-spec-args (length spec-arglist))
 591          (n-required-args (f90-count-non-optional-args spec-arglist)))
 592     (when (or match-sub-list
 593               (and (<= n-required-args n-passed-args)
 594                    (<= n-passed-args n-spec-args)))
 595       (loop for arg in arglist
 596             for spec-arg in spec-arglist
 597             with match = nil
 598             unless (or (null arg)
 599                        (string= (f90-get-parsed-type-typename arg)
 600                                 (f90-get-parsed-type-typename spec-arg)))
 601             do (return nil)
 602             finally (return t)))))
 603
 604 ;;; Internal functions
 605
 606 (defun f90-clean-comments ()
 607   "Clean Fortran 90 comments from the current buffer."
 608   (save-excursion
 609     (goto-char (point-min))
 610     (set-syntax-table f90-mode-syntax-table)
 611     (while (search-forward "!" nil t)
 612       (when (nth 4 (parse-partial-sexp (line-beginning-position) (point)))
 613         (delete-region (max (1- (point)) (line-beginning-position))
 614                        (line-end-position))))))
 615
 616 (defun f90-clean-continuation-lines ()
 617   "Splat Fortran continuation lines in the current buffer onto one line."
 618   (save-excursion
 619     (goto-char (point-min))
 620     (while (re-search-forward "&[ \t]*\n[ \t]*&?" nil t)
 621       (replace-match "" nil t))))
 622
 623 (defun f90-normalise-string (string)
 624   "Return a suitably normalised version of STRING."
 625   ;; Trim whitespace
 626   (save-match-data
 627     (when (string-match "\\`[ \t]+" string)
 628       (setq string (replace-match "" t t string)))
 629     (when (string-match "[ \t]+\\'" string)
 630       (setq string (replace-match "" t t string)))
 631     (downcase string)))
 632
 633 (defun f90-get-interface (name &optional interfaces)
 634   "Get the interface with NAME from INTERFACES.
 635
 636 If INTERFACES is nil use `f90-all-interfaces' instead."
 637   (gethash name (or interfaces f90-all-interfaces)))
 638
 639 (defsetf f90-get-interface (name &optional interfaces) (val)
 640   `(setf (gethash ,name (or ,interfaces f90-all-interfaces)) ,val))
 641
 642 ;;; Entry point to parsing routines
 643
 644 (defun f90-parse-file-p (file)
 645   "Return non-nil if FILE should be parsed.
 646
 647 This checks that FILE exists and is readable, and then calls
 648 additional test functions from `f90-file-name-check-functions'."
 649   (and (file-exists-p file)
 650        (file-readable-p file)
 651        (loop for test in f90-file-name-check-functions
 652              unless (funcall test file)
 653              do (return nil)
 654              finally (return t))))
 655
 656 (defun f90-check-fluidity-refcount (file)
 657   "Return nil if FILE is that of a Fluidity refcount template."
 658   (let ((fname (file-name-nondirectory file)))
 659     (and (not (string-match "\\`Reference_count_interface" fname))
 660          (not (string-equal "Refcount_interface_templates.F90" fname))
 661          (not (string-equal "Refcount_templates.F90" fname)))))
 662
 663 (defun f90-maybe-insert-extra-files (file)
 664   "Maybe insert extra files corresponding to FILE when parsing.
 665
 666 To actually insert extra files, customize the variable
 667 `f90-extra-file-functions'.  For an example insertion function
 668 see `f90-insert-fluidity-refcount'."
 669   (let ((fname (file-name-nondirectory file)))
 670     (loop for fn in f90-extra-file-functions
 671           do (funcall fn file fname))))
 672
 673 (defun f90-insert-fluidity-refcount (file fname)
 674   "Insert a Fluidity reference count template for FILE.
 675
 676 If FNAME matches \\\\`Reference_count_.*\\\\.F90 then this file
 677 needs a reference count interface, so insert one."
 678   (when (string-match "\\`Reference_count_\\([^\\.]+\\)\\.F90" fname)
 679     (insert-file-contents-literally
 680      (expand-file-name
 681       (format "Reference_count_interface_%s.F90"
 682               (match-string 1 fname))
 683       (file-name-directory file)))))
 684
 685 (defun f90-parse-interfaces (file existing)
 686   "Parse interfaces in FILE and merge into EXISTING interface data."
 687   (with-temp-buffer
 688     (let ((interfaces (make-hash-table :test 'equal)))
 689       ;; Is this file valid for parsing
 690       (when (f90-parse-file-p file)
 691         (insert-file-contents-literally file)
 692         ;; Does this file have other parts elsewhere?
 693         (f90-maybe-insert-extra-files file)
 694         ;; Easier if we don't have to worry about line wrap
 695         (f90-clean-comments)
 696         (f90-clean-continuation-lines)
 697         (goto-char (point-min))
 698         ;; Search forward for a named interface block
 699         (while (re-search-forward
 700                 "^[ \t]*interface[ \t]+\\([^ \t\n]+\\)[ \t]*$" nil t)
 701           (let* ((name (f90-normalise-string (match-string 1)))
 702                  interface)
 703             (unless (string= name "")
 704               (setq interface (make-f90-interface :name name))
 705               (save-restriction
 706                 ;; Figure out all the specialisers for this generic name
 707                 (narrow-to-region
 708                  (point)
 709                  (re-search-forward
 710                   (format "[ \t]*end interface\\(?:[ \t]+%s\\)?[ \t]*$" name)
 711                   nil t))
 712                 (f90-populate-specialisers interface))
 713               ;; Multiple interface blocks with same name (this seems to
 714               ;; be allowed).  In which case merge rather than overwrite.
 715               (if (f90-get-interface name interfaces)
 716                   (f90-merge-interface interface interfaces)
 717                 (setf (f90-get-interface name interfaces) interface)))))
 718         (goto-char (point-min))
 719         ;; Parse type definitions
 720         (save-excursion
 721           (while (re-search-forward
 722                   "^[ \t]*type[ \t]+\\(?:[^ \t\n]+\\)[ \t]*$" nil t)
 723             (let ((beg (match-beginning 0)))
 724               (unless (re-search-forward "^[ \t]*end[ \t]+type.*$" nil t)
 725                 (error "Unable to find end of type definition"))
 726               (save-restriction
 727                 (narrow-to-region beg (match-beginning 0))
 728                 (f90-parse-type-definition)))))
 729
 730         ;; Now find out if an interface is public or private to the module
 731         (f90-set-public-attribute interfaces)
 732
 733         ;; Now find the arglists corresponding to the interface (so we
 734         ;; can disambiguate) and record their location in the file.
 735         (loop for interface being the hash-values of interfaces
 736               do (when (f90-interface-specialisers interface)
 737                    (maphash (lambda (specialiser val)
 738                               (save-excursion
 739                                 (goto-char (point-min))
 740                                 (let ((thing (f90-argument-list specialiser)))
 741                                   (setf (f90-specialiser-arglist
 742                                          val)
 743                                         (cadr thing))
 744                                   (setf (f90-specialiser-location
 745                                          val)
 746                                         (list file (caddr thing)))
 747                                   (setf (f90-specialiser-type
 748                                          val)
 749                                         (car thing)))))
 750                             (f90-interface-specialisers interface))))
 751         ;; Finally merge these new interfaces into the existing data.
 752         (f90-merge-interfaces interfaces existing)))))
 753
 754 (defun f90-merge-interface (interface interfaces)
 755   "Merge INTERFACE into the existing set of INTERFACES."
 756   (let ((name (f90-interface-name interface))
 757         spec-name)
 758     (when (f90-interface-specialisers interface)
 759       (loop for val being the hash-values of
 760             (f90-interface-specialisers interface)
 761             do (setq spec-name (f90-specialiser-name val))
 762             (setf (gethash spec-name (f90-specialisers name interfaces))
 763                   val)))))
 764
 765 (defun f90-merge-interfaces (new existing)
 766   "Merge NEW interfaces into EXISTING ones."
 767   (maphash (lambda (name val)
 768              (if (gethash name existing)
 769                  (f90-merge-interface val existing)
 770                (setf (gethash name existing)
 771                      val)))
 772            new))
 773
 774 (defun f90-populate-specialisers (interface)
 775   "Find all specialisers for INTERFACE."
 776   (save-excursion
 777     (goto-char (point-min))
 778     (setf (f90-interface-specialisers interface)
 779           (make-hash-table :test 'equal))
 780     (while (search-forward "module procedure" nil t)
 781       (let ((names (buffer-substring-no-properties
 782                     (point)
 783                     (line-end-position))))
 784         (mapc (lambda (x)
 785                 (setq x (f90-normalise-string x))
 786                 (setf (gethash x (f90-interface-specialisers interface))
 787                       (make-f90-specialiser :name x)))
 788               (split-string names "[, \n]+" t))))))
 789
 790 (defun f90-set-public-attribute (interfaces)
 791   "Set public/private flag on all INTERFACES."
 792   (save-excursion
 793     ;; Default public unless private is specified.
 794     (let ((public (not (save-excursion
 795                          (re-search-forward "^[ \t]*private[ \t]*$" nil t)))))
 796       (while (re-search-forward (format "^[ \t]*%s[ \t]+"
 797                                         (if public "private" "public"))
 798                                 nil t)
 799         (let ((names (buffer-substring-no-properties
 800                       (match-end 0)
 801                       (line-end-position))))
 802           ;; Set default
 803           (maphash (lambda (k v)
 804                      (ignore k)
 805                      (setf (f90-interface-publicp v) public))
 806                    interfaces)
 807           ;; Override for those specified
 808           (mapc (lambda (name)
 809                   (let ((interface (f90-get-interface name interfaces)))
 810                     (when interface
 811                       (setf (f90-interface-publicp interface) (not public)))))
 812                 (split-string names "[, \t]" t)))))))
 813
 814 ;;; Type/arglist parsing
 815 (defun f90-argument-list (name)
 816   "Return typed argument list of function or subroutine NAME."
 817   (save-excursion
 818     (when (re-search-forward
 819            (format "\\(function\\|subroutine\\)[ \t]+%s[ \t]*("
 820                    name)
 821            nil t)
 822       (let* ((point (match-beginning 0))
 823              (type (match-string 1))
 824              (args (f90-split-arglist (buffer-substring-no-properties
 825                                        (point)
 826                                        (f90-end-of-arglist)))))
 827         (list type (f90-arg-types args) point)))))
 828
 829 (defun f90-parse-type-definition ()
 830   "Parse a type definition at (or in front of) `point'."
 831   (let (type slots slot fn)
 832     (goto-char (point-min))
 833     (unless (re-search-forward "^[ \t]*type[ \t]+\\(.+?\\)[ \t]*$" nil t)
 834       (error "Trying parse a type but no type found"))
 835     (setq type (format "type(%s)" (f90-normalise-string (match-string 1))))
 836     (while (not (eobp))
 837       (setq slot (f90-parse-single-type-declaration))
 838       (when slot
 839         (setf slots (nconc slot slots)))
 840       (forward-line 1))
 841     (eval (f90-make-type-struct type slots))
 842     (setq fn (intern-soft (format "make-f90-type.%s" type)))
 843     (unless fn
 844       (error "Something bad went wrong parsing type definition %s" type))
 845     (setf (gethash type f90-types) (funcall fn))))
 846
 847 (defun f90-make-type-struct (type slots)
 848   "Create a struct describing TYPE with SLOTS."
 849   (let ((struct-name (make-symbol (format "f90-type.%s" type)))
 850         (varnames (reverse (mapcar (lambda (x)
 851                                      (setq x (car x))
 852                                      (if (string-match "\\([^(]+\\)(" x)
 853                                          (match-string 1 x)
 854                                        x)) slots))))
 855     `(defstruct (,struct-name
 856                  (:conc-name ,(make-symbol (format "f90-type.%s." type))))
 857        (-varnames ',varnames :read-only t)
 858        ,@(loop for (name . rest) in slots
 859                collect `(,(make-symbol name) (cons ',name ',rest)
 860                          :read-only t)))))
 861
 862 (defun f90-arglist-types ()
 863   "Return the types of the arguments to the function at `point'."
 864   (save-excursion
 865     (let* ((e (save-excursion (f90-end-of-subprogram) (point)))
 866            (b (save-excursion (f90-beginning-of-subprogram) (point)))
 867            (str (buffer-substring-no-properties b e))
 868            (p (point))
 869            names)
 870       (with-temp-buffer
 871         (with-syntax-table f90-mode-syntax-table
 872           (insert str)
 873           (goto-char (- p b))
 874           (setq p (point-marker))
 875           (f90-clean-continuation-lines)
 876           (goto-char p)
 877           (search-forward "(")
 878           (setq names (f90-split-arglist (buffer-substring
 879                                           (point)
 880                                           (f90-end-of-arglist))))
 881           (goto-char (point-min))
 882           (f90-arg-types names))))))
 883
 884 (defun f90-list-in-scope-vars ()
 885   "Pop up a buffer showing all variables in scope in the procedure at `point'"
 886   (interactive)
 887   (let* ((e (save-excursion (f90-end-of-subprogram) (point)))
 888          (b (save-excursion (f90-beginning-of-subprogram) (point)))
 889          (str (buffer-substring-no-properties b e))
 890          types)
 891     (with-temp-buffer
 892       (with-syntax-table f90-mode-syntax-table
 893         (insert str)
 894         (goto-char (point-min))
 895         (f90-clean-comments)
 896         (f90-clean-continuation-lines)
 897         (forward-line 1)                ; skip procedure name
 898         (let ((not-done t)
 899               type)
 900           (while (and not-done (not (eobp)))
 901             ;; skip "implicit none" which may appear at top of procedure
 902             (when (looking-at "\\s-*implicit\\s-+none")
 903               (forward-line 1))
 904             (when (not (looking-at "^\\s-*$"))
 905               (setq type (ignore-errors (f90-parse-single-type-declaration)))
 906               ;; If we were on a line with text and failed to parse a
 907               ;; type, we must have reached the end of the type
 908               ;; definitions, so don't push it on and finish.
 909               (if type
 910                   (push type types)
 911                 (setq not-done nil)))
 912             (forward-line 1)))))
 913     (with-current-buffer (get-buffer-create "*Variables in scope*")
 914       (setq buffer-read-only nil)
 915       (erase-buffer)
 916       (f90-mode)
 917       ;; Show types of the same type together
 918       (setq types (sort types (lambda (x y)
 919                                 (string< (cadar x) (cadar y)))))
 920       (loop for (type name) in types
 921             do
 922             (insert (format "%s :: %s\n"
 923                             (f90-format-parsed-slot-type type)
 924                             (f90-get-parsed-type-varname type))))
 925       (pop-to-buffer (current-buffer))
 926       (goto-char (point-min))
 927       (setq buffer-read-only t))))
 928
 929 (defun f90-arg-types (names)
 930   "Given NAMES of arguments return their types.
 931
 932 This works even with derived type subtypes (e.g. if A is a type(foo)
 933 with slot B of type REAL, then A%B is returned being a REAL)."
 934   (loop for arg in names
 935         for subspec = nil then nil
 936         do (setq arg (f90-normalise-string arg))
 937         if (string-match "\\`\\([^%]+?\\)[ \t]*%\\(.+\\)\\'" arg)
 938         do (setq subspec (match-string 2 arg)
 939                  arg (match-string 1 arg))
 940         collect (save-excursion
 941                   (save-restriction
 942                     (when (re-search-forward
 943                            (format "^[ \t]*\\([^!\n].+?\\)[ \t]*::.*\\<%s\\>"
 944                                    arg) nil t)
 945                       (goto-char (match-beginning 0))
 946                       (let ((type (assoc arg
 947                                          (f90-parse-single-type-declaration))))
 948                         (f90-get-type-subtype type subspec)))))))
 949
 950 (defun f90-get-type-subtype (type subspec)
 951   "Return the type of TYPE possibly including slot references in SUBSPEC."
 952   (cond ((null subspec)
 953          type)
 954         ((string-match "\\`\\([^%]+?\\)[ \t]*%\\(.+\\)\\'" subspec)
 955          (f90-get-type-subtype (f90-get-slot-type (match-string 1 subspec)
 956                                                   type)
 957                                (match-string 2 subspec)))
 958         (t
 959          (f90-get-slot-type subspec type))))
 960
 961 (defun f90-split-arglist (arglist &optional level)
 962   "Split ARGLIST into words.
 963
 964 Split based on top-level commas.  For example
 965
 966   (f90-split-arglist \"foo, bar, baz(quux, zot)\")
 967     => (\"foo\" \"bar\" \"baz(quux, zot)\").
 968
 969 If LEVEL is non-nil split on commas up to and including LEVEL.
 970 For example:
 971
 972   (f90-split-arglist \"foo, bar, baz(quux, zot)\" 1)
 973     => (\"foo\" \"bar\" \"baz(quux\" \"zot)\")."
 974   (setq level (or level 0))
 975   (loop for c across arglist
 976         for i = 0 then (1+ i)
 977         with cur-level = 0
 978         with b = 0
 979         with len = (length arglist)
 980         if (eq c ?\()
 981         do (incf cur-level)
 982         else if (eq c ?\))
 983         do (decf cur-level)
 984         if (and (<= cur-level level)
 985                 (eq c ?,))
 986         collect (f90-normalise-string (substring arglist b i))
 987         and do (setq b (1+ i))
 988         if (and (<= cur-level level)
 989                 (= (1+ i) len))
 990         collect (f90-normalise-string (substring arglist b))))
 991
 992 (defun f90-end-of-arglist ()
 993   "Find the end of the arglist at `point'."
 994   (save-excursion
 995     (let ((level 0))
 996       (while (> level -1)
 997         (cond ((eq (char-after) ?\()
 998                (incf level))
 999               ((eq (char-after) ?\))
1000                (decf level))
1001               (t nil))
1002         (forward-char)))
1003     (1- (point))))
1004
1005 (defun f90-parse-names-list (names)
1006   "Return a list of NAMES from the RHS of a :: type declaration."
1007   (let ((names-list (f90-split-arglist names)))
1008     (loop for name in names-list
1009           if (string-match "\\`\\([^=]+\\)[ \t]*=.*\\'" name)
1010           collect (f90-normalise-string (match-string 1 name))
1011           else
1012           collect (f90-normalise-string name))))
1013
1014 (defun f90-parse-single-type-declaration ()
1015   "Parse a single f90 type declaration at `point'.
1016
1017 Assumes that this has the form
1018   TYPENAME[, MODIFIERS]* :: NAME[, NAMES]*
1019
1020 NAMES can optionally have initialisation attached to them which is
1021 dealt with correctly."
1022   (when (looking-at "^[ \t]*\\(.*?\\)[ \t]*::[ \t]*\\(.*\\)$")
1023     (let ((dec-orig (match-string 1))
1024           (names (f90-parse-names-list (match-string 2))))
1025       (loop for name in names
1026             for dec = (f90-split-declaration dec-orig)
1027             then (f90-split-declaration dec-orig)
1028             if (string-match "\\([^(]+\\)(\\([^)]+\\))" name)
1029             do (progn (if (assoc "dimension" dec)
1030                           (setcdr (assoc "dimension" dec)
1031                                   (1+ (f90-count-commas
1032                                        (match-string 2 name))))
1033                         (add-to-list 'dec
1034                                      (cons "dimension"
1035                                            (1+ (f90-count-commas
1036                                                 (match-string 2 name))))
1037                                      t))
1038                       (setq name (match-string 1 name)))
1039             collect (cons name dec)))))
1040
1041 (defun f90-split-declaration (dec)
1042   "Split and parse a type declaration DEC.
1043
1044 This takes the bit before the :: and returns a list of the typename
1045 and any modifiers."
1046   (let ((things (f90-split-arglist dec)))
1047     (cons (if (string-match
1048                "\\([^(]+?\\)[ \t]*([ \t]*\\(:?len\\|kind\\)[ \t]*=[^)]+)"
1049                (car things))
1050               (match-string 1 (car things))
1051             (car things))
1052           (loop for thing in (cdr things)
1053                 if (string-match "dimension[ \t]*(\\(.+\\))" thing)
1054                 collect (cons "dimension"
1055                               (1+ (f90-count-commas (match-string 1 thing))))
1056                 else
1057                 collect thing))))
1058
1059 (provide 'f90-interface-browser)
1060
1061 ;;; f90-interface-browser.el ends here