1 ;;; f90-interface-browser.el --- Parse and browse f90 interfaces
3 ;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc
5 ;; Author: Lawrence Mitchell <wence@gmx.li>
7 ;; URL: http://github.com/wence-/f90-iface/
9 ;; Package-Type: simple
13 ;; This program is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; This program is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
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.
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'.
39 ;; Now you are able to browse (with completion) all defined interfaces
40 ;; in your code by calling `f90-browse-interface-specialisers'.
41 ;; Alternatively, if `point' is on a procedure call, you can call
42 ;; `f90-find-tag-interface' and you'll be shown a list of the
43 ;; interfaces that match the (possibly typed) argument list of the
44 ;; current procedure. This latter hooks into the `find-tag' machinery
45 ;; so that you can use it on the M-. keybinding and it will fall back
46 ;; to completing tag names if you don't want to look for an interface
48 ;; In addition, if you're in a large procedure and want the list of
49 ;; the variables in scope (perhaps you want to define a new loop
50 ;; variable), you can use `f90-list-in-scope-vars' to pop up a buffer
51 ;; giving a reasonable guess. Note this doesn't give you module
52 ;; variables, or the variables of parent procedures if the current
53 ;; subroutine is contained within another.
55 ;; Derived types are also parsed, so that slot types of derived types
56 ;; are given the correct type (rather than a UNION-TYPE) when arglist
57 ;; matching. You can show the definition of a known derived type by
58 ;; calling `f90-show-type-definition' which prompts (with completion)
59 ;; for a typename to show.
61 ;; The parser assumes you write Fortran in the style espoused in
62 ;; Metcalf, Reid and Cohen. Particularly, variable declarations use a
63 ;; double colon to separate the type from the name list.
65 ;; Here's an example of a derived type definition
67 ;; real, allocatable, dimension(:) :: a
68 ;; integer, pointer :: b, c(:)
72 ;; Here's a subroutine declaration
73 ;; subroutine foo(a, b)
74 ;; integer, intent(in) :: a
75 ;; real, intent(inout), dimension(:,:) :: b
79 ;; Local procedures whose names conflict with global ones will likely
80 ;; confuse the parser. For example
82 ;; subroutine foo(a, b)
86 ;; subroutine bar(a, b)
88 ;; call subroutine foo
96 ;; Also not handled are overloaded operators, scalar precision
97 ;; modifiers, like integer(kind=c_int), for which the precision is
98 ;; just ignored, and many other aspects.
100 ;; Some tests of the parser are available in f90-tests.el (in the same
101 ;; repository as this file).
106 (eval-when-compile (require 'cl))
111 (defgroup f90-iface nil
112 "Static parser for Fortran 90 code"
116 (defcustom f90-file-extensions (list "f90" "F90" "fpp")
117 "Extensions to consider when looking for Fortran 90 files."
118 :type '(repeat string)
121 (defcustom f90-file-name-check-functions '(f90-check-fluidity-refcount)
122 "List of functions to call to check if a file should be parsed.
124 In addition to checking if a file exists and is readable, you can
125 add extra checks before deciding to parse a file. Each function
126 will be called with one argument, the fully qualified name of the
127 file to test, it should return non-nil if the file should be
128 parsed. For an example test function see
129 `f90-check-fluidity-refcount'."
130 :type '(repeat function)
133 (defcustom f90-extra-file-functions '(f90-insert-fluidity-refcount)
134 "List of functions to call to insert extra files to parse.
136 Each function should be a function of two arguments, the first is the
137 fully qualified filename (with directory) the second is the
138 unqualified filename."
139 :type '(repeat function)
142 ;;; Internal variables
143 (defvar f90-interface-type nil)
144 (make-variable-buffer-local 'f90-interface-type)
146 (defvar f90-buffer-to-switch-to nil)
147 (make-variable-buffer-local 'f90-buffer-to-switch-to)
149 (defvar f90-invocation-marker nil)
150 (make-variable-buffer-local 'f90-invocation-marker)
152 ;; Data types for storing interface and specialiser definitions
153 (defstruct f90-interface
154 (name "" :read-only t)
158 (defstruct f90-specialiser
159 (name "" :read-only t)
164 (defvar f90-all-interfaces (make-hash-table :test 'equal)
165 "Hash table populated with all known f90 interfaces.")
167 (defvar f90-types (make-hash-table :test 'equal)
168 "Hash table populated with all known f90 derived types.")
170 ;;; Inlineable utility functions
171 (defsubst f90-specialisers (name interfaces)
172 "Return all specialisers for NAME in INTERFACES."
173 (f90-interface-specialisers (f90-get-interface name interfaces)))
175 (defsubst f90-valid-interface-name (name)
176 "Return non-nil if NAME is an interface name."
177 (gethash name f90-all-interfaces))
179 (defsubst f90-count-commas (str &optional level)
180 "Count commas in STR.
182 If LEVEL is non-nil, only count commas up to the specified nesting
183 level. For example, a LEVEL of 0 counts top-level commas."
184 (1- (length (f90-split-arglist str level))))
186 (defsubst f90-get-parsed-type-varname (type)
187 "Return the variable name of TYPE."
190 (defsubst f90-get-parsed-type-typename (type)
191 "Return the type name of TYPE."
194 (defsubst f90-get-parsed-type-modifiers (type)
195 "Return the modifiers of TYPE."
198 (defsubst f90-get-type (type)
199 "Return the struct definition corresponding to TYPE."
200 (gethash (f90-get-parsed-type-typename type) f90-types))
202 (defsubst f90-get-slot-type (slot type)
203 "Get the type of SLOT in TYPE."
204 (let ((fn (intern-soft (format "f90-type.%s.%s"
205 (f90-get-parsed-type-typename type) slot))))
207 (funcall fn (f90-get-type type)))))
209 (defsubst f90-merge-into-tags-completion-table (ctable)
210 "Merge completions in CTABLE into the tags completion table."
211 (if (or tags-file-name tags-table-list)
212 (let ((table (tags-completion-table)))
213 (maphash (lambda (k v)
220 (defun f90-lazy-completion-table ()
221 "Lazily produce a completion table of all interfaces and tag names."
222 (lexical-let ((buf (current-buffer)))
223 (lambda (string pred action)
224 (with-current-buffer buf
226 ;; If we need to ask for the tag table, allow that.
227 (let ((enable-recursive-minibuffers t))
228 (visit-tags-table-buffer))
229 (complete-with-action action (f90-merge-into-tags-completion-table f90-all-interfaces) string pred))))))
231 (defsubst f90-extract-type-name (name)
232 "Return the typename from NAME.
234 If NAME is like type(TYPENAME) return TYPENAME, otherwise just NAME."
235 (if (and name (string-match "\\`type(\\([^)]+\\))\\'" name))
236 (match-string 1 name)
239 ;;; User-visible routines
241 (defun f90-parse-all-interfaces (dir)
242 "Parse all interfaces found in DIR and its subdirectories.
244 Recurse over all (non-hidden) directories below DIR and parse
245 interfaces found within them using `f90-parse-interfaces-in-dir',
246 a directory is considered hidden if it's name doesn't start with
247 an alphanumeric character."
248 (interactive "DParse files in tree: ")
252 (pending (list (expand-file-name dir))))
254 (push (pop pending) dirs)
255 (let* ((this-dir (car dirs))
256 (contents (directory-files this-dir))
257 (default-directory this-dir))
258 (setq attrs (nthcdr 10 (file-attributes this-dir)))
259 (unless (member attrs seen)
261 (dolist (file contents)
262 ;; Ignore hidden directories
263 (and (string-match "\\`[[:alnum:]]" file)
264 (file-directory-p file)
265 (setq pending (nconc pending
266 (list (expand-file-name file)))))))))
267 (mapc 'f90-parse-interfaces-in-dir dirs)))
269 (defun f90-parse-interfaces-in-dir (dir)
270 "Parse all Fortran 90 files in DIR to populate `f90-all-interfaces'."
271 (interactive "DParse files in directory: ")
272 (loop for file in (directory-files dir t
274 `(and "." (or ,@f90-file-extensions)
276 do (f90-parse-interfaces file f90-all-interfaces)))
278 (defun f90-find-tag-interface (name &optional match-sublist)
279 "List all interfaces matching NAME.
281 Restricts list to those matching the (possibly typed) arglist of
282 the word at point. If MATCH-SUBLIST is non-nil, only check if
283 the arglist is a sublist of the specialiser's arglist. For more
284 details see `f90-approx-arglist-match' and
285 `f90-browse-interface-specialisers'."
286 (interactive (let ((def (word-at-point)))
287 (list (completing-read
288 (format "Find interface/tag (default %s): " def)
289 (f90-lazy-completion-table)
291 current-prefix-arg)))
292 (if (f90-valid-interface-name name)
293 (f90-browse-interface-specialisers name (f90-arglist-types)
296 (find-tag name match-sublist)))
298 (defun f90-browse-interface-specialisers (name &optional arglist-to-match
301 "Browse all interfaces matching NAME.
303 If ARGLIST-TO-MATCH is non-nil restrict to those interfaces that match
305 If MATCH-SUBLIST is non-nil only restrict to those interfaces for
306 which ARGLIST-TO-MATCH is a sublist of the specialiser's arglist.
308 If INVOCATION-POINT is non-nil it should be a `point-marker'
309 indicating where we were called from, for jumping back to with
311 (interactive (let ((def (word-at-point)))
312 (list (completing-read
313 (format "Interface%s: "
315 (format " (default %s)" def)
318 nil t nil nil def))))
319 (let ((buf (current-buffer)))
320 (or invocation-point (setq invocation-point (point-marker)))
321 (with-current-buffer (get-buffer-create "*Interface Browser*")
322 (let ((interface (f90-get-interface name f90-all-interfaces))
325 (setq buffer-read-only nil)
328 (loop for s being the hash-values of
329 (f90-interface-specialisers interface)
330 do (setq type (f90-specialiser-type s))
331 when (or (null arglist-to-match)
332 (f90-approx-arglist-match
333 arglist-to-match s match-sublist))
338 (format "%s [defined in %s]\n (%s)\n"
339 (propertize (f90-specialiser-name s)
342 (f90-specialiser-location s))))
344 (file-name-nondirectory
346 (file-name-directory f)))
347 (file-name-nondirectory f)))
349 (f90-specialiser-arglist s)))
350 'f90-specialiser-location
351 (f90-specialiser-location s)
352 'f90-specialiser-name (f90-specialiser-name s)
353 'mouse-face 'highlight
355 "mouse-1: find definition in other window")
357 'f90-specialiser-extent (f90-specialiser-name s)))
359 (goto-char (point-min))
360 (insert (format "Interfaces for %s:\n\n"
361 (f90-interface-name interface)))
362 (when arglist-to-match
363 (insert (format "%s\n%s\n\n"
365 "No interfaces matching arglist (intrinsic?):"
366 "Only showing interfaces matching arglist:")
367 (f90-fontify-arglist arglist-to-match))))
368 (f90-interface-browser-mode)
369 (setq f90-buffer-to-switch-to buf)
370 (setq f90-interface-type type)
371 (setq f90-invocation-marker invocation-point)
372 (pop-to-buffer (current-buffer))))))
374 (defun f90-next-definition (&optional arg)
375 "Go to the next ARG'th specialiser definition."
380 (goto-char (next-single-property-change
382 'f90-specialiser-extent
386 (defun f90-previous-definition (&optional arg)
387 "Go to the previous ARG'th specialiser definition."
393 do (goto-char (previous-single-property-change
395 'f90-specialiser-extent
397 (f90-next-definition 1)
400 (defun f90-mouse-find-definition (e)
401 "Visit the definition at the position of the event E."
403 (let ((win (posn-window (event-end e)))
404 (point (posn-point (event-end e))))
405 (when (not (windowp win))
406 (error "No definition here"))
407 (with-current-buffer (window-buffer win)
409 (f90-find-definition))))
411 (defun f90-quit-browser ()
412 "Quit the interface browser."
414 (let ((buf f90-buffer-to-switch-to))
415 (kill-buffer (current-buffer))
416 (pop-to-buffer buf)))
418 (defun f90-find-definition ()
419 "Visit the definition at `point'."
421 (let ((location (get-text-property (point) 'f90-specialiser-location))
422 (name (get-text-property (point) 'f90-specialiser-name))
423 (type f90-interface-type)
424 (buf (current-buffer))
427 (progn (ring-insert find-tag-marker-ring f90-invocation-marker)
428 (find-file-other-window (car location))
429 (setq buf-to (current-buffer))
430 (goto-char (cadr location))
431 ;; Try forwards then backwards near the recorded
433 (or (re-search-forward (format "%s[ \t]+%s[ \t]*("
435 (re-search-backward (format "%s[ \t]+%s[ \t]*("
440 (setq f90-buffer-to-switch-to buf-to))
441 (error "No definition at point"))))
443 (defvar f90-interface-browser-mode-map
444 (let ((map (make-sparse-keymap)))
445 (define-key map (kbd "RET") 'f90-find-definition)
446 (define-key map (kbd "<down>") 'f90-next-definition)
447 (define-key map (kbd "TAB") 'f90-next-definition)
448 (define-key map (kbd "<up>") 'f90-previous-definition)
449 (define-key map (kbd "<backtab>") 'f90-previous-definition)
450 (define-key map (kbd "q") 'f90-quit-browser)
451 (define-key map (kbd "<mouse-1>") 'f90-mouse-find-definition)
453 "Keymap for `f90-interface-browser-mode'.")
455 (define-derived-mode f90-interface-browser-mode fundamental-mode "IBrowse"
456 "Major mode for browsing f90 interfaces."
457 (setq buffer-read-only t)
458 (set-buffer-modified-p nil))
462 (defun f90-type-at-point ()
463 "Return a guess for the type of the thing at `point'.
465 If `point' is currently on a line containing a variable declaration,
466 return the typename of the declaration. Otherwise try and figure out
467 the typename of the variable at point (possibly including slot
470 ;; Are we on a line with type(TYPENAME)?
473 (f90-parse-single-type-declaration))
474 ;; No, try and derive the type of the variable at point
476 (let ((syntax (copy-syntax-table f90-mode-syntax-table)))
477 (modify-syntax-entry ?% "w" syntax)
478 (with-syntax-table syntax
479 (skip-syntax-backward "w")
482 (buffer-substring-no-properties
484 (progn (skip-syntax-forward "w") (point)))))))))))
485 (f90-extract-type-name (f90-get-parsed-type-typename (car name)))))
487 (defun f90-show-type-definition (type)
488 "Show the definition of TYPE.
490 This formats the parsed definition of TYPE, rather than jumping to the
493 When called interactively, default to the type of the thing at `point'.
494 If `point' is on a type declaration line, the default is the
496 If `point' is on a variable name (possibly with slot references) the
497 default is the type of the variable."
498 (interactive (list (let ((def (f90-type-at-point)))
500 (if def (format "Type (default %s): " def) "Type: ")
501 (loop for type being the hash-keys of f90-types
502 collect (f90-extract-type-name type))
503 nil t nil nil def))))
504 (with-current-buffer (get-buffer-create "*Type definition*")
505 (setq buffer-read-only nil)
508 (let* ((tname (format "type(%s)" type))
509 (type-struct (f90-get-type (list nil tname)))
512 (setq fns (loop for name in (funcall (intern-soft
513 (format "f90-type.%s.-varnames"
516 collect (intern-soft (format "f90-type.%s.%s"
518 (if (null type-struct)
519 (insert (format "The type %s is not a known derived type."
521 (insert (format "type %s\n" type))
523 for parsed = (funcall fn type-struct)
524 then (funcall fn type-struct)
526 (insert (format " %s :: %s\n"
527 (f90-format-parsed-slot-type parsed)
528 (f90-get-parsed-type-varname parsed))))
529 (insert (format "end type %s\n" type))
531 (goto-char (point-min))
533 (pop-to-buffer (current-buffer)))))
535 ;;; Arglist matching/formatting
537 (defun f90-format-parsed-slot-type (type)
538 "Turn a parsed TYPE into a valid f90 type declaration."
542 (setq type (cdr type))
543 (mapconcat 'identity (loop for a in type
545 (string= (car a) "dimension"))
546 collect (format "dimension(%s)"
553 "\\`intent(\\(?:in\\|out\\|inout\\))"
558 (defun f90-fontify-arglist (arglist)
559 "Fontify ARGLIST using `f90-mode'."
561 (if (stringp arglist)
562 (insert (format "%s :: foo\n" arglist))
563 (insert (mapconcat (lambda (x)
564 (format "%s :: foo" (f90-format-parsed-slot-type x)))
567 (if (fboundp 'font-lock-ensure)
568 (font-lock-ensure) (font-lock-fontify-buffer))
569 (goto-char (point-min))
571 (loop while (not (eobp))
572 collect (buffer-substring (line-beginning-position)
573 (- (line-end-position)
578 (defun f90-count-non-optional-args (arglist)
579 "Count non-optional args in ARGLIST."
580 (loop for arg in arglist
581 count (not (member "optional" (f90-get-parsed-type-modifiers arg)))))
583 (defun f90-approx-arglist-match (arglist specialiser &optional match-sub-list)
584 "Return non-nil if ARGLIST matches the arglist of SPECIALISER.
586 If MATCH-SUB-LIST is non-nil just require that ARGLIST matches the
587 first (length ARGLIST) args of SPECIALISER."
588 (let* ((n-passed-args (length arglist))
589 (spec-arglist (f90-specialiser-arglist specialiser))
590 (n-spec-args (length spec-arglist))
591 (n-required-args (f90-count-non-optional-args spec-arglist)))
592 (when (or match-sub-list
593 (and (<= n-required-args n-passed-args)
594 (<= n-passed-args n-spec-args)))
595 (loop for arg in arglist
596 for spec-arg in spec-arglist
597 unless (or (null arg)
598 (string= (f90-get-parsed-type-typename arg)
599 (f90-get-parsed-type-typename spec-arg)))
601 finally (return t)))))
603 ;;; Internal functions
605 (defun f90-clean-comments ()
606 "Clean Fortran 90 comments from the current buffer."
608 (goto-char (point-min))
609 (set-syntax-table f90-mode-syntax-table)
610 (while (search-forward "!" nil t)
611 (when (nth 4 (parse-partial-sexp (line-beginning-position) (point)))
612 (delete-region (max (1- (point)) (line-beginning-position))
613 (line-end-position))))))
615 (defun f90-clean-continuation-lines ()
616 "Splat Fortran continuation lines in the current buffer onto one line."
618 (goto-char (point-min))
619 (while (re-search-forward "&[ \t]*\n[ \t]*&?" nil t)
620 (replace-match "" nil t))))
622 (defun f90-normalise-string (string)
623 "Return a suitably normalised version of STRING."
626 (when (string-match "\\`[ \t]+" string)
627 (setq string (replace-match "" t t string)))
628 (when (string-match "[ \t]+\\'" string)
629 (setq string (replace-match "" t t string)))
632 (defun f90-get-interface (name &optional interfaces)
633 "Get the interface with NAME from INTERFACES.
635 If INTERFACES is nil use `f90-all-interfaces' instead."
636 (gethash name (or interfaces f90-all-interfaces)))
638 (defsetf f90-get-interface (name &optional interfaces) (val)
639 `(setf (gethash ,name (or ,interfaces f90-all-interfaces)) ,val))
641 ;;; Entry point to parsing routines
643 (defun f90-parse-file-p (file)
644 "Return non-nil if FILE should be parsed.
646 This checks that FILE exists and is readable, and then calls
647 additional test functions from `f90-file-name-check-functions'."
648 (and (file-exists-p file)
649 (file-readable-p file)
650 (loop for test in f90-file-name-check-functions
651 unless (funcall test file)
653 finally (return t))))
655 (defun f90-check-fluidity-refcount (file)
656 "Return nil if FILE is that of a Fluidity refcount template."
657 (let ((fname (file-name-nondirectory file)))
658 (and (not (string-match "\\`Reference_count_interface" fname))
659 (not (string-equal "Refcount_interface_templates.F90" fname))
660 (not (string-equal "Refcount_templates.F90" fname)))))
662 (defun f90-maybe-insert-extra-files (file)
663 "Maybe insert extra files corresponding to FILE when parsing.
665 To actually insert extra files, customize the variable
666 `f90-extra-file-functions'. For an example insertion function
667 see `f90-insert-fluidity-refcount'."
668 (let ((fname (file-name-nondirectory file)))
669 (loop for fn in f90-extra-file-functions
670 do (funcall fn file fname))))
672 (defun f90-insert-fluidity-refcount (file fname)
673 "Insert a Fluidity reference count template for FILE.
675 If FNAME matches \\\\`Reference_count_.*\\\\.F90 then this file
676 needs a reference count interface, so insert one."
677 (when (string-match "\\`Reference_count_\\([^\\.]+\\)\\.F90" fname)
678 (insert-file-contents-literally
680 (format "Reference_count_interface_%s.F90"
681 (match-string 1 fname))
682 (file-name-directory file)))))
684 (defun f90-parse-interfaces (file existing)
685 "Parse interfaces in FILE and merge into EXISTING interface data."
687 (let ((interfaces (make-hash-table :test 'equal)))
688 ;; Is this file valid for parsing
689 (when (f90-parse-file-p file)
690 (insert-file-contents-literally file)
691 ;; Does this file have other parts elsewhere?
692 (f90-maybe-insert-extra-files file)
693 ;; Easier if we don't have to worry about line wrap
695 (f90-clean-continuation-lines)
696 (goto-char (point-min))
697 ;; Search forward for a named interface block
698 (while (re-search-forward
699 "^[ \t]*interface[ \t]+\\([^ \t\n]+\\)[ \t]*$" nil t)
700 (let* ((name (f90-normalise-string (match-string 1)))
702 (unless (string= name "")
703 (setq interface (make-f90-interface :name name))
705 ;; Figure out all the specialisers for this generic name
709 (format "[ \t]*end interface\\(?:[ \t]+%s\\)?[ \t]*$" name)
711 (f90-populate-specialisers interface))
712 ;; Multiple interface blocks with same name (this seems to
713 ;; be allowed). In which case merge rather than overwrite.
714 (if (f90-get-interface name interfaces)
715 (f90-merge-interface interface interfaces)
716 (setf (f90-get-interface name interfaces) interface)))))
717 (goto-char (point-min))
718 ;; Parse type definitions
720 (while (re-search-forward
721 "^[ \t]*type[ \t]+\\(?:[^ \t\n]+\\)[ \t]*$" nil t)
722 (let ((beg (match-beginning 0)))
723 (unless (re-search-forward "^[ \t]*end[ \t]+type.*$" nil t)
724 (error "Unable to find end of type definition"))
726 (narrow-to-region beg (match-beginning 0))
727 (f90-parse-type-definition)))))
729 ;; Now find out if an interface is public or private to the module
730 (f90-set-public-attribute interfaces)
732 ;; Now find the arglists corresponding to the interface (so we
733 ;; can disambiguate) and record their location in the file.
734 (loop for interface being the hash-values of interfaces
735 do (when (f90-interface-specialisers interface)
736 (maphash (lambda (specialiser val)
738 (goto-char (point-min))
739 (let ((thing (f90-argument-list specialiser)))
740 (setf (f90-specialiser-arglist
743 (setf (f90-specialiser-location
745 (list file (caddr thing)))
746 (setf (f90-specialiser-type
749 (f90-interface-specialisers interface))))
750 ;; Finally merge these new interfaces into the existing data.
751 (f90-merge-interfaces interfaces existing)))))
753 (defun f90-merge-interface (interface interfaces)
754 "Merge INTERFACE into the existing set of INTERFACES."
755 (let ((name (f90-interface-name interface))
757 (when (f90-interface-specialisers interface)
758 (loop for val being the hash-values of
759 (f90-interface-specialisers interface)
760 do (setq spec-name (f90-specialiser-name val))
761 (setf (gethash spec-name (f90-specialisers name interfaces))
764 (defun f90-merge-interfaces (new existing)
765 "Merge NEW interfaces into EXISTING ones."
766 (maphash (lambda (name val)
767 (if (gethash name existing)
768 (f90-merge-interface val existing)
769 (setf (gethash name existing)
773 (defun f90-populate-specialisers (interface)
774 "Find all specialisers for INTERFACE."
776 (goto-char (point-min))
777 (setf (f90-interface-specialisers interface)
778 (make-hash-table :test 'equal))
779 (while (search-forward "module procedure" nil t)
780 (let ((names (buffer-substring-no-properties
782 (line-end-position))))
784 (setq x (f90-normalise-string x))
785 (setf (gethash x (f90-interface-specialisers interface))
786 (make-f90-specialiser :name x)))
787 (split-string names "[, \n]+" t))))))
789 (defun f90-set-public-attribute (interfaces)
790 "Set public/private flag on all INTERFACES."
792 ;; Default public unless private is specified.
793 (let ((public (not (save-excursion
794 (re-search-forward "^[ \t]*private[ \t]*$" nil t)))))
795 (while (re-search-forward (format "^[ \t]*%s[ \t]+"
796 (if public "private" "public"))
798 (let ((names (buffer-substring-no-properties
800 (line-end-position))))
802 (maphash (lambda (k v)
804 (setf (f90-interface-publicp v) public))
806 ;; Override for those specified
808 (let ((interface (f90-get-interface name interfaces)))
810 (setf (f90-interface-publicp interface) (not public)))))
811 (split-string names "[, \t]" t)))))))
813 ;;; Type/arglist parsing
814 (defun f90-argument-list (name)
815 "Return typed argument list of function or subroutine NAME."
817 (when (re-search-forward
818 (format "\\(function\\|subroutine\\)[ \t]+%s[ \t]*("
821 (let* ((point (match-beginning 0))
822 (type (match-string 1))
823 (args (f90-split-arglist (buffer-substring-no-properties
825 (f90-end-of-arglist)))))
826 (list type (f90-arg-types args) point)))))
828 (defun f90-parse-type-definition ()
829 "Parse a type definition at (or in front of) `point'."
830 (let (type slots slot fn)
831 (goto-char (point-min))
832 (unless (re-search-forward "^[ \t]*type[ \t]+\\(.+?\\)[ \t]*$" nil t)
833 (error "Trying parse a type but no type found"))
834 (setq type (format "type(%s)" (f90-normalise-string (match-string 1))))
836 (setq slot (f90-parse-single-type-declaration))
838 (setf slots (nconc slot slots)))
840 (eval (f90-make-type-struct type slots))
841 (setq fn (intern-soft (format "make-f90-type.%s" type)))
843 (error "Something bad went wrong parsing type definition %s" type))
844 (setf (gethash type f90-types) (funcall fn))))
846 (defun f90-make-type-struct (type slots)
847 "Create a struct describing TYPE with SLOTS."
848 (let ((struct-name (make-symbol (format "f90-type.%s" type)))
849 (varnames (reverse (mapcar (lambda (x)
851 (if (string-match "\\([^(]+\\)(" x)
854 `(defstruct (,struct-name
855 (:conc-name ,(make-symbol (format "f90-type.%s." type))))
856 (-varnames ',varnames :read-only t)
857 ,@(loop for (name . rest) in slots
858 collect `(,(make-symbol name) (cons ',name ',rest)
861 (defun f90-arglist-types ()
862 "Return the types of the arguments to the function at `point'."
864 (let* ((e (save-excursion (f90-end-of-subprogram) (point)))
865 (b (save-excursion (f90-beginning-of-subprogram) (point)))
866 (str (buffer-substring-no-properties b e))
870 (with-syntax-table f90-mode-syntax-table
873 (setq p (point-marker))
874 (f90-clean-continuation-lines)
877 (setq names (f90-split-arglist (buffer-substring
879 (f90-end-of-arglist))))
880 (goto-char (point-min))
881 (f90-arg-types names))))))
883 (defun f90-list-in-scope-vars ()
884 "Pop up a buffer showing all variables in scope in the procedure at `point'"
886 (let* ((e (save-excursion (f90-end-of-subprogram) (point)))
887 (b (save-excursion (f90-beginning-of-subprogram) (point)))
888 (str (buffer-substring-no-properties b e))
891 (with-syntax-table f90-mode-syntax-table
893 (goto-char (point-min))
895 (f90-clean-continuation-lines)
896 (forward-line 1) ; skip procedure name
899 (while (and not-done (not (eobp)))
900 ;; skip "implicit none" which may appear at top of procedure
901 (when (looking-at "\\s-*implicit\\s-+none")
903 (when (not (looking-at "^\\s-*$"))
904 (setq type (ignore-errors (f90-parse-single-type-declaration)))
905 ;; If we were on a line with text and failed to parse a
906 ;; type, we must have reached the end of the type
907 ;; definitions, so don't push it on and finish.
910 (setq not-done nil)))
912 (with-current-buffer (get-buffer-create "*Variables in scope*")
913 (setq buffer-read-only nil)
916 ;; Show types of the same type together
917 (setq types (sort types (lambda (x y)
918 (string< (cadar x) (cadar y)))))
919 (loop for (type _name) in types
921 (insert (format "%s :: %s\n"
922 (f90-format-parsed-slot-type type)
923 (f90-get-parsed-type-varname type))))
924 (pop-to-buffer (current-buffer))
925 (goto-char (point-min))
926 (setq buffer-read-only t))))
928 (defun f90-arg-types (names)
929 "Given NAMES of arguments return their types.
931 This works even with derived type subtypes (e.g. if A is a type(foo)
932 with slot B of type REAL, then A%B is returned being a REAL)."
933 (loop for arg in names
934 for subspec = nil then nil
935 do (setq arg (f90-normalise-string arg))
936 if (string-match "\\`\\([^%]+?\\)[ \t]*%\\(.+\\)\\'" arg)
937 do (setq subspec (match-string 2 arg)
938 arg (match-string 1 arg))
939 collect (save-excursion
941 (when (re-search-forward
942 (format "^[ \t]*\\([^!\n].+?\\)[ \t]*::.*\\<%s\\>"
944 (goto-char (match-beginning 0))
945 (let ((type (assoc arg
946 (f90-parse-single-type-declaration))))
947 (f90-get-type-subtype type subspec)))))))
949 (defun f90-get-type-subtype (type subspec)
950 "Return the type of TYPE possibly including slot references in SUBSPEC."
951 (cond ((null subspec)
953 ((string-match "\\`\\([^%]+?\\)[ \t]*%\\(.+\\)\\'" subspec)
954 (f90-get-type-subtype (f90-get-slot-type (match-string 1 subspec)
956 (match-string 2 subspec)))
958 (f90-get-slot-type subspec type))))
960 (defun f90-split-arglist (arglist &optional level)
961 "Split ARGLIST into words.
963 Split based on top-level commas. For example
965 (f90-split-arglist \"foo, bar, baz(quux, zot)\")
966 => (\"foo\" \"bar\" \"baz(quux, zot)\").
968 If LEVEL is non-nil split on commas up to and including LEVEL.
971 (f90-split-arglist \"foo, bar, baz(quux, zot)\" 1)
972 => (\"foo\" \"bar\" \"baz(quux\" \"zot)\")."
973 (setq level (or level 0))
974 (loop for c across arglist
975 for i = 0 then (1+ i)
978 with len = (length arglist)
983 if (and (<= cur-level level)
985 collect (f90-normalise-string (substring arglist b i))
986 and do (setq b (1+ i))
987 if (and (<= cur-level level)
989 collect (f90-normalise-string (substring arglist b))))
991 (defun f90-end-of-arglist ()
992 "Find the end of the arglist at `point'."
996 (cond ((eq (char-after) ?\()
998 ((eq (char-after) ?\))
1004 (defun f90-parse-names-list (names)
1005 "Return a list of NAMES from the RHS of a :: type declaration."
1006 (let ((names-list (f90-split-arglist names)))
1007 (loop for name in names-list
1008 if (string-match "\\`\\([^=]+\\)[ \t]*=.*\\'" name)
1009 collect (f90-normalise-string (match-string 1 name))
1011 collect (f90-normalise-string name))))
1013 (defun f90-parse-single-type-declaration ()
1014 "Parse a single f90 type declaration at `point'.
1016 Assumes that this has the form
1017 TYPENAME[, MODIFIERS]* :: NAME[, NAMES]*
1019 NAMES can optionally have initialisation attached to them which is
1020 dealt with correctly."
1021 (when (looking-at "^[ \t]*\\(.*?\\)[ \t]*::[ \t]*\\(.*\\)$")
1022 (let ((dec-orig (match-string 1))
1023 (names (f90-parse-names-list (match-string 2))))
1024 (loop for name in names
1025 for dec = (f90-split-declaration dec-orig)
1026 then (f90-split-declaration dec-orig)
1027 if (string-match "\\([^(]+\\)(\\([^)]+\\))" name)
1028 do (progn (if (assoc "dimension" dec)
1029 (setcdr (assoc "dimension" dec)
1030 (1+ (f90-count-commas
1031 (match-string 2 name))))
1032 (push (cons "dimension"
1033 (1+ (f90-count-commas
1034 (match-string 2 name))))
1036 (setq name (match-string 1 name)))
1037 collect (cons name (nreverse dec))))))
1039 (defun f90-split-declaration (dec)
1040 "Split and parse a type declaration DEC.
1042 This takes the bit before the :: and returns a list of the typename
1044 (let ((things (f90-split-arglist dec)))
1045 (cons (if (string-match
1046 "\\([^(]+?\\)[ \t]*([ \t]*\\(:?len\\|kind\\)[ \t]*=[^)]+)"
1048 (match-string 1 (car things))
1050 (loop for thing in (cdr things)
1051 if (string-match "dimension[ \t]*(\\(.+\\))" thing)
1052 collect (cons "dimension"
1053 (1+ (f90-count-commas (match-string 1 thing))))
1057 (provide 'f90-interface-browser)
1059 ;;; f90-interface-browser.el ends here