;;; -*- Mode:LISP; Package:ZWEI; Base:10 -*-
;;;ART-Q-LIST references (and some related functions) in ZWEI

;;;!!! Removed font-stack usage; patch avail. -KmC

;;;From DJ: L.ZWEI; NPRIM.LISP#>
;;; Parse a file, finding the defuns, adding the names to the completion Aarray and the
;;; symbols' property lists
;;; Note that this must be called with PACKAGE bound to the file's package,
;;; which is typically done by making the buffer current.
;;; If a stream is specified, we read that stream into the buffer until eof,
;;; a line at a time, and sectionize the stuff as we go.
;;; In that case, HACK-FONTS is passed on to INTERVAL-STREAM.

;;; If PROPERTY is non-NIL, we maintain on each function spec
;;; a property of that name, whose value is a list of buffers it is defined in.
;;; We add and remove entries in those lists for sections that appear and disappear.
(DEFUN SECTIONIZE-FILE-BUFFER (BUFFER &OPTIONAL AARRAY PROPERTY START-NODE END-NODE
			       STREAM HACK-FONTS
                                 &AUX (PACKAGE PACKAGE)
				 (NODE-LIST NIL)
				 (MODE (SEND BUFFER ':MAJOR-MODE))
				 (*INTERVAL* BUFFER) INT-STREAM
				 FIRST-BP LAST-BP ADDED-COMPLETIONS
				 BUFFER-TICK OLD-CHANGED-SECTIONS
				 NODES-TO-REUSE ACTUAL-NEW-NODES
				 START-PREDECESSOR END-FOLLOWER)
  "Compute the sectionization of all or part of BUFFER.
If START-NODE and END-NODE are NIL, the whole buffer is resectionized from scratch.
If they are non-NIL, they should be sections of the buffer;
that portion of the buffer (inclusive!) is resectionized,
reusing any existing nodes if objects with the same names are still present."
  (COMPUTE-BUFFER-PACKAGE BUFFER)
  (SETQ FIRST-BP (INTERVAL-FIRST-BP (OR START-NODE BUFFER))
	LAST-BP (IF END-NODE (COPY-BP (INTERVAL-LAST-BP END-NODE))
		  (INTERVAL-LAST-BP BUFFER)))
  ;; If operating on a specified range of sections,
  ;; from START-NODE to END-NODE inclusive,
  ;; put all those nodes on NODES-TO-REUSE.
  (IF START-NODE
      (DO ((N START-NODE (NODE-NEXT N)))
	  (())
	(PUSH N NODES-TO-REUSE)
	(IF (EQ N END-NODE) (RETURN))))
  (SETQ END-FOLLOWER (IF END-NODE (NODE-NEXT END-NODE))
	START-PREDECESSOR (IF START-NODE (NODE-PREVIOUS START-NODE)))
  ;;Buffer must be a FILE-BUFFER, but need not be a real ZMACS BUFFER.
  (WHEN AARRAY
    (SETQ ADDED-COMPLETIONS (zl:MAKE-ARRAY #o100 :TYPE 'ART-Q-LIST :LEADER-LENGTH 2 :LEADER-LIST '(0))))
  (AND STREAM
       (SETQ INT-STREAM (INTERVAL-STREAM-INTO-BP LAST-BP HACK-FONTS)))
  ;; Make sure the buffer ends with an empty line.
;  (OR (ZEROP (BP-INDEX LAST-BP))
;      (INSERT LAST-BP #\CR))
  (SETQ BUFFER-TICK (BUFFER-TICK BUFFER))
  (TICK)
  ;; This is no longer needed for computing the NODE-TICK of sections,
  ;; since that can be determined from the text.
  ;; But it is still useful for remembering the compile-ticks.
  (OR NODES-TO-REUSE
      (DOLIST (NODE (NODE-INFERIORS BUFFER))
	(PUSH (CONS (SECTION-NODE-NAME NODE)
		    NODE)
	      OLD-CHANGED-SECTIONS)))
  ;; Now scan the buffer and record the definitions.
  (DO* ((LINE (BP-LINE FIRST-BP) (LINE-NEXT LINE))
	(LIMIT (IF (ZEROP (BP-INDEX LAST-BP))	;Line to stop at (may be NIL)
		   (BP-LINE LAST-BP)
		 (LINE-NEXT (BP-LINE LAST-BP))))
	(EOFFLG)
	(BP (COPY-BP FIRST-BP))
	(PREV-NODE-START-BP FIRST-BP)
	(PREV-NODE-DEFUN-LINE NIL)
	(FIRST-NODE-NAME (IF START-NODE "Things deleted" "Buffer header"))
	(PREVIOUS-NODE NIL)
	(ADD-SECTIONS (GET MODE 'EDITING-TYPE))
	(SECTION-P (GET ADD-SECTIONS 'SECTION-P))
	(SECTION-NAME-FUNCTION (GET ADD-SECTIONS 'GET-SECTION-NAME)))
      (NIL)
    ;; If we have a stream, and we are at the limit, read another line.
    (WHEN (AND STREAM (EQ LINE LIMIT) (NOT EOFFLG))
      (LET ((DEFAULT-CONS-AREA *ZWEI-AREA*))
	(MULTIPLE-VALUE-SETQ (LINE EOFFLG)
	  (SEND STREAM :LINE-IN LINE-LEADER-SIZE))
	(IF LINE (SETQ LINE (SEND INT-STREAM :LINE-OUT LINE)))
	(SETQ LIMIT (LINE-NEXT LINE))))
    ;; See if the line is the start of a defun.
    ;; If so, record the section that it terminates.
    (WHEN (AND ADD-SECTIONS
	       (OR EOFFLG
		   (EQ LINE LIMIT)
		   (AND LINE (FUNCALL SECTION-P LINE))))
      (LET ((START PREV-NODE-START-BP)
	    END OLD-NODE)
	(cond ((OR EOFFLG (EQ LINE LIMIT))
	       (SETQ END LAST-BP))
	      (t
	       (MOVE-BP BP LINE 0)
	       (SETQ END (COPY-BP BP))
	  ;; Include one blank line before the form in the same section with it.
	       (IF (AND (LINE-PREVIOUS (BP-LINE END))
			(LINE-BLANK-P (LINE-PREVIOUS (BP-LINE END))))
		   (MOVE-BP END (LINE-PREVIOUS (BP-LINE END)) 0))
	       (SETQ PREV-NODE-START-BP END)))
	(UNLESS (AND (NOT (OR EOFFLG (EQ LINE LIMIT)))
		     (OR (BP-= START END)
			 (AND (NOT PREV-NODE-DEFUN-LINE)
			      START-NODE
			      (NOT (EQ START-NODE (CAR (NODE-INFERIORS BUFFER)))))))
	  ;; Now we have decided for certain to create a section ending here.
	  ;; Extract the name of the section that is just being terminated.
	  ;; By now, all the lines that the name runs over must have been read in.
	  (MULTIPLE-VALUE-BIND (SYM STR ERR)
	      (IF PREV-NODE-DEFUN-LINE
		  (FUNCALL SECTION-NAME-FUNCTION PREV-NODE-DEFUN-LINE BP)
		FIRST-NODE-NAME)
	    (WHEN ERR
	      (SETQ SYM "Unknown" STR NIL))
	    (UNLESS ERR
	      (SETQ OLD-NODE (CDR (SI:ASSOC-EQUAL SYM OLD-CHANGED-SECTIONS))))
	    (SETQ PREVIOUS-NODE
		  (ADD-SECTION-NODE START END
				    SYM PREV-NODE-DEFUN-LINE BUFFER PREVIOUS-NODE
				    NIL
;				    (IF OLD-NODE
;					(NODE-TICK OLD-NODE)
;				      (IF STREAM BUFFER-TICK *TICK*))
				    (IF OLD-NODE
					(SECTION-NODE-COMPILE-TICK OLD-NODE)
				      BUFFER-TICK)
				    NODES-TO-REUSE))
	    (cond ((MEMQ PREVIOUS-NODE NODES-TO-REUSE)
		   (SETQ NODES-TO-REUSE (DELQ PREVIOUS-NODE NODES-TO-REUSE)))
		  (t
		   (PUSH PREVIOUS-NODE ACTUAL-NEW-NODES)
		   (WHEN (AND ADDED-COMPLETIONS (NOT (STRINGP SYM)))
		     (SECTION-COMPLETION SYM STR ADDED-COMPLETIONS)
		     (UNLESS (SYMBOLP SYM)
		       (SECTION-COMPLETION SYM
					   (DEFINITION-NAME-AS-STRING NIL SYM)
					   ADDED-COMPLETIONS)))))
	    (PUSH PREVIOUS-NODE NODE-LIST))))
      (SETQ PREV-NODE-DEFUN-LINE LINE))
    ;; After processing the last line, exit.
    (WHEN (OR EOFFLG (EQ LINE LIMIT))
      (RETURN)))
  ;; If reading a stream, we should not have inserted a CR
  ;; after the eof line.
  (AND STREAM
       (DELETE-INTERVAL (FORWARD-CHAR (INTERVAL-LAST-BP BUFFER) -1 T)
			(INTERVAL-LAST-BP BUFFER)
			T))
  ;; Splice the nodes just made in with the nodes
  ;; before START-NODE and after END-NODE
  (LET ((FIRST-NEW-NODE (CAR (LAST NODE-LIST)))
	(FLUSHED-NODES (IF START-NODE NODES-TO-REUSE (NODE-INFERIORS BUFFER))))
    (COND (NODE-LIST
	   (WHEN END-FOLLOWER
	     (SETF (NODE-PREVIOUS END-FOLLOWER) (CAR NODE-LIST))
	     (SETF (NODE-NEXT (CAR NODE-LIST)) END-FOLLOWER))
	   (WHEN START-PREDECESSOR
	     (SETF (NODE-NEXT START-PREDECESSOR) FIRST-NEW-NODE)
	     (SETF (NODE-PREVIOUS FIRST-NEW-NODE) START-PREDECESSOR)))
	  ((AND START-PREDECESSOR END-FOLLOWER)
	   (SETF (NODE-NEXT START-PREDECESSOR) END-FOLLOWER)
	   (SETF (NODE-PREVIOUS END-FOLLOWER) START-PREDECESSOR)))
    ;; Construct the new list of all inferiors of BUFFER.
    ;; Except: if all old nodes were reused, and no new ones made,
    ;; these lists are both still correct.
    (IF (OR FLUSHED-NODES ACTUAL-NEW-NODES)
	(LET (ALL-NODES)
	  (DO ((N (IF END-FOLLOWER (CAR (LAST (NODE-INFERIORS BUFFER)))
		    (CAR NODE-LIST))
		  (NODE-PREVIOUS N)))
	      ((NULL N))
	    (PUSH N ALL-NODES))
	  (SETF (NODE-INFERIORS BUFFER) ALL-NODES)))
    ;; Flush old section nodes that were not reused.
    (DOLIST (NODE FLUSHED-NODES)
      ;; Flush ZMACS-BUFFERS properties for old nodes not reused.
      (WHEN PROPERTY
	(LET ((THE-BUFFER BUFFER)
	      (SYM (SECTION-NODE-NAME NODE)))
	  (OR (STRINGP SYM)
	      (CONDITION-CASE ()
		  (SI:FUNCTION-SPEC-PUTPROP
		   SYM
		   (DEL-IF #'(LAMBDA (DEFN) (EQ (CAR DEFN) THE-BUFFER))
			   (SI:FUNCTION-SPEC-GET SYM PROPERTY))
		   PROPERTY)
		(SYS:INVALID-FUNCTION-SPEC NIL)))))
      (FLUSH-BP (INTERVAL-FIRST-BP NODE))
      (FLUSH-BP (INTERVAL-LAST-BP NODE)))
    ;; Attach ZMACS-BUFFERS properties to the symbols defined herein.
    (WHEN PROPERTY
      (DOLIST (NODE ACTUAL-NEW-NODES)
	(UNLESS (STRINGP (SECTION-NODE-NAME NODE))
	  (CONDITION-CASE ()
	      (SI:FUNCTION-SPEC-PUSH-PROPERTY 
	       (SECTION-NODE-NAME NODE)
	       (CONS BUFFER (SECTION-NODE-DEFUN-LINE NODE))
	       PROPERTY)
	    (SYS:INVALID-FUNCTION-SPEC NIL))))))
  ;; Merge new entries into the aarray.
  (WHEN ADDED-COMPLETIONS
    ;; Copy all the completion entries now, so they all go on one page.
    (LET ((I (ARRAY-LEADER ADDED-COMPLETIONS 0)))
      (UNLESS (ZEROP I)
	(DOTIMES (J I)
	  (SETF (AREF ADDED-COMPLETIONS J)
		(CONS (STRING-APPEND (CAR (AREF ADDED-COMPLETIONS J)))
		      (CDR (AREF ADDED-COMPLETIONS J)))))
	;; Sort them and merge them into the main list.
	(SORT-COMPLETION-AARRAY ADDED-COMPLETIONS)
	(MERGE-COMPLETION-AARRAY AARRAY ADDED-COMPLETIONS)))))

;;;ok
(DEFUN SECTION-COMPLETION (THING &OPTIONAL STRING MERGING-AARRAY (EXTEND-BY #o100))
  "Add an entry to the unsorted completion aarray MERGING-AARRAY.
THING is the object name, and STRING is string for it to be recognized by."
  (OR STRING (SETQ STRING (STRING THING)))
  (VECTOR-PUSH-EXTEND (CONS STRING (IF (CONSP THING) (NCONS THING) THING))
		     MERGING-AARRAY
		     EXTEND-BY))

;;;From DJ: L.ZWEI; COMD.LISP#>

(DEFUN COMPLETE-STRING (STRING ALIST DELIMS &OPTIONAL DONT-NEED-LIST CHAR-POS TRUNC
						      IGNORE-TRAILING-SPACE
			&AUX NCHUNKS CHUNKS CHUNK-DELIMS FILLS CHAMB TEMS RETS
			     RCHUNKS TEM LEN COMPLETED-P CHAR-CHUNK CHAR-OFFSET MAGIC-POS
			     TAIL ONE-BEFORE-TAIL TEMSTRING)
  "Complete a given STRING from an ALIST of strings.
DELIMS is a list of delimiter characters that delimit chunks.
 Each chuck is matched against the chunks of strings in the ALIST.
DONT-NEED-LIST says we really dont want all the possibilities, just not NIL.
CHAR-POS is position in string to be relocated with new things inserted.
 (The CHAR-POS value is the position of the same in the completed string).
TRUNC says dont complete more than one chunk at end.
IGNORE-TRAILING-SPACE non-NIL says ignore a trailing space character if any.
Returns new STRING, matching subset of ALIST, COMPLETED-P if some completion was done,
new CHAR-POS, and MAGIC-POS location of first point of ambiguity.
COMPLETED-P is 'NOSPACE if proper delimiter is already at end of string.
For efficiency, if ALIST is an ART-Q-LIST array, it is assumed to be alphabetically
sorted."
  (SETQ CHUNKS (MAKE-ARRAY 20. :FILL-POINTER 0)
	CHUNK-DELIMS (MAKE-ARRAY 20. :TYPE 'ART-Q :FILL-POINTER 0))
  (SETQ LEN (STRING-LENGTH STRING))
  (AND IGNORE-TRAILING-SPACE
       (> LEN 0)
       (= (AREF STRING (1- LEN)) #/SP)
       (DECF LEN))
  (DO ((I 0 (1+ I))
       (J 0))
      ((> I LEN))
    (WHEN (COND ((= I LEN)
		 (SETQ TEM -1))		;Last character delimits a chunk unless it is empty.
		(T
;character lossage
		 (OR (MEMQ (SETQ TEM (GLOBAL:AREF STRING I)) DELIMS)
		     (MEMQ (INT-CHAR TEM) DELIMS))))
      (AND CHAR-POS (> CHAR-POS J)	;Keep track of relative position
	   (SETQ CHAR-CHUNK (ARRAY-LEADER CHUNKS 0)
		 CHAR-OFFSET (- CHAR-POS J)))
      (VECTOR-PUSH-EXTEND (NSUBSTRING STRING J I) CHUNKS)
      (VECTOR-PUSH-EXTEND TEM CHUNK-DELIMS)
      (SETQ J I)))
  (SETQ NCHUNKS (ARRAY-ACTIVE-LENGTH CHUNKS)
	FILLS (MAKE-ARRAY NCHUNKS)
	TEMS (MAKE-ARRAY NCHUNKS)
	RCHUNKS (MAKE-ARRAY NCHUNKS)
	CHAMB (MAKE-ARRAY NCHUNKS :TYPE 'ART-1B))
  (AND (ARRAYP ALIST)
       (MULTIPLE-VALUE (ALIST TAIL ONE-BEFORE-TAIL)
	 (COMPLETE-STRING-BOUNDS ALIST DELIMS NCHUNKS CHUNKS CHUNK-DELIMS)))
  (AND ONE-BEFORE-TAIL
       (N-CHUNKS-MATCH-P (CAAR ALIST) (CAAR ONE-BEFORE-TAIL) NCHUNKS DELIMS)
       ;; The first and last possibilities are the same, for as many chunks as we need,
       ;; so all in between must also be the same.
       DONT-NEED-LIST
       ;; So if we don't need all the possibilities,
       ;; keep just the first one and the last one.
       (SETQ ALIST (LIST (CAR ALIST) (CAR ONE-BEFORE-TAIL))
	     TAIL NIL))
  (DO ((L ALIST (CDR L))
       (ALL-AMBIG))
      ((EQ L TAIL))
    (COND ((ATOM L))				;Indirect through multiple alists
	  ((NULL (COMPLETE-CHUNK-COMPARE (CAAR L) DELIMS NCHUNKS CHUNKS CHUNK-DELIMS TEMS
					 (AND (NULL RETS) RCHUNKS)))
	   (OR RETS (SETQ CHUNKS RCHUNKS))	;First winner determines case of result
	   (PUSH (CAR L) RETS)		;add to list of partial matches
	   (SETQ ALL-AMBIG DONT-NEED-LIST)
	   (DO ((I 0 (1+ I))
		(FILL))
	       (( I NCHUNKS))
	     (SETQ TEM (AREF TEMS I)
		   FILL (AREF FILLS I))
	     (COND ((NULL FILL)			;First one to complete a chunk
		    (SETF (AREF FILLS I) TEM)	;save for later ones
		    (AND (PLUSP (STRING-LENGTH TEM))
			 (SETQ ALL-AMBIG NIL)))	;This chunk not ambiguous yet
		   ((AND (EQUAL FILL "")
			 (ZEROP (AREF CHAMB I))
			 (NOT (EQUAL TEM "")))
		    ;; If there was an exact match found for this chunk,
		    ;; ignore everything that is NOT an exact match in this chunk.
		    (SETQ ALL-AMBIG NIL)
		    (RETURN NIL))
		   ((AND (EQUAL TEM "")
			 (NOT (AND (EQUAL FILL "")
				   (ZEROP (AREF CHAMB I)))))
		    ;; The first time we find an exact match for this chunk,
		    ;; from now on consider only exact matches for it,
		    ;; and forget anything we concluded about later chunks
		    ;; from completions that were inexact in this chunk.
		    (SETF (AREF FILLS I) "")
		    (SETF (AREF CHAMB I) 0)
		    (DO ((I (1+ I) (1+ I))) ((= I NCHUNKS))
		      (SETF (AREF FILLS I) NIL)
		      (SETF (AREF CHAMB I) 0))
		    (SETQ ALL-AMBIG NIL))
		   (T
		    (SETQ LEN (STRING-LENGTH FILL))
		    (DO ((J 0 (1+ J))
			 (LEN1 (STRING-LENGTH TEM)))
			(( J LEN)
			 (OR (ZEROP LEN)
			     (AND (= I (1- NCHUNKS))
				  (= LEN 1)
				  (MEM '= (AREF FILL 0) DELIMS))
			     (SETQ ALL-AMBIG NIL)))
		      (WHEN (OR ( J LEN1)
				(NOT (CHAR-EQUAL (AREF FILL J) (AREF TEM J))))
			;; Not the same completion, shorten final version
			(ASET (NSUBSTRING FILL 0 J) FILLS I)
			(SETF (AREF CHAMB I) 1)	;Remember this was ambiguous
			(OR (ZEROP J) (SETQ ALL-AMBIG NIL))
			(RETURN NIL))))))
	   ;;If not going to complete and don't need actual list, finish up now.
	   (AND ALL-AMBIG (NULL (AREF FILLS (1- NCHUNKS))) (RETURN NIL)))))
  (WHEN (AND TRUNC (SETQ TEMSTRING (AREF FILLS (1- NCHUNKS))))
    (SETQ LEN (STRING-LENGTH TEMSTRING))
    (AND (ZEROP (AREF CHAMB (1- NCHUNKS)))	;If last chunk wasn't ambigous,
	 (SETQ TRUNC 'NOSPACE))			;shouldn't have delimiter there
    (DO ((I 0 (1+ I)))
	(( I LEN))
      (WHEN (MEM '= (AREF TEMSTRING I) DELIMS)
	(ASET (NSUBSTRING TEMSTRING 0 (1+ I)) FILLS (1- NCHUNKS))
	(SETQ TRUNC 'NOSPACE)			;Already gave a delimiter
	(RETURN NIL))))
  (SETQ TEMSTRING "")
  (DO ((I 0 (1+ I)))
      (( I NCHUNKS))
    (AND CHAR-POS CHAR-CHUNK (= I CHAR-CHUNK)	;In case inside chunk not completed,
	 (SETQ CHAR-POS (+ (STRING-LENGTH TEMSTRING) CHAR-OFFSET)))	;relocate
    (SETQ TEMSTRING (STRING-APPEND TEMSTRING (AREF CHUNKS I)))
    (WHEN (AND (SETQ TEM (AREF FILLS I)) (> (STRING-LENGTH TEM) 0))
      (SETQ TEMSTRING (STRING-APPEND TEMSTRING TEM)
	    COMPLETED-P T)
      (AND CHAR-POS CHAR-CHUNK (= I CHAR-CHUNK)	;If inside completed chunk,
	   (SETQ CHAR-POS (STRING-LENGTH TEMSTRING))))	;move to end of it
    (OR MAGIC-POS (ZEROP (AREF CHAMB I))		;Remember end of leftmost ambigous chunk
	(SETQ MAGIC-POS (STRING-LENGTH TEMSTRING))))
  (AND COMPLETED-P (EQ TRUNC 'NOSPACE)
       (SETQ COMPLETED-P 'NOSPACE))
  (WHEN (OR (AND (ARRAY-HAS-LEADER-P TEMSTRING)
		 (MINUSP (FILL-POINTER TEMSTRING)))
	    (AND CHAR-POS (MINUSP CHAR-POS))
	    (AND MAGIC-POS (MINUSP MAGIC-POS)))
    (FERROR "Internal error in completion.  Report a bug."))
  (VALUES TEMSTRING (NREVERSE RETS) COMPLETED-P CHAR-POS MAGIC-POS))

;;;From DJ: L.ZWEI; COMD.LISP#>

;;; Given an ART-Q-LIST array and the chunks to match, compute the subset of that array
;;; that could possibly be a completion of the string, and return an NTHCDR of the G-L-P
;;; and the appropriate tail to stop with.
(DEFUN COMPLETE-STRING-BOUNDS (ALIST DELIMS NCHUNKS CHUNKS CHUNK-DELIMS
			       &OPTIONAL (NCHUNKS-FOR-ORDERING 1)
			       (LO 0) (HIHI (ARRAY-ACTIVE-LENGTH ALIST))
			       (HI LO))
  (DECF LO)
  (DO ((HILO HIHI)
       (IDX)
       (VAL T))
      (NIL)
    (AND (ZEROP (SETQ IDX (TRUNCATE (- HILO LO) 2)))	;binary search
	 (RETURN NIL))
    (SETQ IDX (+ LO IDX))
    (SETQ VAL (COMPLETE-CHUNK-COMPARE (CAR (AREF ALIST IDX)) DELIMS
				      NCHUNKS CHUNKS CHUNK-DELIMS NIL NIL
				      NCHUNKS-FOR-ORDERING))
    (COND ((EQ VAL 'LESS)
	   (SETQ LO IDX)
	   (SETQ HI IDX))
	  (T
	   (SETQ HILO IDX)
	   (COND ((NEQ VAL 'GREATER)
		  (SETQ HI IDX))
		 (T (SETQ HIHI IDX))))))
  (DO ((IDX)
       (VAL))
      (NIL)
    (AND (ZEROP (SETQ IDX (TRUNCATE (- HIHI HI) 2)))
	 (RETURN NIL))
    (SETQ IDX (+ HI IDX))
    (SETQ VAL (COMPLETE-CHUNK-COMPARE (CAR (AREF ALIST IDX)) DELIMS
				      NCHUNKS CHUNKS CHUNK-DELIMS NIL NIL
				      NCHUNKS-FOR-ORDERING))
    (COND ((NEQ VAL 'GREATER)
	   (SETQ HI IDX))
	  (T (SETQ HIHI IDX))))
  ;; At this point, HI is the last one not greater,
  ;; but LO is the last one that is less.  Increment LO to exclude that one.
  (INCF LO)
;  ;; I think problems can happen if HI is too close to LO.
;  (WHEN (<= HI (1+ LO))
;    (WHEN (< HI (LENGTH ALIST))
;      (INCF HI)))
  (IF (OR (= LO (LENGTH ALIST)) (< HI LO))
      (VALUES NIL NIL NIL)
    ;; Do the lowest and highest match for all the chunks we considered?
    (IF (AND (> HI (+ LO 2))
	     (N-CHUNKS-MATCH-P (CAR (AREF ALIST LO)) (CAR (AREF ALIST HI))
			       NCHUNKS-FOR-ORDERING DELIMS))
	;; Yes => search again, considering one more chunk,
	;; and search only the range not yet eliminated.
	(COMPLETE-STRING-BOUNDS ALIST DELIMS NCHUNKS CHUNKS CHUNK-DELIMS
				(1+ NCHUNKS-FOR-ORDERING) LO (1+ HI))
      (VALUES (%MAKE-POINTER DTP-LIST (ALOC ALIST LO))
	      (CDR (%MAKE-POINTER DTP-LIST (ALOC ALIST HI)))
	      (%MAKE-POINTER DTP-LIST (ALOC ALIST HI))))))

(DEFUN N-CHUNKS-MATCH-P (STRING1 STRING2 N DELIMS &AUX (POS -1))
  "T if the first N chunks of the two strings are identical."
  (DOTIMES (I N)
    (SETQ POS (STRING-SEARCH-SET DELIMS STRING1 (1+ POS)))
    (UNLESS POS (RETURN NIL)))
  (AND POS
       (PLUSP POS)
       (STRING-EQUAL STRING1 STRING2 :START1 0 :START2 0 :END1 POS :END2 POS)))

(DEFUN SORT-COMPLETION-AARRAY (AARRAY)
  "Sort AARRAY, an ART-Q-LIST array of conses, by the cars of the conses.
If array leader element is T, it means the array is already sorted,
so we do not sort it again."
  (COND ((NOT (ARRAY-LEADER AARRAY 1))	;If not sorted right now
	 (SORT AARRAY (FUNCTION (LAMBDA (X Y)
				  (STRING-LESSP (CAR X) (CAR Y)))))
	 (STORE-ARRAY-LEADER T AARRAY 1))))

(DEFCONST MERGE-COMPLETION-AARRAY-FUDGE 20.
  "Amount of space to leave for insertion of new aarray elements in MERGE-COMPLETION-ARRAY.")

(DEFUN FIND-AARRAY-INSERTION-INDEX (AARRAY STRING)
  "Given an AARRAY, find the index of the element for STRING, or where to insert one.
Assumes that AARRAY is sorted.  Uses a binary search.
AARRAY should be an ART-Q-LIST array of conses whose cars are strings."
  (DO ((LO 0) (HI (ARRAY-ACTIVE-LENGTH AARRAY)))
      ((= LO HI) (RETURN LO))
    (LET ((IDX (LSH (+ LO HI) -1)))
      (COND ((STRING-EQUAL STRING (CAR (AREF AARRAY IDX)))
	     (RETURN IDX))
	    ((STRING-LESSP STRING (CAR (AREF AARRAY IDX)))
	     (SETQ HI IDX))
	    ((SETQ LO (1+ IDX)))))))

(DEFUN MERGE-COMPLETION-AARRAY (AARRAY ADDITIONAL-AARRAY &AUX OLD-MAX ADDED-MAX NEW-AARRAY)
  "Merge the elements of ADDITIONAL-AARRAY into AARRAY.
An aarray is an ART-Q-LIST array of conses whose cars are strings.
If AARRAY was sorted, it remains sorted."
  (COND ((ZEROP (SETQ ADDED-MAX (ARRAY-ACTIVE-LENGTH ADDITIONAL-AARRAY)))
	 AARRAY)
	((ZEROP (SETQ OLD-MAX (ARRAY-ACTIVE-LENGTH AARRAY)))
	 (SETQ NEW-AARRAY ADDITIONAL-AARRAY)
	 (STORE-ARRAY-LEADER T NEW-AARRAY 1)
	 (STRUCTURE-FORWARD AARRAY NEW-AARRAY))
	((AND (ARRAY-LEADER AARRAY 1)
	      (< ADDED-MAX 4))
	 ;; If number being added is small,  do it by inserting in the old array.
	 ;; Make AARRAY big enough to hold all the new elements.
	 (IF (> (+ OLD-MAX ADDED-MAX) (ARRAY-LENGTH AARRAY))
	     (ADJUST-ARRAY-SIZE AARRAY (+ OLD-MAX ADDED-MAX MERGE-COMPLETION-AARRAY-FUDGE)))
	 (DOLIST (NEWELT (G-L-P ADDITIONAL-AARRAY))
	   (LET* ((AARRAY (FOLLOW-STRUCTURE-FORWARDING AARRAY))
		  (OLDIDX (FIND-AARRAY-INSERTION-INDEX AARRAY (CAR NEWELT)))
		  (OLDELT (AREF AARRAY OLDIDX)))
	     (IF (AND (< OLDIDX OLD-MAX)
		      (STRING-EQUAL (CAR OLDELT) (CAR NEWELT)))
		 (SETF (CDR OLDELT)
		       (MERGE-AND-ELIMINATE-DUPLICATES (CDR OLDELT) (CDR NEWELT)))
	       (SYS:%BLT-TYPED
		 (ALOC AARRAY (1- OLD-MAX))
		 (ALOC AARRAY OLD-MAX)
		 (- OLD-MAX OLDIDX) -1)
	       (SETF (FILL-POINTER AARRAY) (INCF OLD-MAX))
	       (SETF (AREF AARRAY OLDIDX) NEWELT))))
	 (FOLLOW-STRUCTURE-FORWARDING AARRAY))
	(T
	 ;; Make a new AARRAY big enough to hold both.
	 (SETQ NEW-AARRAY (MAKE-ARRAY (+ OLD-MAX ADDED-MAX MERGE-COMPLETION-AARRAY-FUDGE)
				      :TYPE 'ART-Q-LIST
				      :LEADER-LENGTH 2
				      :LEADER-LIST '(0)))
	 ;; Now merge the two inputs into it.
	 (DO ((OLD 0) (ADDED 0)
	      (OLD-ELEM) (ADDED-ELEM)
	      (ELEM-TO-BE-ADDED)
	      (LAST-ELEM-ADDED NIL ELEM-TO-BE-ADDED))
	     ;; Done when both inputs are empty.
	     ((AND (= OLD OLD-MAX) (= ADDED ADDED-MAX)))
	   ;; Find which input aarray's next element is least.  Remove it
	   (SETQ ADDED-ELEM (AND ( ADDED ADDED-MAX) (AREF ADDITIONAL-AARRAY ADDED))
		 OLD-ELEM (AND ( OLD OLD-MAX) (AREF AARRAY OLD)))
	   (IF (AND OLD-ELEM
		    (OR (NULL ADDED-ELEM)
			(STRING-LESSP (CAR OLD-ELEM) (CAR ADDED-ELEM))))
	       (SETQ ELEM-TO-BE-ADDED OLD-ELEM
		     OLD (1+ OLD))
	     (SETQ ELEM-TO-BE-ADDED ADDED-ELEM
		   ADDED (1+ ADDED)))
	   ;; and insert it into the new aarray.  But flush duplicate strings.
	   (COND ((AND LAST-ELEM-ADDED
		       (%STRING-EQUAL (CAR ELEM-TO-BE-ADDED) 0
				      (CAR LAST-ELEM-ADDED) 0 NIL))
		  (SETF (CDR LAST-ELEM-ADDED)
			(MERGE-AND-ELIMINATE-DUPLICATES (CDR ELEM-TO-BE-ADDED)
							(CDR LAST-ELEM-ADDED)))
		  (SETQ ELEM-TO-BE-ADDED LAST-ELEM-ADDED))
		 ((ARRAY-PUSH NEW-AARRAY ELEM-TO-BE-ADDED))
		 (T				;This ought to never happen
		  (ARRAY-PUSH-EXTEND NEW-AARRAY ELEM-TO-BE-ADDED))))
	 (STORE-ARRAY-LEADER T NEW-AARRAY 1)
	 (STRUCTURE-FORWARD AARRAY NEW-AARRAY))))

(DEFUN MERGE-AND-ELIMINATE-DUPLICATES (L1 L2 &AUX LIST)
  (SETQ LIST (IF (ATOM L1) (NCONS L1) (NREVERSE L1)))
  (IF (ATOM L2)
      (PUSH* L2 LIST)
    (DOLIST (X L2)
      (PUSH* X LIST)))
  (SETQ LIST (NREVERSE LIST))
  (IF (CDR LIST) LIST (CAR LIST)))

(DEFUN STRING-IN-AARRAY-P (STRING AARRAY)
  "T if STRING is the car of one of the elements of AARRAY.
Assumes AARRAY is sorted by the cars of its elements."
  (SETQ STRING (STRING STRING))
  (DO ((LO 0)
       (HI (ARRAY-ACTIVE-LENGTH AARRAY))
       IDX INC TEM)
      (NIL)
    (AND (ZEROP (SETQ INC (TRUNCATE (- HI LO) 2)))
	 (RETURN NIL))
    (SETQ IDX (+ LO INC))
    (COND ((ZEROP (SETQ TEM (STRING-COMPARE STRING (CAR (AREF AARRAY IDX)))))
	   (RETURN T))
	  ((PLUSP TEM)
	   (SETQ LO IDX))
	  (T
	   (SETQ HI IDX)))))

;;;From DJ: L.ZWEI; DOC.LISP#>

(DEFCOM COM-GENERATE-WALLCHART "Generates a Wallchart a la emacs for one or all comtabs.
The comtabs and the destination file are read from the minbuffer
Organised into keyboard and extended (i.e. not on a key) commands. Mouse
commands are ignored because they are not generally useful. Numeric and
self-inserting commands are not mentioned because they are obvious." ()
  (LET ((COMPLETION-ARRAY (MAKE-ARRAY (1+ (LENGTH ALL-COMTABS))
				      :TYPE :ART-Q-LIST
				      :LEADER-LENGTH 2)))
    (DOTIMES (ELT (1- (LENGTH COMPLETION-ARRAY)))
      (ASET (LET ((NAME (NTH ELT ALL-COMTABS)))
	      (CONS (MAKE-COMMAND-NAME NAME) NAME)) COMPLETION-ARRAY ELT))
    (ASET (NCONS "All") COMPLETION-ARRAY (1- (LENGTH COMPLETION-ARRAY)))
    (SORT-COMPLETION-AARRAY COMPLETION-ARRAY)
    (LET ((COMTAB (COMPLETING-READ-FROM-MINI-BUFFER "Wallchart of:" COMPLETION-ARRAY
						    NIL NIL "You are typing the name of a comtab, from which a wallchart will be generated. 
/"All/" will list all commands, including those not on any key.")))
      (AND (ATOM COMTAB) (BARF))
      (GENERATE-WALLCHART (READ-DEFAULTED-AUX-PATHNAME "Put wallchart into:") (CDR COMTAB))))
  DIS-NONE)

;;;From DJ: L.ZWEI; SECTIO.LISP#>

(DEFUN READ-TAG-TABLE (FILE &AUX (ADDED-COMPLETIONS (MAKE-ARRAY 500. :TYPE 'ART-Q-LIST
								     :LEADER-LENGTH 2)))
  "Read in tag table file named FILE, recording source files of functions in it."
  (STORE-ARRAY-LEADER 0 ADDED-COMPLETIONS 0)
  (WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :SUPER-IMAGE T :CHARACTERS T)
    (DO ((FILE-LIST) (PATHNAME) (MODE))
	(NIL)
      (MULTIPLE-VALUE-BIND (LINE EOF)
	  (SEND STREAM :LINE-IN)
	(COND (EOF
	       (SEND FILE :PUTPROP (NREVERSE FILE-LIST) 'ZMACS-TAG-TABLE-FILE-SYMBOLS)
	       (OR (RASSQ FILE *ZMACS-TAG-TABLE-ALIST*)
		   (PUSH (CONS (STRING FILE) FILE) *ZMACS-TAG-TABLE-ALIST*))
	       (RETURN)))
	(SETQ PATHNAME (FS:MERGE-PATHNAME-DEFAULTS LINE *PATHNAME-DEFAULTS*))
	(PUSH PATHNAME FILE-LIST)
	(SETQ LINE (SEND STREAM :LINE-IN))	;Length,Mode
	(SETQ MODE (GET-FILE-MAJOR-MODE
		     (INTERN (SUBSTRING LINE (1+ (STRING-SEARCH-CHAR #/, LINE))) "USER")))
	(DO ((*PACKAGE* (PKG-FIND-PACKAGE (OR (SEND (SEND PATHNAME :GENERIC-PATHNAME)
						    :GET ':PACKAGE)
					      *PACKAGE*)))
	     (SPACE-POS) (RUBOUT-POS)
	     (STR) (SNAME))
	    ((EQ (CHAR (SETQ LINE (SEND STREAM :LINE-IN)) 0) #/))
	  (COND ((SETQ SPACE-POS (STRING-SEARCH-SET '(#/SP #/TAB) LINE))
		 (SETQ SPACE-POS (1+ SPACE-POS)
		       RUBOUT-POS (COND ((STRING-SEARCH-CHAR (int-char #o177) LINE SPACE-POS))
					(T (SEND STREAM :LINE-IN)
					   (1+ (STRING-LENGTH LINE))))
		       STR (SUBSTRING LINE SPACE-POS (1- RUBOUT-POS)))
		 (COND ((CASE (GET MODE 'EDITING-TYPE)
			  (:LISP
			   (AND (%STRING-EQUAL LINE 0 "(DEF" 0 4)
				(NOT (%STRING-EQUAL LINE 0 "(DEFPROP " 0 9))
				(SETQ SNAME (SYMBOL-FROM-STRING STR LINE))))
			  (:TEXT
			   (AND (%STRING-EQUAL LINE 0 ".DEF" 0 4)
				(SETQ SNAME (INTERN STR *UTILITY-PACKAGE*))))
			  (OTHERWISE NIL))
			(SECTION-COMPLETION SNAME STR ADDED-COMPLETIONS 1000)
			(SECTION-COMPLETION SNAME (DEFINITION-NAME-AS-STRING NIL SNAME)
					    ADDED-COMPLETIONS 1000)
			(OR (GET SNAME ':SOURCE-FILE-NAME)
			    (SETF (GET SNAME ':SOURCE-FILE-NAME) PATHNAME))
			(PUSH* PATHNAME (GET SNAME 'ZMACS-TAG-FILE-SYMBOLS))))))))))
  (SORT-COMPLETION-AARRAY ADDED-COMPLETIONS)
  (MERGE-COMPLETION-AARRAY *ZMACS-COMPLETION-AARRAY* ADDED-COMPLETIONS))

;;;From DJ: L.ZWEI; ZMACS.LISP#>

(DEFUN INITIALIZE-ZMACS ()
  (PKG-GOTO 'USER)
  (INITIALIZE-ZWEI-GLOBALS)
  (INITIALIZE-ZMACS-COMTABS)
  (INITIALIZE-MAIL-CONTROL-X-COMTAB)
  (WHEN (VARIABLE-BOUNDP *ALL-ZMACS-WINDOWS*)
    (DOLIST (W *ALL-ZMACS-WINDOWS*)
      (IF (TYPEP (SEND W :SUPERIOR) 'ZMACS-FRAME)
	  (SEND (SEND W :SUPERIOR) :DEACTIVATE)
	  (SEND W :DEACTIVATE)))
    (SETQ *ALL-ZMACS-WINDOWS* NIL))
  (SETQ *ZMACS-BUFFER-LIST* NIL
	*ZMACS-BUFFER-NAME-ALIST* NIL *ZMACS-TAG-TABLE-ALIST* NIL)
  (SETQ *ZMACS-COMPLETION-AARRAY* (MAKE-ARRAY #o100 :TYPE 'ART-Q-LIST :LEADER-LIST '(0 T)))
  ;; Make command alist (and strings in it) not occupy too many pages.
  (SETQ *COMMAND-ALIST* (COPYALIST *COMMAND-ALIST*))
  (DOLIST (ELT *COMMAND-ALIST*)
    (SETF (CAR ELT) (COPY-SEQ (CAR ELT))))
  ;; Make one frame now.
  (LET ((FRAME (TV:MAKE-WINDOW 'ZMACS-FRAME :ACTIVATE-P T)))
    ;; Make an overlying window now, so that the first View command is faster.
    (LET ((WINDOW (SEND FRAME :EDITOR-WINDOW)))
      (CREATE-OVERLYING-WINDOW WINDOW))))