LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032419. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "COMG" :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 2758716776. :AUTHOR "REL3" :LENGTH-IN-BYTES 27243. :LENGTH-IN-BLOCKS 27. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  ;;; Zwei commands, see ZWEI;COMA for comments -*- Mode:Common-Lisp; Package:ZWEI; Base:10 -*-;;;                           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) 1985, 1987 Texas Instruments Incorporated. All rights reserved.;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **(DEFCOM COM-SET-KEY "Install a specified Zwei command on a specified key.If the key is currently holding a command prefix (like Control-X), it will askyou for another character, so that you can redefine Control-X commands.  However,with a numeric argument, it will assume you want to redefine Control-X itself,and will not ask for another character." ()   (LET ((COMMAND (COMPLETING-READ-FROM-MINI-BUFFER "Command to install" *COMMAND-ALIST*)))     (UNLESS (CONSP COMMAND)       (BARF))     (INSTALL-COMMAND-INTERNAL (CDR COMMAND)))) (DEFCOM COM-INSTALL-COMMAND "Install a specified Lisp function on a specified key.The name of the function is read from the minibuffer (the top of the kill ringcontains the name of the current defun), and a character from the echo area.If the key is currently holding a command prefix (like Control-X), it will askyou for another character, so that you can redefine Control-X commands.  However,with a numeric argument, it will assume you want to redefine Control-X itself,and will not ask for another character." ()   (DO (NAME)       (NIL)     (SETQ NAME(READ-FUNCTION-NAME "Name of function to install"    (RELEVANT-FUNCTION-NAME (POINT) () T T T) () 'ALWAYS-READ))     (AND (OR (FBOUNDP NAME)      (FQUERY '(:SELECT T) "~A is not defined, ok to install anyway? " NAME))  (RETURN (INSTALL-COMMAND-INTERNAL NAME))))) (DEFCOM COM-INSTALL-MACRO "Install a specified user macro on a specifed key.The macro should be a \"permanent\" macro, that has a name.The name of the macro is read from the mini-buffer, and the keystroke on whichto install it is read in the echo area.If the key is currently holding a command prefix (like Control-X), it will askyou for another character, so that you can redefine Control-X commands.  However,with a numeric argument, it will assume you want to redefine Control-X itself,and will not ask for another character."   () (COM-INSTALL-MACRO-INTERNAL ())) (DEFCOM COM-INSTALL-MOUSE-MACRO   "Like Install Macro, but moves the mouse to where clicked first." ()   (COM-INSTALL-MACRO-INTERNAL T)) (DEFCOM COM-DEINSTALL-MACRO "Deinstall a keyboard macro" ()   (MULTIPLE-VALUE-BIND (KEYS OLD-CMD) (INSTALL-COMMAND-INTERNAL-RETURN-KEY-LIST () () T)     (LET* ((NAME (SYMEVAL-IN-CLOSURE OLD-CMD 'SYMBOL))    (MAC (GET NAME 'MACRO-STREAM-MACRO)))       (DOLIST (KEY KEYS) (SETF (MACRO-INSTALLED-ON-KEYS MAC)       (DELETE KEY (THE LIST (MACRO-INSTALLED-ON-KEYS MAC)) :TEST #'EQ)))))   DIS-NONE) (DEFUN COM-INSTALL-MACRO-INTERNAL (MOUSE-P)  (OR (MEMBER :MACRO-PREVIOUS-ARRAY (SEND *STANDARD-INPUT* :WHICH-OPERATIONS) :TEST #'EQ)     (BARF "This stream does not support macros"))  (LET ((*PACKAGE* PKG-KEYWORD-PACKAGE)NAMEMAC)    (SETQ NAME (TYPEIN-LINE-READ "Name of macro to install (CR for last macro defined):"))    (COND ((EQ NAME '*EOF*)   (SETQ MAC (SEND *STANDARD-INPUT* :MACRO-PREVIOUS-ARRAY) NAME (GENSYM))   (SETF (GET NAME 'MACRO-STREAM-MACRO) MAC)   (SETF (MACRO-NAME MAC) NAME))  ((NOT (SETQ MAC (GET NAME 'MACRO-STREAM-MACRO)))   (BARF "~A is not a defined macro." NAME)))    (SETF (MACRO-INSTALLED-ON-KEYS MAC)       (APPEND(INSTALL-COMMAND-INTERNAL-RETURN-KEY-LIST (MAKE-MACRO-COMMAND NAME MOUSE-P) T () MOUSE-P)(MACRO-INSTALLED-ON-KEYS MAC))))  DIS-NONE) (DEFUN INSTALL-COMMAND-INTERNAL (COMMAND &OPTIONAL REMEMBER-OLD-P DEINSTALL-P MOUSE-P)  (INSTALL-COMMAND-INTERNAL-RETURN-KEY-LIST COMMAND REMEMBER-OLD-P DEINSTALL-P MOUSE-P)  DIS-NONE) (DEFUN INSTALL-COMMAND-INTERNAL-RETURN-KEY-LIST (COMMAND &OPTIONAL REMEMBER-OLD-P DEINSTALL-P MOUSE-P &AUX KEY-LIST OLD-COMMAND)  "This is just like INSTALL-COMMAND-INTERNAL but returns the keylist and old command on key."  (PROMPT-LINE (IF DEINSTALL-P "Key to deinstall:" "Key to get it:"))  (CLEAR-PROMPTS)  (ALWAYS-DISPLAY-PROMPTS)  (WITHOUT-IO-BUFFER-OUTPUT-FUNCTION    (DO ((COMTAB *COMTAB*) (KEY (INPUT-WITH-PROMPTS *STANDARD-INPUT* :READ-MOUSE-OR-KBD)      (INPUT-WITH-PROMPTS *STANDARD-INPUT* :TYI)))(NIL)      (WHEN (AND MOUSE-P (NOT (CHAR-BIT KEY :MOUSE)))(BARF "Mouse macros must be installed on mouse clicks."))      (WHEN (AND (MEMBER KEY '(#\ABORT #\END #\c-G) :TEST #'EQ) (NOT (Y-OR-N-P (FORMAT NIL "Do you really want to install ~s on ~:C" COMMAND KEY))))(THROW 'TOP-LEVEL NIL))      (PUSH KEY KEY-LIST)      (SETQ OLD-COMMAND (COMMAND-LOOKUP KEY COMTAB))      (COND ((AND (PREFIX-COMMAND-P OLD-COMMAND) (NOT *NUMERIC-ARG-P*))     (SETQ COMTAB (SYMEVAL-IN-CLOSURE OLD-COMMAND 'COMTAB)))    (T     (AND DEINSTALL-P  (SETQ COMMAND (MOUSE-MACRO-COMMAND-LAST-COMMAND (COMMAND-LOOKUP KEY COMTAB))))     (AND REMEMBER-OLD-P  (SET-MOUSE-MACRO-COMMAND-LAST-COMMAND COMMAND (COMMAND-LOOKUP KEY COMTAB)))     (COMMAND-STORE COMMAND KEY COMTAB)     (RETURN NIL)))))  (LET ((COMMAND-NAME (OR (AND (CLOSUREP COMMAND)       (SYMEVAL-IN-CLOSURE COMMAND 'SYMBOL))  COMMAND)))    (FORMAT *QUERY-IO* "~&Command ~S installed on" COMMAND-NAME))  (DOLIST (KEY (NREVERSE KEY-LIST))    (FORMAT *QUERY-IO* " ~:@C" KEY))  (FORMAT *QUERY-IO* ".")  (VALUES KEY-LIST OLD-COMMAND)) ;;;EMACS compatible macro commands(DEFCOM COM-START-KBD-MACRO   "Begin defining a keyboard macro.A numeric argument means append to the previous keyboard macro.For information on macro commands try Meta-Ctrl-Term Help.  Also try the Aproposcommand on the string MACRO." ()   (OR (MEMBER :MACRO-PUSH (SEND *STANDARD-INPUT* :WHICH-OPERATIONS) :TEST #'EQ)       (BARF "This stream doesn't support macros"))   (SEND *STANDARD-INPUT* :MACRO-PUSH (+ 2 *NUMERIC-ARG-N-DIGITS*)    (AND *NUMERIC-ARG-P* (SEND *STANDARD-INPUT* :MACRO-PREVIOUS-ARRAY)))   DIS-NONE) (DEFCOM COM-END-KBD-MACRO "Terminate the definition of a keyboard macro" ()   (OR (MEMBER :MACRO-POP (SEND *STANDARD-INPUT* :WHICH-OPERATIONS) :TEST #'EQ)       (BARF "This stream doesn't support macros"))   (CATCH 'MACRO-LOOP  ;In case no macro running     (SEND *STANDARD-INPUT* :MACRO-POP (+ 2 *NUMERIC-ARG-N-DIGITS*)   (AND *NUMERIC-ARG-P* *NUMERIC-ARG*))) ;;gsl 4-16-85   DIS-NONE) (DEFCOM COM-CALL-LAST-KBD-MACRO "Repeat the last keyboard macro" ()   (OR (MEMBER :MACRO-EXECUTE (SEND *STANDARD-INPUT* :WHICH-OPERATIONS) :TEST #'EQ)       (BARF "This stream doesn't support macros"))   (SEND *STANDARD-INPUT* :MACRO-EXECUTE () (AND *NUMERIC-ARG-P* *NUMERIC-ARG*)) ;;gsl 4-16-85   DIS-NONE) (DEFCOM COM-KBD-MACRO-QUERY "Interactive keyboard macro" ()   (OR (MEMBER :MACRO-QUERY (SEND *STANDARD-INPUT* :WHICH-OPERATIONS) :TEST #'EQ)       (BARF "This stream doesnt support macros"))   (SEND *STANDARD-INPUT* :MACRO-QUERY (+ 2 *NUMERIC-ARG-N-DIGITS*))   DIS-NONE) (DEFCOM COM-VIEW-KBD-MACRO "Typeout the specified keyboard macro.The macro should be a \"permanent\" macro, that has a name.The name of the macro is read from the mini-buffer.Just Return means the last one defined, even if temporary." ()   (OR (MEMBER :MACRO-PREVIOUS-ARRAY (SEND *STANDARD-INPUT* :WHICH-OPERATIONS) :TEST #'EQ)       (BARF "This stream does not support macros"))   (LET ((*PACKAGE* PKG-KEYWORD-PACKAGE) NAME MAC)     (SETQ NAME (TYPEIN-LINE-READ "Name of macro to view (CR for last macro defined):"))     (COND ((EQ NAME '*EOF*)    (SETQ MAC (SEND *STANDARD-INPUT* :MACRO-PREVIOUS-ARRAY))    (UNLESS MAC (BARF "There is no previously defined macro.")))   ((NOT (SETQ MAC (GET NAME 'MACRO-STREAM-MACRO)))    (BARF "~A is not a defined macro." NAME)))     (DO ((I 0 (1+ I))  (LEN (MACRO-LENGTH MAC))  (CH)) ((> I LEN))       (FORMAT T (CASE (SETQ CH (AREF MAC I))   (*MOUSE* "Mouse command ~*")           (*SPACE* "Macro query ~*")           (*RUN* "Repeat ~*")           (NIL "Input ~*")           (OTHERWISE "~:C "))       CH)))   DIS-NONE) (DEFCOM COM-NAME-LAST-KBD-MACRO "Make the last temporary macro permanent.The new name for the macro is read from the mini-buffer." ()   (OR (MEMBER :MACRO-PREVIOUS-ARRAY (SEND *STANDARD-INPUT* :WHICH-OPERATIONS) :TEST #'EQ)       (BARF "This stream does not support macros"))   (LET* ((MAC (OR (SEND *STANDARD-INPUT* :MACRO-PREVIOUS-ARRAY)   (BARF "There is no previous keyboard macro")))  (*PACKAGE* PKG-KEYWORD-PACKAGE)  (NAME (TYPEIN-LINE-READ "Name for macro:"))  (MACRO-CLOSURE (MAKE-MACRO-COMMAND NAME ())))     (SETF (GET NAME 'MACRO-STREAM-MACRO) MAC)     ;;Let it be called as a command. gsl 4-21-85     (SETF (GET NAME 'MACRO-STREAM-MACRO-COMMAND) MACRO-CLOSURE)     (MAKE-MACRO-A-COMMAND NAME MACRO-CLOSURE)     ;;Tell it it's name.     (SETF (MACRO-NAME MAC) NAME)) ;;gsl   DIS-NONE) (DEFCOM COM-WRITE-KBD-MACRO "Append a kbd macro to a file for retrieval with Load Kbd Macros.The name of the macro and the filename are both read from the minibuffer." () ;;gsl   (LET* ((*PACKAGE* PKG-KEYWORD-PACKAGE)  (NAME (LET ((NAME (TYPEIN-LINE-READ "Name of macro:  (RETURN for last macro defined.)")))  (IF (EQ NAME '*EOF*) () NAME)))  (MAC (COND (NAME      (OR (GET NAME 'MACRO-STREAM-MACRO)  (BARF "There is no keyboard macro named ~a." NAME)))     ((SEND *STANDARD-INPUT* :MACRO-PREVIOUS-ARRAY))     (T (BARF "There is no previous keyboard macro"))))  (PATHNAME (READ-DEFAULTED-PATHNAME (FORMAT () "Append ~a to what file?" (OR NAME "it"))     (PATHNAME-DEFAULTS *PATHNAME-DEFAULTS*) () :NEWEST :WRITE))  (LEADER (LOOP FOR I FROM 0 BELOW (ARRAY-LEADER-LENGTH MAC)COLLECTING (ARRAY-LEADER MAC I)))  (CONTENTS (LOOP FOR I FROM 0 TO (+ 2 (MACRO-LENGTH MAC))  COLLECTING (AREF MAC I))))     (OR NAME (SETQ NAME (MACRO-NAME MAC)))     ;;It may know it's name already.     (OR NAME(PROGN (SETQ NAME (GENSYM)) ;;give it some name.       (SETF (GET NAME 'MACRO-STREAM-MACRO) MAC)       (SETF (NTH 4 LEADER) NAME)       (SETF (MACRO-NAME MAC) NAME)))     (WITH-OPEN-FILE-RETRY (STREAM (PATHNAME FS:FILE-ERROR)   :DIRECTION :OUTPUT :IF-EXISTS :APPEND   :IF-DOES-NOT-EXIST :CREATE)      (SETQ *PACKAGE* ())      (FORMAT STREAM "~&(~s~%~2@T(~{~s ~}(~{~^~@c~^ ~}))"      NAME (BUTLAST LEADER) (CAR (LAST LEADER)))      (DO ((TAIL CONTENTS (CDR TAIL))   (LINE-FEED-AT 8)   (I 1 (1+ I)))  ((NULL TAIL)   (FORMAT STREAM "~%~2@T)~%"))(IF (= I 1) (FORMAT STREAM "~%~2@T"))(FORMAT STREAM "~:[~s~;~@c~] " (NUMBERP (CAR TAIL)) (CAR TAIL))(IF (= I LINE-FEED-AT) (SETQ I 0)))))   DIS-NONE) (DEFUN KBD-MACRO-STORE (FORM COMTAB) ;;gsl  "Reads in a form as created by COM-WRITE-KBD-MACRO and creates a named keyboard macro for it."  (LET ((NAME (FIRST FORM))(LEADER (SECOND FORM))(KEYS (NTH 5 (SECOND FORM)))(CONTENTS (CDDR FORM)))    (LET ((MAC (MAKE-MACRO-ARRAY :MACRO-POSITION (NTH 0 LEADER) :MACRO-LENGTH (NTH 1 LEADER) :MACRO-COUNT (NTH 2 LEADER) :MACRO-DEFAULT-COUNT (NTH 3 LEADER) :MACRO-NAME (NTH 4 LEADER) :MACRO-INSTALLED-ON-KEYS (NTH 5 LEADER)))  (MACRO-CLOSURE (MAKE-MACRO-COMMAND NAME ())))      (ZLC:FILLARRAY MAC CONTENTS)      (SETF (GET (CAR FORM) 'MACRO-STREAM-MACRO) MAC)      (DOLIST (KEY KEYS)(COMMAND-STORE MACRO-CLOSURE KEY COMTAB))      ;;Let it be called as a command. gsl 4-25-85      (SETF (GET NAME 'MACRO-STREAM-MACRO-COMMAND) MACRO-CLOSURE)      (MAKE-MACRO-A-COMMAND NAME MACRO-CLOSURE)))) (DEFCOM COM-LOAD-KBD-MACROS   "Loads, and possibly installs, keyboard macros thatwere stored in a file with the Write Kbd Macro command." () ;;gsl   (LOAD-KBD-MACROS (READ-DEFAULTED-PATHNAME "Load keyboard macros from which file?"     (PATHNAME-DEFAULTS *PATHNAME-DEFAULTS*)     () :NEWEST :READ)    *MODE-COMTAB*)   DIS-NONE) (DEFUN LOAD-KBD-MACROS (PATHNAME &OPTIONAL (COMTAB *STANDARD-COMTAB*) &AUX (EOF '(NIL))) ;;gsl  "Loads, and possibly installs, keyboard macros stored to a file with the   write named kbd macros command.  Pathname may be a pathname object or a string."  (IF (TYPEP PATHNAME 'STRING)      (SETQ PATHNAME (MAKE-DEFAULTED-PATHNAME PATHNAME (PATHNAME-DEFAULTS))))  (WITH-OPEN-FILE-CASE (STREAM PATHNAME)     (:NO-ERROR      (DO ((FORM (READ STREAM NIL EOF) (READ STREAM NIL EOF)))  ((EQL FORM EOF))(KBD-MACRO-STORE FORM COMTAB)))     (FS:FILE-NOT-FOUND (BARF STREAM))     (FS:FILE-ERROR (BARF STREAM)))) ;;; Sorting commands(DEFCOM COM-SORT-LINES "Sort the region alphabetically by lines" ()   (REGION (BP1 BP2)     (SORT-LINES-INTERVAL #'STRING-LESSP BP1 BP2 T))   DIS-TEXT) (DEFCOM COM-SORT-PARAGRAPHS "Sort the region alphabetically by paragraphs. With a numeric    arg it won't adjust the ends of your region for you." ()  (REGION (BP1 BP2)    (UNLESS *NUMERIC-ARG-P*      ;;unless told not to, include whitespace before first paragraph. gsl 3-25-85      (LET ((BP3 (FORWARD-PARAGRAPH (FORWARD-PARAGRAPH BP1 -1 T) 1 T))    (BP4 (FORWARD-PARAGRAPH (FORWARD-PARAGRAPH BP2 -1 T) 1 T)))(IF (BP-< BP3 BP1) ;;if we had a prev paragraph...    (SETQ BP1 BP3)  ;;then we'll start from end of prev paragraph.    (LET ((BP-TOP (BACKWARD-OVER *WHITESPACE-CHARS* BP1))  (BP-PREV (AND (LINE-PREVIOUS (BP-LINE BP1))(CREATE-BP (LINE-PREVIOUS (BP-LINE BP1)) 0))))      (AND BP-PREV  ;;else we'll try to move back a blank line.   (OR (BP-= BP-PREV BP-TOP)       (BP-< BP-TOP BP-PREV))   (SETQ BP1 BP-PREV))))(SETQ BP2 BP4)))    (SORT-INTERVAL-FUNCTIONS #'FORWARD-OVER-BLANK-OR-TEXT-JUSTIFIER-LINES     #'(LAMBDA (BP) (FORWARD-PARAGRAPH BP 1 T))     #'(LAMBDA (BP) BP)     #'INTERVAL-WITH-SORT-INTERVAL-LESSP     BP1 BP2 T))  DIS-TEXT) ;;; This returns a function which takes a BP and returns a resultant BP after performing;;; the given kbd-macro operation.(DEFUN MAKE-KBD-MACRO-MOVER (PROMPT)  "Returns a function which takes a BP, moves, and returns a BP.The function is defined to perform the ZWEI commands that you typewhile MAKE-KBD-MACRO-MOVER is running.  Prompts with PROMPT."  (COM-START-KBD-MACRO)  (FORMAT *QUERY-IO* "~&Defining a keyboard macro to ~A~@[; type ~A to finish it~]" PROMPT  (KEY-FOR-COMMAND 'COM-END-KBD-MACRO *COMTAB* NIL NIL #\)))  (LET ((MACRO-ERROR-HOOK #'(LAMBDA ()      (THROW 'EXIT-MAKE-KBD-MACRO-MOVER :MACRO-ERROR)))(MACRO-POP-HOOK #'(LAMBDA ()    (THROW 'EXIT-MAKE-KBD-MACRO-MOVER T))))    (AND (EQ (CATCH 'EXIT-MAKE-KBD-MACRO-MOVER (SEND SELF :EDIT))     :MACRO-ERROR) (THROW 'ZWEI-COMMAND-LOOP T)))  (COND ((NOT (BOUNDP '*MAKE-KBD-MACRO-MOVER-COMTAB*)) (SETQ *MAKE-KBD-MACRO-MOVER-COMTAB* (CREATE-SPARSE-COMTAB 'MACRO-MOVER-COMTAB)) (SETF (COMTAB-KEYBOARD-ARRAY *MAKE-KBD-MACRO-MOVER-COMTAB*)       '((-1 . COM-EXIT-KBD-MACRO-MOVER)))))  (SET-COMTAB-INDIRECTION *MAKE-KBD-MACRO-MOVER-COMTAB* *COMTAB*)  (LET-CLOSED ((OLD-MACRO-PREVIOUS-ARRAY (SEND *STANDARD-INPUT* :MACRO-PREVIOUS-ARRAY)))    (VECTOR-PUSH-EXTEND -1 OLD-MACRO-PREVIOUS-ARRAY)    (SETF (MACRO-LENGTH OLD-MACRO-PREVIOUS-ARRAY)  (1- (MACRO-POSITION OLD-MACRO-PREVIOUS-ARRAY)))    #'(LAMBDA (BP &AUX (POINT (POINT))OLD-POINT       (MACRO-ERROR-HOOK #'(LAMBDA ()     (THROW 'EXIT-KBD-MACRO-MOVER :MACRO-ERROR))))(SETQ OLD-POINT (COPY-BP POINT :NORMAL))(UNWIND-PROTECT    (PROGN      (MOVE-BP (POINT) BP) ;; moved into unwind-protect. gsl. 3-11-85      (SEND *STANDARD-INPUT* :MACRO-EXECUTE OLD-MACRO-PREVIOUS-ARRAY 1)      (AND (EQ (CATCH 'EXIT-KBD-MACRO-MOVER (SEND *WINDOW* :EDIT () *MAKE-KBD-MACRO-MOVER-COMTAB*))       :MACRO-ERROR)   (THROW 'ZWEI-COMMAND-LOOP T))      (COPY-BP POINT))  (MOVE-BP (POINT) OLD-POINT)  (FLUSH-BP OLD-POINT))))) (DEFUN COM-EXIT-KBD-MACRO-MOVER ()  (THROW 'EXIT-KBD-MACRO-MOVER T)) (DEFCOM COM-SORT-VIA-KEYBOARD-MACROS   "Sort the region alphabetically.Keyboard macros are read to move to the various part of the region to be sorted." ()  (IF *NUMERIC-ARG-P*           ;;give user some slack. gsl 3-23-85      (SETQ *NUMERIC-ARG-P* NIL  ;;else macros get messed up.    *REGION-FIXUP* T)      (SETQ *REGION-FIXUP* NIL))  (REGION (BP1 BP2)    (WITH-BP (FIRST-BP BP1 :NORMAL)      (WITH-BP (LAST-BP BP2 :MOVES)(SETF (WINDOW-MARK-P *WINDOW*) NIL)(MOVE-BP (POINT) FIRST-BP)(MUST-REDISPLAY *WINDOW* DIS-BPS)(LET ((MOVE-TO-KEY-MACRO (MAKE-KBD-MACRO-MOVER "move to the start of the sort key"))      (MOVE-OVER-KEY-MACRO (MAKE-KBD-MACRO-MOVER "move over the sort key"))      (MOVE-TO-NEXT-MACRO (MAKE-KBD-MACRO-MOVER "move to the end of the record")))  (SORT-INTERVAL-FUNCTIONS MOVE-TO-KEY-MACRO MOVE-OVER-KEY-MACRO MOVE-TO-NEXT-MACRO   #'INTERVAL-WITH-SORT-INTERVAL-LESSP FIRST-BP LAST-BP T)))))   DIS-TEXT) ;; Function redefined from patch 94.188.  ddd/gsl 3/4/84.(DEFUN READ-FLAVOR-NAME (PROMPT HELP &AUX TEM);;gsl 3-14-85  "Reads a flavor name using the minibuffer, prompting with PROMPT.HELP is a string to print to say what the flavor name is for."  (SORT-COMPLETION-AARRAY *ALL-FLAVOR-NAMES-AARRAY*)  (LET ((*ZMACS-COMPLETION-AARRAY* *ALL-FLAVOR-NAMES-AARRAY*))    (MULTIPLE-VALUE-BIND (FLAVOR STRING)(READ-FUNCTION-NAME PROMPT () 'AARRAY-OK () HELP)      ;; If have flavors of the same name in more than one package,      ;; and a package prefix was not given, the one we get is random.      ;; So use the one in the current package, if there is such a one.      (COND ((AND (EQUAL STRING (SYMBOL-NAME FLAVOR))  ;No prefix specified.  (NEQ (SYMBOL-PACKAGE FLAVOR) *PACKAGE*)  (SETQ TEM (FIND-SYMBOL (SYMBOL-NAME FLAVOR) *PACKAGE*))  (NEQ TEM FLAVOR)        ;And the sym is not this package's  (GET TEM 'SI:FLAVOR))  ;and this package's sym is a defined flavor.     TEM)    ((GET FLAVOR 'SI:FLAVOR)     FLAVOR)    (:ELSE     (BARF "~S is not the name of a flavor." FLAVOR)))))) (DEFCOM COM-DESCRIBE-FLAVOR "Describe the specified flavor." ()   (DESCRIBE-FLAVOR-INTERNAL (READ-FLAVOR-NAME "Describe flavor"       "You are typing the name of a flavor, to be described."))   DIS-NONE) (DEFUN DESCRIBE-FLAVOR-INTERNAL (FLAVOR &AUX FL TEM)  (OR (SETQ FL (GET FLAVOR 'SI:FLAVOR))      (BARF "~S is not the name of a flavor" FLAVOR))  (FORMAT T "~&Flavor ")  (SEND *STANDARD-OUTPUT* :ITEM 'FLAVOR-NAME FLAVOR)  (COND ((SETQ TEM (DONT-OPTIMIZE (SI:FLAVOR-DEPENDS-ON FL))) (FORMAT T " directly depends on flavor~P:~%" (LENGTH TEM)) (SEND *STANDARD-OUTPUT* :ITEM-LIST 'FLAVOR-NAME TEM))(T (FORMAT T " does not directly depend on any other flavors~%")))  (COND ((SETQ TEM (DONT-OPTIMIZE (SI:FLAVOR-INCLUDES FL))) (FORMAT T "~& and directly includes flavor~P:~%" (LENGTH TEM)) (SEND *STANDARD-OUTPUT* :ITEM-LIST 'FLAVOR-NAME TEM)))  (COND ((SETQ TEM (DONT-OPTIMIZE (SI:FLAVOR-DEPENDED-ON-BY FL))) (FORMAT T "~& and is directly depended on by flavor~P:~%" (LENGTH TEM)) (SEND *STANDARD-OUTPUT* :ITEM-LIST 'FLAVOR-NAME TEM)))  (IF (NULL (DONT-OPTIMIZE (SI:FLAVOR-DEPENDS-ON-ALL FL)))      (SI:COMPOSE-FLAVOR-COMBINATION FL))  (COND ((SETQ TEM (CDR (DONT-OPTIMIZE (SI:FLAVOR-DEPENDS-ON-ALL FL)))) (FORMAT T "~&Its entire list of components is:~%") (SEND *STANDARD-OUTPUT* :ITEM-LIST 'FLAVOR-NAME TEM)))  (LET ((LIV (DONT-OPTIMIZE (SI:FLAVOR-LOCAL-INSTANCE-VARIABLES FL))))    (DECLARE (SPECIAL LIV))    (SETQ LIV (LOOP FOR V IN LIV COLLECT (IF (ATOM V) V (CAR V))))    (IF (NULL LIV)(FORMAT T "~&~S has no local instance variables~%" FLAVOR)(PROGN  (FORMAT T "~&Instance variable~P of ~S: " (LENGTH LIV) FLAVOR)  (FORMAT:PRINT-LIST *STANDARD-OUTPUT* "~S" LIV)  (TERPRI *STANDARD-OUTPUT*)))    (COND ((SETQ TEM (DONT-OPTIMIZE (SI:FLAVOR-INSTANCE-SIZE FL)))   (FORMAT T "Flavor ~S has instance size ~D" FLAVOR TEM)   (LET ((IIV (REMOVE-IF #'(LAMBDA (X)     (MEMBER X LIV :TEST #'EQ)) (DONT-OPTIMIZE (SI:FLAVOR-ALL-INSTANCE-VARIABLES FL)))))     (COND (IIV    (FORMAT T ", with inherited instance variables: ")    (FORMAT:PRINT-LIST *STANDARD-OUTPUT* "~S" IIV))   (T (WRITE-CHAR #\. *STANDARD-OUTPUT*))))   (TERPRI *STANDARD-OUTPUT*))))  (LET ((STATE (LIST () ())))    (DOLIST (F (DONT-OPTIMIZE (SI:FLAVOR-DEPENDS-ON-ALL FL)))      (DESCRIBE-FLAVOR-1 F STATE FLAVOR)))  (DO ((PLIST (DONT-OPTIMIZE (SI:FLAVOR-PLIST FL)) (CDDR PLIST))       (FLAG NIL))      ((NULL PLIST))    (COND ((NOT (MEMBER (CAR PLIST) '(:DEFAULT-INIT-PLIST :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES):TEST #'EQ))   (COND ((NOT FLAG)  (FORMAT T "Random properties:~%")  (SETQ FLAG T)))   (FORMAT T "~5@T~S:~S~%" (CAR PLIST) (CADR PLIST)))))  ()) (DEFUN DESCRIBE-FLAVOR-1 (FLAVOR STATE TOP-FLAVOR-NAME &AUX FL (FLAVOR-FLAG NIL))  (COND ((NULL (SETQ FL (GET FLAVOR 'SI:FLAVOR))))((NOT (MEMBER FL (SECOND STATE) :TEST #'EQ)) (DO ((MTES (SORT (COPY-LIST (DONT-OPTIMIZE (SI:FLAVOR-METHOD-TABLE FL))) 'ALPHALESSP :KEY #'CAR)    (CDR MTES))      (MTE)      (ELEM)      (MSG)      (MSG-FLAG NIL NIL)      (TEM))     ((NULL MTES))   (SETQ MTE (CAR MTES) MSG (FIRST MTE) MTE (CDDDR MTE))   (OR (SETQ ELEM (ASSOC MSG (FIRST STATE) :TEST #'EQ))       (PUSH (SETQ ELEM (LIST MSG () ())) (FIRST STATE)))   (COND ((AND (SETQ TEM (SI:METH-LOOKUP MTE :BEFORE))       (SI:METH-DEFINEDP TEM)       (NOT (MEMBER TEM (SECOND ELEM) :TEST #'EQ)))  (MULTIPLE-VALUE-SETQ (FLAVOR-FLAG MSG-FLAG)       (DESCRIBE-FLAVOR-PRINT-MSG FL MSG (SI:METH-FUNCTION-SPEC TEM) "before"  MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME))  (PUSH TEM (SECOND ELEM))))   ;; This assumes the combination type is daemon.  Hard to check at this level.   (COND ((AND (SETQ TEM (SI:METH-LOOKUP MTE (QUOTE ())))       (SI:METH-DEFINEDP TEM)       (NULL (THIRD ELEM)))  (MULTIPLE-VALUE-SETQ (FLAVOR-FLAG MSG-FLAG)       (DESCRIBE-FLAVOR-PRINT-MSG FL MSG (SI:METH-FUNCTION-SPEC TEM) "primary"  MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME))  (SETF (THIRD ELEM) TEM)))   (COND ((AND (SETQ TEM (SI:METH-LOOKUP MTE :AFTER))       (SI:METH-DEFINEDP TEM)       (NOT (MEMBER TEM (SECOND ELEM) :TEST #'EQ)))  (MULTIPLE-VALUE-SETQ (FLAVOR-FLAG MSG-FLAG)       (DESCRIBE-FLAVOR-PRINT-MSG FL MSG (SI:METH-FUNCTION-SPEC TEM) "after"  MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME))  (PUSH TEM (SECOND ELEM))))   (COND ((AND (SETQ TEM (SI:METH-LOOKUP MTE :WRAPPER))       (SI:METH-DEFINEDP TEM)       (NOT (MEMBER TEM (SECOND ELEM) :TEST #'EQ)))  (MULTIPLE-VALUE-SETQ (FLAVOR-FLAG MSG-FLAG)       (DESCRIBE-FLAVOR-PRINT-MSG FL MSG (SI:METH-FUNCTION-SPEC TEM) "wrapper"  MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME))  (PUSH TEM (SECOND ELEM))));In case there are any other method types   (LOOP FOR TEM IN MTE UNLESS (MEMBER (SI:METH-METHOD-TYPE TEM)'(:BEFORE NIL :AFTER :WRAPPER :COMBINED) :TEST #'EQ) UNLESS (OR (NOT (SI:METH-DEFINEDP TEM))    (MEMBER TEM (SECOND ELEM) :TEST #'EQ)) DO (MULTIPLE-VALUE-SETQ (FLAVOR-FLAG MSG-FLAG) (DESCRIBE-FLAVOR-PRINT-MSG FL MSG (SI:METH-FUNCTION-SPEC TEM)    (STRING-DOWNCASE (SI:METH-METHOD-TYPE TEM)) MSG-FLAG    FLAVOR-FLAG TOP-FLAVOR-NAME)) (PUSH TEM (SECOND ELEM)))   (AND MSG-FLAG (TERPRI *STANDARD-OUTPUT*))) (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST     FL (SORT (COPY-LIST (DONT-OPTIMIZE (SI:FLAVOR-GETTABLE-INSTANCE-VARIABLES FL)))      'ALPHALESSP)     "automatically-generated methods to get instance variable"     "" FLAVOR-FLAG TOP-FLAVOR-NAME)) (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST     FL (SORT (COPY-LIST (DONT-OPTIMIZE (SI:FLAVOR-SETTABLE-INSTANCE-VARIABLES FL)))      'ALPHALESSP)     "automatically-generated methods to set instance variable"     "" FLAVOR-FLAG TOP-FLAVOR-NAME)) (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST     FL (SORT (MAPCAR #'CDR (DONT-OPTIMIZE (SI:FLAVOR-INITTABLE-INSTANCE-VARIABLES FL)))      'ALPHALESSP)     "instance variable"     " that may be set by initialization"     FLAVOR-FLAG TOP-FLAVOR-NAME)) (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST     FL (SORT (COPY-LIST (DONT-OPTIMIZE (SI:FLAVOR-INIT-KEYWORDS FL)))      'ALPHALESSP)     "keyword"     " in the :INIT message"     FLAVOR-FLAG TOP-FLAVOR-NAME)) (SETQ FLAVOR-FLAG (DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST     FL (SORT (COPY-LIST (SI:FLAVOR-GET FL :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES))      'ALPHALESSP)     "macros to access variable"     "" FLAVOR-FLAG TOP-FLAVOR-NAME)) (LET ((DEFAULT-PLIST (SI:FLAVOR-GET FL :DEFAULT-INIT-PLIST)))   (COND (DEFAULT-PLIST  (DESCRIBE-FLAVOR-PRINT-FLAVOR-NAME FL FLAVOR-FLAG TOP-FLAVOR-NAME)  (FORMAT T " Plus default init plist: ")  (DO ((L DEFAULT-PLIST (CDDR L))       (FLAG T NIL))      ((NULL L))    (FORMAT T "~:[, ~]~S ~S" FLAG (CAR L) (CADR L)))  (TERPRI *STANDARD-OUTPUT*)))) (PUSH FL (SECOND STATE))))  STATE) (DEFUN DESCRIBE-FLAVOR-PRINT-FLAVOR-NAME (FL FLAG TOP-FLAVOR-NAME &AUX FLAVOR-NAME)  (COND ((NOT FLAG)  ;If not already printed (SETQ FLAVOR-NAME (DONT-OPTIMIZE (SI:FLAVOR-NAME FL))) (FORMAT T "Method(s) ~:[inherited from~;of~] ~S:~%" (EQ FLAVOR-NAME TOP-FLAVOR-NAME) FLAVOR-NAME)))  T)      ;New value of flag(DEFUN DESCRIBE-FLAVOR-PRINT-MSG (FL MSG FUNCTION TYPE MSG-FLAG FLAVOR-FLAG TOP-FLAVOR-NAME)  ;; If method type is :CASE, mention suboperation too.  (IF (FIFTH FUNCTION)      (SETQ TYPE (WITH-OUTPUT-TO-STRING (*STANDARD-OUTPUT*)   (PRINC TYPE)   (PRINC " ")   (LET (*PACKAGE*)     (PRIN1 (FIFTH FUNCTION))))))  (DESCRIBE-FLAVOR-PRINT-FLAVOR-NAME FL FLAVOR-FLAG TOP-FLAVOR-NAME)  (IF MSG-FLAG      (PRINC ", ")      (PROGN(PRINC "   ")(COND ((EQUAL (SYMBOL-PACKAGE MSG) PKG-GLOBAL-PACKAGE)       (PRINC ":")       (PRIN1 MSG))      (T       (LET (*PACKAGE*) (PRIN1 MSG))))(PRINC " ")))  (WHEN (> (+ (LENGTH TYPE) (SEND *STANDARD-OUTPUT* :READ-CURSORPOS :CHARACTER))   (SEND *STANDARD-OUTPUT* :SIZE-IN-CHARACTERS))    (TERPRI)    (PRINC "     "))  (SEND *STANDARD-OUTPUT* :ITEM 'FUNCTION-NAME FUNCTION TYPE)  (VALUES T T)) ;New values for the flags(DEFUN DESCRIBE-FLAVOR-PRINT-MISCELLANEOUS-LIST (FL LIST STR1 STR2 FLAG TOP-FLAVOR-NAME)  (COND (LIST   ;If there is something there (DESCRIBE-FLAVOR-PRINT-FLAVOR-NAME FL FLAG TOP-FLAVOR-NAME) (FORMAT T " Plus ~A~P~A: ~{~<~%  ~2:;~:S~>~^, ~}~%" STR1 (LENGTH LIST) STR2 LIST) T);New value of the flag(T FLAG))) (W:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* FLAVOR-NAME "Edit" EDIT-DEFINITION-FOR-MOUSE T   "Edit the definition of this flavor.") (W:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* FLAVOR-NAME "Describe"   DESCRIBE-FLAVOR-INTERNAL () "Describe this flavor.") letions(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