LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032412. :SYSTEM-TYPE :LOGICAL :VERSION 3. :TYPE "LISP" :NAME "COMD" :DIRECTORY ("REL3-SOURCE" "ZMACS") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758716656. :AUTHOR "REL3" :LENGTH-IN-BYTES 68216. :LENGTH-IN-BLOCKS 67. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  ;;; Zwei commands, see ZWEI;COMA for comments -*- Mode:Common-Lisp; Package:ZWEI; Base:8 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;;;;; Copyright (C) 1984,1987 Texas Instruments Incorporated. All rights reserved.;;; Copyright (C) 1980, Massachusetts Institute of Technology;;; Q-Register Commands.(DEFUN GET-REGISTER-NAME (PROMPT &OPTIONAL PURPOSE &AUX CHAR ECHO-FLAG)  "Read a register name in the echo area.Puts PROMPT in the mode line.  Returns a symbol in the utility package.The ZWEI:TEXT property of that symbol is the text contents.The ZWEI:POINT property of it is a location saved on it."  (SETQ CHAR (READ-CHAR-NO-HANG))  (LOOP    (COND ((NULL CHAR)   (FORMAT *QUERY-IO* "~&~A " PROMPT)   (TYPEIN-LINE-ACTIVATE     (SETQ CHAR (READ-CHAR)))   (SETQ ECHO-FLAG T)))    (IF (CHAR/= CHAR #\HELP)(RETURN)(PROGN  (SETQ CHAR NIL)  (SEND *QUERY-IO* :CLEAR-SCREEN)  (FORMAT *QUERY-IO* "You are typing the name of a ZWEI register~A.A name is just a character with bits attribute = 0; case is ignored."  (OR PURPOSE "")))))  (IF (CHAR= CHAR #\c-G)      (SIGNAL EH:*ABORT-OBJECT*))  (SETQ CHAR (CHAR-UPCASE (MAKE-CHAR CHAR)))  (IF ECHO-FLAG (FORMAT *QUERY-IO* "~C" CHAR))  (MAKE-REGISTER-NAME CHAR))(DEFUN MAKE-REGISTER-NAME (CHAR &OPTIONAL (RECORD T) &AUX SYM STR OLDP)  "Return the symbol that represents the ZWEI register named CHAR."  (SETQ STR (MAKE-ARRAY 1 :ELEMENT-TYPE 'STRING-CHAR))  (SETF (AREF STR 0) CHAR)  (MULTIPLE-VALUE-SETQ (SYM OLDP)    (INTERN STR *UTILITY-PACKAGE*))  (COND (OLDP (RETURN-ARRAY STR))(RECORD (PUSH SYM *Q-REG-LIST*)))  SYM)  (DEFCOM COM-OPEN-GET-REGISTER "Insert text from a specified register, gobbling blank lines.The register name, a character with bits attribute = 0, is read from the keyboard.Uses up blank lines the way Return does (calling the definition of Return).Leaves the point after, and the mark before, the text.With an argument, puts point before and mark after." ()   (LET ((QREG (GET-REGISTER-NAME "Get text from register:" " containing text")))     (LET ((POINT (POINT))   (MARK (MARK))   (THING (GET QREG 'TEXT)))       (OR THING (BARF "The register ~A does not contain any text." QREG))       (WITH-UNDO-SAVE ("Get register" POINT POINT T)  (MOVE-BP MARK (INSERT-INTERVAL POINT THING))  (FIXUP-FONTS-INTERVAL (GET QREG 'TEXT-FONTS) POINT MARK T)  (SETQ *CURRENT-COMMAND-TYPE* 'YANK)  (LET ((SAVE-PT (COPY-BP POINT))(NL (1- (COUNT-LINES POINT MARK))))    (AND (BEG-LINE-P (MARK)) (MOVE-BP MARK (FORWARD-CHAR MARK -1)))    (MOVE-BP POINT MARK)    (DOTIMES (I NL)      (KEY-EXECUTE #\NEWLINE))    (DELETE-INTERVAL POINT MARK)    (MOVE-BP (POINT) SAVE-PT)))       (OR *NUMERIC-ARG-P*   (SWAP-BPS POINT MARK))))   DIS-TEXT) (DEFCOM COM-GET-REGISTER "Insert text contained in specified register.The register name, a character with bits attribute = 0, is read from the keyboard.Leaves \"point\" before, and\"mark\" after, the text.With argument, puts point after and mark before." ()   (LET ((QREG (GET-REGISTER-NAME "Get text from register:" " containing text")))     (LET ((THING (GET QREG 'TEXT)))       (OR THING   (BARF "The register ~A does not contain any text." QREG))       (WITH-UNDO-SAVE ("Get register" (POINT) (POINT) T)  (MOVE-BP (MARK) (INSERT-INTERVAL (POINT) THING))  (FIXUP-FONTS-INTERVAL (GET QREG 'TEXT-FONTS) (POINT) (MARK) T))       (SETQ *CURRENT-COMMAND-TYPE* 'YANK)       (OR *NUMERIC-ARG-P*   (SWAP-BPS (POINT) (MARK)))))   DIS-TEXT) (DEFCOM COM-PUT-REGISTER "Put text from point to mark into a register.The register name, a character with bits attribute = 0, is read from the keyboard.With an argument, the text is also deleted." ()   (REGION (BP1 BP2)      (LET ((QREG (GET-REGISTER-NAME "Put text into register:")))(SETF (GET QREG 'TEXT) (COPY-INTERVAL BP1 BP2 T))(COND (*NUMERIC-ARG-P*       (DELETE-INTERVAL (POINT) (MARK))       DIS-TEXT)      (T       DIS-NONE))))) (DEFUN VIEW-REGISTER (SYM)  (LET ((TEXT (GET SYM 'TEXT)))    (FORMAT T "~&~10,5,2A~A~%" SYM            (COND ((NULL TEXT)   "[EMPTY]")                  (T   (SUMMARIZE-INTERVAL TEXT)))))  (LET* ((BP (CAR (GET SYM 'POINT))))    (WHEN BP      (LET ((*INTERVAL* (BP-TOP-LEVEL-NODE BP)))(FORMAT T "~& Position: Buffer ~A,~%~8T~A -|- ~A~%" (CDR (GET SYM 'POINT))(OR (SUMMARIZE-INTERVAL (FORWARD-LINE BP -1 T) BP) "")(OR (SUMMARIZE-INTERVAL BP (FORWARD-LINE BP 1 T)) "")))))) (DEFCOM COM-LIST-REGISTERS "List and display the contents of all defined registers." ()  (FORMAT T "List of all registers:")  (DO ((L *Q-REG-LIST* (CDR L)))      ((NULL L)       NIL)    (VIEW-REGISTER (CAR L)))  (FORMAT T "Done.")  DIS-NONE) (DEFCOM COM-KILL-REGISTER "Kill a register.The register name, a character with bits attribute = 0, is read from the keyboard." ()   (LET ((Q-REG (GET-REGISTER-NAME "Kill register:")))     (COND ((GET Q-REG 'TEXT)    (SETQ *Q-REG-LIST* (DELETE Q-REG (THE LIST *Q-REG-LIST*) :TEST #'EQ))    (REMPROP Q-REG 'TEXT))   (T    (BARF "The register ~A does not contain anything." Q-REG))))   DIS-NONE) (DEFCOM COM-SAVE-POSITION "Save the current point in a register.The register name, a character with bits attribute = 0, is read from the keyboard." ()   (LET ((Q-REG (GET-REGISTER-NAME "Point to register:")))     (SAVE-POSITION-IN-REGISTER Q-REG (POINT)))   DIS-NONE) (DEFUN SAVE-POSITION-IN-REGISTER (REGISTER BP)  (LET ((PT (GET REGISTER 'POINT)))    (COND (PT   (MOVE-BP (CAR PT) BP)   (RPLACD PT (BP-TOP-LEVEL-NODE BP)))  (T   (SETQ PT (CONS (COPY-BP BP :NORMAL) (BP-TOP-LEVEL-NODE BP)))))    (SETF (GET REGISTER 'POINT) PT))) (DEFCOM COM-JUMP-TO-SAVED-POSITION "Restore a saved position from a register.The register name, a character with bits attribute = 0, is read from the keyboard." (KM)  (LET ((Q-REG (GET-REGISTER-NAME "Register to point:" " containing a location")))    (LET ((PT (GET Q-REG 'POINT)))      (WHEN (NULL PT)(BARF "The register ~A doesn't point anywhere." Q-REG))      (MOVE-TO-BP (CAR PT)) ;;gsl.            (POINT-PDL-PUSH (POINT) *WINDOW* NIL T)))  DIS-BPS) ;;; Completing-reader and other minibuffer stuff;;; Change all user-interfaces with the minibuffer to reference the word;;; "MINIBUFFER" rather than two words, "MINI BUFFER".(DEFCOM COM-END-OF-MINIBUFFER "Terminate input from the typein line." ()   (THROW 'RETURN-FROM-COMMAND-LOOP NIL)) ;; The c-G command in the minibuffer.(DEFCOM COM-MINIBUFFER-BEEP "Quit out of the mini buffer.If there is text in the mini buffer, delete it all.If the mini buffer is empty, quit out of it." ()  (BEEP)  (COND (*NUMERIC-ARG-P* DIS-NONE)((BP-= (INTERVAL-FIRST-BP *INTERVAL*)       (INTERVAL-LAST-BP *INTERVAL*)) (THROW 'TOP-LEVEL T))(T (DELETE-INTERVAL *INTERVAL*) DIS-TEXT))) (DEFCOM COM-YANK-DEFAULT-STRING "Insert the default string into the mini buffer." ()  (IF (NULL *MINI-BUFFER-DEFAULT-STRING*)      (BARF "*MINI-BUFFER-DEFAULT-STRING* is NIL now.")      (INSERT-MOVING (POINT) *MINI-BUFFER-DEFAULT-STRING*))  DIS-TEXT) (DEFCOM COM-YANK-SEARCH-STRING "Insert the last search string into the mini buffer." ()  (IF (NULL *SEARCH-RING*)      (BARF "No search string is recorded.")      (INSERT-MOVING (POINT) (CAAR *SEARCH-RING*)))  DIS-TEXT)   (DEFCOM COM-RECURSIVE-EDIT-ABORT "Quit out of recursive edit right away" ()  (THROW 'TOP-LEVEL T)) ;; Doc on this function changed from patch 94.181. ddd/gsl, 3/4/84.;; Macro for suggestions added by rpm 11-26-86.(DEFUN EDIT-IN-MINI-BUFFER (&OPTIONAL (COMTAB *MINI-BUFFER-COMTAB*) INITIAL-CONTENTS    INITIAL-CHAR-POS MODE-LINE-LIST)  "Read input using a mini buffer, and return a string.\(If the end key, com-end-of-mini-buffer, is used, the usual case, the value returned is nil,and the third value returned is an interval containing the mini-buffer's text.)COMTAB is the comtab to use while in the mini buffer; the default is usually right.INITIAL-CONTENTS is a string to initialize the mini buffer fromand INITIAL-CHAR-POS is where in that string to start the cursor.MODE-LINE-LIST is what to display in the mode line during."  (SYS:WITH-SUGGESTIONS-MENUS-FOR ZWEI:EDIT-IN-MINI-BUFFER    (AND *MINI-BUFFER-COMMAND-IN-PROGRESS*;Recursive mini-buffers don't work        (BARF "Mini-buffer entered recursively"))    (AND *MINI-BUFFER-REPEATED-COMMAND* (POP *MINI-BUFFER-REPEATED-COMMAND* INITIAL-CONTENTS) (SETQ INITIAL-CHAR-POS (LENGTH INITIAL-CONTENTS)))    (MUST-REDISPLAY *MINI-BUFFER-WINDOW* DIS-TEXT)    ;; Set up the initial contents of the mini buffer, and discard previous undo records.    (LET ((*INTERVAL* (WINDOW-INTERVAL *MINI-BUFFER-WINDOW*))  (*BATCH-UNDO-SAVE* T)  (BP (WINDOW-POINT *MINI-BUFFER-WINDOW*)))      (DISCARD-UNDO-INFORMATION *INTERVAL*)      (DELETE-INTERVAL *INTERVAL*)      (AND INITIAL-CONTENTS   (INSERT BP (SETQ INITIAL-CONTENTS (STRING INITIAL-CONTENTS))))      (AND INITIAL-CHAR-POS   (MOVE-BP BP (FORWARD-CHAR BP INITIAL-CHAR-POS))))    (OR *MINI-BUFFER-DONT-RECORD*(RECORD-MINI-BUFFER-VALUE T))    (PROG* KLUDGE (VAL SUCCESSFUL       (TOP-W (SEND (W:SHEET-SUPERIOR *MINI-BUFFER-WINDOW*) :TOP-OF-EDITOR-HIERARCHY))       (OSUBST (SEND TOP-W :SELECTION-SUBSTITUTE)))   ;; Prevent a delay when mini buffer window is selected   (SEND (WINDOW-SHEET *MINI-BUFFER-WINDOW*) :MINI-BUFFER-ENTERED)   (UNWIND-PROTECT       (BIND-MODE-LINE MODE-LINE-LIST (LET ((*MINI-BUFFER-COMMAND-IN-PROGRESS* *CURRENT-COMMAND*)       (*PACKAGE* *PACKAGE*)       (*COMTAB* COMTAB)       (*OUTER-LEVEL-MINI-BUFFER-COMMAND* *MINI-BUFFER-COMMAND*)       (INTERVAL (WINDOW-INTERVAL *MINI-BUFFER-WINDOW*)))   ;; Actually do the editing.   (SETQ VAL (SEND *MINI-BUFFER-WINDOW* :EDIT))   (SETQ *MINI-BUFFER-COMMAND* *OUTER-LEVEL-MINI-BUFFER-COMMAND*)   (OR *MINI-BUFFER-DONT-RECORD*       (RECORD-MINI-BUFFER-VALUE NIL (STRING-INTERVAL INTERVAL)))   ;; If we are repeating a command, re-input any non-mini-buffer   ;; characters that followed this mini-buffer.   (DOLIST (CHAR (REVERSE (CAR *MINI-BUFFER-REPEATED-COMMAND*)))     (SEND *TERMINAL-IO* :PUSH-INPUT CHAR))   (POP *MINI-BUFFER-REPEATED-COMMAND*)   (SETQ SUCCESSFUL T)   (RETURN-FROM KLUDGE VAL *MINI-BUFFER-WINDOW* INTERVAL)))     ;;If we quit out of a minibuffer, tell (:method editor :edit)     ;;not to push this command on the ring.     ;;Likewise if this is being run from a mouse click, since then     ;;*CURRENT-COMMAND* is NIL and we could not reexecute this properly.     (OR (AND *CURRENT-COMMAND* SUCCESSFUL) (SETQ *MINI-BUFFER-COMMAND* NIL))     ;; Don't reselect a typeout window that has been popped down.     (IF (AND OSUBST      (NOT (MEMBER OSUBST (W:SHEET-INFERIORS (W:SHEET-SUPERIOR OSUBST)) :TEST #'EQ))) (SETQ OSUBST (W:SHEET-SUPERIOR OSUBST)))     (SEND TOP-W :SET-SELECTION-SUBSTITUTE OSUBST)     (UNLESS (EQ *WINDOW* *MINI-BUFFER-WINDOW*)       (DISAPPEAR-MINI-BUFFER-WINDOW)))))) (DEFUN DISAPPEAR-MINI-BUFFER-WINDOW ()  ;; Bring the typein window back, and hence get rid of the mini-buffer  (SEND *TYPEIN-WINDOW* :EXPOSE)  (SEND (WINDOW-SHEET *MINI-BUFFER-WINDOW*) :DEACTIVATE)  (SEND *MODE-LINE-WINDOW* :DONE-WITH-MODE-LINE-WINDOW)) ;; Redefinition of function from patch 94.177. ddd/gsl 3/4/84.;; And slight modification from patch 94.189.  ddd/gsl 3/4/84.(DEFUN RECORD-MINI-BUFFER-VALUE (START-OK &OPTIONAL STRING)  "Record a string returned by a mini buffer as part of the sequence  of arguments of the current command.  With no string, records all characters typed in since this mini buffer  entered."  (OR *MINI-BUFFER-COMMAND*      (IF START-OK  (SETQ *MINI-BUFFER-COMMAND*`((,*CURRENT-COMMAND* ,*NUMERIC-ARG-P* ,*NUMERIC-ARG* ,@(CURRENT-PROMPTS))))  (FERROR NIL "No mini-buffer command is in progress.")))  (LET* ((RECORD (SEND *STANDARD-INPUT* :PLAYBACK)) (LEN (ARRAY-TOTAL-SIZE RECORD)) (RECORD-POINTER (REM (1+ (W:IO-BUFFER-RECORD-POINTER RECORD)) LEN)))    (IF (NOT (OR STRING START-OK))(DO ((PTR *MINI-BUFFER-END-POINTER* (REM (1+ PTR) LEN))     CHARS)    ((= PTR RECORD-POINTER)     (RETURN (RPLACA (LAST *MINI-BUFFER-COMMAND*) (NREVERSE CHARS))))  (IF (NUMBERP (AREF RECORD PTR))      (PUSH (AREF RECORD PTR) CHARS))))    (SETQ *MINI-BUFFER-END-POINTER* RECORD-POINTER));made this unconditional gsl  (IF STRING      (RPLACD (LAST *MINI-BUFFER-COMMAND*) (LIST STRING NIL)))) ;; The mini buffer command history.;; The top level loop pushes *MINI-BUFFER-COMMAND* onto this history list.(DEFUN MINI-BUFFER-RING-PUSH (THING)  "Push THING on the ring of saved mini buffers."  (PUSH-ON-HISTORY THING *MINI-BUFFER-HISTORY*)) (DEFUN SUMMARIZE-MINI-BUFFER-COMMAND (COMMAND-DESC)  (LET ((ARG-P (CADAR COMMAND-DESC))(ARG (CADDAR COMMAND-DESC))(PROMPTS (CDDDAR COMMAND-DESC))(COMMAND (CAAR COMMAND-DESC))(CONTENTS (CDR COMMAND-DESC))STR)    (IF PROMPTS(SETQ STR (WITH-OUTPUT-TO-STRING (*STANDARD-OUTPUT*)    (DOLIST (PROMPT PROMPTS)      (COND ((STRINGP PROMPT) (PRINC PROMPT))    (T (FORMAT T "~:C" PROMPT)))      (WRITE-CHAR #\SPACE))))(PROGN  (SETQ STR (OR (KEY-FOR-COMMAND COMMAND)(GET COMMAND 'COMMAND-NAME)))  (AND ARG-P       (SETQ STR (STRING-APPEND (FORMAT-ARGUMENT ARG-P ARG) #\SPACE STR)))  (SETQ STR (STRING-APPEND STR #\SPACE))))    (DO ((CONTENTS CONTENTS (CDDR CONTENTS)))((NULL CONTENTS))      (LET ((STRING (CAR CONTENTS))    (CHARS (CADR CONTENTS)))(SETQ STR (STRING-APPEND STR STRING #\SPACE))(DOLIST (CHAR CHARS)  (OR (CONSP CHAR)      (SETQ STR (STRING-APPEND STR       (WITH-OUTPUT-TO-STRING (*STANDARD-OUTPUT*) (FORMAT T "~:C" CHAR))       #\SPACE))))))    STR)) ;; Re-executing minibuffer commands.;;; Change references to the words "MINI BUFFER" to the single;;; word "MINIBUFFER" from the user interface standpoint.(DEFCOM COM-REPEAT-MINIBUFFER-COMMAND "Repeat a recent minibuffer command.A numeric argument does the nth previous one.An argument of 0 lists which ones are remembered." ()  ;; Bind the flag for COM-REPEAT-MINIBUFFER-COMMAND. rpm 7-2-86  (LET ((REPEATING-MINIBUFFER-COMMAND-P T))    (HISTORY-YANK *MINI-BUFFER-HISTORY*)));; This is the YANK-METHOD for the *MINI-BUFFER-HISTORY*(DEFUN MINI-BUFFER-HISTORY-YANK (COMMAND &OPTIONAL KILL-PREVIOUS LEAVE-POINT-BEFORE)  KILL-PREVIOUS LEAVE-POINT-BEFORE  (UNLESS COMMAND (BEEP))  (APPLY 'MUST-REDISPLAY *WINDOW* (MULTIPLE-VALUE-LIST (RE-EXECUTE-MINI-BUFFER-COMMAND COMMAND)))) ;;;  From Garr.  Add a context check and some other fixes.(DEFCOM COM-POP-MINIBUFFER-HISTORY "Back up to previous minibuffer.With arg of 0 resets the minibuffer history to the most recent entry.With arg of Control-U goes to previous minibuffer command of this type.Other args go back the corresponding number of minibuffer commands.Keeps backing up with successive calls, with wrap around." ()  (CONTEXT-CHECK '*OUTER-LEVEL-MINI-BUFFER-COMMAND*)  (CONTEXT-CHECK #'CLOSUREP *STANDARD-INPUT*)  ;;check that we're in zmacs, not a standalone ed. gsl  (LET* ((HISTORY *MINI-BUFFER-HISTORY*) (COMMAND   ;; If not the first minibuffer in this command,   ;; back up to previous minibuffer (in same command if arg.).   (PROG1     (IF (CDR *OUTER-LEVEL-MINI-BUFFER-COMMAND*) ;;??? gsl. (PROGN   (SETF (CAR (LAST *OUTER-LEVEL-MINI-BUFFER-COMMAND*)) ())   *OUTER-LEVEL-MINI-BUFFER-COMMAND*) ;;Otherwise rotate history to appropriate place. ;;reset if arg was 0. (PROGN   (COND ((AND *NUMERIC-ARG-P* (= *NUMERIC-ARG* 0))  ;;reset to number 1  (SETF (HISTORY-YANK-POINTER HISTORY) 1)) ;;yank same type of command if user did control-u. ((EQ *NUMERIC-ARG-P* :CONTROL-U)  (LET* ((NEXT-ITEM   (ASSOC (CAR *OUTER-LEVEL-MINI-BUFFER-COMMAND*)  (NTHCDR (1+ (HISTORY-YANK-POINTER HISTORY))  (HISTORY-LIST HISTORY))  :TEST #'EQUAL)) (HISTORY-TAIL   (OR (AND NEXT-ITEM    (MEMBER NEXT-ITEM (HISTORY-LIST HISTORY) :TEST #'EQUAL))       (HISTORY-LIST HISTORY))))    (SETF (HISTORY-YANK-POINTER HISTORY)  (- (LENGTH (HISTORY-LIST HISTORY)) (LENGTH HISTORY-TAIL)))    (SETQ *NUMERIC-ARG* 1))) ;;move 0 if first time. ;;but move 1 if we got here via COM-REPEAT-MINIBUFFER-COMMAND. rpm 7-2-86  ((AND (NEQ *LAST-COMMAND-TYPE* '*MINI-BUFFER-HISTORY*)       (NOT REPEATING-MINIBUFFER-COMMAND-P));rpm 7-2-86  (SETQ *NUMERIC-ARG* (1- *NUMERIC-ARG*))))   (ROTATE-HISTORY-YANK-POINTER HISTORY *NUMERIC-ARG*)))     (SETQ *CURRENT-COMMAND-TYPE* '*MINI-BUFFER-HISTORY*))));record that we've been here.    ;; Setup to repeat the one before this    (W:UNREAD-ANY `(:EXECUTE POP-RING-RE-EXECUTE-MINI-BUFFER-COMMAND   ,COMMAND)))  (THROW 'TOP-LEVEL T)) ;C-M-Y pushes a blip that makes the command loop call this function.;NIL as value flushes typeout.;Must bind *MINI-BUFFER-DONT-RECORD* to NIL since the :EXECUTE mechanism binds it to T.(DEFUN POP-RING-RE-EXECUTE-MINI-BUFFER-COMMAND (MINI-BUFFER-COMMAND)  (LET ((*MINI-BUFFER-DONT-RECORD* NIL))    (LET ((VALUES (MULTIPLE-VALUE-LIST (RE-EXECUTE-MINI-BUFFER-COMMAND MINI-BUFFER-COMMAND))))      (APPLY 'MUST-REDISPLAY *WINDOW* VALUES)))  ;; Return NIL so typeout gets flushed.  NIL) ;; This is called from the top level command loop;; and does the actual work of reexecuting the command.(DEFUN RE-EXECUTE-MINI-BUFFER-COMMAND (*MINI-BUFFER-REPEATED-COMMAND*       &AUX *MINI-BUFFER-ENTIRE-REPEATED-COMMAND*       PROMPTS)  "Re-execute a mini-buffer command (such as an element of *MINI-BUFFER-HISTORY*)."  (SETQ *MINI-BUFFER-ENTIRE-REPEATED-COMMAND* *MINI-BUFFER-REPEATED-COMMAND*)  (OR *MINI-BUFFER-REPEATED-COMMAND*      (BARF "No previous command"))  (POP *MINI-BUFFER-REPEATED-COMMAND*       `(,*CURRENT-COMMAND* ,*NUMERIC-ARG-P* ,*NUMERIC-ARG* ,@PROMPTS))  (OR *MINI-BUFFER-COMMAND*      (SETQ *MINI-BUFFER-COMMAND*    `((,*CURRENT-COMMAND* ,*NUMERIC-ARG-P* ,*NUMERIC-ARG* ,@PROMPTS))))  (FUNCALL *CURRENT-COMMAND*)) (DEFUN COMPLETING-READ-FROM-MINI-BUFFER (PROMPT *COMPLETING-ALIST* &OPTIONAL *COMPLETING-IMPOSSIBLE-IS-OK-P* INITIAL-COMPLETE *COMPLETING-HELP-MESSAGE* *COMPLETING-DOCUMENTER* &AUX CONTENTS CHAR-POS)  "Read a string from the mini buffer with completion.PROMPT is displayed in the mode line.*COMPLETING-ALIST* is an alist, or sorted array of pairs, to complete from.*COMPLETING-IMPOSSIBLE-IS-OK-P* non-NIL means allow inputs that are not on the alist and don't complete.INITIAL-COMPLETE if non-NIL is a string to start out with, or T meaning try completing the empty string.*COMPLETING-HELP-MESSAGE* is a string to print if Help is typed, etc.*COMPLETING-DOCUMENTER* is a function which, given an alist element, prints documentation of its meaning on *STANDARD-OUTPUT*.The value is an element of the alist, or just a string (if it was an impossible completion). The null string is always a possible value."  (AND INITIAL-COMPLETE       (MULTIPLE-VALUE-SETQ (CONTENTS NIL NIL NIL CHAR-POS)         (COMPLETE-STRING (IF (EQ INITIAL-COMPLETE T)      ""      INITIAL-COMPLETE)  *COMPLETING-ALIST*  *COMPLETING-DELIMS*  T  (LENGTH (IF (EQ INITIAL-COMPLETE T)      ""      INITIAL-COMPLETE)))))  (EDIT-IN-MINI-BUFFER *COMPLETING-READER-COMTAB* CONTENTS CHAR-POS       (IF PROMPT   `(,PROMPT (:RIGHT-FLUSH " (Completion)"))   '(:RIGHT-FLUSH "(Completion)")))) ;; Note that WINDOW is a window system type window, not a ZWEI-WINDOW(DEFUN COMPLETING-READ (WINDOW *COMPLETING-ALIST* &OPTIONAL PROMPT*COMPLETING-IMPOSSIBLE-IS-OK-P* INITIAL-COMPLETE*COMPLETING-HELP-MESSAGE* *COMPLETING-DOCUMENTER* &AUX ZWEI-WINDOWCONTENTS CHAR-POS)  "Read a string with completion using the specified editor window.WINDOW should be a window instance, not a defstruct.The remaining args are as for COMPLETING-READ-FROM-MINI-BUFFER.You must make WINDOW's ZWEI-WINDOW contain an editor closuremade from TOP-LEVEL-EDITOR-CLOSURE-VARIABLES, and made with*COMTAB* equal to *COMPLETING-READER-COMTAB*."  (AND INITIAL-COMPLETE       (MULTIPLE-VALUE-SETQ (CONTENTS NIL NIL NIL CHAR-POS) (COMPLETE-STRING "" *COMPLETING-ALIST* *COMPLETING-DELIMS* T 0)))  (AND PROMPT (SEND WINDOW :SET-LABEL PROMPT))  (SETQ ZWEI-WINDOW (SEND WINDOW :ZWEI-WINDOW))  (LET ((INTERVAL (WINDOW-INTERVAL ZWEI-WINDOW)))    (IF INTERVAL (DELETE-INTERVAL INTERVAL)(SEND ZWEI-WINDOW :SET-INTERVAL (CREATE-INTERVAL NIL NIL T))))  (SETF (WINDOW-REDISPLAY-DEGREE ZWEI-WINDOW) DIS-ALL)  (AND CONTENTS       (NOT (EQUAL CONTENTS ""))       (LET ((*INTERVAL* (WINDOW-INTERVAL ZWEI-WINDOW))     (BP (WINDOW-POINT ZWEI-WINDOW))) (INSERT BP CONTENTS) (AND CHAR-POS (MOVE-BP BP (FORWARD-CHAR BP CHAR-POS)))))  (LET ((OLD-STATUS (SEND WINDOW :STATUS)))    (UNWIND-PROTECT (W:WINDOW-CALL (WINDOW) (SEND ZWEI-WINDOW :EDIT))      (SEND WINDOW :SET-STATUS OLD-STATUS))))(W:DEF-BEEP-TYPE 'NO-COMPLETION :SHOOP) (DEFCOM COM-COMPLETE "Attempt to complete the current line." ()  (OR (COMPLETE-LINE T T)      (BEEP 'NO-COMPLETION))  DIS-TEXT) (DEFCOM COM-SELF-INSERT-AND-COMPLETE "Attempt to complete after inserting break character." ()  (OR (END-LINE-P (POINT))      (INSERT-MOVING (POINT) *LAST-COMMAND-CHAR*))  (OR (COMPLETE-LINE NIL NIL *LAST-COMMAND-CHAR*)      *COMPLETING-IMPOSSIBLE-IS-OK-P*      (BEEP 'NO-COMPLETION))  DIS-TEXT) (DEFCOM COM-COMPLETE-AND-EXIT "Attempt to complete and return if unique." ()  (COM-COMPLETE-AND-EXIT-1 NIL)) (DEFUN COM-COMPLETE-AND-EXIT-1 (EXPLICIT-P)  (PROG ((LINE (BP-LINE (WINDOW-START-BP *WINDOW*))) COMPLETION VAL (IMPOSSIBLE-OK (AND (NOT EXPLICIT-P) *COMPLETING-IMPOSSIBLE-IS-OK-P*)))    (SETQ VAL (COND ((ZEROP (LINE-LENGTH LINE));Allow typing just CR     "")    ((NOT IMPOSSIBLE-OK);Not allowed to type new things,     (SETQ COMPLETION (COMPLETE-LINE T NIL NIL (NOT EXPLICIT-P)))     (COND ((NULL COMPLETION)    ;; No completions at all.    (BEEP 'NO-COMPLETION)    (RETURN NIL))   ((NULL (CDR COMPLETION))    ;; It is unique.    (SETQ VAL (CAR COMPLETION)))   ((NULL (SETQ VAL (ASSOC LINE COMPLETION :TEST 'STRING-EQUAL)))    ;; Multiple completions, and no exact match.    (RETURN NIL)))     ;; Completes uniquely somehow.     (MUST-REDISPLAY *WINDOW* DIS-TEXT);Typed something good     (AND (WINDOW-READY-P *WINDOW*)  (REDISPLAY *WINDOW* :NONE))     VAL)    ((AND (EQ IMPOSSIBLE-OK 'MAYBE)  ;; If allowed one failure  (NEQ *LAST-COMMAND-TYPE* 'FAILING-COMPLETION)  (CHARACTERP *LAST-COMMAND-CHAR*)  (NOT (CHAR-BIT (COMTAB-CHAR-INDIRECTION *LAST-COMMAND-CHAR*) :CONTROL)))     (SETQ COMPLETION (COMPLETE-LINE T NIL NIL (NOT EXPLICIT-P)))     (SETQ COMPLETION (IF (= (LENGTH COMPLETION) 1)  (CAR COMPLETION)  (ASSOC LINE COMPLETION :TEST 'STRING-EQUAL)))     (COND ((NULL COMPLETION);This is no good         (SETQ *CURRENT-COMMAND-TYPE* 'FAILING-COMPLETION)    (BEEP)    (FORMAT *WINDOW* "  This did not previously exist. If OK press ~:@C." #\NEWLINE)    (RETURN NIL))   (T    (MUST-REDISPLAY *WINDOW* DIS-TEXT)    (AND (WINDOW-READY-P *WINDOW*) (REDISPLAY *WINDOW* :NONE))    COMPLETION)))    ((AND (NEQ IMPOSSIBLE-OK 'ALWAYS-STRING)  (SETQ COMPLETION (ASSOC LINE (IF (ARRAYP *COMPLETING-ALIST*)   (G-L-P *COMPLETING-ALIST*)   *COMPLETING-ALIST*)  :TEST 'STRING-EQUAL)))     COMPLETION)    (T     (STRING-APPEND LINE))))    (THROW 'RETURN-FROM-COMMAND-LOOP VAL))  DIS-TEXT) (DEFCOM COM-COMPLETE-AND-EXIT-IF-UNIQUE "Attempt to complete and return only if unique." ()   (COM-COMPLETE-AND-EXIT-1 T)) (DEFCOM COM-LIST-COMPLETIONS "Give a menu of possible completions for string so far." ()   (LET (POSS)     (MULTIPLE-VALUE-SETQ (NIL POSS)       (COMPLETE-STRING (BP-LINE (POINT)) *COMPLETING-ALIST* *COMPLETING-DELIMS*))     (OR POSS (BARF))     (AND *COMPLETING-HELP-MESSAGE*  (FORMAT T "~&~A" *COMPLETING-HELP-MESSAGE*))     (LIST-COMPLETIONS-INTERNAL POSS))   DIS-NONE) (DEFUN LIST-COMPLETIONS-INTERNAL (POSS &AUX LEN)  (SETQ LEN (LENGTH POSS))  (COND ((ZEROP LEN) (FORMAT T "~&There are no known completions of the text you have typed.~%"))((= LEN 1) (FORMAT T "~&The only known completion of the text you have typed is ") (SEND *STANDARD-OUTPUT* :ITEM 'COMPLETION (CAAR POSS)) (FORMAT T ":~%") (COND (*COMPLETING-DOCUMENTER*(TERPRI *STANDARD-OUTPUT*)(FUNCALL *COMPLETING-DOCUMENTER* (CAR POSS)))))((OR (< LEN 62)     (LET ((*QUERY-IO* *STANDARD-OUTPUT*))       (FQUERY NIL "There are ~D known possibilities, do you really want to see them all? "       LEN))) (FORMAT T "~&These are the known completions of the text you have typed:~2%") (SEND *STANDARD-OUTPUT* :ITEM-LIST 'COMPLETION (SORT (MAPCAR #'CAR POSS) #'STRING-LESSP)) (TERPRI *STANDARD-OUTPUT*)))) ;; This is from patch 94.165. ddd/gsl 3/1/84.(DEFCOM COM-COMPLETION-APROPOS"Do apropos within the completions of what has been typed for completing read.Available on Control- for completing reads.  Control-U causes dashes to be treated asspaces for the purposes of this command, which is pretty useless, but is the originalmethod of operation of this command." ()  (LET ((LINE (BP-LINE (POINT)))(*DELIMS* (IF (< *NUMERIC-ARG* 4)      '(#\SPACE) *COMPLETING-DELIMS*));gsl 11/6/83FUNCTION)    (LET (IDX)      (IF (SETQ IDX (STRING-SEARCH-SET *DELIMS* LINE))  (SETQ LINE (DO ((I 0)  (J IDX)  (LIST)) (NIL)       (OR (= (OR J (LENGTH LINE)) I)   (PUSH (SUBSEQ LINE I J) LIST))       (OR J   (RETURN (NREVERSE LIST)))       (SETQ I (1+ J)     J (STRING-SEARCH-SET *DELIMS* LINE I)))FUNCTION 'FSM-STRING-SEARCH)  (SETQ FUNCTION 'GLOBAL:STRING-SEARCH)))    (AND *COMPLETING-HELP-MESSAGE* (FORMAT T "~&~A" *COMPLETING-HELP-MESSAGE*))    (FORMAT T    "~&These are the currently known completions matching~:[ \"~A\"~;~{ \"~A\"~^ or~}~]:"    (CONSP LINE) LINE)    (AND (CONSP LINE) (SETQ LINE (LIST LINE NIL NIL)))    (DO ((ALIST (IF (ARRAYP *COMPLETING-ALIST*)    (G-L-P *COMPLETING-ALIST*)    *COMPLETING-ALIST*)(CDR ALIST)) (POSS NIL))((NULL ALIST) (SEND *STANDARD-OUTPUT* :ITEM-LIST 'COMPLETION       (SORT (MAPCAR #'CAR POSS) #'STRING-LESSP)))      (DO () ((CONSP ALIST))(SETQ ALIST (CAR ALIST)));Indirect through multiple alists             (AND (FUNCALL FUNCTION LINE (CAAR ALIST))   (PUSH (CAR ALIST) POSS))))  (FORMAT T "~%Done.~%")  DIS-NONE)  (W:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* COMPLETION "Select" SELECT-COMPLETION T   "Use this completion.") ;Called if the user mouses one of the completions(DEFUN SELECT-COMPLETION (STRING)  (OR (EQ *INTERVAL* (WINDOW-INTERVAL *MINI-BUFFER-WINDOW*)) (BARF))  (OR (VARIABLE-BOUNDP *COMPLETING-ALIST*) (BARF))  (SEND *STANDARD-OUTPUT* :MAKE-COMPLETE) ;Only one completion can be meaningful  (DELETE-INTERVAL *INTERVAL*)  (INSERT-MOVING (POINT) STRING)  (MUST-REDISPLAY *WINDOW* DIS-TEXT)  (COM-COMPLETE-AND-EXIT)) ;;; This command is on the HELP key when the user is in the completing reader.;;; The caller of the completing reader can pass this two implicit arguments;;; through the specal variables *COMPLETING-HELP-MESSAGE* and *COMPLETING-DOCUMENTER*.;;; The command first prints the value of *COMPLETING-HELP-MESSAGE*, if non-NIL;;;; otherwise it prints "You are in the completing reader."  The top-level value;;; of this variable is NIL.  Then it explains how completion works, and tells;;; the user what options he can complete to.  If there is only one option,;;; and *COMPLETING-DOCUMENTER* is non-NIL, then *COMPLETING-DOCUMENTER* is;;; applied to the one element of the ALIST that the user is indicating;;;; the function should output helpful cruft to *STANDARD-OUTPUT*.(DEFCOM COM-DOCUMENT-COMPLETING-READ   "Explain how the completing reader works.Also tell you what you are currently doing." ()   (LET (POSS)     (FORMAT T "~&~A~2%" (OR *COMPLETING-HELP-MESSAGE* "You are in the completing reader."))     (FORMAT T"You are typing to a mini-buffer, with the following commands redefined:~A causes as much of the string as can be determined to be insertedinto the mini-buffer (this is called command completion).  ~A is similar;it completes up to the next ~:*~A."       (KEY-FOR-COMMAND 'COM-COMPLETE *COMTAB* NIL NIL #\ESCAPE)       (KEY-FOR-COMMAND 'COM-SELF-INSERT-AND-COMPLETE *COMTAB* NIL NIL #\SPACE))     (FORMAT T     (IF (CDR *OUTER-LEVEL-MINI-BUFFER-COMMAND*)"Use ~A to go back to editing the previous argument if youare no longer satisfied with what you typed.""Use ~A to cancel this command and begin to re-executethe previous command that read minibuffer arguments.")     (KEY-FOR-COMMAND 'COM-POP-MINIBUFFER-HISTORY *COMTAB* NIL NIL #\c-m-Y))     (FORMAT T     "~A lists all the strings that complete what you have typed so far,without the rest of this HELP display.  ~A lists all the stringsthat contain what you have typed anywhere within them.~A will complete as much as possible and return if that gives a unique result.~A will complete as much as possible, and "     (KEY-FOR-COMMAND 'COM-LIST-COMPLETIONS *COMTAB* NIL NIL #\c-?)     (KEY-FOR-COMMAND 'COM-COMPLETION-APROPOS *COMTAB* NIL NIL #\c-/)     (KEY-FOR-COMMAND 'COM-COMPLETE-AND-EXIT-IF-UNIQUE *COMTAB* NIL NIL #\END)     (KEY-FOR-COMMAND 'COM-COMPLETE-AND-EXIT *COMTAB* NIL NIL #\NEWLINE))     (FORMAT T     (IF *COMPLETING-IMPOSSIBLE-IS-OK-P* "return the result.""if that is a valid string itwill return it."))     (MULTIPLE-VALUE-SETQ (NIL POSS)       (COMPLETE-STRING (BP-LINE (POINT)) *COMPLETING-ALIST* *COMPLETING-DELIMS*))     (TERPRI)     (TERPRI)     (LIST-COMPLETIONS-INTERNAL POSS))   DIS-NONE) (DEFUN COMPLETE-LINE (FORWARD-OK IGNORE      &OPTIONAL INSERT IGNORE-TRAILING-SPACE      &AUX NSTR POSS WINP LINE POINT CHAR-POS EOLP MAGIC-POS)  (SETQ POINT (POINT))  (SETQ LINE (BP-LINE POINT)CHAR-POS (BP-INDEX POINT))  (SETQ EOLP (= CHAR-POS (LINE-LENGTH LINE)))  (MULTIPLE-VALUE-SETQ (NSTR POSS WINP CHAR-POS MAGIC-POS)     (COMPLETE-STRING LINE *COMPLETING-ALIST* *COMPLETING-DELIMS*      T CHAR-POS (NOT FORWARD-OK) IGNORE-TRAILING-SPACE))  (AND MAGIC-POS       FORWARD-OK       (SETQ CHAR-POS MAGIC-POS))  (COND (POSS (DELETE-INTERVAL (BEG-LINE POINT) (END-LINE POINT)) (INSERT-MOVING POINT NSTR)))  ;; Insert the given character, unless we have fully completed only one completion.  ;; But don't insert spaces at beginning of line.  (AND INSERT       EOLP       (OR (NEQ WINP 'NOSPACE)   (AND (ASSOC LINE POSS :TEST 'STRING-EQUAL)(NOT (NULL (CDR POSS)))))       (OR (CHAR/= INSERT #\SPACE)   (NOT (BEG-LINE-P POINT)))       (INSERT-MOVING POINT INSERT))  (COND (WINP)(FORWARD-OK (COND (MAGIC-POS(MOVE-BP POINT LINE MAGIC-POS)))))  POSS) ;;;  Changed an art-32b array (chunk-delims) to art-q because;;;  it wants to use negative numbers.  This is a compatible change.(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 chunk is matched against the chunks of strings in the ALIST.DONT-NEED-LIST says we really don't 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 alphabeticallysorted."  (SETQ CHUNKS (MAKE-ARRAY 24 :LEADER-LIST '(0))CHUNK-DELIMS (MAKE-ARRAY 24 :ELEMENT-TYPE 'T :LEADER-LIST '(0)))  (SETQ LEN (LENGTH STRING))  (AND IGNORE-TRAILING-SPACE       (> LEN 0)       (CHAR= (AREF STRING (1- LEN)) #\SPACE)       (DECF LEN))  (DO ((I 0 (1+ I))       (J 0))      ((> I LEN))    (COND ((COND ((= I LEN)  (SETQ TEM -1))                ;Last character delimits a chunk unless it is empty. (T  (MEMBER (SETQ TEM (AREF STRING I)) DELIMS :TEST #'EQ)))   (AND CHAR-POS(> CHAR-POS J)                  ;Keep track of relative position(SETQ CHAR-CHUNK (ARRAY-LEADER CHUNKS 0)      CHAR-OFFSET (- CHAR-POS J)))           ;; Modified to disallow multiple blanks between chunks of extended commands,           ;; since they would cause completion to fail. Done by rpm (from ap) on 9-29-86.   ;; Modified to allow multiple non-blank delimiters. Done by rpm (from cmi) on 4-2-87.           (UNLESS (AND (STRING-EQUAL (NSUBSTRING STRING J I) " ")(CHAR-EQUAL (AREF STRING I) #\SPACE)(NOT (= I LEN)))             (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 :ELEMENT-TYPE 'BIT))  (AND (ARRAYP ALIST)       (MULTIPLE-VALUE-SETQ (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 (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 (LENGTH FILL))    (DO ((J 0 (1+ J)) (LEN1 (LENGTH TEM)))((>= J LEN) (OR (ZEROP LEN)     (AND (= I (1- NCHUNKS))  (= LEN 1)  (MEMBER (AREF FILL 0) DELIMS :TEST #'EQ))     (SETQ ALL-AMBIG NIL)))      (COND ((OR (>= J LEN1) (NOT (CHAR-EQUAL (AREF FILL J) (AREF TEM J))))     ;;Not the same completion, shorten final version     (SETF (AREF FILLS I) (NSUBSTRING FILL 0 J))     (SETF (AREF CHAMB I) 1);Remember this was ambiguous     (OR (ZEROP J) (SETQ ALL-AMBIG NIL))     (RETURN NIL)))))))   ;;If not going to complete and dont need actual list, finish up now.   (AND ALL-AMBIG(NULL (AREF FILLS (1- NCHUNKS)))(RETURN NIL)))))  (COND ((AND TRUNC (SETQ TEMSTRING (AREF FILLS (1- NCHUNKS)))) (SETQ LEN (LENGTH TEMSTRING)) (AND (ZEROP (AREF CHAMB (1- NCHUNKS)));If last chunk wasn't ambiguous,      (SETQ TRUNC 'NOSPACE));shouldn't have delimiter there (DO ((I 0 (1+ I)))     ((>= I LEN)      NIL)   (COND ((MEMBER (AREF TEMSTRING I) DELIMS :TEST #'EQ)  (SETF (AREF FILLS (1- NCHUNKS)) (NSUBSTRING TEMSTRING 0 (1+ I)))  (SETQ TRUNC 'NOSPACE);Already gave a delimiter  (RETURN NIL))))))  (SETQ TEMSTRING "")  (DO ((I 0 (1+ I)))      ((>= I NCHUNKS)       NIL)    (AND CHAR-POS CHAR-CHUNK (= I CHAR-CHUNK)                                         ;In case inside chunk not completed, (SETQ CHAR-POS (+ (LENGTH TEMSTRING) CHAR-OFFSET)))      ;relocate    (SETQ TEMSTRING (STRING-APPEND TEMSTRING (AREF CHUNKS I)))    (COND ((AND (SETQ TEM (AREF FILLS I)) (> (LENGTH TEM) 0))   (SETQ TEMSTRING (STRING-APPEND TEMSTRING TEM) COMPLETED-P T)   (AND CHAR-POSCHAR-CHUNK(= I CHAR-CHUNK)                ;If inside completed chunk,(SETQ CHAR-POS (LENGTH TEMSTRING)))));move to end of it    (OR MAGIC-POS(ZEROP (AREF CHAMB I))             ;Remember end of leftmost ambiguous chunk(SETQ MAGIC-POS (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)) ;;;Compare a STR with the given chunks and return NIL if it is a possible completion,;;;else LESS or GREATER according as it is less or greater than the CHUNKS.;;;T is returned for the indeterminate case, for the sake of the binary search in the;;;array case.  The actual completer only checks NULL.;;;If no ordering is found in the first NCHUNKS-FOR-ORDERING chunks,;;;the value is always T unless we have an exact match.(DEFUN COMPLETE-CHUNK-COMPARE (STR DELIMS NCHUNKS CHUNKS CHUNK-DELIMS       &OPTIONAL TEMS RCHUNKS (NCHUNKS-FOR-ORDERING 1)       &AUX LEN2)  (SETQ LEN2 (LENGTH STR))  (DO ((I 0 (1+ I))       (J 0)       (K)       (LEN1)       (CHUNK)       (EXACT-SO-FAR T)       (DELIM))      ((>= I NCHUNKS) NIL)    ;Aligns with each chunk, a winner    (SETQ CHUNK (AREF CHUNKS I) LEN1 (LENGTH CHUNK))    (SETQ K (DO ((J1 0 (1+ J1)) (K1 J (1+ K1)) (CH1) (CH2))((>= J1 LEN1) (UNLESS (= K1 LEN2)   (SETQ EXACT-SO-FAR NIL)) K1)      (AND (>= K1 LEN2) (RETURN 'LESS))      (SETQ CH1 (CHAR-UPCASE (MAKE-CHAR (AREF CHUNK J1)))    CH2 (CHAR-UPCASE (MAKE-CHAR (AREF STR K1))))      (COND ((CHAR= CH1 CH2))    ((CHAR< CH1 CH2)     (RETURN 'GREATER))    (T     (RETURN 'LESS)))))    (OR (NUMBERP K)     ;; If comparison of first chunks yields an ordering, return it.     ;; Also if ordering is LESS on this chunk, and previous chunks are exact, return it.     ;; If later chunks don't match, just return T.(COND ((< I NCHUNKS-FOR-ORDERING)       (RETURN K))      ((AND EXACT-SO-FAR (EQ K 'LESS))       (RETURN K))      (T       (RETURN T))))    (AND RCHUNKS (SETF (AREF RCHUNKS I) (NSUBSTRING STR J K)))    (COND ((MINUSP (SETQ DELIM (AREF CHUNK-DELIMS I)))   (SETQ J NIL));For the last chunk, use rest of string  ((AND (SETQ J (STRING-SEARCH-SET DELIMS STR K LEN2))(CHAR= DELIM (AREF STR J))))  (T   (RETURN T)));Compare fails if can't find chunk when expected.    (AND TEMS (SETF (AREF TEMS I) (NSUBSTRING STR K J))))) ;;;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)    (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 (SYS:%MAKE-POINTER SYS:DTP-LIST (ALOC ALIST LO)) (CDR (SYS:%MAKE-POINTER SYS:DTP-LIST (ALOC ALIST HI))) (SYS:%MAKE-POINTER SYS: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 #'(LAMBDA (X Y)  (STRING-LESSP (CAR X) (CAR Y)))) (STORE-ARRAY-LEADER T AARRAY 1)))) (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-TOTAL-SIZE AARRAY))     (ADJUST-ARRAY 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))) (PROGN   (SYS:%BLT-TYPED (LOCF (AREF AARRAY (1- OLD-MAX)))   (LOCF (AREF 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       (SYS:%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)) ((VECTOR-PUSH ELEM-TO-BE-ADDED NEW-AARRAY)) (T;This ought to never happen  (VECTOR-PUSH-EXTEND ELEM-TO-BE-ADDED NEW-AARRAY)))) (STORE-ARRAY-LEADER T NEW-AARRAY 1) (STRUCTURE-FORWARD AARRAY NEW-AARRAY))))  ;; Function redefined by patch 94.178.  ddd/gsl 3/4/84.(DEFUN MERGE-AND-ELIMINATE-DUPLICATES (L1 L2 &AUX LIST)  "Merges cdrs of aarrays and is smart about methods, though the code looks kludgy."; gsl  (SETQ LIST (IF (OR (ATOM L1) (EQ (CAR L1) :METHOD)) (CONS L1 NIL) (NREVERSE L1)))  (IF (OR (ATOM L2) (EQ (CAR L2) :METHOD))      (PUSH+ L2 LIST)     ;push* no good for methods. gsl 11/27/83      (DOLIST (X L2)(PUSH+ X LIST)))  (SETQ LIST (NREVERSE LIST))  (IF (OR (CDR LIST)  (AND (CONSP (CAR LIST))       (EQ (CAAR LIST) :METHOD)))      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))))) ;;; Variables.;;; Given a variable and a stream, prints the variable's name and value to that stream.(DEFUN PRINT-VARIABLE (VAR &OPTIONAL (STREAM *STANDARD-OUTPUT*))  "Describe the ZWEI variable VAR on STREAM.Prints the name, value and documentation."  (LET ((*PACKAGE* (FIND-PACKAGE "ZWEI"))(*PRINT-BASE* 12)(*NOPOINT NIL)(VAL (SYMBOL-VALUE VAR))(TYPE (GET VAR 'VARIABLE-TYPE)))    (FORMAT STREAM "~25,4,2A " (STRING-APPEND (GET VAR 'VARIABLE-NAME) ":"))    (CASE TYPE      ((:BOOLEAN :KEYWORD :STRING :FIXNUM-OR-NIL :FIXNUM :ANYTHING :SMALL-FRACTION)       (PRIN1 VAL STREAM))      ((:PIXEL :PIXEL-OR-NIL)       (IF VAL  (FORMAT STREAM "~D pixels (~D spaces in current font, plus ~D pixels)"  VAL (TRUNCATE VAL (FONT-SPACE-WIDTH)) (REM VAL (FONT-SPACE-WIDTH)))  (PRIN1 VAL STREAM)))      (:CHAR       (FORMAT STREAM "~:c" VAL))      (:CHAR-LIST       (FORMAT STREAM "\"~{~:c~^ ~}\"" VAL)))    (TERPRI STREAM))) (DEFUN PRINT-VARIABLE-DOC (VAR &OPTIONAL (STREAM *STANDARD-OUTPUT*))  "Print the short doc for ZWEI variable VAR on STREAM.Adds some leading spaces and a trailing newline."  (LET ((DOC (DOCUMENTATION VAR 'VARIABLE)))    (LET ((FIRST-CR (POSITION #\NEWLINE (THE STRING (STRING DOC)) :TEST #'CHAR-EQUAL)))      (FORMAT STREAM "    ~A~&" (IF FIRST-CR    (NSUBSTRING DOC 0 FIRST-CR)    DOC))))) (DEFCOM COM-LIST-VARIABLES   "List all editor user option variables and their values.With an argument, print out documentation as well." ()  (FORMAT T "~%ZWEI variables:~2%")  (SETQ *VARIABLE-ALIST* (SORT *VARIABLE-ALIST* #'STRING-LESSP :KEY #'CAR))  (DO ((L *VARIABLE-ALIST* (CDR L)))      ((NULL L) NIL)    (PRINT-VARIABLE (CDAR L))    (AND *NUMERIC-ARG-P* (PRINT-VARIABLE-DOC (CDAR L))))  (FORMAT T "~&~%Done.    Press SPACE to remove.")  DIS-NONE);; Definition from patch 94.191.  ddd/gsl 3/4/84.(DEFCOM COM-VARIABLE-APROPOS "List all editor options whose names contain a given substring.Each variable is mouse-sensitive and may be modified by clicking upon it." ()   (MULTIPLE-VALUE-BIND (FUNCTION ARG STR)       (GET-EXTENDED-SEARCH-STRINGS "Variable Apropos. (substring):")     (SETQ *LAST-VARIABLE-APROPOS* (LIST FUNCTION ARG STR))     (DO-VARIABLE-APROPOS FUNCTION ARG STR))   DIS-NONE) ;;;  Work function for the above and for refresh-variable-apropos.(DEFUN DO-VARIABLE-APROPOS (FUNCTION ARG STR)  (WITH-TYPEOUT-FONT-MAP-OF ((GET-SEARCH-MINI-BUFFER-WINDOW))     (FORMAT T "~&ZWEI variables matching \"~A\"." STR)     (FORMAT T "  Variable names are mouse-sensitive.~2&")     (LOOP FOR (NAME . VARIABLE) IN *VARIABLE-ALIST*   WHEN (FUNCALL FUNCTION ARG NAME)   DO (PRINT-VARIABLE-MOUSABLE VARIABLE))     (FORMAT T "~2&Done."))) ;; Various function definitions from patch 94.191.   ddd/gsl 3/4/84.;;; Given a variable and a stream, prints the variable's name and value to that stream.;; Minor change from patch 94.194.   ddd/gsl 3/4/84.(DEFUN PRINT-VARIABLE-MOUSABLE (VAR &OPTIONAL (STREAM *STANDARD-OUTPUT*))  "Describe the ZWEI variable VAR on STREAM, which must an editor typeout window.Prints the name, value and, with an arg, documentation."  (LET ((*PACKAGE* (FIND-PACKAGE "ZWEI"))(*PRINT-BASE* 12)(*NOPOINT NIL)(VAL (SYMBOL-VALUE VAR))(TYPE (GET VAR 'VARIABLE-TYPE)))    (SEND STREAM :ITEM 'ZMACS-VARIABLE VAR     (FORMAT NIL "~A " (STRING-APPEND (GET VAR 'VARIABLE-NAME) ":")))    (FORMAT STREAM "~23,4T  ")    (CASE TYPE      ((:BOOLEAN :KEYWORD :STRING :FIXNUM-OR-NIL :FIXNUM :ANYTHING :SMALL-FRACTION) ;;gsl 3-23-85       (PRIN1 VAL STREAM))      ((:PIXEL :PIXEL-OR-NIL)       (IF VAL  (FORMAT STREAM "~D pixels (~D spaces in current font, plus ~D pixels)"  VAL (TRUNCATE VAL (FONT-SPACE-WIDTH)) (REM VAL (FONT-SPACE-WIDTH)))  (PRIN1 VAL STREAM)))      (:CHAR       (WRITE-CHAR (INT-CHAR VAL) STREAM))      (:CHAR-LIST       (WRITE-CHAR #\" STREAM)       (FORMAT STREAM "~{~:C~^ ~}" VAL)       (WRITE-CHAR #\" STREAM)))    (TERPRI STREAM))) ;;; This lets the typeout window be initialized knowing about com-show-kill-ring things.(W:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* ZMACS-VARIABLE "Modify" MODIFY-VAR-APROPOS-VAR   'MODIFY-VAR-APROPOS-VAR "Change the value of this variable") ;; Function changed slightly by 94.217.   ddd/gsl, 3/5/84.(DEFUN REFRESH-VARIABLE-APROPOS ()  "List all editor options whose names contain a previously-given substring.Each variable is mouse-sensitive and may be modified by clicking upon it."  (APPLY #'DO-VARIABLE-APROPOS *LAST-VARIABLE-APROPOS*)  DIS-NONE) (DEFUN SET-ZMACS-VARIABLE-VALUE (VAR)  "Gets variable value from user and sets it as new value of a 'defvariable' variable."  (LET ((*MINI-BUFFER-DEFAULT-STRING* (VARIABLE-STRING VAR))(*PACKAGE* (FIND-PACKAGE "ZWEI"))(TYPE (GET VAR 'VARIABLE-TYPE))(VALUE (SYMBOL-VALUE VAR))(*READ-BASE* 12)(*PRINT-BASE* 12))    (SET VAR (CASE TYPE   (:CHAR    (LET ((V (TYPEIN-LINE-READLINE-WITH-DEFAULT       (FORMAT NIL "~S" VALUE)       "New value (one character)")))      (OR (= (LENGTH V) 1) (BARF "~S is not one character." V))      (MAKE-CHAR (AREF V 0))))   (:CHAR-LIST    (LET ((V (TYPEIN-LINE-READLINE-WITH-DEFAULT       (FORMAT NIL "~{~:C~}" VALUE)       "New value (a string)")))      (DO ((I 0 (1+ I))   (RET)   (LIM (LENGTH V)))  ((>= I LIM)   (NREVERSE RET))(PUSH (MAKE-CHAR (AREF V I)) RET))))   (:STRING    (TYPEIN-LINE-READLINE-WITH-DEFAULT      (FORMAT NIL "~S" VALUE)      "New value (a string)"))   ((:PIXEL :FIXNUM)    (LET ((V (TYPEIN-LINE-READ-WITH-DEFAULT       (FORMAT NIL "~S" VALUE)       "New value (a fixnum)")))      (OR (INTEGERP V) (BARF "~S is not a fixnum." V))      V))   ((:FIXNUM-OR-NIL :PIXEL-OR-NIL)    (LET ((V (TYPEIN-LINE-READ-WITH-DEFAULT       (FORMAT NIL "~S" VALUE)       "New value (NIL or a fixnum)")))      (OR (INTEGERP V) (NULL V) (BARF "~S is neither a fixnum not NIL." V))      V))   (:SMALL-FRACTION    (LET ((V (TYPEIN-LINE-READ-WITH-DEFAULT       (FORMAT NIL "~S" VALUE)       "New value (a flonum between 0.0 and 1.0")))      (OR (FLOATP V) (BARF "~S is not a floating-point number." V))      (OR (AND (>= V 0.0s0) (<= V 1.0s0))  (BARF "~S is not between 0.0 and 1.0" V))      (SMALL-FLOAT V)))   (:BOOLEAN    (LET ((V (TYPEIN-LINE-READ-WITH-DEFAULT       (FORMAT NIL "~S" VALUE)       "New value (T or NIL)")))      (OR (MEMBER V '(T NIL) :TEST #'EQ) (BARF "~S is neither T nor NIL." V))      V))   (:KEYWORD    (LET ((V (TYPEIN-LINE-READ-WITH-DEFAULT       (FORMAT NIL "~S" VALUE)       "New value (a symbol)")))      (OR (SYMBOLP V) (BARF "~S is not a symbol." V))      V))   (:ANYTHING (TYPEIN-LINE-READ-WITH-DEFAULT(FORMAT NIL "~S" VALUE)"New value")))))) (DEFUN MODIFY-VAR-APROPOS-VAR (VAR)  "Set editor user option variable, with some type checking."  (SET-ZMACS-VARIABLE-VALUE VAR)  (PRINT-VARIABLE-MOUSABLE VAR)  DIS-NONE) ;;;  Add a full-documentation option to the mouse-click for variables.(W:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST*  ZMACS-VARIABLE  "Document"  DOCUMENT-VAR-APROPOS-VAR  NIL  "Show the documentation for this variable") ;;;  New function, full documentation on a mouse-sensitive variable.(DEFUN DOCUMENT-VAR-APROPOS-VAR (VAR)  (FORMAT T "~2&")  (PRINT-VARIABLE VAR)  (LET ((DOC (DOCUMENTATION VAR 'VARIABLE)))    (IF DOC (FORMAT T "~&~A~2&" DOC)       (FORMAT T "~&~A has no documentation." (GET VAR 'VARIABLE-NAME))))  DIS-NONE) ;; Next two functions have been redefined from patch 94.191.   ddd/gsl 3/4/84.(DEFCOM COM-DESCRIBE-VARIABLE "Print documentation of editor user option variable.Reads the name of a variable (using completion),and prints its documentation string." ()   (LET ((X (COMPLETING-READ-FROM-MINI-BUFFER      "Variable name:" *VARIABLE-ALIST* NIL NIL      "You are typing the name of a variable to document.")))     (COND ((EQUAL X "")    (BARF))   (T    (PRINT-VARIABLE (CDR X))    (FORMAT T "~A~&" (DOCUMENTATION (CDR X) 'VARIABLE)))))   DIS-NONE) (DEFCOM COM-SET-VARIABLE "Set editor user option variable, checking type.Read the name of a variable (with completion), display current valueand documentation, and read a new variable.  Some checking is donethat the variable is the right type." ()   (LET ((X (COMPLETING-READ-FROM-MINI-BUFFER      "Variable name:" *VARIABLE-ALIST* NIL NIL      "You are typing the name of a variable to be set."      #'(LAMBDA (X)  (PRINT-VARIABLE (CDR X))  (FORMAT T "~A~&"  (DOCUMENTATION (CDR X) 'VARIABLE))))))     (AND (EQUAL X "") (BARF))     (PRINT-VARIABLE (CDR X))     (FORMAT T "~A~&" (DOCUMENTATION (CDR X) 'VARIABLE))     (SET-ZMACS-VARIABLE-VALUE (CDR X)))   DIS-NONE) (DEFUN VARIABLE-STRING (VAR) "Return a string representing the value of ZWEI variable VAR."  (LET ((*PACKAGE* (FIND-PACKAGE "ZWEI"))(*PRINT-BASE* 12)(*NOPOINT NIL)(VAL (SYMBOL-VALUE VAR))(TYPE (GET VAR 'VARIABLE-TYPE)))    (CASE TYPE  ((:BOOLEAN :KEYWORD :STRING :FIXNUM-OR-NIL :FIXNUM :ANYTHING :PIXEL :PIXEL-OR-NIL)   (FORMAT NIL "~S" VAL))  (:CHAR   (FORMAT NIL "~C" VAL))  (:CHAR-LIST   (DO ((VAL VAL (CDR VAL))(STRING (MAKE-ARRAY 12 :ELEMENT-TYPE 'STRING-CHAR :LEADER-LIST '(0))))       ((NULL VAL) STRING)     (VECTOR-PUSH-EXTEND (CAR VAL) STRING))))))  (DEFCOM COM-MAKE-LOCAL-VARIABLE "Make editor user option variable local to this buffer.Reads the name of a variable (with completion)and makes the variable local to the current bufferso that if you set it you will not affect any other buffer." ()   (LET ((VARNAME (COMPLETING-READ-FROM-MINI-BUFFER    "Variable name:" *VARIABLE-ALIST* NIL NIL    "You are typing the name of a variable to be made local to this buffer."    #'(LAMBDA (X)(PRINT-VARIABLE (CDR X))(FORMAT T "~A~&"(DOCUMENTATION (CDR X) 'VARIABLE))))))     (UNLESS (CONSP VARNAME) (BARF))     (MAKE-LOCAL-VARIABLE (CDR VARNAME)))   DIS-NONE) (DEFCOM COM-KILL-LOCAL-VARIABLE "Make editor user option variable global in this buffer.Reads the name of a variable (with completion)and makes the variable no longer be local to this buffer,so that this buffer will share the value with most other buffers." ()   (LET ((VARNAME (COMPLETING-READ-FROM-MINI-BUFFER    "Variable name:" *VARIABLE-ALIST* NIL NIL    "You are typing the name of a variable to be made local to this buffer."    #'(LAMBDA (X)(PRINT-VARIABLE (CDR X))(FORMAT T "~A~&" (DOCUMENTATION (CDR X) 'VARIABLE))))))     (UNLESS (CONSP VARNAME) (BARF))     (KILL-LOCAL-VARIABLE (CDR VARNAME)))   DIS-NONE) (DEFCOM COM-LIST-LOCAL-VARIABLES "List editor user option variables local in this buffer." ()   (DOLIST (VARNAME *LOCAL-VARIABLES*)     (PRINT-VARIABLE VARNAME)     (FORMAT T "~A~&" (DOCUMENTATION VARNAME 'VARIABLE)))   DIS-NONE) ;; Function definitions from patch 94.210.   ddd/gsl, 3/7/84.(DEFUN PUSH-POINT-AND-GOTO (BP-PUSH-ITEM-LIST-SWAP-HOOK)  "This is  a  routine  for  mousing  a  bp  on  the  typeout window.  The type isregister-bp for the *typeout-command-alist*.  The single parameter passed by themouse process is a list consisting of the items named in the formal arg:  BP is the bp, in any buffer.  PUSH if non-nil means that point should be pushed on the point pdl.  Since bp may have come from, or may be, an item in a list, it may be desirableto put the selected item at the front of the list.  ITEM is the item which  willbe moved to the front of LIST.  Its first occurance in LIST is removed, if thereis any.   Note  that  LIST  is  longer  if  ITEM  was not in it previous to thisoperation.   SWAP if NIL means don't mess with LIST, leave it alone.  HOOK may be a list or a function.  If it is a function, it is called with thisfunctions argument.  If it is a list, its CAR should be a function which will beAPPLIED to its HOOK's cdr."  (LET ((BP (FIRST BP-PUSH-ITEM-LIST-SWAP-HOOK))(PUSH-P (SECOND BP-PUSH-ITEM-LIST-SWAP-HOOK))(ITEM (THIRD BP-PUSH-ITEM-LIST-SWAP-HOOK))(LIST (COPY-LIST (FOURTH BP-PUSH-ITEM-LIST-SWAP-HOOK)))(SWAP-P (FIFTH BP-PUSH-ITEM-LIST-SWAP-HOOK))(HOOK (NTHCDR 5 BP-PUSH-ITEM-LIST-SWAP-HOOK))HEAD HEADS-TAIL TAIL);; Push point onto the point pdl.    (IF PUSH-P (POINT-PDL-PUSH (POINT) *WINDOW* T T))    ;; Put item on front of list, removing it from prev. position in list if any.    (WHEN SWAP-P      (SETQ HEADS-TAIL (MEMBER ITEM LIST :TEST #'EQUAL)         ;List from item on.    TAIL (CDR (COPY-LIST HEADS-TAIL))                ;List after item.    HEADS-TAIL (AND HEADS-TAIL (RPLACD HEADS-TAIL ()));To chop list at item.    HEAD (IF HEADS-TAIL (BUTLAST LIST) LIST)        ;List up to, not including item.    LIST (FOURTH BP-PUSH-ITEM-LIST-SWAP-HOOK))        ;make list the real thing.      (RPLACA LIST ITEM)      (RPLACD LIST (APPEND HEAD TAIL)))    ;; Do anything else like making sure list is not now too long.    (IF HOOK       (IF (CONSP HOOK)   (APPLY (CAR HOOK) (CDR HOOK))   (FUNCALL HOOK BP-PUSH-ITEM-LIST-SWAP-HOOK)))    ;;Move to bp.    (MOVE-TO-BP BP))) (W:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST*  REGISTER-BP  "Move"  PUSH-POINT-AND-GOTO  'PUSH-POINT-AND-GOTO  "Push point on point pdl and go to position shown.") (DEFCOM COM-SHOW-SAVED-POSITIONS   "Gives a mousable display of positions saved in registers with Save Position (C-X S).Pushes current point on point pdl for easy return with various commands." ()   (FORMAT T "~V@TThis is a mousable list of saved locations to which you may jump.~@              ~V@T Save positions with Control-X S plus a register-name letter.~@              ~V@T Numeric arguments to this command change number of lines shown.~%~%" 5 7 7)   (DO ((L *Q-REG-LIST* (CDR L))(*NUMERIC-ARG* (IF *NUMERIC-ARG-P* (ABS *NUMERIC-ARG*) 1)))       ((NULL L))     (MOUSABLE-SHOW-REGISTER-POSITION (CAR L)))   DIS-TEXT) (DEFUN MOUSABLE-SHOW-REGISTER-POSITION (SYM)  (LET ((BP (CAR (GET SYM 'POINT))))    (WHEN BP      (LET* ((START-LINE (BP-LINE BP))     (SECTION (LINE-NODE START-LINE)))(FORMAT T "~% Position: Register ~A:" SYM)(IF (TYPEP SECTION 'SECTION-NODE)    (FORMAT T "~%~V@T from ~A in ~A~%" 2 (SEND SECTION :NAME)    (SEND (SEND SECTION :SUPERIOR) :NAME))    (FORMAT T "~%~V@T from ~A:~%" 2    (COND ((SEND SECTION :SEND-IF-HANDLES :NAME))  (T "some nameless node"))))(DO* ((THIS-LINE START-LINE (LINE-NEXT THIS-LINE))      (THE-BP-AND-COUNT(LIST BP T SYM *Q-REG-LIST* T)(LIST (CONS THIS-LINE (CONS 0 (LIST :NORMAL))) T SYM *Q-REG-LIST* T))      (LINE-COUNT 0 (1+ LINE-COUNT)))     ((OR (NULL THIS-LINE)  (EQ LINE-COUNT *NUMERIC-ARG*)))  (FORMAT T "~5T")  (SEND *STANDARD-OUTPUT* :ITEM 'REGISTER-BP THE-BP-AND-COUNT "~a" THIS-LINE)  (FORMAT T "~%")))))) ;; Two more function defs from 94.210.(DEFCOM COM-SHOW-ALL-REGISTERS   "Gives a mousable display of text saved in registers with Put Register (C-X X)." ()   (FORMAT T   "~V@TThis is a mousable list of saved text which you may yank.~@            ~V@T Save text with Control-X X plus a register-name letter.~%~%" 5 7)   (DO* ((L *Q-REG-LIST* (CDR L)) (REG (CAR L) (CAR L)) TEXT)((NULL L))     (SETQ TEXT (GET REG 'TEXT))     (WHEN TEXT       (FORMAT T "~&~% Text in Register ~A:~%" REG)       (SHOW-YANKABLE-NODE TEXT "" "<< Yank the entire register >>")))   DIS-TEXT) (DEFCOM COM-VIEW-REGISTER "Display the contents of a register.The register name, a character with bits attribute = 0, is read from the keyboard." (KM)   (WITH-TYPEOUT-FONT-MAP-OF (*WINDOW*)      (LET* ((SYM (GET-REGISTER-NAME "View register:"))     (PT (GET SYM 'POINT))     (TEXT (GET SYM 'TEXT)))(FORMAT T "~&Register ~A:" SYM)(LET ((BP (CAR PT)))  (WHEN BP    (MOUSABLE-SHOW-REGISTER-POSITION SYM)))(WHEN TEXT  (FORMAT T "~&~% Text: Register ~A:" SYM)  (SHOW-YANKABLE-NODE TEXT "" "<< Yank the entire register >>"))(AND (NULL (SYMBOL-PLIST SYM)) (FORMAT T "~& No text or saved position assigned.")))      (FORMAT T "~&"))   DIS-NONE) (DEFUN COMPLETION-EXPAND (TYPE TYPEOUT?) "Expand the atom at point using TYPE completion algorithm.TYPE may be one of :RECOGNITION :APROPOS or :SPELLING-CORRECTEDIf TYPEOUT? is non-nil, completions are put in the typeout-buffer   where the user may mouse them."  (LET ((BP (POINT))(MAX-LIST 5)BP1 WORD POSSIBLE LOTS-OF-COMPLETIONS?)    (SETQ BP1 (FORWARD-ATOM BP -1 T); beginning of atom  WORD (STRING-TRIM " " (STRING-UPCASE (STRING-INTERVAL BP1 BP))))    (WHEN (POSITION #\NEWLINE (THE STRING (STRING WORD)) :TEST #'CHAR-EQUAL)      (SETQ WORD ""))    (WHEN WORD      (SETQ POSSIBLE (W::GET-SYMBOL-COMPLETIONS       WORD TYPE       (IF (CHAR= (BP-CHAR-BEFORE BP1) #\()   #'FBOUNDP   #'BOUNDP)))      (IF (NOT POSSIBLE)  (BARF "No ~a completions for ~a" TYPE WORD)  (MULTIPLE-VALUE-BIND (NEW-WORD COMPLETED-P)      (W::EXPAND-MOST-COMPLETE WORD POSSIBLE)   (WHEN (NOT COMPLETED-P)     (IF TYPEOUT? (DISPLAY-COMPLETIONS (LOOP FOR WORD IN POSSIBLE    COLLECT (FORMAT NIL "~s" WORD))      "These are the ~a completions for ~s: ~{~%~S~}" TYPE WORD) (PROGN   (SETQ LOTS-OF-COMPLETIONS? (> (LENGTH POSSIBLE) MAX-LIST))   (FORMAT *QUERY-IO* "These are ~:[~;some of~] the ~a completions for ~s"   LOTS-OF-COMPLETIONS? (STRING-DOWNCASE TYPE) WORD)   (FORMAT *QUERY-IO* "~%~{ ~s~}~:[~;...~]"   (IF LOTS-OF-COMPLETIONS?       (FIRSTN MAX-LIST POSSIBLE)       POSSIBLE)   LOTS-OF-COMPLETIONS?)   (WHEN LOTS-OF-COMPLETIONS?     (FORMAT *QUERY-IO* "~%For a complete list type ~[Control~;Super~;Hyper~]-/"     (POSITION TYPE       (THE LIST '(:RECOGNITION :APROPOS :SPELLING-CORRECTED))       :TEST #'EQ))))))   (REPLACE-ATOM-AT-POINT NEW-WORD COMPLETED-P)))))  DIS-TEXT) (DEFUN REPLACE-ATOM-AT-POINT (STRING &OPTIONAL (BLANKP T))  "Replace the atom at POINT with STRING.If BLANKP is non-nil and there is an open parenthisis before the atom,put a blank after the atom."  (LET* ((BP (POINT)) (BP1 (FORWARD-ATOM BP -1 T)))    (WHEN (AND BLANKP (CHAR= (BP-CHAR-BEFORE BP1) #\())      (SETQ STRING (STRING-APPEND STRING " ")))    (MOVE-BP BP (CASE-REPLACE (COPY-BP BP1 :NORMAL) BP STRING)))  NIL) (DEFUN DISPLAY-COMPLETIONS (POSSIBLE HEADING-STRING &REST FORMAT-ARGS)  "Display completions in the typeout buffer"  (APPLY #'FORMAT T HEADING-STRING FORMAT-ARGS)  (FRESH-LINE)  (WRITE-CHAR #\NEWLINE) ;Blank line after heading  (SEND *STANDARD-OUTPUT* :ITEM-LIST 'REPLACE-ATOM POSSIBLE)  (FORMAT T "~%Select one or hit any key to continue.")) ; ADD REPLACE-ATOM TO THE TYPEOUT-COMMAND-ALIST(PROGN  (DELETE (ASSOC 'REPLACE-ATOM *TYPEOUT-COMMAND-ALIST* :TEST #'EQ)  (THE LIST *TYPEOUT-COMMAND-ALIST*) :TEST #'EQ)  (PUSH-END '(REPLACE-ATOM REPLACE-ATOM-AT-POINT (COMPLETE-DOC GLOBAL:STRING))     *TYPEOUT-COMMAND-ALIST*)) (DEFUN COMPLETE-DOC (ITEM)  (OR (DOCUMENTATION (READ-FROM-STRING (SECOND ITEM) T))      "Select a completion.")) ;;;; ADD COMMANDS TO DO COMPLETION;;(DEFCOM COM-APROPOS-COMPLETE "Do apropos completion on the word before point." ()   (COMPLETION-EXPAND :APROPOS NIL)) (DEFCOM COM-RECOGNITION-COMPLETE "Do recognition completion on the word before point." ()   (COMPLETION-EXPAND :RECOGNITION NIL)) (DEFCOM COM-SPELLING-CORRECTED-COMPLETE   "Do spelling corrected completion on the word before point." ()   (COMPLETION-EXPAND :SPELLING-CORRECTED NIL)) (DEFCOM COM-LIST-APROPOS-COMPLETIONS "List apropos completions on the word before point." ()   (COMPLETION-EXPAND :APROPOS T)) (DEFCOM COM-LIST-RECOGNITION-COMPLETIONS   "List recognition completions on the word before point." ()   (COMPLETION-EXPAND :RECOGNITION T)) (DEFCOM COM-LIST-SPELLING-CORRECTED-COMPLETIONS   "List spelling corrected completions on the word before point." ()   (COMPLETION-EXPAND :SPELLING-CORRECTED T)) d onto one line instead of beingdisplayed at separate locations.*"  ;1;; Note that the old forms of the mouse keywords are supported too.*  ;1;; That is writing :MOUSE-1-1 instead of :MOUSE-L-1.  This is done*  ;1;; only in case someone out there is using that form.  We want users*  ;1;; to use the newer form because it makes for better documentation,*  ;1;; that is why we 