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

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