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

   1 ;;!emacs
   2 ;;
   3 ;; FILE:         br-smt.el
   4 ;; SUMMARY:      Support routines for Smalltalk 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:    26-Jul-90
  12 ;; LAST-MOD:      9-Jun-99 at 18:05:18 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 ;;   See `smt-class-def-regexp' for regular expression that matches class
  22 ;;   definitions.
  23 ;;
  24 ;; DESCRIP-END.
  25
  26 ;;; ************************************************************************
  27 ;;; Other required Elisp libraries
  28 ;;; ************************************************************************
  29
  30 (require 'br-lib)
  31
  32 ;;; ************************************************************************
  33 ;;; User visible variables
  34 ;;; ************************************************************************
  35
  36 (defvar smt-lib-search-dirs nil
  37   "List of directories below which Smalltalk Library source files are found.
  38 Subdirectories of Library source are also searched.  A Library is a stable
  39 group of classes.")
  40
  41 (defvar smt-sys-search-dirs nil
  42   "List of directories below which Smalltalk System source files are found.
  43 Subdirectories of System source are also searched.  A System class is one
  44 that is not yet reusable and is likely to change before release.")
  45
  46 (defconst smt-narrow-view-to-class nil
  47  "*Non-nil means narrow buffer to just the matching class definition when displayed.")
  48
  49 ;;; ************************************************************************
  50 ;;; Internal functions
  51 ;;; ************************************************************************
  52
  53 (defun smt-get-classes-from-source (filename &rest ignore)
  54   "Scans FILENAME and returns cons of class list with parents-class alist.
  55 Handles multiple inheritance.  Assumes file existence and readability have
  56 already been checked."
  57   (let ((no-kill (get-file-buffer filename))
  58         classes class parents parent-cons)
  59     (if no-kill
  60         (set-buffer no-kill)
  61       (funcall br-view-file-function filename))
  62     (save-restriction
  63       (save-excursion
  64         (widen)
  65         (goto-char (point-min))
  66         (while (re-search-forward smt-class-def-regexp nil t)
  67           (setq class (br-buffer-substring (match-beginning 3) (match-end 3))
  68                 parent-cons
  69                 (cons
  70                  (and (match-end 1) (> (match-end 1) 0)
  71                       (list (br-buffer-substring
  72                              (match-beginning 1)
  73                              (match-end 1))))
  74                  class))
  75           ;; Assume class name not found within a comment.
  76           (setq classes (cons class classes)
  77                 parents (cons parent-cons parents)))))
  78     (or no-kill (kill-buffer (current-buffer)))
  79     (cons classes (delq nil parents))))
  80
  81 (defun smt-get-parents-from-source (filename class-name)
  82   "Scan source in FILENAME and return list of parents of CLASS-NAME.
  83 Assume file existence has already been checked."
  84     (or (null class-name)
  85         (car (car (br-rassoc
  86                    class-name
  87                    (cdr (smt-get-classes-from-source filename)))))))
  88
  89 (defun smt-select-path (paths-htable-elt &optional feature-p)
  90   "Select proper pathname from PATHS-HTABLE-ELT based upon value of optional FEATURE-P.
  91 Selection is between path of class definition and path for features associated
  92 with the class."
  93   (cdr paths-htable-elt))
  94
  95 (defun smt-set-case (type)
  96   "Return string TYPE identifier for use as a class name."
  97   type)
  98
  99 (defun smt-set-case-type (class-name)
 100   "Return string CLASS-NAME for use as a type identifier."
 101   class-name)
 102
 103 (defun smt-to-class-end ()
 104   "Assuming point is at start of class, move to best guess start of line after end of class."
 105   (interactive)
 106   (goto-char (point-max)))
 107
 108 (defun smt-to-comments-begin ()
 109   "Skip back from current point past any preceding Smalltalk comments.
 110 Presently a no-op."
 111   )
 112
 113 ;;; ************************************************************************
 114 ;;; Internal variables
 115 ;;; ************************************************************************
 116
 117 (defconst smt-type-tag-separator "@"
 118   "String that separates a tag's type from its normalized definition form.
 119 This should be a single character which is unchanged when quoted for use as a
 120 literal in a regular expression.")
 121
 122 (defconst smt-subclass-separator
 123   "\\(variableSubclass:\\|variableWordSubclass:\\|variableByteSubclass:\\|subclass:\\)"
 124   "Regexp matching delimiter following parent identifier.")
 125
 126 (defconst smt-identifier-chars "a-zA-Z0-9"
 127   "String of chars and char ranges that may be used within a Smalltalk identifier.")
 128
 129 (defconst smt-identifier (concat "\\([a-zA-Z][" smt-identifier-chars "]*\\)")
 130   "Regular expression matching a Smalltalk identifier.")
 131
 132
 133 (defconst smt-class-name-before
 134   (concat "^[ \t]*" smt-identifier
 135           "[ \t\n\r]+" smt-subclass-separator
 136           "[ \t\n\r]*#")
 137   "Regexp preceding the class name in a class definition.")
 138
 139 (defconst smt-class-name-after
 140   ""
 141   "Regexp following the class name in a class definition.")
 142
 143 (defconst smt-class-def-regexp
 144   (concat smt-class-name-before smt-identifier smt-class-name-after)
 145   "Regular expression used to match to class definitions in source text.
 146 Class name identifier is grouped expression 3.  `subclass:' inheritance
 147 indicator is grouped expression 2.  Parent identifier is grouped
 148 expression 1.")
 149
 150
 151 (defconst smt-lang-prefix "smt-"
 152  "Prefix string that starts \"br-smt.el\" symbol names.")
 153
 154 (defconst smt-src-file-regexp ".\\.st$"
 155   "Regular expression matching a unique part of Smalltalk source file name and no others.")
 156
 157 (defvar smt-children-htable nil
 158   "Htable whose elements are of the form: (LIST-OF-CHILD-CLASSES . CLASS-NAME).
 159 Used to traverse Smalltalk inheritance graph.  `br-build-children-htable' builds
 160 this list.")
 161 (defvar smt-parents-htable nil
 162   "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
 163 Used to traverse Smalltalk inheritance graph.  `br-build-parents-htable' builds
 164 this list.")
 165 (defvar smt-paths-htable nil
 166   "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . FILE-PATH).
 167 FILE-PATH gives the location of classes found in LIST-OF-CLASS-NAMES.
 168 `br-build-paths-htable' builds this list.")
 169
 170
 171 (defvar smt-lib-parents-htable nil
 172   "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
 173 Only classes from stable software libraries are used to build the list.")
 174 (defvar smt-lib-paths-htable nil
 175   "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . FILE-PATH).
 176 FILE-PATH gives the location of classes found in LIST-OF-CLASS-NAMES.
 177 Only classes from stable software libraries are used to build the list.")
 178
 179 (defvar smt-sys-parents-htable nil
 180   "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
 181 Only classes from systems that are likely to change are used to build the list.")
 182 (defvar smt-sys-paths-htable nil
 183   "Alist whose elements are of the form: (LIST-OF-CLASS-NAMES . FILE-PATH).
 184 FILE-PATH gives the location of classes found in LIST-OF-CLASS-NAMES.
 185 Only classes from systems that are likely to change are used to build the
 186 list.")
 187
 188 (defvar smt-lib-prev-search-dirs nil
 189   "Used to check if `smt-lib-classes-htable' must be regenerated.")
 190 (defvar smt-sys-prev-search-dirs nil
 191   "Used to check if `smt-sys-classes-htable' must be regenerated.")
 192
 193 (defvar smt-env-spec nil
 194   "Non-nil value means Environment specification has been given but not yet built.
 195 Nil means current Environment has been built, though it may still require updating.")
 196
 197 (provide 'br-smt)