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