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

   1 ;;!emacs
   2 ;;
   3 ;; FILE:         br-eif.el
   4 ;; SUMMARY:      Support routines for Eiffel inheritance browsing and error parsing.
   5 ;; USAGE:        GNU Emacs Lisp Library
   6 ;; KEYWORDS:     oop, tools
   7 ;;
   8 ;; AUTHOR:       Bob Weiner
   9 ;; ORG:          BeOpen.com
  10 ;;
  11 ;; ORIG-DATE:     7-Dec-89
  12 ;; LAST-MOD:     13-Jul-99 at 17:00:51 by Bob Weiner
  13 ;;
  14 ;; Copyright (C) 1989-1995, 1997  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-lib)
  27
  28 ;;; ************************************************************************
  29 ;;; User visible variables
  30 ;;; ************************************************************************
  31
  32 (defvar eif-lib-search-dirs nil
  33   "List of directories below which Eiffel Library source files are found.
  34 Subdirectories of Library source are also searched.  A Library is a stable
  35 group of classes.")
  36
  37 (defvar eif-sys-search-dirs nil
  38   "List of directories below which Eiffel System source files are found.
  39 Subdirectories of System source are also searched.  A System class is one
  40 that is not yet reusable and is likely to change before release.")
  41
  42 (defconst eif-narrow-view-to-class nil
  43  "*Non-nil means narrow buffer to just the matching class definition when displayed.")
  44
  45 ;;; ************************************************************************
  46 ;;; Public functions
  47 ;;; ************************************************************************
  48
  49 (defun eif-get-classes-from-source (filename &optional skip-tags
  50                                     skip-tags-cleanup)
  51   "Scans FILENAME and returns cons of class list with parents-class alist.
  52 Handles multiple inheritance.  Assumes file existence and readability have
  53 already been checked.
  54    With optional SKIP-TAGS non-nil, does not compute and store lookup tags
  55 for element definitions.  If SKIP-TAGS is nil, normally a cleanup
  56 function is called after scanning the elements.  SKIP-TAGS-CLEANUP
  57 non-nil suppresses this action."
  58   ;; Multiple classes per file allowed
  59   (let (classes class end parents parent-cons signatures start)
  60     (funcall br-view-file-function filename)
  61     (save-excursion
  62       (save-restriction
  63         (widen)
  64         (goto-char (point-min))
  65         (while (re-search-forward eif-class-def-regexp nil t)
  66           (setq start (point)
  67                 class
  68                 (br-buffer-substring (match-beginning 2) (match-end 2))
  69                 classes (cons class classes))
  70           (eif-to-class-end)
  71           (setq end (point)
  72                 parents (eif-scan-class-parents end))
  73           ;; All classes (aside from PLATFORM and GENERAL) have ANY as an
  74           ;; ancestor, so if no superclass was found, add ANY to the list of
  75           ;; `parents'.
  76           (if (and (null parents)
  77                    (not (br-member class '("ANY" "PLATFORM" "GENERAL"))))
  78               (setq parents (cons "ANY" parents)))
  79           (setq parent-cons (cons parents class)
  80                 parents (cons parent-cons parents))
  81           ;;
  82           (goto-char end)
  83           (or skip-tags
  84               ;; Scan class features
  85               (setq signatures
  86                     (eif-scan-features-in-class class start end))))))
  87     (if skip-tags
  88         nil
  89       (eif-output-feature-tags filename signatures)
  90       (or skip-tags-cleanup (br-feature-build-htables)))
  91     (cons classes (delq nil parents))))
  92
  93 (defun eif-get-parents-from-source (filename class)
  94   "Scan source in FILENAME and return list of parents of CLASS.
  95 Assume file existence has already been checked."
  96     (cond ((null class) nil)
  97           ((equal filename br-null-path)
  98            ;; This means there is no source for this class, so
  99            ;; if this is not one of the ANY, PLATFORM or GENERAL classes,
 100            ;; return ANY as the sole parent.
 101            (if (not (br-member class '("ANY" "PLATFORM" "GENERAL")))
 102                '("ANY")))
 103           (t (car (car (br-rassoc
 104                         class
 105                         (cdr (eif-get-classes-from-source filename t nil))))))))
 106
 107 ;;; ************************************************************************
 108 ;;; Internal functions
 109 ;;; ************************************************************************
 110
 111 (defun eif-scan-class-parents (end)
 112   "Return list of parents from an Eiffel class declaration preceding END point."
 113   (let ((parents) (par)
 114         (case-fold-search t) ;; Ignore case in searches
 115         found indent)
 116     (goto-char (point-min))
 117     (while (and (setq found (re-search-forward
 118                              (concat "\\<inherit[ \t\n\r]+"
 119                                      eif-parent-regexp)
 120                              end t))
 121                 (eif-in-comment-p)))
 122     (if (not found)
 123         nil
 124       ;; Save first parent
 125       (setq parents (list
 126                      (br-buffer-substring (match-beginning 2)
 127                                           (match-end 2)))
 128             indent (save-excursion
 129                      (goto-char (match-beginning 2))
 130                      (current-column)))
 131       ;; Save any succeeding parents
 132       (save-excursion
 133         (if (re-search-forward "^[a-zA-Z]" nil t)
 134             (setq end (1- (point)))))
 135       (forward-line 1)
 136       (while (< (point) end)
 137         (back-to-indentation)
 138         (and (<= (current-column) indent)
 139              (looking-at eif-identifier)
 140              (setq par (br-buffer-substring (match-beginning 1)
 141                                             (match-end 1)))
 142              (if (or (br-member par parents)
 143                      (hash-key-p par eif-reserved-words-htable))
 144                  nil
 145                (setq parents (cons par parents))))
 146         (forward-line 1)))
 147     (nreverse parents)))
 148
 149 (defun eif-select-path (paths-htable-elt &optional feature-p)
 150   "Select proper pathname from PATHS-HTABLE-ELT based upon value of optional FEATURE-P.
 151 Selection is between path of class definition and path for features associated
 152 with the class."
 153   (cdr paths-htable-elt))
 154
 155 ;; Return string TYPE identifier for use as a class name.
 156 (defalias 'eif-set-case 'identity)
 157
 158 (defun eif-set-case-type (class-name)
 159   "Return string CLASS-NAME for use as a type identifier."
 160   (upcase class-name))
 161
 162
 163 (defun eif-to-class-end ()
 164   "Assuming point is at start of class, move to start of line after end of class."
 165   (interactive)
 166   (if (and (re-search-forward "^end[ \t\n\r\f-]" nil t)
 167            (= (forward-line 1) 0))
 168       nil
 169     (goto-char (point-max))))
 170
 171 (defun eif-to-comments-begin ()
 172   "Skip back from current point past any preceding blank lines and comments."
 173   (let ((opoint))
 174     (while
 175         (progn (setq opoint (point))
 176                ;; To previous line
 177                (and (= 0 (forward-line -1))
 178                     ;; If begins with "--", then is a comment.
 179                     (cond ((looking-at "[ \t]*--"))
 180                           ((looking-at "[ \t]*$"))))))
 181     (goto-char opoint)
 182     ;; Skip past whitespace
 183     (skip-chars-forward " \t\n\r\f")
 184     (beginning-of-line)))
 185
 186 ;;; ************************************************************************
 187 ;;; Internal variables
 188 ;;; ************************************************************************
 189
 190 (defconst eif-class-name-before "^[ \t]*\\(deferred[ \t\n\r]+\\|expanded[ \t\n\r]+\\)?class[ \t\n\r]+"
 191   "Regexp preceding the class name in a class definition.")
 192
 193 (defconst eif-class-name-after "[ \t\n\r]+"
 194   "Regexp following the class name in a class definition.")
 195
 196 (defconst eif-identifier-chars "A-Za-z0-9_"
 197   "String of chars and char ranges that may be used within an Eiffel identifier.")
 198
 199 (defconst eif-identifier (concat "\\([a-zA-Z][" eif-identifier-chars "]*\\)")
 200   "Regular expression matching an Eiffel identifier.")
 201
 202 (defconst eif-class-def-regexp
 203   (concat eif-class-name-before eif-identifier eif-class-name-after)
 204   "Regular expression used to match to class definitions in source text.
 205 Class name identifier is grouped expression 2.")
 206
 207 (defconst eif-class-name-preceding
 208   "\\([\[\{>;:][ \t\n\r]*\\|[a-zA-z][ \t\n\r]+\\)"
 209   "Pattern preceding any valid non-comment use of an Eiffel class/type name.")
 210
 211 (defconst eif-class-name-pat
 212   (concat eif-class-name-preceding eif-identifier)
 213   "Class name is grouped expression 2.")
 214
 215 (defconst eif-lang-prefix "eif-"
 216   "Prefix string that starts \"br-eif.el\" symbol names.")
 217
 218
 219 (defconst eif-parent-regexp (concat "[ \t\n\r]*\\(--.*[\n]\\)*[ \t\n\r]*"
 220                                     eif-identifier)
 221   "Parent identifier is grouped expression 2.")
 222
 223 (defconst eif-src-file-regexp ".\\.e$"
 224   "Regular expression matching a unique part of Eiffel class filenames and no others.")
 225
 226 (defvar eif-children-htable nil
 227   "Htable whose elements are of the form: (LIST-OF-CHILD-CLASSES . CLASS-NAME).
 228 Used to traverse Eiffel inheritance graph.  `br-build-children-htable' builds
 229 this list.")
 230 (defvar eif-parents-htable nil
 231   "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
 232 Used to traverse Eiffel inheritance graph.  `br-build-parents-htable' builds
 233 this list.")
 234 (defvar eif-paths-htable nil
 235   "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY).
 236 DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES.
 237 `br-build-paths-htable' builds this list.")
 238
 239 (defvar eif-lib-parents-htable nil
 240   "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
 241 Only classes from stable software libraries are used to build the list.")
 242 (defvar eif-lib-paths-htable nil
 243   "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY).
 244 DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES.
 245 Only classes from stable software libraries are used to build the list.")
 246
 247 (defvar eif-sys-parents-htable nil
 248   "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
 249 Only classes from systems that are likely to change are used to build the list.")
 250 (defvar eif-sys-paths-htable nil
 251   "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY).
 252 DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES.
 253 Only classes from systems that are likely to change are used to build the
 254 list.")
 255
 256 (defvar eif-lib-prev-search-dirs nil
 257   "Used to check if `eif-lib-paths-htable' must be regenerated.")
 258 (defvar eif-sys-prev-search-dirs nil
 259   "Used to check if `eif-sys-paths-htable' must be regenerated.")
 260
 261 (defvar eif-env-spec nil
 262   "Non-nil value means Environment specification has been given but not yet built.
 263 Nil means current Environment has been built, though it may still require updating.")
 264
 265 (provide 'br-eif)