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

   1 ;;!emacs
   2 ;;
   3 ;; FILE:         eif-ise-er.el
   4 ;; SUMMARY:      Parses ISE's Eiffel error messages; compiles Eiffel classes.
   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 at 00:17:18
  12 ;; LAST-MOD:      9-Jun-99 at 18:05:58 by Bob Weiner
  13 ;;
  14 ;; Copyright (C) 1989-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 ;;
  21 ;;   `eif-ec' compiles an Eiffel class.
  22 ;;   `eif-es' compiles an Eiffel system.
  23 ;;
  24 ;;   Load this library and then invoke error parsing via {C-x `}.
  25 ;;   See the GNU Emacs Manual for an explanation of error parsing.
  26 ;;
  27 ;;   `eif-ise-next-error' bound to {C-x `} parses ISE Eiffel compiler
  28 ;;   error messages.  As in:
  29 ;;
  30 ;;   "my_class", 16: syntax error : Keyword `expanded' may not be used as identifier
  31 ;;
  32 ;;   Only handles compilation lines of the following form:
  33 ;;
  34 ;;      <compiler> [<option> ... <option>] <pathname>
  35 ;;
  36 ;;   Requires the `br-class-path', `br-build-sys-paths-htable', and
  37 ;;   `br-build-paths-htable' functions from the OO-Browser `br-lib' package.
  38 ;;   This is used to determine the full pathname for the source code of each
  39 ;;   class since ISE does not include any pathname information in its error
  40 ;;   messages.
  41 ;;
  42 ;;
  43 ;;   To reset the {C-x `} key to parse non-Eiffel error messages, use:
  44 ;;
  45 ;;           {M-x load-lib RET compile RET}
  46 ;;
  47 ;; DESCRIP-END.
  48
  49 (require 'br-lib)
  50 (require 'br-eif)
  51 (require 'compile)
  52
  53 (global-set-key "\C-x`" 'eif-ise-next-error)
  54 (and (boundp 'eiffel-mode-map) (define-key eiffel-mode-map "\C-c!" 'eif-ec))
  55
  56 (setq compilation-error-regexp "\"\\([^ \t]+\\)\", \\([0-9]+\\):.*")
  57
  58 (defconst eif-compile-dir nil
  59   "Default directory in which to invoke an Eiffel compile command.")
  60
  61 (defconst eif-compile-cmd "ec"
  62   "Default command name with which to invoke the Eiffel compiler.")
  63
  64 (defun eif-ise-next-error (&optional argp)
  65   "Visit next compilation error message and corresponding source code.
  66 This operates on the output from the \\[compile] command.
  67 If all preparsed error messages have been processed,
  68 the error message buffer is checked for new ones.
  69 A non-nil argument (prefix arg, if interactive)
  70 means reparse the error message buffer and start at the first error."
  71   (interactive "P")
  72   (if (or (eq compilation-error-list t)
  73           argp)
  74       (progn (compilation-forget-errors)
  75              (setq compilation-parsing-end 1)))
  76   (if compilation-error-list
  77       nil
  78     (save-excursion
  79       (switch-to-buffer "*compilation*")
  80       (set-buffer-modified-p nil)
  81       (eif-ise-compilation-parse-errors)))
  82   (let ((next-error (car compilation-error-list)))
  83     (if (null next-error)
  84         (error (concat compilation-error-message
  85                        (if (and compilation-process
  86                                 (eq (process-status compilation-process)
  87                                     'run))
  88                            " yet" ""))))
  89     (setq compilation-error-list (cdr compilation-error-list))
  90     (if (null (car (cdr next-error)))
  91         nil
  92       (switch-to-buffer (marker-buffer (car (cdr next-error))))
  93       (goto-char (car (cdr next-error)))
  94       (set-marker (car (cdr next-error)) nil))
  95     (let* ((pop-up-windows t)
  96            (w (display-buffer (marker-buffer (car next-error)))))
  97       (set-window-point w (car next-error))
  98       (set-window-start w (car next-error)))
  99     (set-marker (car next-error) nil)))
 100
 101 (defun eif-ise-compilation-filename ()
 102   "Return a string which is the last filename from the compilation command.
 103 Ignore quotes around it.  Return nil if no filename was given."
 104   ;; First arg of compile cmd should be filename
 105   (if (string-match "^.*[ \t]+\\([^ \t\"]+\\)" compile-command)
 106       (substring compile-command (match-beginning 1) (match-end 1))))
 107
 108 (defun eif-ise-compilation-parse-errors ()
 109   "Parse the current buffer as error messages.
 110 This makes a list of error descriptors, compilation-error-list.  For each
 111 error line-number in the buffer, the source file is read in, and the text
 112 location is saved in compilation-error-list.  The function next-error,
 113 assigned to \\[next-error], takes the next error off the list and visits its
 114 location."
 115   (setq compilation-error-list nil)
 116   (message "Parsing error messages...")
 117   (let (text-buffer
 118         last-filename last-linenum)
 119     ;; Don't reparse messages already seen at last parse.
 120     (goto-char compilation-parsing-end)
 121     ;; Don't parse the first two lines as error messages.
 122     ;; This matters for grep.
 123     (if (bobp)
 124         (forward-line 2))
 125     (let ((case-fold-search) class-name linenum filename
 126           error-marker text-marker)
 127       (while (re-search-forward compilation-error-regexp nil t)
 128         ;; Extract line number from error message.
 129         (setq linenum (string-to-int (buffer-substring
 130                                        (match-beginning 2)
 131                                        (match-end 2))))
 132         ;; Extract class name from error message and convert to the full
 133         ;; pathname of the class' source file.
 134         (setq class-name (buffer-substring (match-beginning 1) (match-end 1))
 135               filename (br-class-path class-name))
 136         (if (null filename) ; No matching class name in lookup table.
 137             (progn
 138               (message "Rebuilding Eiffel system class locations table...")
 139               (sit-for 2)
 140               ;; Next call is typically pretty fast.
 141               (call-interactively 'br-build-sys-classes-htable)
 142               (message "Rebuilding Eiffel system class locations table...Done")
 143               (setq filename (br-class-path class-name))
 144               (if (null filename)
 145                   (error "`%s' not in lookup table, use {M-x br-build-paths-htable RET} to update."
 146                          class-name))))
 147         ;; Locate the erring file and line.
 148         (if (and (equal filename last-filename)
 149                  (= linenum last-linenum))
 150             nil
 151           (beginning-of-line 1)
 152           (setq error-marker (point-marker))
 153           ;; text-buffer gets the buffer containing this error's file.
 154           (if (not (equal filename last-filename))
 155               (setq text-buffer
 156                     (and (file-exists-p (setq last-filename filename))
 157                          (if (boundp 'br-find-file-noselect-function)
 158                              (funcall br-find-file-noselect-function
 159                                       filename)
 160                            (find-file-noselect filename)))
 161                     last-linenum 0))
 162           (if text-buffer
 163               ;; Go to that buffer and find the erring line.
 164               (save-excursion
 165                 (set-buffer text-buffer)
 166                 (if (zerop last-linenum)
 167                     (progn
 168                       (goto-char 1)
 169                       (setq last-linenum 1)))
 170                 (forward-line (- linenum last-linenum))
 171                 (setq last-linenum linenum)
 172                 (setq text-marker (point-marker))
 173                 (setq compilation-error-list
 174                       (cons (list error-marker text-marker)
 175                             compilation-error-list)))))
 176         (forward-line 1)))
 177     (setq compilation-parsing-end (point-max)))
 178   (message "Parsing error messages...done")
 179   (setq compilation-error-list (nreverse compilation-error-list)))
 180
 181
 182 ;;; The following version of `eif-ec' courtesy of:
 183 ;;; Heinz W. Schmidt                                     hws@icsi.berkeley.edu
 184 ;;; International Computer Science Institute             (415) 643-9153   x175
 185 ;;; 1947 Center Street, Ste. 600                    /\/\|;; CLOS saves time and
 186 ;;; Berkeley, CA 94704                              \/\/|-- Eiffel is faster
 187 ;;; 2/11/90
 188 ;;; With a number of Bob Weiner's modifications
 189
 190 (defun str2argv (STR)
 191   (if (string-match "[^ ]" STR)
 192       (let ((arg1 (read-from-string STR)))
 193         (cons (prin1-to-string (car arg1))
 194               (str2argv (substring STR (cdr arg1)))))))
 195
 196 (defvar eif-ec-args "" "Default arguments to send to the Eiffel ec class compiler.")
 197
 198 (defun eif-ec (ARG &optional CMD DIR CLASS-NAME)
 199   "Calls Eiffel compiler.  Compile with optional CMD, `eif-compile-cmd' or \"ec\".
 200 By default, the compiler is called on the file associated with the current
 201 buffer.  With numeric argument 0 prompts for explicit command line arguments.
 202 Other numeric arguments allow you to insert options or further class names."
 203   (interactive "P")
 204   (setq CLASS-NAME (or CLASS-NAME
 205                        (let ((fn (file-name-nondirectory buffer-file-name)))
 206                          (substring fn 0 (- (length fn) 2))))
 207         ec-dir (or DIR eif-compile-dir (file-name-directory buffer-file-name)))
 208   (let* ((ec-output (get-buffer-create "*compilation*"))
 209          (ec-process (get-buffer-process ec-output))
 210          (curr-buffer (current-buffer)))
 211     (if ec-process
 212         (if (y-or-n-p "Kill current Eiffel compilation process? ")
 213             (delete-process ec-process)
 214           (error "Can't ec concurrently.")))
 215     (if (and (buffer-modified-p)
 216              (y-or-n-p (format "Save file %s? " buffer-file-name)))
 217         (progn (save-buffer) (message "")))
 218     ;; Maybe prompt for args and dispatch according to numeric ARG.
 219     (setq eif-ec-args (if ARG (read-string "ec args: " eif-ec-args) ""))
 220     ;; Switch to shell buffer and run ec.
 221     (set-buffer ec-output)
 222     (erase-buffer)
 223     ;; Move to directory and trim classname so ec works in situations
 224     ;; like: ec -t class1 <CLASS-NAME>
 225     (cd ec-dir)
 226     (insert (or CMD eif-compile-cmd "ec")
 227             (if ARG (format " %s" eif-ec-args) "")
 228             (format " %s" (if (not (and ARG (zerop ARG))) CLASS-NAME ""))
 229             "\n")
 230     (set-buffer curr-buffer)
 231     (display-buffer ec-output)
 232     (eval
 233      (append '(start-process "ec" ec-output (or CMD eif-compile-cmd "ec"))
 234              (str2argv eif-ec-args)
 235              (if (not (and ARG (zerop ARG))) (list CLASS-NAME))))))
 236
 237 (defun eif-es (&optional dir)
 238   "Compile Eiffel system with es."
 239   (interactive)
 240   (eif-ec nil "es" dir ""))
 241
 242 (provide 'eif-ise-er)