cgit.sxemacs.org Git - packages/blob - xemacs-packages/oo-browser/br-eif-ft.el

   1 ;;!emacs
   2 ;;
   3 ;; FILE:         br-eif-ft.el
   4 ;; SUMMARY:      Eiffel OO-Browser class and feature functions.
   5 ;; USAGE:        GNU Emacs Lisp Library
   6 ;; KEYWORDS:     oop, tools
   7 ;;
   8 ;; AUTHOR:       Bob Weiner
   9 ;; ORG:          BeOpen.com
  10 ;;
  11 ;; ORIG-DATE:    03-Oct-90
  12 ;; LAST-MOD:     10-May-01 at 05:42:39 by Bob Weiner
  13 ;;
  14 ;; Copyright (C) 1990-1996  BeOpen.com
  15 ;; See the file BR-COPY for license information.
  16 ;;
  17 ;; This file is part of the OO-Browser.
  18 ;;
  19 ;; DESCRIPTION:
  20 ;; DESCRIP-END.
  21
  22 ;;; ************************************************************************
  23 ;;; Other required Elisp libraries
  24 ;;; ************************************************************************
  25
  26 (require 'br-c-ft)
  27 (require 'eif-calls)
  28
  29 ;;; ************************************************************************
  30 ;;; Public variables
  31 ;;; ************************************************************************
  32
  33 (defconst eif-type-tag-separator ","
  34   "String that separates a tags type from its normalized definition form.
  35 This should be a single character which is unchanged when quoted for use as a
  36 literal in a regular expression.")
  37
  38 (defconst eif-tag-fields-regexp
  39   ;; The \\\\? below is necessary because we sometimes use this expression to
  40   ;; test against a string that has been regexp-quoted and some of the
  41   ;; characters in br-feature-type-regexp will then be preceded by \\.
  42   (format "^\\([^%s \n]+\\)%s\\\\?\\(%s \\)\\([^%s\n]+\\)"
  43           eif-type-tag-separator eif-type-tag-separator
  44           br-feature-type-regexp eif-type-tag-separator)
  45  "Regexp matching the fields of an Eiffel feature tag line.
  46 Group 1 is the class of the feature.  Group 2 is the prefix preceding the
  47 feature when displayed within a listing buffer.  Group 3 is the feature
  48 name.")
  49
  50 ;;; ************************************************************************
  51 ;;; Public functions
  52 ;;; ************************************************************************
  53
  54 (defun eif-add-default-classes ()
  55   (if br-c-tags-flag (c-add-default-classes)))
  56
  57 (defun eif-feature-implementors (ftr-name)
  58   "Return unsorted list of Eiffel feature tags which implement FTR-NAME."
  59   (eif-feature-matches (concat "^" (regexp-quote ftr-name) "$")))
  60
  61 (defun eif-feature-name-to-regexp (name)
  62   "Converts feature NAME into a regular expression matching the feature's name tag."
  63   (if (string-match (concat "^" br-feature-type-regexp " ") name)
  64       (setq name (substring name (match-end 0))))
  65   (format "%s%s%s %s[ \n\r]"
  66           eif-identifier eif-type-tag-separator br-feature-type-regexp
  67           (regexp-quote name)))
  68
  69 (defun eif-feature-signature-to-name (feature-sig-or-tag &optional with-class for-display)
  70   "Extract the feature name without its class name from FEATURE-SIG-OR-TAG.
  71 If optional WITH-CLASS is non-nil, class name and :: are prepended to the
  72 name returned.  If optional FOR-DISPLAY is non-nil, a feature type character
  73 is prepended to the name for display in a browser listing."
  74   (cond ((br-feature-tag-p feature-sig-or-tag)
  75          (br-feature-tag-name feature-sig-or-tag with-class for-display))
  76         ((string-match (concat eif-type-tag-separator
  77                                "\\(" br-feature-type-regexp " \\)")
  78                        feature-sig-or-tag)
  79          (let ((class (substring feature-sig-or-tag 0 (match-beginning 0)))
  80                (name (substring feature-sig-or-tag (match-end 0))))
  81            (cond ((and with-class for-display)
  82                   (concat class "::" (substring feature-sig-or-tag
  83                                                 (match-beginning 1))))
  84                  (with-class
  85                   (concat class "::" name))
  86                  (for-display
  87                   (substring feature-sig-or-tag (match-beginning 1)))
  88                  (t name))))
  89         (t feature-sig-or-tag)))
  90
  91 (defun eif-feature-signature-to-regexp (signature)
  92   "Given an Eiffel class or feature SIGNATURE, return regexp to match its definition."
  93   (let ((regexp) name type)
  94     (cond ((string-match (concat "\\`" br-feature-type-regexp " ")
  95                          signature)
  96            (setq name (substring signature (match-end 0))
  97                  type (string-to-char
  98                        (substring signature 0 1)))
  99            (setq regexp
 100                  (cond ((memq type '(?- ?1 ?> ?/))
 101                         ;; routine
 102                         (eif-routine-to-regexp name))
 103                        ((eq type ?=)
 104                         ;; attribute
 105                         (eif-attribute-to-regexp name)))))
 106           ((equal 0 (string-match eif-identifier signature))
 107            ;; Assume is a class name
 108            (setq regexp
 109                  (concat eif-class-name-before
 110                          (regexp-quote signature)
 111                          eif-class-name-after))))
 112     (or regexp
 113         (error "(eif-feature-signature-to-regexp): Invalid format, `%s'"
 114                signature))))
 115
 116 (defun eif-output-feature-tags (feature-file feature-tags-list)
 117   "Write Eiffel FEATURE-FILE's FEATURE-TAGS-LIST into `br-feature-tags-file'.
 118 Assume `br-feature-tags-init' has been called."
 119   (interactive)
 120   (save-excursion
 121     (br-feature-set-tags-buffer)
 122     (goto-char 1)
 123     ;; Delete any prior feature tags associated with feature-file
 124     (if (search-forward feature-file nil 'end)
 125         (progn (forward-line -1)
 126                (let ((start (point)))
 127                  (search-forward "\^L" nil 'end 2)
 128                  (backward-char 1)
 129                  (delete-region start (point)))))
 130     (if feature-tags-list
 131         (progn (insert "\^L\n")
 132                ;; Quote pathname to avoid read errors on MS OSes.
 133                (prin1 feature-file (current-buffer))
 134                (insert "\n")
 135                (mapcar (function (lambda (tag) (insert tag "\n")))
 136                        feature-tags-list)))))
 137
 138 (defun eif-scan-features-in-class (class start end)
 139   "Return unordered list of Eiffel feature definitions in CLASS.
 140 START and END give buffer region to search."
 141   (save-excursion
 142     (save-restriction
 143       (narrow-to-region start end)
 144       (goto-char start)
 145       (let ((attributes-and-routines (eif-parse-features t)))
 146         (append
 147          (mapcar
 148           (function (lambda (routine)
 149                       (concat class eif-type-tag-separator routine)))
 150           (cdr attributes-and-routines))
 151          (mapcar
 152           (function (lambda (attribute)
 153                       (concat class eif-type-tag-separator attribute)))
 154           (car attributes-and-routines)))))))
 155
 156 (defun eif-to-definition (&optional identifier)
 157   "If point is within an Eiffel class or feature name, try to move to its definition.
 158 With optional IDENTIFIER, do the same instead for it."
 159   (interactive)
 160   (let ((cl (or identifier (eif-find-class-name))))
 161     (cond
 162      ((eif-keyword-p) nil)
 163      ((br-check-for-class cl))
 164      ((eif-feature cl))
 165      ((progn
 166         (beep)
 167         (message
 168          "(OO-Browser):  Select an Eiffel identifier to move to its definition.")
 169         nil))
 170      )))
 171
 172 ;;; ************************************************************************
 173 ;;; Private functions
 174 ;;; ************************************************************************
 175
 176 (defun eif-export-feature-p ()
 177   "Return nil unless point is within a class export clause."
 178   (save-excursion
 179     (let ((end (point)))
 180       (beginning-of-line)
 181       ;; If in a comment, return nil.
 182       (if (search-forward "--" end t)
 183           nil
 184         (goto-char (point-min))
 185         (and (re-search-forward eif-export-key-regexp end t)
 186              (not (re-search-forward "^\\(inherit\\|feature\\)\\([ \t]\\|$\\)" end t)))))))
 187
 188 (defun eif-feature (&optional ftr)
 189   "Return nil if definition is not found for optional FTR or feature declared at point."
 190   (interactive)
 191   (let ((class-deferred)
 192         (class)
 193         (deferred-p)
 194         (ftr-def-class))
 195     (cond ((or ftr (and (eif-export-feature-p)
 196                         (setq ftr (eif-to-feature-decl))))
 197            (if (and (setq class-deferred (eif-get-class-name-from-source))
 198                     (setq class (car class-deferred)
 199                           deferred-p (cdr class-deferred)
 200                           ftr-def-class (eif-find-ancestors-feature
 201                                          (list class) deferred-p ftr)))
 202                (cond ((equal (car ftr-def-class) class) t)
 203                      ((equal (cdr ftr-def-class) ftr)
 204                       ;; Feature inherited but not renamed.
 205                       (message
 206                        "Feature `%s' of class `%s' inherited from class `%s'."
 207                        ftr class (car ftr-def-class)))
 208                      ;; Feature inherited and renamed.
 209                      (t (message "Feature `%s', class `%s' from feature `%s', class `%s'."
 210                                  ftr class (cdr ftr-def-class)
 211                                  (car ftr-def-class))
 212                         t))
 213              (beep)
 214              (message "(OO-Browser):  `%s' feature not found." ftr)
 215              t))
 216           ((and (not ftr) (eif-feature-def-p)))
 217           ;;
 218           ;; Later we might add the case of a feature invocation here.
 219           ;;
 220           )))
 221
 222 (defun eif-feature-def-p ()
 223   "If point is within a feature definition's name, display feature including leading comments."
 224   (let ((opoint (point)))
 225     (beginning-of-line)
 226     (if (or (looking-at eif-routine-regexp)
 227             (looking-at eif-attribute-regexp))
 228         (progn (setq opoint (match-beginning eif-feature-name-grpn))
 229                (br-display-code opoint))
 230       (goto-char opoint)
 231       nil)))
 232
 233 (defun eif-feature-map-tags (function regexp)
 234   "Apply FUNCTION to all current feature tags that match REGEXP and return a list of the results."
 235   (let ((identifier-chars (concat "[" eif-identifier-chars "]*")))
 236     ;; Ensure handle "^" and "$" meta-chars.
 237     (setq regexp
 238           (concat (format "\\`%s " br-feature-type-regexp)
 239                   (if (equal (substring regexp 0 1) "^")
 240                       (progn (setq regexp (substring regexp 1)) nil)
 241                     identifier-chars)
 242                   (if (equal (substring regexp -1) "$")
 243                       (substring regexp 0 -1)
 244                     (concat regexp identifier-chars))
 245                   "\\'"))
 246     (br-feature-map-tags function regexp)))
 247
 248 (defun eif-feature-matches (regexp)
 249   "Return an unsorted list of feature tags whose names match in part or whole to REGEXP.
 250 ^ and $ characters may be used to match to the beginning and end of a feature name,
 251 respectively."
 252   (eif-feature-map-tags 'identity regexp))
 253
 254 (defun eif-find-ancestors-feature (class-list deferred-class ftr)
 255   (let* ((classes class-list)
 256          (cl)
 257          (file)
 258          (found-ftr))
 259     (if (null class-list)
 260         nil
 261       (while (and (not found-ftr) classes)
 262         (setq cl (car classes)
 263               file (br-class-path cl))
 264         (and file (setq found-ftr
 265                         (br-feature-found-p file ftr deferred-class)))
 266         ;; If found-ftr is a cons cell, then only one parent class need
 267         ;; be searched to look for ftr.
 268         (if (consp found-ftr)
 269             (setq class-list (list (car found-ftr))
 270                   ftr (cdr found-ftr)))
 271         (setq classes (cdr classes)))
 272       (cond ((consp found-ftr)
 273              (eif-find-ancestors-feature class-list deferred-class ftr))
 274             ((null found-ftr)
 275              (eif-find-ancestors-feature
 276               (apply 'append (mapcar (function
 277                                        (lambda (cl) (br-get-parents cl)))
 278                                      class-list))
 279               deferred-class
 280               ftr))
 281             (t (cons cl ftr))))))
 282
 283 (defun eif-find-class-name ()
 284   "Return class name that point is within, else nil."
 285   (if (= (point) (point-max)) (skip-chars-backward " \t\n\r"))
 286   (save-excursion
 287     (skip-chars-forward " \t")
 288     (skip-chars-backward eif-identifier-chars)
 289     (skip-chars-backward " \t\n\r\f")
 290     (backward-char 1)
 291     (and (looking-at eif-class-name-pat)
 292          (br-buffer-substring (match-beginning 2)
 293                               (match-end 2)))))
 294
 295 (defun eif-find-feature (feature-name)
 296   "With point selecting a class in a listing buffer, move point to definition of FEATURE-NAME in viewer window.
 297 Move point and return non-nil iff FEATURE-NAME is found."
 298   (interactive "sFeature to find: ")
 299   ;; If selected class is displayed, don't go to start of class
 300   (if (equal (br-class-path (br-find-class-name))
 301              (progn
 302                (br-to-from-viewer)
 303                (expand-file-name buffer-file-name)))
 304       nil
 305     (br-edit))
 306   (if (eiffel-find-feature feature-name)
 307       (progn (recenter 0)
 308              t)
 309     (br-to-from-viewer)
 310     (and (interactive-p)
 311          (progn
 312            (beep)
 313            (message "(OO-Browser):  No `%s' feature found." feature-name)))))
 314
 315 (defun eif-feature-locate-p (feature-tag)
 316   (let (start class feature-sig)
 317     (if (br-feature-tag-p feature-tag)
 318         (setq class (br-feature-tag-class feature-tag)
 319               name (br-feature-tag-name feature-tag nil nil)
 320               feature-sig (br-feature-tag-signature feature-tag))
 321       (setq feature-sig feature-tag
 322             name (br-feature-name feature-tag)
 323             class nil))
 324     ;;
 325     ;; First move to the proper class implementation, so that if two
 326     ;; classes in the same file have the same feature signature, we still
 327     ;; end up at the right one.
 328     (cond (class
 329            (if (not (br-default-class-p class))
 330                (re-search-forward
 331                 (concat eif-class-name-before (regexp-quote class)
 332                         eif-class-name-after)
 333                 nil t)))
 334           ((string-match (concat "\\`[^\]\[]+" eif-type-tag-separator)
 335                          feature-sig)
 336            (setq class (substring feature-sig 0 (1- (match-end 0))))
 337            (re-search-forward
 338             (concat eif-class-name-before (regexp-quote class)
 339                     eif-class-name-after)
 340             nil t)))
 341     (if (not (re-search-forward
 342               (eif-feature-signature-to-regexp feature-sig) nil t))
 343         nil
 344       (goto-char (match-beginning 0))
 345       (if (search-forward name nil t) (goto-char (match-beginning 0)))
 346       (setq start (point))
 347       (br-display-code start))))
 348
 349 (defun eif-keyword-p ()
 350   "Return t if point is within an Eiffel keyword, else nil."
 351   (if (= (point) (point-max)) (skip-chars-backward " \t\n\r"))
 352   (save-excursion
 353     (skip-chars-forward " \t")
 354     (skip-chars-backward eif-identifier-chars)
 355     (and (looking-at eif-identifier)
 356          (hash-key-p (br-buffer-substring (match-beginning 0)
 357                                           (match-end 0))
 358                      eif-reserved-words-htable))))
 359
 360 (defun eif-locate-feature (ftr ftr-pat)
 361   (let ((opoint (point)))
 362     (goto-char (point-min))
 363     (if (and (re-search-forward "^feature\\([ \t]\\|$\\)" nil t)
 364              (re-search-forward ftr-pat nil t))
 365         (progn (goto-char (match-beginning 0))
 366                (if (search-forward ftr nil t)
 367                    (goto-char (match-beginning 0)))
 368                (setq opoint (point))
 369                (br-display-code opoint))
 370       (goto-char opoint)
 371       (and (interactive-p) (error "Feature `%s' not found." ftr)))))
 372
 373 (defun eif-renamed-feature-p (ftr)
 374   (goto-char (point-min))
 375   (let ((rename-regexp "[ \t\n\r]+rename[ \t\n\r]")
 376         (rename-match
 377          (concat eif-identifier "[ \t\n\r]+as[ \t\n\r]+" ftr "[,; \t\n\r]"))
 378         (prev-feature-nm)
 379         (prev-class)
 380         (parents))
 381     (while (and (setq prev-feature-nm
 382                       (and (re-search-forward rename-regexp nil t)
 383                            (re-search-forward rename-match nil t)))
 384                 (setq prev-feature-nm
 385                       (br-buffer-substring (match-beginning 1) (match-end 1))
 386                       prev-class (match-beginning 0))
 387                 (progn (backward-char 1)
 388                        (eif-in-comment-p))))
 389     (if prev-feature-nm
 390         (progn (goto-char prev-class)
 391                (setq parents (eif-get-parents-from-source
 392                               buffer-file-name nil))
 393                (if (re-search-backward (concat
 394                                         "[^[][ \t\n\r]+\\("
 395                                         (mapconcat 'identity parents "\\|")
 396                                         "\\)")
 397                                        nil t)
 398                    (progn (setq prev-class (br-buffer-substring
 399                                             (match-beginning 1)
 400                                             (match-end 1)))
 401                           (cons prev-class prev-feature-nm))
 402                  (beep)
 403                  (message
 404                   "(OO-Browser):  Internal error - no class associated with rename clause."))))))
 405
 406 (defun eif-to-feature-decl ()
 407   (let ((end))
 408     (while (and (progn (skip-chars-backward "^, \t\n\r")
 409                        (and (not (eq (preceding-char) ?,))
 410                             (not (looking-at "export[ \t\n\r]+"))))
 411                 (progn (skip-chars-backward " \t\n\r")
 412                        (setq end (point))
 413                        (beginning-of-line)
 414                        (if (search-forward "--" end t)
 415                            (progn (goto-char end)
 416                                   (skip-chars-forward " \t\n\r")
 417                                   nil)
 418                          (goto-char end)
 419                          t)))))
 420   (if (looking-at "export[ \t\n\r]+")
 421       (goto-char (match-end 0))
 422     (skip-chars-forward " \t\n\r"))
 423   (if (looking-at eif-feature-name)
 424       (br-buffer-substring (match-beginning 0) (match-end 0))))
 425
 426 ;; Prefixed with `eiffel' rather than `eif' since works as a standalone
 427 ;; feature in buffers whose major mode is `eiffel-mode'.  It is used by the
 428 ;; browser but may also be used standalone.
 429 ;;
 430 (defun eiffel-find-feature (feature-name)
 431   "Move point to start of feature named FEATURE-NAME in current buffer.
 432 Display feature including all preceding comments at the top of the window.
 433 Move point and return non-nil iff FEATURE-NAME is found."
 434   (interactive "sFeature to find: ")
 435   (cond ((eif-locate-feature
 436           feature-name (eif-routine-to-regexp feature-name)))
 437         ((eif-to-attribute feature-name)
 438          (br-display-code (point))
 439          (back-to-indentation)
 440          t)))
 441
 442 ;;; ************************************************************************
 443 ;;; Private variables
 444 ;;; ************************************************************************
 445
 446 (defconst eif-feature-name
 447   (concat
 448    "\\("
 449    "\\(prefix[ \t]+\"\\(not\\|\\+\\|-\\)\"\\)"
 450    "\\|infix[ \t]+\"\\(div\\|mod\\|^\\|<=?\\|>=?\\|\+\\|-\\|\\*\\|/"
 451                    "\\|and then\\|and\\|or else\\|or\\|xor\\|implies\\)"
 452    "\\|" eif-identifier "\\)")
 453   "Regexp matching any Eiffel feature name.
 454 Will also match class names and keywords, so tests for these should precede
 455 use of this expression.")
 456
 457 (defconst eif-export-key-regexp
 458   "\\(^[ \t]*\\|[ \t]+\\)export[ \t\n\r]+"
 459   "Regexp matching the Eiffel export keyword in context.")
 460
 461 (defconst eif-class-repeat (concat "repeat[ \t]+" eif-identifier)
 462   "Match to an Eiffel `repeat <class>' phrase.  Grouping 1 is class name.")
 463
 464 (defconst eif-exported-feature
 465   (concat "\\(,\\|export[ \t\n\r]+\\(--.*[ \t\n\r]+\\)*\\)"
 466           eif-feature-name "\\([ \t]*{[^\}]+}\\)?"
 467           "\\([ \t]*[\n\r,]\\|[ \t]+--\\)")
 468   "Regexp to match to a feature declaration in an export clause.
 469   Exclude `repeat <class>' phrases.  Feature name is grouping 3.")
 470
 471
 472 (provide 'br-eif-ft)