;;; Zwei compiler commands, see ZWEI;COMA for comments -*-Mode:LISP; Package:ZWEI-*-
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **

(DEFCOM COM-EVALUATE-MINI-BUFFER "Evaluate a form from the mini-buffer." (KM)
  (EVALUATE-MINI-BUFFER))

(DEFUN EVALUATE-MINI-BUFFER (&OPTIONAL INITIAL-CONTENTS INITIAL-CHAR-POS &AUX INTERVAL)
  (MULTIPLE-VALUE (NIL NIL INTERVAL)
    (EDIT-IN-MINI-BUFFER *MINI-BUFFER-MULTI-LINE-COMTAB* INITIAL-CONTENTS INITIAL-CHAR-POS
			 '("Forms to evaluate (end with End)")))
  (LET ((FORM-STRING (STRING-INTERVAL INTERVAL)))
    (DO ((LEN (STRING-LENGTH FORM-STRING))
	 (I 0)
	 (FORM)
	 (EOF '(())))
	(NIL)
      (MULTIPLE-VALUE (FORM I)
	(READ-FROM-STRING FORM-STRING EOF I))
      (COND ((EQ FORM EOF)
	     (AND (> I LEN) (RETURN NIL))
	     (BARF "Unbalanced parentheses.")))
      (DO ((VALS (LET ((STANDARD-OUTPUT *TYPEOUT-WINDOW*)
		       (STANDARD-INPUT *TYPEOUT-WINDOW*))
		   (MULTIPLE-VALUE-LIST (EVAL FORM)))
		 (CDR VALS))
	   (FLAG T NIL))
	  ((NULL VALS))
	(FUNCALL (IF FLAG #'TYPEIN-LINE #'TYPEIN-LINE-MORE) "~:[, ~]~S" FLAG (CAR VALS)))))
  DIS-TEXT)	;DIS-TEXT in case user manually alters the buffer with Lisp code

(DEFCOM COM-EVALUATE-INTO-BUFFER
	"Evaluate a form from the mini-buffer and insert the result into the buffer.
If given an argument, things printed by the evaluation go there as well." (KM)
  (LET ((FORM (TYPEIN-LINE-READ "Lisp form: (end with END)"))
	(STREAM (INTERVAL-STREAM-INTO-BP (POINT))))
    (FORMAT STREAM "~&~S"
	    (LET ((STANDARD-OUTPUT (IF *NUMERIC-ARG-P* STREAM STANDARD-OUTPUT)))
	      (EVAL FORM)))
    (MOVE-BP (POINT) (FUNCALL STREAM ':READ-BP)))
  DIS-TEXT)

(DEFCOM COM-EVALUATE-AND-REPLACE-INTO-BUFFER
	"Evaluate the next s-expression and replace the result into the buffer" ()
  (LET* ((POINT (POINT)) (MARK (MARK))
	 (STREAM (REST-OF-INTERVAL-STREAM POINT))
	 (FORM (READ STREAM '*EOF*)))
    (AND (EQ FORM '*EOF*) (BARF))
    (SETQ FORM (EVAL FORM))
    (MOVE-BP MARK (FUNCALL STREAM ':READ-BP))
    (UNDO-SAVE POINT MARK T "replacement")
    (PRIN1 FORM STREAM)
    (WITH-BP (END (FUNCALL STREAM ':READ-BP) ':NORMAL)
      (DELETE-INTERVAL POINT MARK T)
      (MOVE-BP POINT END)))
  DIS-TEXT)

(DEFCOM COM-MICROCOMPILE-DEFUN "Microcompile the current defun." ()
  (COMPILE-DEFUN-INTERNAL T "Microcompiling" "microcompiled."
			  NIL    ;USE-TYPEOUT
			  NIL    ;DEFVAR-HACK
			  'COMPILER:MICRO-COMPILE)
  DIS-NONE)

(DEFCOM COM-COMPILE-DEFUN "Compile the current defun." ()
  (COMPILE-DEFUN-INTERNAL T "Compiling" "compiled.")
  DIS-NONE)

(DEFCOM COM-EVALUATE-DEFUN "Evaluate the current defun.
Result is typed out in the echo area." ()
  (COMPILE-DEFUN-INTERNAL  (GET-BUFFER-EVALUATOR *INTERVAL*)
			   "Evaluating"
			   "evaluated."
			   ':PROMPT)
  DIS-NONE)

(DEFCOM COM-EVALUATE-DEFUN-VERBOSE "Evaluate the current defun.
Result is typed out in the typeout window." ()
  (COMPILE-DEFUN-INTERNAL  (GET-BUFFER-EVALUATOR *INTERVAL*)
			   "Evaluating"
			   "evaluated."
			   T)
  DIS-NONE)

(DEFCOM COM-EVALUATE-DEFUN-HACK "Evaluate the current defun.
DEFVAR's are turned into SETQ's" ()
  (COMPILE-DEFUN-INTERNAL  (GET-BUFFER-EVALUATOR *INTERVAL*)
			   "Evaluating"
			   "evaluated."
			   ':PROMPT T)
  DIS-NONE)

(DEFUN COMPILE-DEFUN-INTERNAL (COMPILE-P MODE-NAME ECHO-NAME
			       &OPTIONAL USE-TYPEOUT DEFVAR-HACK
			       (COMPILER-PROCESSING-MODE 'COMPILER:MACRO-COMPILE)
			       &AUX BP1 BP2 DEFUN-NAME)
  (COND ((WINDOW-MARK-P *WINDOW*)
	 (SETQ BP1 (MARK) BP2 (POINT))
	 (OR (BP-< BP1 BP2) (PSETQ BP1 BP2 BP2 BP1))
	 (SETQ DEFUN-NAME "Region"))
	((MULTIPLE-VALUE (BP1 DEFUN-NAME) (DEFUN-INTERVAL (BEG-LINE (POINT)) 1 NIL NIL))
	 (SETQ BP2 (INTERVAL-LAST-BP BP1) BP1 (INTERVAL-FIRST-BP BP1))
	 (SETQ DEFUN-NAME (GET-DEFUN-NAME DEFUN-NAME)
	       DEFVAR-HACK T)
	 (OR (EQ (ARRAY-TYPE DEFUN-NAME) 'ART-STRING)
	     (SETQ DEFUN-NAME (STRING-APPEND "" DEFUN-NAME))))	;Make printable
	(T
	 (BARF "Unbalanced parentheses")))
  (COMPILE-PRINT-INTERVAL BP1 BP2 T COMPILE-P
			  DEFUN-NAME MODE-NAME ECHO-NAME USE-TYPEOUT DEFVAR-HACK
			  COMPILER-PROCESSING-MODE))


(DEFUN COMPILE-PRINT-INTERVAL (BP1 BP2 IN-ORDER-P COMPILE-P DEFUN-NAME MODE-NAME ECHO-NAME
			       &OPTIONAL USE-TYPEOUT DEFVAR-HACK
			       (COMPILER-PROCESSING-MODE  'COMPILER:MACRO-COMPILE)
			       &AUX FORMAT-FUNCTION)
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (SETQ FORMAT-FUNCTION (SELECTQ USE-TYPEOUT
			  (:TYPEOUT #'(LAMBDA (STRING &REST ARGS)
					(LEXPR-FUNCALL #'FORMAT *TYPEOUT-WINDOW*
						       STRING ARGS)))
			  (:PROMPT #'PROMPT-LINE)
			  (OTHERWISE #'TYPEIN-LINE)))
  (FUNCALL FORMAT-FUNCTION "~&~A ~A" MODE-NAME DEFUN-NAME)
  (COMPILE-INTERVAL COMPILE-P (EQ USE-TYPEOUT T) DEFVAR-HACK BP1 BP2 T
		    COMPILER-PROCESSING-MODE
		    (IF *NUMERIC-ARG-P* T))  ;do read followed by processing.
  (UPDATE-INTERVAL-COMPILE-TICK BP1 BP2 T)
  (OR (EQ USE-TYPEOUT ':TYPEOUT)		;Unless being preserved
      (FUNCALL FORMAT-FUNCTION "~&~A ~A" DEFUN-NAME ECHO-NAME)))

;;; Given a BP to the beginning of a DEFUN (as returned by BACKWARD-DEFUN,
;;; or MARK-DEFUN), return the name of the function it defines as a
;;; temporary NSUBSTRING.  Be careful using the returned string.
(DEFUN GET-DEFUN-NAME (BP &AUX BP1)
  ;; Now get the second word after BP.
  (AND (SETQ BP (FORWARD-ATOM BP))
       (SETQ BP (FORWARD-OVER *BLANKS* BP))
       (SETQ BP1 (FORWARD-SEXP BP))
       (STRING-INTERVAL BP BP1)))

(DEFUN GET-BUFFER-EVALUATOR (BUFFER)
  (AND (TYPEP BUFFER 'FILE-BUFFER)
       (FUNCALL (BUFFER-GENERIC-PATHNAME BUFFER) ':GET ':EVALUATOR)))

(DEFCOM COM-EVALUATE-BUFFER "Evaluate the entire buffer." ()
  (COMPILE-BUFFER (GET-BUFFER-EVALUATOR *INTERVAL*) "Evaluating" "evaluated."))

(DEFCOM COM-COMPILE-BUFFER "Compile the entire buffer." ()
  (COMPILE-BUFFER T "Compiling" "compiled."))

(DEFCOM COM-MICROCOMPILE-BUFFER "Microcompile the entire buffer." ()
  (COMPILE-BUFFER T "Microcompiling" "microcompiled." 'COMPILER:MICRO-COMPILE))

(DEFUN COMPILE-BUFFER (COMPILE-P MODE-NAME ECHO-NAME
		       &OPTIONAL (COMPILER-PROCESSING-MODE 'COMPILER:MACRO-COMPILE)
		       &AUX BP1 BP2 NAME)
  (IF *NUMERIC-ARG-P*
      (SETQ BP1 (POINT) BP2 (INTERVAL-LAST-BP *INTERVAL*) NAME "Rest of buffer")
      (SETQ BP1 *INTERVAL* NAME "Buffer"))
  (COMPILE-PRINT-INTERVAL BP1 BP2 T COMPILE-P NAME MODE-NAME ECHO-NAME
			  NIL ;USE-TYPEOUT
			  NIL ;DEFVAR-HACK
			  COMPILER-PROCESSING-MODE)
  DIS-NONE)

(DEFCOM COM-EVALUATE-REGION "Evaluate just between point and the mark." ()
  (REGION (BP1 BP2)
    (COMPILE-PRINT-INTERVAL BP1 BP2 T (GET-BUFFER-EVALUATOR *INTERVAL*)
			    "Region" "Evaluating" "evaluated."))
  DIS-NONE)

(DEFCOM COM-COMPILE-REGION "Compile just between point and the mark." ()
  (REGION (BP1 BP2)
    (COMPILE-PRINT-INTERVAL BP1 BP2 T T
			    "Region" "Compiling" "compiled."))
  DIS-NONE)

(DEFCOM COM-MICROCOMPILE-REGION "Microcompile just between point and the mark." ()
  (REGION (BP1 BP2)
    (COMPILE-PRINT-INTERVAL BP1 BP2 T T
			    "Region" "Microcompiling" "microcompiled."
			    NIL ;USE-TYPEOUT
			    NIL ;DEFVAR-HACK
			    'COMPILER:MICRO-COMPILE))
  DIS-NONE)

;If COMPILE-P is not T or NIL, its a function to call to do an EVAL-PRINT type operation 
(LOCAL-DECLARE ((SPECIAL COMPILE-P USE-TYPEOUT DEFVAR-HACK COMPILE-PROCESSING-MODE))
(DEFUN COMPILE-INTERVAL (COMPILE-P USE-TYPEOUT DEFVAR-HACK BP1 &OPTIONAL BP2 IN-ORDER-P
			 (COMPILE-PROCESSING-MODE 'COMPILER:MACRO-COMPILE)
			 (READ-THEN-PROCESS-FLAG NIL)
			 &AUX (STANDARD-OUTPUT *TYPEOUT-WINDOW*)
			      GENERIC-PATHNAME)
  (SETQ GENERIC-PATHNAME (IF (TYPEP *INTERVAL* 'FILE-BUFFER)
			     (BUFFER-GENERIC-PATHNAME *INTERVAL*)
			     (FS:MAKE-DUMMY-PATHNAME "Unknown")))
  ;; Should re-read the mode line at the front of the file in case it has changed
  ;; Unfortunately SI:FILE-READ-PROPERTY-LIST doesn't work on interval streams.
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (CHECK-INTERVAL-SECTIONS BP1 BP2 T)
  (COMPILER:COMPILE-STREAM
    (INTERVAL-STREAM BP1 BP2 T)
    GENERIC-PATHNAME
    NIL		;FASD-FLAG
    #'(LAMBDA (FORM)		;PROCESS-FN
	(COND ((AND DEFVAR-HACK
		    (LISTP FORM)
		    (> (LENGTH FORM) 2)
		    (MEMQ (CAR FORM) '(DEFVAR DEFCONST)))
	       (OR (SYMBOLP (CADR FORM))
		   (FERROR NIL "~S not a recognized form" FORM))
	       (PUTPROP (CADR FORM) T 'SPECIAL)	;Declare it
	       (COND ((> (LENGTH FORM) 3)	;in case there is a documentation string.
		      (PUTPROP (SECOND FORM) (EVAL (FOURTH FORM)) ':VALUE-DOCUMENTATION)
		      (SETQ FORM (NBUTLAST FORM))))	;remove documentation so that
						;hack into SETQ works properly.
	       (SETF (CAR FORM) 'SETQ)))	;then always SETQ
	(COND ((EQ COMPILE-P T)
	       (COMPILER:COMPILE-DRIVER FORM
					#'COMPILE-BUFFER-FORM NIL))
	      (COMPILE-P
	       (FUNCALL COMPILE-P FORM))
	      (T
	       (RECORD-DEFUN FORM *INTERVAL*)
	       (EVAL-PRINT FORM USE-TYPEOUT))))
    T	;QC-FILE-LOAD-FLAG
    NIL ;QC-FILE-IN-CORE-FLAG
    NIL ;PACKAGE-SPEC
    NIL ;FILE-LOCAL-DECLARATIONS
    READ-THEN-PROCESS-FLAG     ;READ-THEN-PROCESS-FLAG
    )))

(DEFUN EVAL-PRINT (OBJECT USE-TYPEOUT)
  (LET ((LIST (MULTIPLE-VALUE-LIST (EVAL OBJECT))))
    (DOLIST (VAL LIST)
      (IF USE-TYPEOUT (PRINT VAL) (LET ((PRINLENGTH 5) (PRINLEVEL 2))
				    (TYPEIN-LINE "~S" VAL))))
    (VALUES (CAR LIST) OBJECT)))

;;; Functional to be passed to COMPILE-DRIVER.
(DEFUN COMPILE-BUFFER-FORM (FORM TYPE &AUX NAME LAMBDA)
  (DECLARE (SPECIAL COMPILE-PROCESSING-MODE))
  (IF (MEMQ TYPE '(DECLARE RANDOM SPECIAL))
      (EVAL FORM)
      (RECORD-DEFUN FORM *INTERVAL*)
      (SETQ NAME (CADR FORM)
	    LAMBDA (CONS 'LAMBDA (CDDR FORM)))
      (IF (EQ TYPE 'MACRO)
	  (COMPILER:COMPILE-1 NAME (CONS 'MACRO LAMBDA))
	  (COMPILER:COMPILE-1 NAME LAMBDA COMPILE-PROCESSING-MODE))))

;;; This does not really get the right arguments, but can at least make it so that M-.
;;; knows what buffer to sectionize to find the thing
(DEFUN RECORD-DEFUN (FORM INTERVAL)
  (AND (LISTP FORM) (MEMQ (CAR FORM) '(DEFUN MACRO))
       (TYPEP INTERVAL 'FILE-BUFFER)
       (LET ((SYM (SYMBOL-FROM-STRING (CADR FORM))))
	 (COND ((NOT (ASSQ INTERVAL (SI:FUNCTION-SPEC-GET SYM 'ZMACS-BUFFERS)))
		;; NIL for a LINE will never be believed to be valid, forcing sectionization.
		(PUSH (CONS INTERVAL NIL) (SI:FUNCTION-SPEC-GET SYM 'ZMACS-BUFFERS))
		;; This will make sectionizing forget the bogus entry above.
		(LET ((GENERIC-PATHNAME (BUFFER-GENERIC-PATHNAME INTERVAL) ))
		  (PUSH SYM (FUNCALL GENERIC-PATHNAME ':GET 'ZMACS-SECTION-LIST))))))))

(DEFCOM COM-MACRO-EXPAND-SEXP "Macroexpand the next s-expression" ()
  (LET ((STREAM (REST-OF-INTERVAL-STREAM (POINT))))
    (LET ((FORM (READ STREAM '*EOF*)))
      (AND (EQ FORM '*EOF*) (BARF))
      (GRIND-TOP-LEVEL (MACRO-EXPAND-ALL FORM))))
  DIS-NONE)

(DEFUN MACRO-EXPAND-ALL (FORM)
  (SETQ FORM (MACROEXPAND FORM))
  (AND (LISTP FORM)
       (DO ((L FORM (CDR L)))
	   ((OR (NULL L)
		(ATOM L)))
	   (COND ((ATOM (CDR L))		;L may be a dotted pair therefore CDR'ing down
						;list won't do quite the expected thing.
		  (SETF (CAR L)(MACRO-EXPAND-ALL (CAR L)))
		  (SETF (CDR L)(MACRO-EXPAND-ALL (CDR L))))
		 (T (SETF (CAR L) (MACRO-EXPAND-ALL (CAR L)))))))
  FORM)

;Given a function (a symbol!), return the correspondence between
;its sublists and symbols and positions in the buffer which holds the text for it.
;Should handle functions which are not symbols.
;; The caller should set up a catch for TRANSFER-CORRESPONDENCE-LOSSAGE
;; in case the function text and expr definition don't actually match.
(DEFUN FUNCTION-CORRESPONDENCE (FUNCTION)
  (LET* ((LOCATION (CAR (DEFINITION-TEXT-LOCATION FUNCTION)))
	 (BUFFER (CAR LOCATION))
	 (LINE (CDR LOCATION))
	 (INT (DEFUN-INTERVAL (CREATE-BP LINE 0) 1 NIL NIL))
	 (DEFINITION (FDEFINITION FUNCTION))
	 NEWSEXP TEM
	 (CORRESPONDENCE (GET FUNCTION 'ZMACS-CORRESPONDENCE)))
    (COND ((OR (NULL CORRESPONDENCE)
	       (NEQ (CAR CORRESPONDENCE) DEFINITION)
	       (> (INTERVAL-REAL-TICK INT) (CADDR CORRESPONDENCE)))
	   ;; Read in the text.  Get a new sexp for the function,
	   ;; together with a correspondence between it and the text.
	   (MULTIPLE-VALUE (NEWSEXP CORRESPONDENCE)
	     (ESTABLISH-CORRESPONDENCE DEFINITION BUFFER INT))
	   ;; If function is traced, find original definition.
	   (COND ((AND (EQ (CAR DEFINITION) 'NAMED-LAMBDA)
		       (NOT (ATOM (CADR DEFINITION)))
		       (SETQ TEM (ASSQ 'TRACE (CDADR DEFINITION))))
		  (SETQ DEFINITION (FDEFINITION (CADR TEM)))))
	   (SETQ TEM (MEMQ NEWSEXP CORRESPONDENCE))
	   (AND TEM (RPLACA TEM DEFINITION))
	   (SETQ NEWSEXP (CDDR NEWSEXP))	;Flush DEFUN or DEFMETHOD, and fn name.
	   (SELECTQ (CAR DEFINITION)		;Flush LAMBDA, or NAMED-LAMBDA and name.
	     (LAMBDA (SETQ DEFINITION (CDR DEFINITION)))
	     (NAMED-LAMBDA (SETQ DEFINITION (CDDR DEFINITION))))
	   ;; Now the new sexp should look like the definition.
	   ;; Move the correspondence to the definition.
	   (TRANSFER-CORRESPONDENCE FUNCTION CORRESPONDENCE NEWSEXP DEFINITION)
	   (PUTPROP FUNCTION CORRESPONDENCE 'ZMACS-CORRESPONDENCE)))
    CORRESPONDENCE))

(DEFUN ESTABLISH-CORRESPONDENCE (DEFINITION BUFFER BP1 &OPTIONAL BP2 IN-ORDER-P)
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (LET ((STREAM (INTERVAL-STREAM BP1 BP2 T))
	(SI:XR-CORRESPONDENCE-FLAG T)
	SI:XR-CORRESPONDENCE)
    (VALUES (READ STREAM)
	    `(,DEFINITION ,BUFFER ,(NODE-TICK BUFFER)
	      ,BP1 ,BP2 . ,SI:XR-CORRESPONDENCE))))

;When's the latest any line between BP1 and BP2 was modified?
(DEFUN INTERVAL-REAL-TICK (BP1 &OPTIONAL BP2 IN-ORDER-P)
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (DO ((LINE (BP-LINE BP1) (LINE-NEXT LINE))
       (END-LINE (BP-LINE BP2))
       (MAX-TICK 0))
      (NIL)
    (SETQ MAX-TICK (MAX MAX-TICK (LINE-TICK LINE)))
    (AND (EQ LINE END-LINE)
	 (RETURN MAX-TICK))))

;; Given a correspondence from the sexp TEMPDEF, matches up TEMPDEF
;; and REALDEF and clobbers the correspondence to be from REALDEF instead.
;; FUNCTION is just for error messages.  
;; We throw to TRANSFER-CORRESPONDENCE-LOSSAGE if the two sexps don't match.
(DEFUN TRANSFER-CORRESPONDENCE (FUNCTION CORRESPONDENCE TEMPDEF REALDEF)
  (LET ((TEM (MEMQ TEMPDEF CORRESPONDENCE)))
    (AND TEM (RPLACA TEM REALDEF)))
  ;; In the real definition, some displacing macros may have gone off.
  (AND (EQ (CAR REALDEF) 'SI:DISPLACED)
       (SETQ REALDEF (CADR REALDEF)))
  (OR (= (LENGTH TEMPDEF) (LENGTH REALDEF))
      (THROW NIL TRANSFER-CORRESPONDENCE-LOSSAGE))
  (DO ((TD TEMPDEF (CDR TD))
       (RD REALDEF (CDR RD)))
      ((NULL TD))
    (AND (COND ((ATOM (CAR TD)) (NEQ (CAR TD) (CAR RD)))
	       (T (ATOM (CAR RD))))
	 (THROW NIL TRANSFER-CORRESPONDENCE-LOSSAGE))
    (OR (ATOM (CAR TD))
	(TRANSFER-CORRESPONDENCE FUNCTION CORRESPONDENCE (CAR TD) (CAR RD)))))

;;; These functions know about zmacs buffers and nodes
(DEFUN UPDATE-INTERVAL-COMPILE-TICK (BP1 &OPTIONAL BP2 IN-ORDER-P)
  (TICK)
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (DO ((NODE (BP-NODE BP1) (NODE-NEXT NODE)))
      ((OR (NULL NODE)
	   (NOT (BP-< (INTERVAL-FIRST-BP NODE) BP2))))
    (AND (TYPEP NODE 'SECTION-NODE)
	 (SETF (SECTION-NODE-COMPILE-TICK NODE) *TICK*))))

(DEFCOM COM-COMPILE-BUFFER-CHANGED-FUNCTIONS "Compile any sections which have been edited"
	()
  (COMPILER:COMPILER-WARNINGS-CONTEXT-BIND
    (COMPILE-BUFFER-CHANGED-FUNCTIONS *INTERVAL* *NUMERIC-ARG-P*))
  (FORMAT T "~&Done.~%")
  DIS-NONE)

(DEFCOM COM-COMPILE-CHANGED-FUNCTIONS "Compile any sections which have been edited" ()
  (COMPILER:COMPILER-WARNINGS-CONTEXT-BIND
    (DOLIST (BUFFER *ZMACS-BUFFER-LIST*)
      (AND (EQ (IF (EQ BUFFER *INTERVAL*) *MAJOR-MODE*
		   (BUFFER-SAVED-MAJOR-MODE BUFFER))
	       'LISP-MODE)
	   (COMPILE-BUFFER-CHANGED-FUNCTIONS BUFFER *NUMERIC-ARG-P*))))
  (FORMAT T "~&Done.~%")
  DIS-NONE)

(DEFCOM COM-EVALUATE-BUFFER-CHANGED-FUNCTIONS "Evaluate any sections which have been edited"
	()
  (COMPILE-BUFFER-CHANGED-FUNCTIONS *INTERVAL* *NUMERIC-ARG-P* NIL
				    '("Evaluate" "Evaluating" "evaluated."))
  (FORMAT T "~&Done.~%")
  DIS-NONE)

(DEFCOM COM-EVALUATE-CHANGED-FUNCTIONS "Evaluate any sections which have been edited" ()
  (DOLIST (BUFFER *ZMACS-BUFFER-LIST*)
    (AND (EQ (IF (EQ BUFFER *INTERVAL*) *MAJOR-MODE*
		 (BUFFER-SAVED-MAJOR-MODE BUFFER))
	     'LISP-MODE)
	 (COMPILE-BUFFER-CHANGED-FUNCTIONS BUFFER *NUMERIC-ARG-P*
					   NIL '("Evaluate" "Evaluating" "evaluated.") )))
  (FORMAT T "~&Done.~%")
  DIS-NONE)

(DEFUN COMPILE-BUFFER-CHANGED-FUNCTIONS (*INTERVAL* ASK-P
					 &OPTIONAL (COMPILE-P T)
					 (NAMES '("Compile" "Compiling" "compiled."))
					 &AUX (QUERY-IO *TYPEOUT-WINDOW*))
  (DOLIST (SECTION (NODE-INFERIORS *INTERVAL*))
    (AND (TYPEP SECTION 'SECTION-NODE)
	 (> (NODE-TICK SECTION) (SECTION-NODE-COMPILE-TICK SECTION))
	 (LET ((NAME (GET-SECTION-NODE-NAME SECTION)))
	   (AND (OR (NOT ASK-P)
		    (FQUERY '(:SELECT T) "~A ~A? " (FIRST NAMES) NAME))
		(COMPILE-PRINT-INTERVAL SECTION NIL T COMPILE-P NAME
					(SECOND NAMES) (THIRD NAMES) ':TYPEOUT T))))))

(DEFUN GET-SECTION-NODE-NAME (SECTION-NODE &AUX DEFUN-LINE)
  (IF (SETQ DEFUN-LINE (SECTION-NODE-DEFUN-LINE SECTION-NODE))
      (GET-DEFUN-NAME (CREATE-BP DEFUN-LINE 0))
      (SECTION-NODE-NAME SECTION-NODE)))

(DEFCOM COM-LIST-CHANGED-FUNCTIONS "List any sections which have been edited" ()
  (LET ((ITEM-LIST (LIST-CHANGED-FUNCTIONS-INTERNAL NIL)))
    (EDIT-FUNCTIONS-DISPLAY ITEM-LIST "~A:" "No ~A found." "Changed functions"))
  DIS-NONE)

(DEFCOM COM-EDIT-CHANGED-FUNCTIONS "Edit any sections which have been edited" ()
  (LIST-CHANGED-FUNCTIONS-INTERNAL NIL)
  (COM-NEXT-CALLER))

(DEFCOM COM-LIST-BUFFER-CHANGED-FUNCTIONS "List any sections which have been edited" ()
  (LET ((ITEM-LIST (LIST-CHANGED-FUNCTIONS-INTERNAL T)))
    (EDIT-FUNCTIONS-DISPLAY ITEM-LIST "~A:" "No ~A found." "Changed functions"))
  DIS-NONE)

(DEFCOM COM-EDIT-BUFFER-CHANGED-FUNCTIONS "Edit any sections which have been edited" ()
  (LIST-CHANGED-FUNCTIONS-INTERNAL T)
  (COM-NEXT-CALLER))

(DEFUN LIST-CHANGED-FUNCTIONS-INTERNAL (ONE-BUFFER-P &AUX ITEM-LIST SYMBOL-LIST)
  (IF ONE-BUFFER-P
      (MULTIPLE-VALUE (ITEM-LIST SYMBOL-LIST)
	(LIST-CHANGED-FUNCTIONS-INTERNAL-1 *INTERVAL*))
      (DOLIST (BUFFER *ZMACS-BUFFER-LIST*)
	(AND (EQ (IF (EQ BUFFER *INTERVAL*) *MAJOR-MODE*
		   (BUFFER-SAVED-MAJOR-MODE BUFFER))
	       'LISP-MODE)
	     (MULTIPLE-VALUE-BIND (ITL SML)
		 (LIST-CHANGED-FUNCTIONS-INTERNAL-1 BUFFER)
	       (SETQ ITEM-LIST (NCONC ITEM-LIST ITL)
		     SYMBOL-LIST (NCONC SYMBOL-LIST SML))))))
  (SETUP-ZMACS-CALLERS-TO-BE-EDITED SYMBOL-LIST)
  ITEM-LIST)

(DEFUN LIST-CHANGED-FUNCTIONS-INTERNAL-1 (BUFFER &AUX ITEM-LIST SYMBOL-LIST)
  (DOLIST (SECTION (NODE-INFERIORS BUFFER))
    (AND (TYPEP SECTION 'SECTION-NODE)
	 (> (NODE-TICK SECTION) (MIN (BUFFER-TICK BUFFER)
				     (SECTION-NODE-COMPILE-TICK SECTION)))
	 (SECTION-NODE-DEFUN-LINE SECTION)
	 (LET ((SYMBOL (SECTION-NODE-NAME SECTION)))
	   (PUSH SYMBOL SYMBOL-LIST)
	   (PUSH (CONS (GET-SECTION-NODE-NAME SECTION) SYMBOL) ITEM-LIST))))
  (VALUES (NREVERSE ITEM-LIST) (NREVERSE SYMBOL-LIST)))

;;; These are the functions called from inside the compiler for maintaining the
;;; compiler-warnings buffer.

;;; This is called by the compiler when it begins to compile something
(DEFUN SETUP-COMPILER-WARNINGS (&OPTIONAL INPUT-STREAM
				&AUX WO NAME PATHNAME TYPE FULL-P WARNINGS-INT)
  
  (COND ((NULL INPUT-STREAM))
	((MEMQ ':COMPILER-WARNINGS-NAME (SETQ WO (FUNCALL INPUT-STREAM ':WHICH-OPERATIONS)))
	 (MULTIPLE-VALUE (PATHNAME NAME TYPE FULL-P)
	   (FUNCALL INPUT-STREAM ':COMPILER-WARNINGS-NAME)))
	((MEMQ ':PATHNAME WO)
	 (AND (SETQ PATHNAME (FUNCALL INPUT-STREAM ':PATHNAME))
	      (SETQ NAME (FUNCALL PATHNAME ':STRING-FOR-PRINTING)
		    TYPE "file"
		    FULL-P T))))
  (OR NAME
      (SETQ NAME "random" TYPE "Someplace" FULL-P NIL))
  (COND ((NULL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM)
	 (SETQ FULL-P T))
	((NEQ COMPILER:CONCATENATE-COMPILER-WARNINGS-P ':BY-FILE)
	 (FORMAT COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
		 "~2&Compiling ~:[from ~]~A ~A~2%" FULL-P TYPE NAME)
	 (SETQ FULL-P T))			;Pretend to be doing whole file
	(T
	 (AND PATHNAME (SETQ NAME (FUNCALL PATHNAME ':STRING-FOR-PRINTING)
			     TYPE "file"))
	 ;;Get the buffer into which warnings are going
	 (SETQ WARNINGS-INT (BP-TOP-LEVEL-NODE
			      (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
				       ':READ-BP)))
	 (MULTIPLE-VALUE-BIND (START-BP END-BP)
	     (FIND-WARNINGS-FOR-FILE WARNINGS-INT NAME)
	   (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
		    ':SET-BP END-BP)
	   (IF START-BP
	       (AND FULL-P
		    (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
			     ':DELETE-INTERVAL
			     (LET ((*INTERVAL* WARNINGS-INT))
			       (BEG-LINE START-BP 1 T))
			     END-BP T))
	       (FORMAT COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
		       "~2&~|~%Warnings for ~A ~A~%" TYPE NAME))
	   (SETQ END-BP (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
				   ':READ-BP))
	   (LET ((*INTERVAL* WARNINGS-INT))
	     (OR (LINE-BLANK-P (BP-LINE END-BP))
		 (WITH-BP (BP END-BP ':NORMAL)
		   (INSERT (BEG-LINE BP) #\CR)
		   (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
			    ':SET-BP BP)))))))
  FULL-P)

(DEFUN FIND-WARNINGS-FOR-FILE (WARNINGS-INT NAME)
  (DO ((LINE (BP-LINE (INTERVAL-FIRST-BP WARNINGS-INT)) (LINE-NEXT LINE))
       (LAST-LINE (BP-LINE (INTERVAL-LAST-BP WARNINGS-INT)))
       (START-LINE) (START-BP)
       (LAST-P) (PAGE-P)
       (FIRST-P T PAGE-P))
      (NIL)
    (COND ((OR (SETQ LAST-P (EQ LINE LAST-LINE))
	       (SETQ PAGE-P (%STRING-EQUAL LINE 0 "" 0 1)))
	   (COND ((OR START-LINE LAST-P)
		  (SETQ START-BP (CREATE-BP LINE (IF LAST-P
						     (BP-INDEX (INTERVAL-LAST-BP
								 WARNINGS-INT))
						     0)))
		  (RETURN (AND START-LINE (CREATE-BP START-LINE 0))
			  START-BP))))
	  ((AND FIRST-P
		(%STRING-EQUAL LINE 0 "Warnings for " 0 13.)
		(LET ((LEN (ARRAY-ACTIVE-LENGTH NAME)))
		  (%STRING-EQUAL LINE (- (LINE-LENGTH LINE) LEN) NAME 0 LEN)))
	   (SETQ START-LINE LINE)))))

;;; This is called when starting to compile from an interval stream
;;; Returns pathname, name, type, full-file-p
(DEFUN INTERVAL-IO-COMPILER-WARNINGS-NAME (IGNORE &AUX INT)
   (DECLARE (SPECIAL *LINE* *INDEX*))
   (AND (TYPEP (SETQ INT (BP-TOP-LEVEL-NODE (CREATE-BP *LINE* *INDEX*))) 'FILE-BUFFER)
	(VALUES (BUFFER-PATHNAME INT)
		(BUFFER-NAME INT)
		"buffer"
		(AND (BP-= (INTERVAL-FIRST-BP *INTERVAL*) (INTERVAL-FIRST-BP INT))
		     (BP-= (INTERVAL-LAST-BP *INTERVAL*) (INTERVAL-LAST-BP INT))))))

;;; This is called when compiling single functions for each one.
;;; Find any warnings for this function from before and delete them.
(DEFUN COMPILER-WARNINGS-SETUP-FOR-PROCESSING-FUNCTION (FUNCTION &AUX START-BP END-BP)
  (LET* ((BP (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM ':READ-BP))
	 (*INTERVAL* (BP-TOP-LEVEL-NODE BP)))
    (SETQ START-BP (FORWARD-PAGE BP -1 T)
	  END-BP (FORWARD-PAGE START-BP 1 T))
    (AND (STRING-EQUAL (BP-LINE START-BP) "")
	 (SETQ START-BP (BEG-LINE START-BP 1 T)))
    (AND (STRING-EQUAL (BP-LINE END-BP) "")
	 (SETQ END-BP (BEG-LINE END-BP -1 T))))
  (LET ((NAME (FORMAT NIL "~S" FUNCTION)))
    (DO ((LINE (BP-LINE START-BP) (LINE-NEXT LINE))
	 (END-LINE (BP-LINE END-BP))
	 (LEN (ARRAY-ACTIVE-LENGTH NAME))
	 (START-LINE) (LAST-P))
	(NIL)
      (COND ((OR (SETQ LAST-P (EQ LINE END-LINE))
		 (%STRING-EQUAL LINE 0 "<< While compiling " 0 19.))
	     (COND (START-LINE
		    (FUNCALL COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
			     ':DELETE-INTERVAL (CREATE-BP START-LINE 0) (CREATE-BP LINE 0) T)
		    (RETURN NIL)))
	     (AND LAST-P (RETURN NIL))							      
	     (AND (%STRING-EQUAL LINE (- (LINE-LENGTH LINE) LEN 3) NAME 0 LEN)
		  (SETQ START-LINE LINE)))))))