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

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