1 ;;; ***********************************************************
  2 ;;; *                                                         *
  3 ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4 ;;; *                                                         *
  5 ;;; * Copyright (c) 1978 by Massachusetts Institute of        *
  6 ;;; * Technology and Honeywell Information Systems, Inc.      *
  7 ;;; *                                                         *
  8 ;;; ***********************************************************
  9 
 10 ;;; HISTORY COMMENTS:
 11 ;;;  1) change(86-04-23,Margolin), approve(86-04-23,MCR7325),
 12 ;;;     audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136):
 13 ;;;     Added *expr declarations so that it would compile without warnings.
 14 ;;;  2) change(86-11-24,Margolin), approve(87-01-27,MCR7607),
 15 ;;;     audit(87-02-13,RBarstad), install(87-03-25,MR12.1-1014):
 16 ;;;     To not use "file_output" buffer, and to add one-error-scan-buffer,
 17 ;;;     compile-two-windows, and compile-local-display options.
 18 ;;;  3) change(87-01-28,Margolin), approve(87-01-28,MCR7607),
 19 ;;;     audit(87-02-13,RBarstad), install(87-03-25,MR12.1-1014):
 20 ;;;     Added display-compilation-result.
 21 ;;;                                                      END HISTORY COMMENTS
 22 
 23 
 24 ;;;
 25 (%include e-macros)
 26 (%include other_other)
 27 ^L
 28 
 29 ;;; Common part of error list processor.
 30 ;;; Paul Schauble, DVCP, Phoenix.
 31 
 32 (declare (special error-list-builder e-list error-scan-buffer
 33                   mode-identification fill-prefix buffer-minor-modes
 34                   current-buffer buffer-uid compiler fpathname
 35                   compile-options two-window-mode number-of-lines-in-buffer))
 36 (declare (*expr comout-to-buffer create-new-window-and-stay-here
 37                 redisplay-current-window-relative save-same-file))
 38 
 39 (defvar ((compile-local-display nil)
 40          (compile-two-windows nil)
 41          (error-list '())
 42          error-source-buffer
 43          nuwindows
 44          (one-error-scan-buffer t)))
 45 
 46 (defun locate-next-error ()
 47        (if (not (memq 'Error/ scan buffer-minor-modes))
 48            (build-new-error-list))
 49        (if e-list             ; Advance to next error
 50            (let ((error-entry (car e-list)))
 51                 (save-excursion-buffer
 52                   (find-buffer-in-window error-scan-buffer)
 53                   (without-modifying
 54                     (if-at '/=
 55                            (delete-char) (delete-char)
 56                            (insert-string "  "))
 57                     (go-to-mark (car error-entry))
 58                     (delete-char) (delete-char)
 59                     (insert-string "=>"))
 60                   (go-to-beginning-of-line)
 61                   (redisplay-current-window-relative 0)
 62                   (find-buffer-in-window previous-buffer))
 63                 (let ((z (cdr error-entry)))
 64                      (if z (go-to-mark z))))
 65            (setq e-list (cdr e-list))
 66            else
 67            (exit-error-scan-mode)
 68            (display-error "No more errors.")))
 69 
 70 (defun build-new-error-list ()
 71        (if error-list                             ;  Wipe old mark list
 72            (save-excursion-buffer
 73              (go-to-buffer error-scan-buffer)
 74              (exit-error-scan-mode)))
 75        (let ((crufty-error-list-builder error-list-builder)
 76              ;; Ack! Not bound correctly in file_output!!!
 77              (temp-error-list nil)
 78              (other-buffer current-buffer)
 79              (buffer-modified-flag t))
 80             (save-excursion-buffer
 81               (go-to-buffer error-scan-buffer)
 82               (unless (eq error-source-buffer other-buffer)
 83                       (display-error "This buffer was not the last one compiled."))
 84               (without-modifying
 85                 (go-to-end-of-buffer)
 86                 (setq temp-error-list (funcall crufty-error-list-builder)))
 87               (if (not (symbolp temp-error-list))
 88                   (setq buffer-uid -143
 89                         read-only-flag t)
 90                   else
 91                   (setq buffer-uid 0)))
 92             (setq error-list temp-error-list))    ;get into this buffer's variable
 93        (cond
 94          ((null error-list)
 95           (display-error "No errors found."))
 96          ((eq error-list 'not-compile)
 97           (setq error-list nil)
 98           (display-error "Last comout was not a compilation."))
 99                                                   ; That error returned so that error-list-builder does
100                                                   ; not command-quit while in file_output
101          ;; The mark list is a list of (<mark in file_output> . <line num>)
102          ;; convert the line num to a mark in the source buffer.
103          (t
104            (go-to-beginning-of-buffer)
105            (let ((line 1) (target) (move))
106                 (dolist (error-entry error-list)
107                     (setq target (cdr error-entry))
108                     (if target
109                         (setq move (- target line))
110                         (cond
111                           ((= move 0))            ; on that line now
112                           ((> move 0)             ; must advance
113                            (do-times move (next-line)))
114                           (t                      ; else move back
115                             (do-times (- move)(prev-line))))
116                         (setq line target)
117                         (rplacd error-entry (set-mark)))))
118                                                   ; error-list is now list of (<mark in file_output> . <mark in source>)
119            (setq e-list error-list)
120            (assert-minor-mode 'Error/ scan))))
121 
122 
123 
124 (defun exit-error-scan-mode ()
125        ; Must be in source buffer when called
126        (dolist (error-entry error-list)
127                (and (cdr error-entry)
128                     (release-mark (cdr error-entry))))
129        (save-excursion-buffer
130          (go-to-buffer error-scan-buffer)
131          (setq read-only-flag nil
132                buffer-uid 0
133                buffer-modified-flag t)
134          (if-at '/=
135                 (delete-char) (delete-char)
136                 (insert-string "  "))
137          (dolist (error-entry error-list)
138                  (release-mark (car error-entry)))
139          (setq buffer-modified-flag nil))
140        (negate-minor-mode 'Error/ scan)
141        (setq error-list nil
142              e-list nil))
143 ^L
144 ;;;
145 ;;; Conditional new line, does new line and insert special prefix
146 ;;;   if the current line has significant contents, it will be used.
147 ;;;   Note that the new prefix must be an arg, since this needs both
148 ;;;   the old and new values.
149 
150 (defun conditional-new-line (pfx)
151        (go-to-beginning-of-line)
152        (if (or (line-is-blank)
153                (and (looking-at fill-prefix)
154                     (= curlinel (1+ (stringlength fill-prefix)))))
155            (without-saving (kill-to-end-of-line))
156            else
157            (go-to-end-of-line)
158            (let ((fill-prefix "")) (new-line)))
159        (if pfx (insert-string pfx)))
160 ^L
161 
162 ;;;
163 ;;; Fortran compilatons, January 29, 1979, by Paul Schauble
164 ;;;
165 
166 (defun compile-buffer ()
167        (if buffer-modified-flag (save-same-file))
168        (mapc 'register-local-var
169              '(error-scan-buffer error-list e-list))
170        (if error-list (exit-error-scan-mode))
171        (let ((compile-command
172                (catenate compiler " " fpathname " " compile-options))
173              (curbuf current-buffer)
174              (type-buffer-expected mode-identification))
175             (setq error-scan-buffer
176                   (cond (one-error-scan-buffer '|Compilation Errors|)
177                         (t (make_atom
178                              (catenate current-buffer " Errors")))))
179             (minibuffer-print compile-command "<>")
180             (and compile-two-windows
181                  (< nuwindows 2)
182                  (create-new-window-and-stay-here))
183             (comout-to-buffer error-scan-buffer compile-command)
184             (register-local-var 'error-source-buffer)
185             (setq error-source-buffer curbuf)
186             (setq buffer-uid type-buffer-expected)
187             (cond ((> nuwindows 1))               ;display in other window
188                   (compile-local-display          ;local display the errors
189                     (display-buffer-as-printout)
190                     (end-local-displays))
191                   (t (display-compilation-result)))    ;local display success/failure
192             (find-buffer-in-window curbuf)))
193 
194 (defun display-compilation-result ()
195        (init-local-displays)
196        (local-display-generator
197          (cond ((> number-of-lines-in-buffer 2)
198                 (catenate (decimal-rep number-of-lines-in-buffer)
199                           " lines of compilation errors were generated."))
200                (t "No compilation errors were generated.")))
201        (end-local-displays))
202 
203 (defun set-compiler (comp)
204        (setq compiler (catenate comp " ")))
205 
206 (defun set-compile-options n
207        (setq compile-options "")
208        (do i 1 (1+ i) (> i n)
209            (setq compile-options (catenate compile-options " " (arg i)))))
210