;;; Primitive data structure manipulation for ZWEI.    -*- Mode:LISP; Package:ZWEI -*-
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **

(DEFUN CREATE-LINE (ARRAY-TYPE SIZE NODE)
  (MAKE-LINE :MAKE-ARRAY (:AREA *LINE-AREA* :TYPE ARRAY-TYPE :LENGTH SIZE)
	     LINE-TICK *TICK* LINE-LENGTH SIZE
	     LINE-NODE NODE))

(DEFUN CREATE-BP (LINE INDEX &OPTIONAL STATUS)
  (IF STATUS
      (LET ((BP (MAKE-BP BP-LINE LINE BP-INDEX INDEX BP-STATUS STATUS)))
        (PUSH BP (LINE-BP-LIST LINE))
	BP)
      (MAKE-TEMP-BP BP-LINE LINE BP-INDEX INDEX)))

(DEFUN COPY-BP (BP &OPTIONAL STATUS)
  (CREATE-BP (BP-LINE BP) (BP-INDEX BP) STATUS))

;;; With no args, make empty interval.
;;; With one arg, turn string into interval.
;;; With two args, they are limiting bps.
(DEFUN CREATE-INTERVAL (&OPTIONAL ARG1 ARG2 (NODE-P T) &AUX INTERVAL)
  (SETQ INTERVAL (IF NODE-P
		     (MAKE-NODE NODE-TICK *TICK*)
                     (MAKE-INTERVAL)))
  (OR ARG2
      (LET ((LINE (CREATE-LINE 'ART-STRING 0 INTERVAL)))
        (SETF (INTERVAL-FIRST-BP INTERVAL) (CREATE-BP LINE 0 ':NORMAL))
	(SETF (INTERVAL-LAST-BP INTERVAL) (CREATE-BP LINE 0 ':MOVES))))
  (AND ARG1
       (COND (ARG2
              (SETF (INTERVAL-FIRST-BP INTERVAL) ARG1)
              (SETF (INTERVAL-LAST-BP INTERVAL) ARG2))
             (T
              (INSERT (INTERVAL-FIRST-BP INTERVAL) ARG1))))
  INTERVAL)

;;; There are two forms:  (MOVE-BP <bp> <to-bp>) and (MOVE-BP <bp> <line> <index>)
(DEFUN MOVE-BP (BP LINE &OPTIONAL INDEX &AUX OLINE)
  (SETQ OLINE (BP-LINE BP))
  (COND ((NULL INDEX)
	 (SETQ INDEX (BP-INDEX LINE) LINE (BP-LINE LINE)))
	;; If we were not passed a BP, check that the INDEX is in range.
	((> INDEX (LINE-LENGTH LINE))
	 (FERROR NIL "The index ~O is greater than the length of the line ~S"
		 INDEX LINE)))
  (COND ;; If it is to the same line, there can be no problem.
    ((EQ OLINE LINE)
     (SETF (BP-INDEX BP) INDEX))
    (T
     (COND ((BP-STATUS BP)
	    ;; It is a permanent bp changing lines.  Fix relocation lists.
	    (SETF (LINE-BP-LIST OLINE) (DELQ BP (LINE-BP-LIST OLINE)))
	    (PUSH BP (LINE-BP-LIST LINE))))
     (SETF (BP-LINE BP) LINE)
     (SETF (BP-INDEX BP) INDEX)))
  BP)

;;; Move a BP backward over one character.
;;; Return the bp, altered.
;;; At the beginning of the interval, return nil and don't alter it.
;;; FIXUP-P means return the unaltered bp instead of nil.
(DEFUN DBP (BP &OPTIONAL FIXUP-P)
  (COND ((BP-= BP (INTERVAL-FIRST-BP *INTERVAL*))
	 (AND FIXUP-P BP))
	((= (BP-INDEX BP) 0)
	 (MOVE-BP BP (LINE-PREVIOUS (BP-LINE BP))
		  (LINE-LENGTH (LINE-PREVIOUS (BP-LINE BP)))))
	(T (MOVE-BP BP (BP-LINE BP) (1- (BP-INDEX BP))))))

;;; Move a BP forward over one character.
;;; Return the bp, altered.
;;; At the end of the interval, return nil and don't alter it.
;;; FIXUP-P means return the unaltered bp instead of nil.
(DEFUN IBP (BP &OPTIONAL FIXUP-P)
  (COND ((BP-= BP (INTERVAL-LAST-BP *INTERVAL*))
	 (AND FIXUP-P BP))
	((= (BP-INDEX BP) (LINE-LENGTH (BP-LINE BP)))
	 (MOVE-BP BP (LINE-NEXT (BP-LINE BP)) 0))
	(T (MOVE-BP BP (BP-LINE BP) (1+ (BP-INDEX BP))))))

;;; Mark a buffer as changed
;;; Call this before changing it as it may err out if the buffer is read-only.
(DEFUN MUNG-BP-INTERVAL (BP)
  (TICK)
  (MUNG-NODE (BP-NODE BP)))

;;; Call this before changing it as it may err out if the buffer is read-only.
(DEFUN MUNG-BP-LINE-AND-INTERVAL (BP &AUX (LINE (BP-LINE BP)))
  (TICK)
  (AND (GET (LOCF (LINE-PLIST LINE)) ':DIAGRAM) (BARF "Diagram line"))
  (MUNG-NODE (BP-NODE BP))
  (SETF (LINE-TICK LINE) *TICK*)
  (SETF (LINE-CONTENTS-PLIST LINE) NIL))

;;; Nodes
(DEFUN BP-NODE (BP &AUX LINE)
  (SETQ LINE (BP-LINE BP))
  (DO ((NODE (LINE-NODE LINE) (OR (NODE-NEXT NODE) (NODE-SUPERIOR NODE)))
       (INDEX (BP-INDEX BP))
       (LAST-BP))
      ((OR (NEQ LINE (BP-LINE (SETQ LAST-BP (INTERVAL-LAST-BP NODE))))
	   ( (BP-INDEX LAST-BP) INDEX))
       NODE)))

(DEFUN BP-TOP-LEVEL-NODE (BP)
  (DO ((NODE (BP-NODE BP) SUPERIOR)
       (SUPERIOR))
      ((NULL (SETQ SUPERIOR (NODE-SUPERIOR NODE)))
       NODE)))

(DEFUN MUNG-NODE (NODE &AUX SUPERIOR)
  (AND (SETQ SUPERIOR (NODE-SUPERIOR NODE))
       (MUNG-NODE SUPERIOR))			;Do up first in case read only
  (AND (EQ (NODE-TICK NODE) ':READ-ONLY) (BARF "Read-only"))
  (SETF (NODE-TICK NODE) *TICK*))

;;; Return T if X is after or at LINE, NIL if X is before LINE.
(DEFUN SEARCH-FOR-LINE (X LINE)
  (DO ((FORWARD LINE (LINE-NEXT FORWARD))
       (BACKWARD (LINE-PREVIOUS LINE) (LINE-PREVIOUS BACKWARD)))
      (NIL)
    (COND ((EQ X FORWARD) (RETURN T))
	  ((EQ X BACKWARD) (RETURN NIL))
	  ((NULL FORWARD) (RETURN NIL))
	  ((NULL BACKWARD) (RETURN T)))))

(DEFUN BEG-LINE-P (BP)
  (OR (= (BP-INDEX BP) 0)
      (BP-= BP (INTERVAL-FIRST-BP *INTERVAL*))))

(DEFUN END-LINE-P (BP)
  (OR (= (BP-INDEX BP) (LINE-LENGTH (BP-LINE BP)))
      (BP-= BP (INTERVAL-LAST-BP *INTERVAL*))))

(DEFUN BEG-OF-LINE (LINE)
  (CREATE-BP LINE (IF (EQ LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*)))
		      (BP-INDEX (INTERVAL-FIRST-BP *INTERVAL*))
		      0)))

(DEFUN END-OF-LINE (LINE)
  (CREATE-BP LINE (IF (EQ LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*)))
		      (BP-INDEX (INTERVAL-LAST-BP *INTERVAL*))
		      (LINE-LENGTH LINE))))

(DEFUN KILL-INTERVAL (BP1 &OPTIONAL BP2 IN-ORDER-P (FORWARDP T) EXPLICIT-P)
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (AND *KILL-INTERVAL-SMARTS*
       (NOT EXPLICIT-P)
       (OR (AND (EQ (BP-LINE BP1) (BP-LINE BP2)) (BEG-LINE-P BP1))
	   (AND (MEM #'CHAR-EQUAL (BP-CHAR-BEFORE BP1) *BLANKS*)
		(NOT (BEG-LINE-P (BACKWARD-OVER *BLANKS* BP1)))))
       (MOVE-BP BP2 (FORWARD-OVER *BLANKS* BP2)))
  (KILL-RING-SAVE-INTERVAL BP1 BP2 T FORWARDP)
  (DELETE-INTERVAL BP1 BP2 T))

(DEFUN KILL-RING-SAVE-INTERVAL (BP1 &OPTIONAL BP2 IN-ORDER-P FORWARDP)
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (COND ((EQ *LAST-COMMAND-TYPE* 'KILL)
	 (INSERT-INTERVAL
	   (LET ((INT (CAR *KILL-RING*)))
	     (COND ((STRINGP INT)
		    (SETQ INT (CREATE-INTERVAL INT))
		    (SETF (CAR *KILL-RING*) INT)))
	     (IF FORWARDP
		 (INTERVAL-LAST-BP INT)
		 (INTERVAL-FIRST-BP INT)))
	   BP1 BP2 T))
	(T (KILL-RING-PUSH (COPY-INTERVAL BP1 BP2 T)))))

(DEFUN KILL-INTERVAL-ARG (BP1 BP2 ARG)
  (IF (PLUSP ARG)
      (KILL-INTERVAL BP1 BP2 T T)
      (KILL-INTERVAL BP2 BP1 T NIL)))

;;; BP had better not be a :MOVES type bp
(DEFUN INSERT-KILL-RING-THING (BP THING)
  (WITH-BP (BP1 (INSERT-THING BP THING) ':MOVES)
    (COND (*KILL-INTERVAL-SMARTS*
	   (IF (MEM #'CHAR-EQUAL (BP-CHAR-BEFORE BP) *BLANKS*)
	       (DELETE-OVER *BLANKS* BP)
	       (FIXUP-WHITESPACE BP))
	   (IF (MEM #'CHAR-EQUAL (BP-CHAR BP1) *BLANKS*)
	       (DELETE-BACKWARD-OVER *BLANKS* BP1)
	       (FIXUP-WHITESPACE BP1))))
    (COPY-BP BP1)))

(DEFUN FIXUP-WHITESPACE (BP &AUX BP2 BP1 CH1 CH2 SYN1 SYN2 FLAG BP3)
  (SETQ BP1 (BACKWARD-OVER *BLANKS* BP)
	BP2 (FORWARD-OVER *BLANKS* BP)
	CH1 (IF (SETQ BP3 (FORWARD-CHAR BP1 -1))
		(BP-CH-CHAR BP3) #\CR)
	CH2 (BP-CH-CHAR BP2)
	SYN1 (LIST-SYNTAX CH1)
	SYN2 (LIST-SYNTAX CH2))
  (COND ((OR (= CH2 #\CR)			;If at the end of the line,
	     (AND (SETQ FLAG (OR (NOT (MEMQ *MAJOR-MODE* '(LISP-MODE ZTOP-MODE)))
				 (MULTIPLE-VALUE-BIND (STRING SLASH COMMENT)
				     (LISP-BP-SYNTACTIC-CONTEXT BP1)	;or any funny syntax
				   (OR STRING SLASH COMMENT))))
		  (NOT (AND (BP-= BP BP1)
			    (BP-= BP BP2))))))	;and some whitespace, leave it alone
	((NOT (= CH1 #\CR))			;If not at beginning of line,
	 (DELETE-INTERVAL BP1 BP2 T)		;flush whitespace, and
	 (AND (IF FLAG
		  (NOT (OR (MEMQ CH1 *BLANKS*) (MEMQ CH2 *BLANKS*)))
		  (AND ( SYN1 LIST-OPEN) ( SYN1 LIST-SINGLE-QUOTE) ( SYN2 LIST-CLOSE)))
	      (INSERT BP1 (IN-CURRENT-FONT #\SP))))))

(DEFUN COUNT-LINES (FROM-BP &OPTIONAL TO-BP IN-ORDER-P)
  (COND ((NULL TO-BP)
	 (SETQ TO-BP (INTERVAL-LAST-BP FROM-BP)
	       FROM-BP (INTERVAL-FIRST-BP FROM-BP))))
  (OR IN-ORDER-P (ORDER-BPS FROM-BP TO-BP))
  (DO ((LINE (BP-LINE FROM-BP) (LINE-NEXT LINE))
       (LAST-LINE (BP-LINE TO-BP))
       (I 1 (1+ I)))
      ((EQ LINE LAST-LINE) I)))

(DEFUN COUNT-CHARS (FROM-BP &OPTIONAL TO-BP IN-ORDER-P)
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (LET ((FIRST-LINE (BP-LINE FROM-BP))
	(FIRST-INDEX (BP-INDEX FROM-BP))
	(LAST-LINE (BP-LINE TO-BP))
	(LAST-INDEX (BP-INDEX TO-BP)))
    (COND ((EQ FIRST-LINE LAST-LINE)
	   (- LAST-INDEX FIRST-INDEX))
	  (T (DO ((LINE (LINE-NEXT FIRST-LINE) (LINE-NEXT LINE))
		  (I 1 (+ 1 I (LINE-LENGTH LINE))))
		 ((EQ LINE LAST-LINE)
		  (+ I (- (LINE-LENGTH FIRST-LINE) FIRST-INDEX) LAST-INDEX)))))))

(DEFUN LINE-N-CHARS (LINE)
  (LET ((FIRST-BP (INTERVAL-FIRST-BP *INTERVAL*))
	(LAST-BP (INTERVAL-LAST-BP *INTERVAL*)))
    (- (IF (EQ LINE (BP-LINE LAST-BP))
	   (BP-INDEX LAST-BP)
	   (LINE-LENGTH LINE))
       (IF (EQ LINE (BP-LINE FIRST-BP))
	   (BP-INDEX FIRST-BP)
	   0))))

(DEFUN SWAP-BPS (BP1 BP2)
  (LET ((LINE (BP-LINE BP1))
	(INDEX (BP-INDEX BP1)))
    (MOVE-BP BP1 BP2)
    (MOVE-BP BP2 LINE INDEX)))

(DEFUN FLUSH-BP (BP)
  (LET ((LINE (BP-LINE BP)))
    (SETF (LINE-BP-LIST LINE) (DELQ BP (LINE-BP-LIST LINE)))))

(DEFUN BP-< (BP1 BP2)
  (LET ((LINE1 (BP-LINE BP1))
	(LINE2 (BP-LINE BP2)))
    (COND ((EQ LINE1 LINE2)
	   (< (BP-INDEX BP1) (BP-INDEX BP2)))
	  (T (NOT (SEARCH-FOR-LINE LINE1 LINE2))))))

(DEFUN BP-= (BP1 BP2)
  (AND (EQ (BP-LINE BP1) (BP-LINE BP2))
       (= (BP-INDEX BP1) (BP-INDEX BP2))))

(DEFUN BP-CHAR (BP)
  (LET ((LINE (BP-LINE BP))
	(INDEX (BP-INDEX BP)))
    (COND ((= INDEX (LINE-LENGTH LINE)) #\CR)
	  (T (AREF LINE INDEX)))))

(DEFUN BP-CHAR-BEFORE (BP)
  (LET ((INDEX (BP-INDEX BP)))
    (COND ((ZEROP INDEX) #\CR)
	  (T (AREF (BP-LINE BP) (1- INDEX))))))

;;; Returns either NIL or the thing it deleted.
(DEFUN DELETE-LAST-ELEMENT (LIST)
  (AND (> (LENGTH LIST) 1)
       (DO ((L LIST (CDR L)))
	   ((NULL (CDDR L))
	    (PROG1 (CADR L) (RPLACD L NIL))))))

(DEFUN POINT-PDL-PUSH (BP WINDOW &OPTIONAL EXPLICIT (NOTIFICATION T) &AUX TEM)
  (SETQ TEM (LIST (COPY-BP BP ':NORMAL) (PLINE-OF-POINT T WINDOW BP)))
  (AND EXPLICIT (SETQ TEM (NCONC TEM (NCONS EXPLICIT))))
  (PUSH TEM (WINDOW-POINT-PDL WINDOW))
  (AND (> (LENGTH (WINDOW-POINT-PDL WINDOW)) *POINT-PDL-MAX*)
       (FLUSH-BP (CAR (DELETE-LAST-ELEMENT (WINDOW-POINT-PDL WINDOW)))))
  (AND NOTIFICATION (TV:SHEET-EXPOSED-P *TYPEIN-WINDOW*)
       (TYPEIN-LINE *AUTO-PUSH-POINT-NOTIFICATION*)))

;Rotate nth (1-origin!) element to the front of the list, rotating the
;part of the list before it.  With a negative arg rotate the same amount
;backwards.  With an arg of 1 rotate the whole list BACKWARDS, i.e. bring
;up the same element as with an arg of 2 but store the old front at the back.
;Zero arg is undefined, do nothing I guess.  Note that 2 and -2 do the same thing.
;Doesn't barf if N is too big.  Alters the list in place.
(DEFUN ROTATE-TOP-OF-LIST (LIST N)
  (AND (= (ABS N) 1) (SETQ N (* N -1 (LENGTH LIST))))
  (COND ((PLUSP N)
	 (SETQ N (MIN (LENGTH LIST) N))
	 (DO ((I 0 (1+ I))
	      (LIST LIST (CDR LIST))
	      (NTH (NTH (1- N) LIST) OLD)
	      (OLD))
	     (( I N))
	   (SETQ OLD (CAR LIST))
	   (SETF (CAR LIST) NTH)))
	((MINUSP N)
	 (SETQ N (MIN (LENGTH LIST) (MINUS N)))
	 (DO ((I 1 (1+ I))
	      (LIST LIST (CDR LIST))
	      (FRONT (CAR LIST)))
	     (( I N) (SETF (CAR LIST) FRONT))
	   (SETF (CAR LIST) (CADR LIST)))))
  LIST)

(DEFUN POINT-PDL-POP (WINDOW)
  (LET ((PDL (WINDOW-POINT-PDL WINDOW)))
    (OR PDL (BARF))
    (LET ((ENTRY (CAR PDL)))
      (SETF (WINDOW-POINT-PDL WINDOW) (NCONC (CDR PDL) (RPLACD PDL NIL)))
      (PROG () (RETURN-LIST ENTRY)))))

(DEFUN POINT-PDL-EXCH (BP WINDOW ARG-P ARG &AUX PDL ENTRY)
  (SETQ PDL (WINDOW-POINT-PDL WINDOW))
  (AND (EQ ARG-P ':CONTROL-U) (SETQ ARG 0))
  (DO ((ARG (ABS ARG))
       (PDL (IF (MINUSP ARG) (REVERSE PDL) PDL) (CDR PDL))
       (ENT))
      ((OR (< ARG 0) (NULL PDL))
       (SETQ ENTRY (OR ENT (BARF))))
    (COND ((THIRD (CAR PDL))
	   (SETQ ENT (CAR PDL)
		 ARG (1- ARG)))))
  (SETF (WINDOW-POINT-PDL WINDOW)
	(CONS (LIST (COPY-BP BP ':NORMAL) (PLINE-OF-POINT NIL WINDOW BP) T)
	      (NCONC (DELQ ENTRY (DEL #'BP-= BP PDL)) (NCONS ENTRY))))
  (PROG () (RETURN-LIST ENTRY)))

;;; Move POINT to a BP, displayed at PLINE (which may be NIL)
(DEFUN POINT-PDL-MOVE (BP PLINE)
  (LET ((INTERVAL (BP-TOP-LEVEL-NODE BP)))
    (OR (EQ INTERVAL (BP-TOP-LEVEL-NODE (INTERVAL-FIRST-BP *INTERVAL*)))
	(IF (TYPEP INTERVAL 'BUFFER)
	    (MAKE-BUFFER-CURRENT INTERVAL)
	    ;(SETQ *INTERVAL* INTERVAL)  ;it isn't nearly this easy
	    (BARF "Attempt to switch intervals?  Please do (bug 'zwei)")
	    )))
  (MOVE-BP (POINT) BP)
  (AND PLINE (REDISPLAY-POINT-ON-PLINE BP *WINDOW* PLINE)))

(DEFUN POINT-PDL-PURGE (BUFFER)
  (DOLIST (WINDOW *WINDOW-LIST*)
    (SETF (WINDOW-POINT-PDL WINDOW)
	  (DEL #'(LAMBDA (BUF POINT) (EQ BUF (BP-TOP-LEVEL-NODE (FIRST POINT)))) BUFFER
	       (WINDOW-POINT-PDL WINDOW)))))

(DEFUN ROTATE-POINT-PDL (WINDOW N &AUX POINT ENTRY LIST)
  (SETQ POINT (WINDOW-POINT WINDOW)
	ENTRY (LIST (COPY-BP POINT ':NORMAL) (PLINE-OF-POINT T WINDOW POINT) T)
	LIST (CONS ENTRY (WINDOW-POINT-PDL WINDOW)))
  (ROTATE-TOP-OF-LIST LIST N)
  (SETQ ENTRY (CAR LIST))
  (POINT-PDL-MOVE (CAR ENTRY) (CADR ENTRY))
  DIS-BPS)

(DEFUN MAYBE-PUSH-POINT (BP)
  (AND *AUTO-PUSH-POINT-OPTION*
       (BPS-FAR-APART BP (POINT) *AUTO-PUSH-POINT-OPTION*)
       (POINT-PDL-PUSH BP *WINDOW*)))

(DEFUN KILL-RING-PUSH (INTERVAL)
  (PUSH INTERVAL *KILL-RING*)
  (AND (> (LENGTH *KILL-RING*) *KILL-RING-MAX*)
       (DELETE-LAST-ELEMENT *KILL-RING*)))

(DEFUN MINI-BUFFER-RING-PUSH (THING)
  (PUSH THING *MINI-BUFFER-RING*)
  (AND (> (LENGTH *MINI-BUFFER-RING*) *KILL-RING-MAX*)
       (DELETE-LAST-ELEMENT *MINI-BUFFER-RING*)))

(DEFUN KILL-RING-POP (ARG)
  (AND (MINUSP ARG) (SETQ ARG (+ ARG (LENGTH *KILL-RING*))))
  (AND (OR (NULL *KILL-RING*) (< ARG 0) ( ARG (LENGTH *KILL-RING*))) (BARF))
  (LET ((CDR (NTHCDR ARG *KILL-RING*)))
    (CAR (SETQ *KILL-RING* (NCONC (PROG1 (CDR CDR) (RPLACD CDR NIL)) *KILL-RING*)))))

;;; Change the font of a character or a string
(DEFUN IN-CURRENT-FONT (X &OPTIONAL (FONT *FONT*))
  (COND ((MEMQ X '(#\CR #\TAB))			;These characters are fontless
	 X)
	((NUMBERP X)
	 (DPB FONT %%CH-FONT X))
	((ZEROP FONT)		;Little efficiency for strings
	 X)
	(T (LET ((LENGTH (STRING-LENGTH X)))
	     (LET ((S (MAKE-ARRAY LENGTH ':TYPE 'ART-FAT-STRING)))
	       (DO ((I 0 (1+ I)))
		   (( I LENGTH) S)
		 (ASET (DPB FONT %%CH-FONT (AREF X I)) S I)))))))

(DEFUN LINE-BLANK-P (LINE)
  (COND ((NUMBERP LINE)
	 (MEMQ (LDB %%CH-CHAR LINE) *BLANKS*))
	((GET (LOCF (LINE-PLIST LINE)) ':DIAGRAM) NIL)
	(T
	 (DO ((I (IF (EQ LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*)))
		     (BP-INDEX (INTERVAL-FIRST-BP *INTERVAL*))
		     0)
		 (1+ I))
	      (LIM (IF (EQ LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*)))
		       (BP-INDEX (INTERVAL-LAST-BP *INTERVAL*))
		       (LINE-LENGTH LINE))))
	     (( I LIM) T)
	   (OR (MEMQ (LDB %%CH-CHAR (AREF LINE I)) *BLANKS*)
	       (RETURN NIL))))))

(DEFUN RANGE (X MIN MAX)
  (MAX MIN (MIN MAX X)))

;;; If any of the BPs on the point pdl are the same as point,
;;; then they are useless; flush them.  Except, leave at least
;;; one BP on the pdl.
(DEFUN CLEAN-POINT-PDL (WINDOW)
  (DO ((L (WINDOW-POINT-PDL WINDOW) (CDR L))
       (PT (WINDOW-POINT WINDOW)))
      ((OR (NULL (CDR L))
	   (NOT (BP-= (CAAR L) PT)))
       (SETF (WINDOW-POINT-PDL WINDOW) L))
    (FLUSH-BP (CAAR L))))

(DEFUN STRING-MATCH (PATTERN SUBJECT)
  (LET ((PATTERN-LENGTH (STRING-LENGTH PATTERN)))
    (COND ((AND ( (STRING-LENGTH SUBJECT) PATTERN-LENGTH)
		(STRING-EQUAL PATTERN SUBJECT 0 0 PATTERN-LENGTH PATTERN-LENGTH))
	   PATTERN-LENGTH)
	  (T NIL))))

;;; Return :BLANK, :COMMENT, :ATOM, :NORMAL, or :DIAGRAM
;;; depending on the first non-blank character.
(DEFUN LINE-TYPE (LINE)
  (IF (GET (LOCF (LINE-PLIST LINE)) ':DIAGRAM) ':DIAGRAM
      (DO ((I (IF (EQ LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*)))
		  (BP-INDEX (INTERVAL-FIRST-BP *INTERVAL*))
		  0)
	      (1+ I))
	   (LIM (IF (EQ LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*)))
		    (BP-INDEX (INTERVAL-LAST-BP *INTERVAL*))
		    (LINE-LENGTH LINE))))
	  (( I LIM) ':BLANK)
	(LET ((CH (LDB %%CH-CHAR (AREF LINE I))))
	  (OR (MEMQ CH *BLANKS*)
	      (RETURN (COND ((= CH #/;) ':COMMENT)
			    ((= CH #\FF) ':FORM)
			    ((= (LIST-SYNTAX CH) LIST-ALPHABETIC) ':ATOM)
			    (T ':NORMAL))))))))

;;; Uppercasify the character pointed to by BP.
(DEFUN UPCASE-CHAR (BP)
  (LET ((LINE (BP-LINE BP))
	(INDEX (BP-INDEX BP)))
    (COND ((< INDEX (LINE-LENGTH LINE))
	   (MUNG-BP-LINE-AND-INTERVAL BP)
	   (ASET (CHAR-UPCASE (AREF LINE INDEX)) LINE INDEX)))))

;;; Lowercasify the character pointed to by BP.
(DEFUN DOWNCASE-CHAR (BP)
  (LET ((LINE (BP-LINE BP))
	(INDEX (BP-INDEX BP)))
    (COND ((< INDEX (LINE-LENGTH LINE))
	   (MUNG-BP-LINE-AND-INTERVAL BP)
	   (ASET (CHAR-DOWNCASE (AREF LINE INDEX)) LINE INDEX)))))

;;; Uppercasify all characters in the specified interval.
(DEFUN UPCASE-INTERVAL (BP1 &OPTIONAL BP2 IN-ORDER-P)
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (MUNG-BP-INTERVAL BP1)
  (CHARMAP-PER-LINE (BP1 BP2 NIL)
      ((MUNG-LINE (CHARMAP-LINE)))
    (LET ((BEFORE (CHARMAP-CHAR)))
      (LET ((AFTER (CHAR-UPCASE BEFORE)))
	(COND ((NOT (= BEFORE AFTER))
	       (CHARMAP-SET-CHAR AFTER)))))))

;;; Lowercasify all characters in the specified interval.
(DEFUN DOWNCASE-INTERVAL (BP1 &OPTIONAL BP2 IN-ORDER-P)
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (MUNG-BP-INTERVAL BP1)
  (CHARMAP-PER-LINE (BP1 BP2 NIL)
      ((MUNG-LINE (CHARMAP-LINE)))
    (LET ((BEFORE (CHARMAP-CHAR)))
      (LET ((AFTER (CHAR-DOWNCASE BEFORE)))
	(COND ((NOT (= BEFORE AFTER))
	       (CHARMAP-SET-CHAR AFTER)))))))

(DEFUN UNDO-SAVE (BP1 &OPTIONAL BP2 IN-ORDER-P NAME)
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (IF (NOT (BOUNDP '*UNDO-START-BP*))
      (SETQ *UNDO-START-BP* (COPY-BP BP1 ':NORMAL)
	    *UNDO-END-BP* (COPY-BP BP2 ':MOVES))
      (MOVE-BP *UNDO-START-BP* BP1)
      (MOVE-BP *UNDO-END-BP* BP2))
  (SETQ *UNDO-OLD-INTERVAL* (COPY-INTERVAL BP1 BP2 T))
; (KILL-RING-PUSH *UNDO-OLD-INTERVAL*)
  (SETQ *UNDO-TYPE* NAME))

(DEFUN RELEVANT-FUNCTION-NAME (BP &OPTIONAL STRINGP (FUNCTION-ONLY T) (FUNCALL-SPECIAL T)
				  &AUX START-BP)
  (SETQ START-BP (FORWARD-DEFUN BP -1 T))
  (DO ((BP1 BP)
       (FN-START)
       (FN-END)
       (X))
      ((NULL (SETQ BP1 (FORWARD-SEXP BP1 -1 NIL 1 START-BP NIL))))
    (OR (SETQ FN-START (FORWARD-CHAR BP1)) (RETURN NIL))
    (OR (SETQ FN-END (FORWARD-SEXP FN-START)) (RETURN NIL))
    (COND ((AND (EQ (BP-LINE FN-START) (BP-LINE FN-END))
		(SETQ X (CATCH-ERROR (READ-FROM-STRING (BP-LINE FN-START) NIL
						       (BP-INDEX FN-START))
				     NIL))
		(SYMBOLP X)
		(OR (NOT FUNCTION-ONLY)
		    (FBOUNDP X)			;Anything you could hope to meta-. to
		    (STRING-IN-AARRAY-P X *ZMACS-COMPLETION-AARRAY*)
		    (GET X ':SOURCE-FILE-NAME)))
	   (AND (MEMQ X '(FUNCALL LEXPR-FUNCALL APPLY)) FUNCALL-SPECIAL
		(SETQ FN-START (FORWARD-OVER *WHITESPACE-CHARS* FN-END))
		(SETQ FN-END (FORWARD-SEXP FN-START))
		(EQ (BP-LINE FN-START) (BP-LINE FN-END))
		(LET ((Y (CATCH-ERROR (READ-FROM-STRING (BP-LINE FN-START) NIL
							(BP-INDEX FN-START))
				      NIL)))
		  (AND (LISTP Y) (MEMQ (CAR Y) '(QUOTE FUNCTION))
		       (SYMBOLP (SETQ Y (CADR Y)))
		       (OR (NOT FUNCTION-ONLY)
			   (FBOUNDP Y)
			   (STRING-IN-AARRAY-P Y *ZMACS-COMPLETION-AARRAY*)
			   (GET Y ':SOURCE-FILE-NAME))
		       (SETQ X Y))))
	   (RETURN (IF STRINGP (FORMAT NIL "~S" X) X))))))

(DEFUN RELEVANT-METHOD-NAME (BP &OPTIONAL (NSEXP 2) &AUX BP1)
  (COND ((AND (SETQ BP (FORWARD-LIST BP -1 NIL 1))
	      (SETQ BP (FORWARD-LIST BP 1 NIL 1 T))
	      (SETQ BP (FORWARD-SEXP BP NSEXP))
	      (SETQ BP (FORWARD-TO-WORD BP))
	      (SETQ BP1 (FORWARD-ATOM BP)))
	 (AND (= (BP-CHAR-BEFORE BP) #/:)	;Pick up package prefix
	      (SETQ BP (FORWARD-ATOM BP -1)))
	 (READ-FROM-STRING (STRING-INTERVAL BP BP1 T)))))

(DEFUN RELEVANT-DEFMETHOD-METHOD-NAME (BP &AUX BP1)
  (COND ((AND (SETQ BP (FORWARD-LIST BP -1 NIL 1))	;up 1
	      (SETQ BP (FORWARD-LIST BP 1 NIL 1 T))	;down 1
	      (SETQ BP (FORWARD-SEXP BP 1))	;forward 1
	      (SETQ BP (FORWARD-LIST BP 1 NIL 1 T))	;down 1
	      (SETQ BP (FORWARD-SEXP BP 1))	;forward 1
	      (SETQ BP (FORWARD-TO-WORD BP))	;to start of atom
	      (SETQ BP1 (FORWARD-ATOM BP)))
	 (AND (= (BP-CHAR-BEFORE BP) #/:)	;Pick up package prefix
	      (SETQ BP (FORWARD-ATOM BP -1)))
	 (READ-FROM-STRING (STRING-INTERVAL BP BP1 T)))))

;;; You might want to change this, if e.g. you are only hacking windows
(DEFVAR *BASE-FLAVOR* 'SI:VANILLA-FLAVOR)

(DEFUN METHOD-ARGLIST (MESSAGE-NAME)
  (MULTIPLE-VALUE-BIND (ARGLIST FUN RETLIST)
      (METHOD-ARGLIST-INTERNAL *BASE-FLAVOR* MESSAGE-NAME NIL NIL NIL)
    (VALUES (IF ARGLIST (CDR ARGLIST) 'NOT-FOUND) FUN RETLIST)))

(DEFUN METHOD-ARGLIST-INTERNAL (FLAVOR MESSAGE-NAME ARGLIST FUN RETLIST
				&AUX FLAVOR-METHOD-TABLE MESSAGE-ENTRY)
  (SETQ FLAVOR (GET FLAVOR 'SI:FLAVOR))
  (AND (SETQ FLAVOR-METHOD-TABLE (SI:FLAVOR-METHOD-TABLE FLAVOR))
       (SETQ MESSAGE-ENTRY (ASSQ MESSAGE-NAME FLAVOR-METHOD-TABLE))
       (DOLIST (METHOD (CDDDR MESSAGE-ENTRY))
	 (LET ((FUNCTION (CAR METHOD)))
	   (COND ((OR (= (LENGTH FUNCTION) 3)
		      (MEMQ (THIRD FUNCTION) '(:BEFORE :AFTER)))
		  ;; FUN is the first method seen, where we assume most of the
		  ;; argument list names came from.  We are assuming that all methods
		  ;; for a given message name are more or less compatible.
		  (OR FUN (SETQ FUN FUNCTION))
		  (MULTIPLE-VALUE-BIND (THISARG THISRET) (ARGLIST (CADR METHOD))
		    (OR RETLIST (SETQ RETLIST THISRET))
		    (SETQ ARGLIST (METHOD-ARGLIST-MERGE ARGLIST THISARG))))))))
  (DOLIST (FLAVOR (SI:FLAVOR-DEPENDED-ON-BY FLAVOR))
    (MULTIPLE-VALUE (ARGLIST FUN)
      (METHOD-ARGLIST-INTERNAL FLAVOR MESSAGE-NAME ARGLIST FUN RETLIST)))
  (VALUES ARGLIST FUN RETLIST))

(DEFUN METHOD-ARGLIST-MERGE (OLD-ARGLIST NEW-ARGLIST)
  (DO ((OLD OLD-ARGLIST (CDR OLD))
       (NEW NEW-ARGLIST (CDR NEW))
       (OLDOLD NIL OLD))
      ((OR (NULL OLD) (NULL NEW)))
    (DO () ((NOT (MEMQ (CAR OLD) '(&OPTIONAL &SPECIAL &LOCAL))))
      (SETQ OLD (CDR OLD)))
    (DO () ((NOT (MEMQ (CAR NEW) '(&OPTIONAL &SPECIAL &LOCAL))))
      (SETQ NEW (CDR NEW)))
    (COND ((EQ (CAR OLD) '&REST)
	   (OR (EQ (CAR NEW) '&REST)
	       (IF OLDOLD (RPLACD OLDOLD NEW) (SETQ OLD-ARGLIST (COPYLIST NEW))))
	   (RETURN))
	  ((EQ (CAR NEW) '&REST)
	   (AND (SYMBOLP (CADR OLD)) (STRING-EQUAL (CADR OLD) 'IGNORE)
		(NOT (AND (SYMBOLP (CADR NEW)) (STRING-EQUAL (CADR NEW) 'IGNORE)))
		(RPLACA (CDR OLD) (CADR NEW)))
	   (RETURN))
	  ((AND (SYMBOLP (CAR OLD)) (STRING-EQUAL (CAR OLD) 'IGNORE))
	   (OR (AND (SYMBOLP (CAR NEW)) (STRING-EQUAL (CAR NEW) 'IGNORE))
	       (RPLACA OLD (CAR NEW))))))
  (OR OLD-ARGLIST (COPYLIST NEW-ARGLIST)))

;;; Return T if BPs are more then N lines apart.  (Used by MAYBE-PUSH-POINT.)
(DEFUN BPS-FAR-APART (BP1 BP2 N)
  (LET ((LINE1 (BP-LINE BP1))
	(LINE2 (BP-LINE BP2)))
    (NOT (OR (DO ((L LINE1 (LINE-NEXT L))
		  (I 0 (1+ I)))
		 (( I N) NIL)
	       (IF (EQ L LINE2) (RETURN T))
	       (IF (NULL L) (RETURN NIL)))
	     (DO ((L LINE1 (LINE-PREVIOUS L))
		  (I 0 (1+ I)))
		 (( I N) NIL)
	       (IF (EQ L LINE2) (RETURN T))
	       (IF (NULL L) (RETURN NIL)))))))

(DEFUN PARAGRAPH-INTERVAL (BP &OPTIONAL (N 1) &AUX OTHER-BP)
  (LET ((TEMP-BP (DO ((BP BP (FORWARD-LINE BP 1)))
		     ((NULL BP)
		      (INTERVAL-LAST-BP *INTERVAL*))
		   (IF (NOT (LINE-BLANK-P (BP-LINE BP)))
		       (RETURN BP)))))
    (SETQ TEMP-BP (FORWARD-PARAGRAPH TEMP-BP 1 T))
    (SETQ TEMP-BP (FORWARD-PARAGRAPH TEMP-BP -1 T))
    (SETQ OTHER-BP (FORWARD-PARAGRAPH TEMP-BP N T))
    (CREATE-INTERVAL TEMP-BP OTHER-BP)))

;;; Interval I/O
;;; HACK-FONTS T means return 's for font changes
;;; HACK-FONTS :TYO means return 16 bit characters
(DEFUN INTERVAL-STREAM (FROM-BP &OPTIONAL TO-BP IN-ORDER-P HACK-FONTS)
  (LOCAL-DECLARE ((SPECIAL *LINE* *INDEX* *LAST-LINE* *LAST-INDEX* *STOP-INDEX* *UNRCHF*
                           *FONT-FLAG*))
    (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
    (LET ((*INTERVAL* (CREATE-INTERVAL FROM-BP TO-BP T))
          (*LINE* (BP-LINE FROM-BP))
          (*INDEX* (BP-INDEX FROM-BP))
          (*LAST-LINE* (BP-LINE TO-BP))
          (*LAST-INDEX* (BP-INDEX TO-BP))
          (*STOP-INDEX* (IF (EQ (BP-LINE FROM-BP) (BP-LINE TO-BP))
                            (BP-INDEX TO-BP)
                            (LINE-LENGTH (BP-LINE FROM-BP))))
          (*UNRCHF* NIL)
          (*FONT-FLAG* 0))
      (AND (EQ HACK-FONTS ':TYI) (SETQ *FONT-FLAG* NIL HACK-FONTS NIL))
      (CLOSURE '(*INTERVAL* *LINE* *INDEX* *LAST-LINE* *LAST-INDEX* *STOP-INDEX* *UNRCHF*
			    *FONT-FLAG*)
	       (IF HACK-FONTS 'INTERVAL-WITH-FONTS-IO 'INTERVAL-IO)))))

;;; *LINE*, *INDEX* point to the next character to be returned.
;;; *STOP-INDEX* is the place on the current line at which to stop (usually the end).
;;; *LAST-LINE*, *LAST-INDEX* is where the interval ends.
;;; If *INDEX* is NIL, we are at the end-of-file.

(LOCAL-DECLARE ((SPECIAL *LINE* *INDEX* *LAST-LINE* *LAST-INDEX* *STOP-INDEX* *UNRCHF*
			 *FONT-FLAG*))
(DEFSELECT (INTERVAL-IO INTERVAL-IO-DEFAULT-HANDLER)
  (:TYI (&OPTIONAL EOF &AUX CH)
   (COND (*UNRCHF*
	  (PROG1 *UNRCHF* (SETQ *UNRCHF* NIL)))
	 ((NULL *INDEX*)
	  (AND EOF (ERROR EOF)))
	 ((< *INDEX* *STOP-INDEX*)
	  (SETQ CH (AREF *LINE* *INDEX*))
	  (AND *FONT-FLAG* (SETQ CH (LDB %%CH-CHAR CH)))
	  (SETQ *INDEX* (1+ *INDEX*))
	  CH)
	 ((EQ *LINE* *LAST-LINE*)
	  (SETQ *INDEX* NIL)
	  (AND EOF (ERROR EOF)))
	 (T
	  (SETQ *LINE* (LINE-NEXT *LINE*))
	  (SETQ *INDEX* 0)
	  (SETQ *STOP-INDEX* (IF (EQ *LINE* *LAST-LINE*)
				 *LAST-INDEX*
				 (LINE-LENGTH *LINE*)))
	  #\CR)))
  (:LINE-IN (&OPTIONAL SIZE EOF)
   ;; First, if there is an unread character, discard it and back up one.
   (COND (*UNRCHF*
	  (SETQ *UNRCHF* NIL)
	  (IF (ZEROP *INDEX*)
	      (SETQ *LINE* (LINE-PREVIOUS *LINE*) *INDEX* (LINE-LENGTH *LINE*))
	      (SETQ *INDEX* (1- *INDEX*)))))
   (LET ((RET-LINE)
	 (AT-END-P (EQ *LINE* *LAST-LINE*)))
     (COND ((AND (NULL SIZE)
		 (ZEROP *INDEX*)
		 (NOT AT-END-P))
	    ;; Easy case, just return the line and advance the pointer.
	    (SETQ RET-LINE *LINE*)
	    (SETQ *LINE* (LINE-NEXT *LINE*))
	    (SETQ *STOP-INDEX* (IF (EQ *LINE* *LAST-LINE*)
				   *LAST-INDEX*
				   (LINE-LENGTH *LINE*))))
	   ((NULL *INDEX*)
	    ;; End of file.
	    (AND EOF (ERROR EOF)))
	   (T
	    ;; Hard case, make a copy.
	    (SETQ RET-LINE
		  (MAKE-ARRAY (- *STOP-INDEX* *INDEX*)
			      ':TYPE (ARRAY-TYPE *LINE*)
			      ':LEADER-LENGTH (IF (NUMBERP SIZE) SIZE NIL)))
	    (DO ((LF *INDEX* (1+ LF))
		 (RT 0 (1+ RT)))
		(( LF *STOP-INDEX*))
	      (ASET (AREF *LINE* LF) RET-LINE RT))
	    (IF (NUMBERP SIZE)
		(STORE-ARRAY-LEADER (- *STOP-INDEX* *INDEX*) RET-LINE 0))
	    ;; Now advance the pointer.
	    (COND (AT-END-P
		   (SETQ *INDEX* NIL))
		  (T
		   (SETQ *LINE* (LINE-NEXT *LINE*))
		   (SETQ *INDEX* 0)
		   (SETQ *STOP-INDEX* (IF (EQ *LINE* *LAST-LINE*)
					  *LAST-INDEX*
					  (LINE-LENGTH *LINE*)))))))
     (VALUES RET-LINE AT-END-P)))
  (:UNTYI (CH)
   (SETQ *UNRCHF* CH))
  (:TYO (CH)
   (LET ((BP (INSERT (CREATE-BP *LINE* *INDEX*) CH)))
     (SETQ *LINE* (BP-LINE BP) *INDEX* (BP-INDEX BP))))
  (:LINE-OUT (LINE)	;Bleagh, really should take two optional args
   (COND ((AND (ZEROP *INDEX*) (EQ (ARRAY-LEADER-LENGTH LINE) LINE-LEADER-SIZE))
	  (INSERT-LINE-WITH-LEADER LINE *LINE*))	;Optimize case for file readin
	 ((ZEROP *INDEX*)			;Optimize case where it's not already a line
	  (LET ((NEW-LINE (CREATE-LINE 'ART-STRING (ARRAY-ACTIVE-LENGTH LINE) *INTERVAL*)))
	    (COPY-ARRAY-CONTENTS LINE NEW-LINE)
	    (INSERT-LINE-WITH-LEADER NEW-LINE *LINE*)))
	 (T
	  (LET ((BP (INSERT
		     (INSERT (CREATE-BP *LINE* *INDEX*) LINE)
		     #\CR)))
	    (SETQ *LINE* (BP-LINE BP) *INDEX* (BP-INDEX BP)))))
   LINE)
  (:STRING-OUT (STRING &OPTIONAL (START 0) END)
   (LET ((BP (INSERT (CREATE-BP *LINE* *INDEX*) STRING START END)))
     (SETQ *LINE* (BP-LINE BP) *INDEX* (BP-INDEX BP))))
  ((:UNTYO-MARK :READ-BP) ()
   (CREATE-BP *LINE* *INDEX*))
  (:UNTYO (MARK)
   (DELETE-INTERVAL MARK (CREATE-BP *LINE* *INDEX*) T)
   (SETQ *LINE* (BP-LINE MARK) *INDEX* (BP-INDEX MARK)))
  (:SET-BP (BP)
   (SETQ *LINE* (BP-LINE BP) *INDEX* (BP-INDEX BP))
   (SETQ *UNRCHF* NIL)
   (LET ((LAST-BP (INTERVAL-LAST-BP *INTERVAL*)))	;Take account of inserted changes
     (SETQ *LAST-LINE* (BP-LINE LAST-BP)
	   *LAST-INDEX* (BP-INDEX LAST-BP)))
   (SETQ *STOP-INDEX* (IF (EQ *LINE* *LAST-LINE*)
			  *LAST-INDEX*
			  (LINE-LENGTH *LINE*))))
  (:DELETE-TEXT ()
   (DELETE-INTERVAL *INTERVAL*))
  (:FRESH-LINE ()
   (OR (ZEROP *INDEX*) (INTERVAL-IO ':TYO #\CR)))
  (:SET-POINTER (POINTER)
   (OR (ZEROP POINTER) (FERROR NIL "Attempt to set pointer other than to beginning."))
   (LET ((BP (INTERVAL-FIRST-BP *INTERVAL*)))
     (SETQ *LINE* (BP-LINE BP)
	   *INDEX* (BP-INDEX BP))))
  (:READ-CURSORPOS (&OPTIONAL UNITS)
    (OR (EQ UNITS ':CHARACTER) (FERROR NIL "~S unknown cursor-position unit" UNITS))
    (DO ((I 0 (1+ I))
	 (X 0))
	(( I *INDEX*) (RETURN X 0))	;Y position always zero
      (SELECTQ (LDB %%CH-CHAR (AREF *LINE* I))
	(#\BS (SETQ X (MAX (1- X) 0)))
	(#\TAB (SETQ X (* (1+ (// X 8)) 8)))
	(OTHERWISE (SETQ X (1+ X))))))
  (:SET-CURSORPOS (X Y &OPTIONAL (UNITS ':PIXEL))
    Y					;This is a bit fraudulent, for FORMAT ~T.  Ignores Y.
    (OR (EQ UNITS ':CHARACTER) (FERROR NIL "~S unknown cursor-position unit" UNITS))
    ;; Can't use the regular indent stuff since we don't have a window.
    (LET ((FROM (INTERVAL-IO ':READ-CURSORPOS ':CHARACTER))
	  (TO X))
      (DO FROM FROM (1+ FROM) ( FROM TO)
	(INTERVAL-IO ':TYO #\SP))))
  ((:CLEAR-SCREEN) (&REST IGNORE))
  ;;These are for the compiler (also FILE-READ-PROPERTY-LIST)
  (:PATHNAME (&AUX INT)
   (AND (TYPEP (SETQ INT (BP-TOP-LEVEL-NODE (CREATE-BP *LINE* *INDEX*))) 'FILE-BUFFER)
	(BUFFER-PATHNAME INT)))
  (:COMPILER-WARNINGS-NAME . INTERVAL-IO-COMPILER-WARNINGS-NAME)
  ;; This is a separate message so that simulated BP of *LINE*,*INDEX* will be kept up to date
  (:DELETE-INTERVAL (START-BP &OPTIONAL END-BP IN-ORDER-P)
    (WITH-BP (BP (CREATE-BP *LINE* *INDEX*) ':NORMAL)
      (DELETE-INTERVAL START-BP END-BP IN-ORDER-P)
      (SETQ *LINE* (BP-LINE BP)
	    *INDEX* (BP-INDEX BP))))
  (:TEXT-DELETED () )
  ))

(DEFUN INTERVAL-IO-DEFAULT-HANDLER (OP &OPTIONAL ARG1 &REST REST)
  (STREAM-DEFAULT-HANDLER 'INTERVAL-IO OP ARG1 REST))

;;; Return an interval stream outputing at BP
(DEFUN INTERVAL-STREAM-INTO-BP (BP &OPTIONAL HACK-FONTS)
  (INTERVAL-STREAM BP BP T HACK-FONTS))

(DEFUN REST-OF-INTERVAL-STREAM (BP)
  (INTERVAL-STREAM BP (INTERVAL-LAST-BP *INTERVAL*) T))

;;; Copy from the stream into the interval until EOF.
;;; Returns a BP to where the end of the inserted text is.
;;; HACK-FONTS means interpret 's in the file as font-change characters
(DEFUN STREAM-INTO-BP (STREAM BP &OPTIONAL HACK-FONTS)
  (LET ((INT-STREAM (INTERVAL-STREAM-INTO-BP BP HACK-FONTS)))
    (STREAM-COPY-UNTIL-EOF STREAM INT-STREAM LINE-LEADER-SIZE)
    (FUNCALL INT-STREAM ':READ-BP)))

;;; Copy from the interval into the stream.
(DEFUN STREAM-OUT-INTERVAL (STREAM FROM-BP &OPTIONAL TO-BP IN-ORDER-P HACK-FONTS)
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (STREAM-COPY-UNTIL-EOF
    (INTERVAL-STREAM FROM-BP TO-BP T HACK-FONTS)
    STREAM
    NIL))
 
;;; Return a stream which inputs from the terminal and outputs to the buffer
(DEFUN MAKE-INTERVAL-TYPEOUT-STREAM ()
  (LET-CLOSED ((*INTERVAL-STREAM* (INTERVAL-STREAM-INTO-BP (POINT)))
	       (*TYPEOUT-WINDOW* *TYPEOUT-WINDOW*))
    'INTERVAL-TYPEOUT-STREAM-IO))

(DEFUN INTERVAL-TYPEOUT-STREAM-IO (OP &REST ARGS)
  (LOCAL-DECLARE ((SPECIAL *INTERVAL-STREAM* *TYPEOUT-WINDOW*))
    (LEXPR-FUNCALL (SELECTQ OP
		     ((:ITEM :ITEM-LIST) 'INTERVAL-TYPEOUT-STREAM-ITEM-IO)
		     ((:TYO :LINE-OUT :STRING-OUT :UNTYO-MARK :READ-BP :UNTYO :SET-BP
		       :DELETE-TEXT :FRESH-LINE :SET-POINTER :READ-CURSORPOS :SET-CURSORPOS
		       :CLEAR-SCREEN)
		      *INTERVAL-STREAM*)
		     (OTHERWISE *TYPEOUT-WINDOW*))
		   OP ARGS)))

(DEFSELECT INTERVAL-TYPEOUT-STREAM-ITEM-IO
  (:ITEM (IGNORE ITEM &REST FORMAT-ARGS)
    (IF FORMAT-ARGS
	(LEXPR-FUNCALL #'FORMAT 'INTERVAL-TYPEOUT-STREAM-IO FORMAT-ARGS)
	(PRINC ITEM 'INTERVAL-TYPEOUT-STREAM-IO)))
  (:ITEM-LIST (TYPE LIST &AUX (MAXL 0) N (SHEET (WINDOW-SHEET *WINDOW*)))
    (INTERVAL-TYPEOUT-STREAM-IO ':FRESH-LINE)
    (COND (LIST					;Do nothing if empty list
	   ;; Compute the maximum width of any item, in dots (MAXL).
	   (DOLIST (ITEM LIST)
	     (LET ((STRING (STRING (IF (LISTP ITEM) (CAR ITEM) ITEM))))
	       (SETQ MAXL (MAX (TV:SHEET-STRING-LENGTH SHEET STRING) MAXL))))
	   ;; How many items go on each line (except the last)?
	   (SETQ N (MAX (MIN (// *FILL-COLUMN*
				 (+ MAXL (FONT-CHAR-WIDTH (TV:SHEET-CURRENT-FONT SHEET))))
			     (LENGTH LIST))
			1))
	   ;; Now print the items and store the data in the table.
	   ;; Move to a new line when we exhaust a line, and at the end.
	   ;; I counts from 1 thru N on each line.
	   (DO ((I 1 (1+ I))
		(LIST LIST (CDR LIST))
		(WIDTH-PER (// *FILL-COLUMN* N)))
	       ((NULL LIST))
	     ;; Actually make this item.
	     (IF (LISTP (CAR LIST))
		 (INTERVAL-TYPEOUT-STREAM-ITEM-IO ':ITEM TYPE (CDAR LIST) "~A" (CAAR LIST))
		 (INTERVAL-TYPEOUT-STREAM-ITEM-IO ':ITEM TYPE (CAR LIST)))
	     ;; Space out for next item, or move to new line.
	     (IF (AND ( I N) (CDR LIST))
		 ;; Not end of line, space out for next item.
		 (MULTIPLE-VALUE-BIND (X Y)
		     (INTERVAL-TYPEOUT-STREAM-IO ':READ-CURSORPOS)
		   (INTERVAL-TYPEOUT-STREAM-IO ':SET-CURSORPOS
					       (* WIDTH-PER
						  (// (+ (1- WIDTH-PER) X)
						      WIDTH-PER))
					Y))
		 ;; End of line.
		 (INTERVAL-TYPEOUT-STREAM-IO ':TYO #\CR)
		 (SETQ I 0)))))))

(DEFUN GRIND-INTO-BP (BP SEXP)
  (SI:GRIND-TOP-LEVEL SEXP 90. (INTERVAL-STREAM-INTO-BP BP) T))

;;; Is the text immediately following BP the same as the contents of STRING?
;;; If string contains newlines, this doesn't work.
(DEFUN LOOKING-AT (BP STRING)
  (LET ((CP (BP-INDEX BP))
	(SLEN (STRING-LENGTH STRING)))
    (STRING-EQUAL (BP-LINE BP) STRING CP 0 (+ CP SLEN))))

;;; Is the text immediately before BP the same as the contents of STRING?
;;; If string contains newlines, this doesn't work.
(DEFUN LOOKING-AT-BACKWARD (BP STRING)
  (LET ((CP (BP-INDEX BP))
	(SLEN (STRING-LENGTH STRING)))
    (AND ( CP SLEN)
	 (STRING-EQUAL (BP-LINE BP) STRING (- CP SLEN) 0 CP))))

;;; Is this character a delimiter?
(DEFUN DELIMCHAR-P (CHAR)
  (LET ((CH (CHAR-UPCASE (LDB %%CH-CHAR CHAR))))
    (NOT (OR (AND ( CH #/A) ( CH #/Z))
	     (AND ( CH #/0) ( CH #/9))))))

(DEFUN BP-LOOKING-AT-LIST (BP LIST)
  (DO ((LIST LIST (CDR LIST))
       (BP-CH (BP-CH-CHAR BP))
       (CH))
      ((NULL LIST) NIL)
    (AND (IF (NUMBERP (SETQ CH (CAR LIST)))
	     (CHAR-EQUAL BP-CH CH)
	     (LET ((LEN (STRING-LENGTH CH))
		   (INDEX (BP-INDEX BP)))
	       (STRING-EQUAL (BP-LINE BP) CH INDEX 0 (+ INDEX LEN) LEN)))
	 (RETURN CH))))

;Return a list of callers of a function, like WHO-CALLS prints
;The symbol UNBOUND-FUNCTION is treated specially here too.
;FUNCTION can be a list of symbols or a single symbol.
(LOCAL-DECLARE ((SPECIAL LIST))
(DEFUN LIST-CALLERS (FUNCTION &OPTIONAL (PKG PKG-GLOBAL-PACKAGE) &AUX (LIST NIL))
  (SI:FIND-CALLERS-OF-SYMBOLS FUNCTION PKG #'(LAMBDA (CALLER IGNORE IGNORE)
					       (OR (MEMQ CALLER LIST) (PUSH CALLER LIST))))
  LIST))

(LOCAL-DECLARE ((SPECIAL FUNCTION LIST))
(DEFUN LIST-MATCHING-SYMBOLS (FUNCTION &OPTIONAL (PKG PKG-GLOBAL-PACKAGE) &AUX (LIST NIL))
  (FUNCALL (IF (EQ PKG PKG-GLOBAL-PACKAGE) #'MAPATOMS-ALL #'MAPATOMS)
	   #'(LAMBDA (SYM) (AND (FUNCALL FUNCTION SYM)
				(NOT (MEMQ SYM LIST))
				(PUSH SYM LIST)))
	   PKG)
  LIST))

;;; Interval sorting
(DEFUN SORT-LINES-INTERVAL (LESSP-FN FROM-BP &OPTIONAL TO-BP IN-ORDER-P)
  "Given a lessp predicate and an interval, sort the lines in that interval.
The argument BP's are assumed to point at the beginning of their lines.
BP's to the ends of the interval remain at the ends of the interval, BP's
inside the interval move with their lines."
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (MUNG-BP-INTERVAL FROM-BP)
  (LET ((PRECEDING-LINE (LINE-PREVIOUS (BP-LINE FROM-BP)))
	(FOLLOWING-LINE (BP-LINE TO-BP))
	(PRECEDING-BPS (DO ((L (LINE-BP-LIST (BP-LINE FROM-BP)) (CDR L))
			    (R NIL))
			   ((NULL L) R)
			 (AND (ZEROP (BP-INDEX (CAR L)))
			      (EQ (BP-STATUS (CAR L)) ':NORMAL)
			      (PUSH (CAR L) R))))
	(N-LINES (1- (COUNT-LINES FROM-BP TO-BP T)))
	LINE-ARRAY FIRST-LINE)
    (SETQ LINE-ARRAY (MAKE-ARRAY N-LINES))
    (DO ((I 0 (1+ I))
	 (L (BP-LINE FROM-BP) (LINE-NEXT L)))
	((EQ L FOLLOWING-LINE))
      (ASET L LINE-ARRAY I))
    (SORT LINE-ARRAY LESSP-FN)
    (DO ((PREC PRECEDING-LINE LINE)
	 (I 0 (1+ I))
	 (LINE))
	((= I N-LINES)
	 (COND ((NOT (NULL LINE))
		(SETF (LINE-NEXT LINE) FOLLOWING-LINE)
		(SETF (LINE-PREVIOUS FOLLOWING-LINE) LINE))))
      (SETQ LINE (AREF LINE-ARRAY I))
      (AND PREC (SETF (LINE-NEXT PREC) LINE))
      (SETF (LINE-PREVIOUS LINE) PREC))
    (SETQ FIRST-LINE (AND (PLUSP N-LINES) (AREF LINE-ARRAY 0)))
    (RETURN-ARRAY (PROG1 LINE-ARRAY (SETQ LINE-ARRAY NIL)))
    (DOLIST (BP PRECEDING-BPS)
      (MOVE-BP BP FIRST-LINE 0))))

(DEFUN SORT-INTERVAL-ARRAY (ARRAY LESSP-FN FROM-BP &OPTIONAL TO-BP IN-ORDER-P)
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (SORT ARRAY LESSP-FN)
  (LET ((NEW-INTERVAL (CREATE-INTERVAL)))
    (DO ((END-BP (INTERVAL-LAST-BP NEW-INTERVAL))
	 (I 0 (1+ I))
	 (LEN (ARRAY-ACTIVE-LENGTH ARRAY)))
	(( I LEN))
      (INSERT-INTERVAL END-BP (AREF ARRAY I)))
    (UNDO-SAVE FROM-BP TO-BP T "Sort")
    (DELETE-INTERVAL FROM-BP TO-BP T)
    (INSERT-INTERVAL FROM-BP NEW-INTERVAL)))

(DEFUN INTERVAL-LESSP (INTERVAL-1-FROM-BP INTERVAL-1-TO-BP INTERVAL-1-IN-ORDER-P
		       INTERVAL-2-FROM-BP INTERVAL-2-TO-BP INTERVAL-2-IN-ORDER-P)
  (GET-INTERVAL INTERVAL-1-FROM-BP INTERVAL-1-TO-BP INTERVAL-1-IN-ORDER-P)
  (GET-INTERVAL INTERVAL-2-FROM-BP INTERVAL-2-TO-BP INTERVAL-2-IN-ORDER-P)
  (DO ((LINE-1 (BP-LINE INTERVAL-1-FROM-BP))
       (LINE-2 (BP-LINE INTERVAL-2-FROM-BP))
       (LEN-1 (LINE-LENGTH (BP-LINE INTERVAL-1-FROM-BP)))
       (LEN-2 (LINE-LENGTH (BP-LINE INTERVAL-2-FROM-BP)))
       (INDEX-1 (BP-INDEX INTERVAL-1-FROM-BP) (1+ INDEX-1))
       (INDEX-2 (BP-INDEX INTERVAL-2-FROM-BP) (1+ INDEX-2))
       (END-LINE-1 (BP-LINE INTERVAL-1-TO-BP))
       (END-LINE-2 (BP-LINE INTERVAL-2-TO-BP))
       (END-INDEX-1 (BP-INDEX INTERVAL-1-TO-BP))
       (END-INDEX-2 (BP-INDEX INTERVAL-2-TO-BP))
       (CH-1) (CH-2))
      (NIL)
    ;; If the second string is exhausted, then the strings are equal or the second one is less
    ;; so we return false.
    (AND (EQ LINE-2 END-LINE-2) (= INDEX-2 END-INDEX-2)
	 (RETURN NIL))
    ;; If the first string is exhausted, it is less.
    (AND (EQ LINE-1 END-LINE-1) (= INDEX-1 END-INDEX-1)
	 (RETURN T))
    (IF (= INDEX-1 LEN-1)
	(SETQ LINE-1 (LINE-NEXT LINE-1)
	      LEN-1 (LINE-LENGTH LINE-1)
	      INDEX-1 -1
	      CH-1 #\CR)
	(SETQ CH-1 (AREF LINE-1 INDEX-1)))
    (IF (= INDEX-2 LEN-2)
	(SETQ LINE-2 (LINE-NEXT LINE-2)
	      LEN-2 (LINE-LENGTH LINE-2)
	      INDEX-2 -1
	      CH-2 #\CR)
	(SETQ CH-2 (AREF LINE-2 INDEX-2)))
    (AND (CHAR-LESSP CH-2 CH-1)
	 (RETURN NIL))
    (AND (CHAR-LESSP CH-1 CH-2)
	 (RETURN T))))

(DEFSTRUCT (INTERVAL-WITH-SORT-INTERVAL :ARRAY :NAMED (:INCLUDE INTERVAL))
  INTERVAL-SORT-FIRST-BP
  INTERVAL-SORT-LAST-BP)

(DEFUN INTERVAL-WITH-SORT-INTERVAL-LESSP (INT1 INT2)
  (INTERVAL-LESSP (INTERVAL-SORT-FIRST-BP INT1) (INTERVAL-SORT-LAST-BP INT1) T
		  (INTERVAL-SORT-FIRST-BP INT2) (INTERVAL-SORT-LAST-BP INT2) T))

(DEFUN SORT-INTERVAL-FUNCTIONS (MOVE-TO-KEY-FN MOVE-OVER-KEY-FN MOVE-TO-NEXT-FN LESSP-FN
				FROM-BP &OPTIONAL TO-BP IN-ORDER-P)
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (LET ((ARRAY (MAKE-ARRAY 400. ':LEADER-LIST '(0))))
    (DO ((*INTERVAL* (CREATE-INTERVAL (COPY-BP FROM-BP ':NORMAL) (COPY-BP TO-BP ':MOVES)))
	 (START-BP FROM-BP END-BP)
	 (KEY-START-BP) (KEY-END-BP) (END-BP))
	((BP-= START-BP TO-BP))
      (SETQ KEY-START-BP (FUNCALL MOVE-TO-KEY-FN START-BP)
	    KEY-END-BP (FUNCALL MOVE-OVER-KEY-FN KEY-START-BP)
	    END-BP (FUNCALL MOVE-TO-NEXT-FN KEY-END-BP))
      (ARRAY-PUSH-EXTEND
	ARRAY (MAKE-INTERVAL-WITH-SORT-INTERVAL INTERVAL-FIRST-BP START-BP
						INTERVAL-LAST-BP END-BP
						INTERVAL-SORT-FIRST-BP KEY-START-BP
						INTERVAL-SORT-LAST-BP KEY-END-BP)))
    (SORT-INTERVAL-ARRAY ARRAY LESSP-FN FROM-BP TO-BP T)))

(DEFSTRUCT (INTERVAL-WITH-SORT-KEY :ARRAY :NAMED (:INCLUDE INTERVAL))
  INTERVAL-SORT-KEY)

(DEFUN SORT-INTERVAL-FUNCTIONS-WITH-KEY (MOVE-TO-KEY-FN GET-KEY-FN MOVE-TO-NEXT-FN LESSP-FN
				FROM-BP &OPTIONAL TO-BP IN-ORDER-P)
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (LET ((ARRAY (MAKE-ARRAY 20. ':LEADER-LIST '(0))))
    (DO ((*INTERVAL* (CREATE-INTERVAL (COPY-BP FROM-BP ':NORMAL) (COPY-BP TO-BP ':MOVES)))
	 (START-BP FROM-BP END-BP)
	 (KEY-START-BP) (KEY-END-BP) (KEY) (END-BP))
	((BP-= START-BP TO-BP))
      (SETQ KEY-START-BP (FUNCALL MOVE-TO-KEY-FN START-BP))
      (MULTIPLE-VALUE (KEY-END-BP KEY)
	(FUNCALL GET-KEY-FN KEY-START-BP))
      (SETQ END-BP (FUNCALL MOVE-TO-NEXT-FN KEY-END-BP))
      (ARRAY-PUSH ARRAY (MAKE-INTERVAL-WITH-SORT-KEY INTERVAL-FIRST-BP START-BP
						     INTERVAL-LAST-BP END-BP
						     INTERVAL-SORT-KEY KEY)))
    (SORT-INTERVAL-ARRAY ARRAY LESSP-FN FROM-BP TO-BP T)))