home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / util / jade-3.0.lha / Jade / lisp / compile.jl < prev    next >
Encoding:
Text File  |  1994-04-16  |  7.6 KB  |  229 lines
  1. ;;;; compile.jl -- Running compilation processes
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (provide 'compile)
  21.  
  22. (setq
  23.   gcc-error-regexp "^(.*):([0-9]+):(.+)"
  24.   gcc-file-expand "\\1"
  25.   gcc-line-expand "\\2"
  26.   gcc-error-expand "\\3")
  27.  
  28. (defvar compile-error-regexp gcc-error-regexp)
  29. (defvar compile-file-expand gcc-file-expand)
  30. (defvar compile-line-expand gcc-line-expand)
  31. (defvar compile-error-expand gcc-error-expand)
  32.  
  33. (defvar compile-keymap (make-keylist))
  34.  
  35. (unless (boundp 'compile-buffer)
  36.   (bind-keys compile-keymap
  37.     "ctrl-c" 'kill-compilation
  38.     "ctrl-z" 'stop-compilation
  39.     "ctrl-f" 'continue-compilation
  40.     "r" '(start-compile-command compile-default-cmd compile-type-str)
  41.     "ctrl-r" 'compile))
  42.  
  43. (defvar compile-buffer nil)
  44. (defvar compile-proc nil)
  45. (defvar compile-argv ["sh" "-c" nil])
  46. (defvar compile-errors nil "List of (ERROR-POS-MARK . ERROR-DESC-LINE)")
  47. (defvar compile-error-pos nil)
  48. (defvar compile-type-str nil)
  49. (defvar compile-error-parsed-errors-p nil)
  50. (defvar compile-errors-exist-p nil)
  51.  
  52. (defvar compile-default-cmd "make"
  53.   "Default command which `(compile)' executes, the value of the last
  54. command executed by `(compile)'.")
  55.  
  56. (defvar compile-command nil
  57.   "Buffer-local symbol which contains the command to compile this buffer. If
  58. nil or unbound use `compile-default-cmd'.")
  59. (set-buffer-variable 'compile-command)
  60.  
  61. (defun compile-init ()
  62.   (if compile-buffer
  63.       (clear-buffer compile-buffer)
  64.     (setq compile-buffer (make-buffer "*compilation*"))
  65.     (with-buffer compile-buffer
  66.       (setq ctrl-c-keymap compile-keymap))
  67.     (set-buffer-special compile-buffer t))
  68.   (when compile-buffer
  69.     (add-buffer compile-buffer)
  70.     (set-file-name compile-buffer (path-name (file-name)))
  71. ;;; (when (equal (file-name compile-buffer) "")
  72. ;;;   (set-file-name compile-buffer "."))
  73.     (setq
  74.       compile-errors nil
  75.       compile-parsed-errors-p nil
  76.       compile-errors-exists-p nil
  77.       compile-error-pos (pos 1 1))
  78.     t))
  79.  
  80. (defun compile-proc-end ()
  81.   (when compile-proc
  82.     (with-buffer compile-buffer
  83.       (beep)
  84.       (if (process-exit-value compile-proc)
  85.       (format (cons compile-buffer t)
  86.         "\ncompilation exited with value %d\n"
  87.         (process-exit-value compile-proc))
  88.     (format (cons compile-buffer t)
  89.       "\ncompilation exited abnormally: status 0x%x\n"
  90.       (process-exit-status compile-proc)))
  91.       (aset compile-argv 2 nil)
  92.       (setq
  93.     compile-proc nil))))
  94.  
  95. (defun start-compile-command (command type-str &aux shell-cmd)
  96.   "(start-compile-command SHELL-COMMAND ERROR-TYPE-STR)
  97. Executes SHELL-COMMAND asynchronously in the directory containing the file
  98. being edited in the current buffer. Output from the process is sent to the
  99. `*compilation*' buffer."
  100.   (if compile-proc
  101.       (signal 'error '("Compilation process already running"))
  102.     (save-some-buffers)
  103.     (compile-init)
  104.     (goto-buffer compile-buffer)
  105.     (setq
  106.       compile-proc (make-process (cons compile-buffer t) 'compile-proc-end)
  107.       shell-cmd (concat "cd " (if (equal (file-name) "") "." (file-name))
  108.             " && " command ?\n))
  109.     (write compile-buffer shell-cmd)
  110.     (aset compile-argv 2 shell-cmd)
  111.     (when (fork-process compile-proc "/bin/sh" compile-argv)
  112.       (setq compile-type-str type-str)
  113.       compile-proc)))
  114.  
  115. (defun kill-compilation ()
  116.   (when compile-proc
  117.     (interrupt-process compile-proc)))
  118. (defun stop-compilation ()
  119.   (when (process-running-p compile-proc)
  120.     (stop-process compile-proc)))
  121. (defun continue-compilation ()
  122.   (when (process-stopped-p compile-proc)
  123.     (continue-process compile-proc)))
  124.  
  125. (defun compile (&optional command)
  126.   (unless command
  127.     (setq command
  128.       (unless compile-command
  129.     (setq compile-default-cmd (prompt "Compile command: " compile-default-cmd)))))
  130.   (when command
  131.     (start-compile-command command "errors" t)))
  132.  
  133. (defun compile-parse-errors ()
  134.   ;; This can be called while the process is still running, one problem though,
  135.   ;; if the compiled file is modified and then a new error is found the line
  136.   ;; numbers won't coincide like they normally would.
  137.   (unless compile-parsed-errors-p
  138.     (with-buffer compile-buffer
  139.       (let*
  140.       (error-file
  141.        error-line
  142.        last-e-line
  143.        last-e-file
  144.        new-errors)
  145.     (while (setq compile-error-pos (find-next-regexp compile-error-regexp compile-error-pos))
  146.       (setq error-line (read-from-string (regexp-expand-line compile-error-regexp compile-line-expand compile-error-pos)))
  147.       (when (or (not last-e-line) (/= error-line last-e-line))
  148.         (setq
  149.           last-e-line error-line
  150.           error-file (file-concat (file-name) (regexp-expand-line compile-error-regexp compile-file-expand compile-error-pos)))
  151.         (if (equal last-e-file error-file)
  152.         (setq error-file last-e-file)
  153.           (setq last-e-file error-file))
  154.         (setq new-errors
  155.           (cons
  156.         (cons
  157.           (make-mark (pos 1 error-line) error-file)
  158.           (pos-line compile-error-pos))
  159.         new-errors)))
  160.       (setq compile-error-pos find-last-end-pos))
  161.     (when new-errors
  162.       (setq
  163.         compile-errors (nconc compile-errors (nreverse new-errors))
  164.         compile-errors-exist-p t))))
  165.     (unless compile-proc
  166.       (setq compile-parsed-errors-p t)))
  167.   t)
  168.  
  169. (defun next-error ()
  170.   "(next-error)
  171. Moves the cursor to the file and line of the next error displayed in the
  172. `*compilation*' buffer."
  173.   (compile-parse-errors)
  174.   (let*
  175.       ((err (car compile-errors)))
  176.     (setq compile-errors (cdr compile-errors))
  177.     (cond
  178.       ((not err)
  179.     (title
  180.       (concat
  181.         "No "
  182.         (if compile-errors-exist-p "more ")
  183.         compile-type-str
  184.         (if compile-proc " yet")))
  185.     (beep)
  186.     nil)
  187.       (t
  188.     (goto-mark (car err))
  189.     (when (cdr err)
  190.       (title
  191.         (regexp-expand-line
  192.           compile-error-regexp compile-error-expand
  193.           (pos 1 (cdr err)) compile-buffer)))
  194.     t))))
  195.  
  196. (defun grep (&optional args)
  197.   "(grep [ARGS-STRING])
  198. Runs the `grep' program with ARGS-STRING (or the result of a prompt) and
  199. sends its output to the `*compilation*' buffer. The `grep' process may still
  200. be executing when this function returns."
  201.   (unless args
  202.     (setq args (prompt "Grep with args: ")))
  203.   (when args
  204.     (start-compile-command (concat "grep -n " args " /dev/null /dev/null") "grep-hits" nil)))
  205.  
  206. (defvar grep-buffer-regexp nil
  207.   "Regular-expression which `grep-buffer' scans for")
  208.  
  209. (defun grep-buffer (&optional regexp)
  210.   "(grep-buffer [REGEXP])
  211. Scans the current buffer for all matches of REGEXP (or the contents of
  212. variable `grep-buffer-regexp'). All hits are displayed in the `*compilation*'
  213. buffer in a form that `goto-next-error' understands."
  214.   (when regexp
  215.     (setq grep-buffer-regexp regexp))
  216.   (when (and grep-buffer-regexp (compile-init))
  217.     (let*
  218.     ((scanpos (pos 1 1))
  219.      (number 0)
  220.      (stream (cons compile-buffer t)))
  221.       (write stream ?\n)
  222.       (while (setq scanpos (find-next-regexp grep-buffer-regexp scanpos))
  223.     (format stream "%s:%d:%s\n" (file-name) (pos-line scanpos) (copy-area (line-start scanpos) (line-end scanpos)))
  224.     (setq number (+ number 1))
  225.     (setq scanpos (line-end scanpos)))
  226.       (goto-buffer compile-buffer)
  227.       (goto (pos 1 1))
  228.       number)))
  229.