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