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