LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032421. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "COMH" :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 2758716808. :AUTHOR "REL3" :LENGTH-IN-BYTES 19357. :LENGTH-IN-BLOCKS 19. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  ;;; -*- 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) 1985, 1987 Texas Instruments Incorporated. All rights reserved.;;; Copyright (C) 1980, Massachusetts Institute of Technology(DEFCOM COM-LISP-UPPERCASE-REGION   "Uppercase the region, but not strings, comments, etc.Characters preceded by slashes are also immune." ()  (REGION (BP1 BP2) (LISP-CHANGE-CASE T BP1 BP2)))   (DEFINE-COMMAND-SYNONYM COM-UPPERCASE-CODE-IN-REGION COM-LISP-UPPERCASE-REGION) (DEFCOM COM-LISP-LOWERCASE-REGION   "Lowercase the region, but not strings, comments, etc.Characters preceded by slashes are also immune." ()  (REGION (BP1 BP2) (LISP-CHANGE-CASE () BP1 BP2))) (DEFINE-COMMAND-SYNONYM COM-LOWERCASE-CODE-IN-REGION COM-LISP-LOWERCASE-REGION) (DEFCOM COM-LISP-UPPERCASE-BUFFER   "Uppercase the whole buffer, but not strings, comments, etc.Characters preceded by slashes are also immune." ()  (LISP-CHANGE-CASE T (INTERVAL-FIRST-BP *INTERVAL*) (INTERVAL-LAST-BP *INTERVAL*))) (DEFINE-COMMAND-SYNONYM COM-UPPERCASE-CODE-IN-BUFFER COM-LISP-UPPERCASE-BUFFER) (DEFCOM COM-LISP-LOWERCASE-BUFFER   "Lowercase the whole buffer, but not strings, comments, etc.Characters preceded by slashes are also immune." ()  (LISP-CHANGE-CASE () (INTERVAL-FIRST-BP *INTERVAL*) (INTERVAL-LAST-BP *INTERVAL*))) (DEFINE-COMMAND-SYNONYM COM-LOWERCASE-CODE-IN-BUFFER COM-LISP-LOWERCASE-BUFFER) (DEFUN LISP-CHANGE-CASE (UP-P BP1 BP2)  (WITH-UNDO-SAVE ((IF UP-P "Upcase" "Downcase") BP1 BP2 T)    (MULTIPLE-VALUE-BIND (STRING-P SLASHIFIED-P COMMENT-P) (LISP-BP-SYNTACTIC-CONTEXT BP1)      (DO ((BP (COPY-BP BP1) (IBP BP))   CH SYN   (START-BP (COPY-BP BP1)))  ((BP-= BP BP2)   (UNLESS (OR COMMENT-P STRING-P SLASHIFIED-P)     (LISP-CHANGE-CASE-IF-NECESSARY START-BP BP UP-P)))(SETQ CH (BP-CH-CHAR BP))(SETQ SYN (LIST-SYNTAX CH))(COND (COMMENT-P       (WHEN (= CH #\NEWLINE) (SETQ COMMENT-P ()) (MOVE-BP START-BP BP) (IBP START-BP)))      (SLASHIFIED-P       (SETQ SLASHIFIED-P ())       (MOVE-BP START-BP BP)       (IBP START-BP))      ((= SYN LIST-SLASH)       (SETQ SLASHIFIED-P BP)       (UNLESS STRING-P (LISP-CHANGE-CASE-IF-NECESSARY START-BP BP UP-P)))      (STRING-P       (WHEN (= CH STRING-P) (SETQ STRING-P ()) (MOVE-BP START-BP BP) (IBP START-BP)))      ((OR (= SYN LIST-COMMENT) (= SYN LIST-DOUBLE-QUOTE))       (IF (= SYN LIST-COMMENT)   (SETQ COMMENT-P T)   (SETQ STRING-P CH))       (LISP-CHANGE-CASE-IF-NECESSARY START-BP BP UP-P))))))  DIS-TEXT) (DEFUN LISP-CHANGE-CASE-IF-NECESSARY (START-BP BP UP-P)  (UNLESS (BP-= START-BP BP)    (IF UP-P(UPCASE-INTERVAL START-BP BP T)(DOWNCASE-INTERVAL START-BP BP T)))) (DEFCOM COM-COMMENT-OUT-REGION "Stick comment start characters at the start of each line in the region.Adds regardless of any that may already be there.A numeric argument specifies how many to add.A negative argument species how many to delete.An argument of C-U is treated like -1: it deletes single comment starts." ()   (IF (EQ *NUMERIC-ARG-P* :CONTROL-U)      (SETQ *NUMERIC-ARG* (TRUNCATE *NUMERIC-ARG* -4)))   (IF (> *NUMERIC-ARG* 0)       (REGION-LINES (START-LINE END-LINE) ;; Group the commenting into one item so it can all be done at once. ;; Done by rpm (from pf) on 9-22-86. (WITH-UNDO-SAVE ("Commenting" (POINT) (MARK))   (LET* ((LEN (LENGTH *COMMENT-BEGIN*))  (INSERT (MAKE-STRING (* *NUMERIC-ARG* LEN))))     (DOTIMES (I *NUMERIC-ARG*)       (COPY-ARRAY-PORTION *COMMENT-BEGIN* 0 LEN   INSERT (* I LEN) (+ (* I LEN) LEN)))     (DO ((LINE START-LINE (LINE-NEXT LINE))  (BP (CREATE-BP START-LINE 0))) ((EQ LINE END-LINE))       (MOVE-BP BP LINE 0)       (UNLESS (MEMBER (LINE-TYPE LINE) '(:BLANK) :TEST #'EQ) (INSERT BP INSERT)))     (RETURN-ARRAY INSERT))))       (PROGN (SETQ *NUMERIC-ARG* (- *NUMERIC-ARG*)) (COM-UNCOMMENT-OUT-REGION)))   DIS-TEXT) (DEFCOM COM-UNCOMMENT-OUT-REGION "Remove comment-start characters from the start of each line in the regionwhich begins with one. A numeric arg specifies how many to remove." ()  (REGION-LINES (START-LINE END-LINE)    ;; Group the commenting into one item so it can all be undone at once.    ;; Done by rpm (from pf) on 9-22-86.    (WITH-UNDO-SAVE ("Uncommenting" (POINT) (MARK))      (DO ((LINE START-LINE (LINE-NEXT LINE))   (BP (CREATE-BP START-LINE 0))   (BPA (CREATE-BP START-LINE 1)))  ((EQ LINE END-LINE))(DOTIMES (I *NUMERIC-ARG*)  (IF (OR (EQ (LINE-TYPE LINE) :BLANK)  (NOT (STRING-EQUAL LINE *COMMENT-BEGIN* :START1 0 :START2 0 :END1 (LENGTH *COMMENT-BEGIN*))))      (RETURN)      (PROGN(MOVE-BP BP LINE 0)(MOVE-BP BPA LINE (LENGTH *COMMENT-BEGIN*))(DELETE-INTERVAL BP BPA T)))))))  DIS-TEXT) ;;; Pattern finding stuff.(DEFCOM COM-LISP-MATCH-SEARCH "Move to next occurrence of the given pattern of Lisp code.In matching, differences in whitespace characters are ignoredexcept for characters that are quoted or inside strings.The character ? as an atom in the pattern matches any sexp in the buffer.The characters ?? as an atom in the pattern match any number of sexps.Patterns starting with infrequent characters such as open parenthesesare found much faster.  Those starting with common letters are likely to be slow.Patterns starting with very infrequent characters are fastest.A negative argument means search backwards.An empty pattern string means repeat the last pattern specified." ()  (LET ((FORM (TYPEIN-LINE-READLINE "Pattern to search for:")))    (COND ((EQUAL FORM "")   (SETQ FORM (OR *LAST-LISP-MATCH-SEARCH-STRING* (BARF "No previous pattern"))))  (T           (SETQ *LAST-LISP-MATCH-SEARCH-STRING* FORM)))    (FORMAT *QUERY-IO* "~&Finding ~S" FORM)    (LET ((BP (LISP-MATCH-SEARCH (POINT) FORM (MINUSP *NUMERIC-ARG*))))      (UNLESS BP (BARF))      (MAYBE-PUSH-POINT BP)      (MOVE-BP (POINT) BP)))  DIS-BPS) ;; Modified extensively by ap and rpm 9-86 to handle wildcards.(DEFUN LISP-MATCH-SEARCH (BP STRING &OPTIONAL REVERSEP FIXUP-P IGNORE LIMIT-BP  &AUX (START 0) (END (LENGTH STRING)))  "Search from BP for Lisp code that matches against STRING.Matching at any given place is done with LISP-STRING-BUFFER-MATCH.Differences in whitespace characters are ignored except when quoted or inside strings.The character ? as an atom in the STRING matches any sexp in the buffer.The characters ?? as an atom in the STRING match any number of sexps.If a match is found, the value is a bp to the end (start, if reverse) of the matching text.A second value, if it exists, is a bp to the start (end, if reverse) of the matching text.REVERSEP means search backward from BP; the code matched must end before BP. Otherwise, search goes forward from BP.LIMIT-BP is a place to stop searching; the matched code cannot continue past there in forward search or begin before there in backward search.FIXUP-P says what to do if no match is found. T means return the end of the range to be searched (either LIMIT-BP or the beginning or end of the interval). NIL means return NIL.  Second value is undefined in either case."  ;; Ignore leading delimiter chars in STRING.  (DO () ((NOT (= LIST-DELIMITER (LIST-SYNTAX (AREF STRING START)))))    (INCF START))  ;; Strings that start with ?? or ? are handled specially.  (COND ((AND (STRING-EQUAL STRING "??" :START1 START :START2 0 :END1 (+ START 2))      (OR (= (+ START 2) END)  (NOT (MEMBER (LIST-SYNTAX (AREF STRING (+ START 2)))                               '(#,LIST-ALPHABETIC #,LIST-SINGLE-QUOTE) :TEST #'EQUAL)))) (BARF "A search pattern that starts with ?? is not meaningful."))((AND (STRING-EQUAL STRING "?" :START1 START :START2 0 :END1 (+ START 1))              (NOT (MEMBER (LIST-SYNTAX (AREF STRING (+ START 1)))                           '(#,LIST-ALPHABETIC #,LIST-SINGLE-QUOTE) :TEST #'EQUAL))              REVERSEP)  (MULTIPLE-VALUE-BIND (BP1 BP2)             (LISP-MATCH-SEARCH BP                                (SUBSEQ (STRING STRING) (+ START 1))                                REVERSEP NIL NIL LIMIT-BP)           (VALUES (OR (IF BP1 (FORWARD-SEXP BP1 -1))                       (AND FIXUP-P LIMIT-BP))                   BP2)))        ((AND (STRING-EQUAL STRING "?" :START1 START :START2 0 :END1 (+ START 1))      (= (+ START 1) END)) (VALUES (FORWARD-SEXP BP 1) BP))        ((AND (STRING-EQUAL STRING "?" :START1 START :START2 0 :END1 (+ START 1))              (NOT (MEMBER (LIST-SYNTAX (AREF STRING (+ START 1)))                           '(#,LIST-ALPHABETIC #,LIST-SINGLE-QUOTE :TEST #'EQUAL))))         (MULTIPLE-VALUE-BIND (BP1 BP2)             (LISP-MATCH-SEARCH (FORWARD-SEXP BP 1)                                (SUBSEQ (STRING STRING) (+ START 1))                                REVERSEP NIL NIL LIMIT-BP)           (VALUES (OR BP1                       (AND FIXUP-P LIMIT-BP))                   (IF BP2 (FORWARD-SEXP BP2 -1)))))(REVERSEP (LET ((BP1 (COPY-BP BP))       (FINAL-LIMIT-BP (INTERVAL-FIRST-BP *INTERVAL*))       TEM)   (LOOP             (SETQ BP1 (SEARCH BP1 (AREF STRING START) T NIL NIL                               (OR LIMIT-BP FINAL-LIMIT-BP)))             (UNLESS BP1 (RETURN (IF FIXUP-P (OR LIMIT-BP FINAL-LIMIT-BP) NIL)))             (IF (SETQ TEM (LISP-STRING-BUFFER-MATCH BP1 BP STRING START))                 (RETURN BP1 TEM)))))(T (LET ((BP1 (COPY-BP BP))       (FINAL-LIMIT-BP (INTERVAL-LAST-BP *INTERVAL*))       TEM)   (LOOP             (SETQ BP1 (DBP (SEARCH BP1 (AREF STRING START) NIL T NIL LIMIT-BP)))             (IF (SETQ TEM (LISP-STRING-BUFFER-MATCH BP1 (OR LIMIT-BP FINAL-LIMIT-BP) STRING START))                 (RETURN TEM BP1))             (IBP BP1)             (IF (OR (BP-= BP1 LIMIT-BP) (BP-= BP1 FINAL-LIMIT-BP))                 (RETURN (IF FIXUP-P BP1)))))))) ;; Modified extensively by ap and rpm 9-86 to handle wildcards.(DEFUN LISP-STRING-BUFFER-MATCH (START-BP LIMIT-BP PATTERN-STRING &OPTIONAL (START 0) END)  "Match part of a string against part of an editor buffer, comparing as Lisp code.The string is PATTERN-STRING; START and END specify the range to use.The buffer text starts at START-BP.  It will not match past LIMIT-BP.If there is a match, the value is a bp to the end of the buffer text matched.Otherwise, the value is NIL.Differences in whitespace characters are ignored except when quoted or inside strings.The character ? as an atom in the PATTERN-STRING matches any sexp in the buffer.The characters ?? as an atom in the PATTERN-STRING match any number of sexps."  (UNLESS END (SETQ END (LENGTH PATTERN-STRING)))  (BLOCK OUTER    (DO ((I START (1+ I))         (BP (COPY-BP START-BP))         IN-STRING QUOTED IN-COMMENT IN-ATOM         (P-SYN -1))        ((= I END) BP)      (IF (NOT (BP-< BP LIMIT-BP))          (RETURN NIL))      (LET* ((S-CHAR (AREF PATTERN-STRING I))             (S-SYN (LIST-SYNTAX S-CHAR)))        ;; S-SYN is this pattern character's syntax.        ;; P-SYN is the previous significant pattern character's syntax.        ;; It is LIST-ALPHABETIC iff the last pattern character, not counting delimiters,        ;;   was such as to be part of an atom.  This is the case in which        ;;   at least one delimiter is required in the buffer in order to match.        (COND (IN-STRING               ;; First update the syntactic state.               (COND (QUOTED                      (SETQ QUOTED NIL))                     ((= S-SYN LIST-DOUBLE-QUOTE)                      (SETQ IN-STRING NIL))                     ((= S-SYN LIST-SLASH)                      (SETQ QUOTED T)))               ;; Now always match against buffer.               (UNLESS (CHAR= S-CHAR (BP-CHAR BP))                 (RETURN NIL))               (SETQ P-SYN -1)               (IBP BP))              (IN-COMMENT               (IF (CHAR= S-CHAR #\NEWLINE)                   (SETQ IN-COMMENT NIL))               ;; Now always match against buffer.               (UNLESS (CHAR-EQUAL S-CHAR (BP-CHAR BP))                 (RETURN NIL))               (SETQ P-SYN -1)               (IBP BP))              (QUOTED               (SETQ QUOTED NIL)               ;; Quoted char, always match against buffer.               (UNLESS (CHAR= S-CHAR (BP-CHAR BP))                 (RETURN NIL))               (SETQ P-SYN LIST-ALPHABETIC)               (IBP BP))              ;; Not in string or comment, not slashified.              ((= S-SYN LIST-DELIMITER)               ;; Just skip all delimiters in the pattern.               (SETQ IN-ATOM NIL))              ((AND (NOT IN-ATOM)                    (<= (+ I 2) END)                    (STRING-EQUAL PATTERN-STRING "??" :START1 I :START2 0 :END1 (+ I 2))                    (OR (= (+ I 2) END)                        (NOT (MEMBER (LIST-SYNTAX (AREF PATTERN-STRING (+ I 2)))                                     '(#,LIST-ALPHABETIC #,LIST-SINGLE-QUOTE) :TEST #'EQUAL))))               ;; "??" has been encountered, and it is an atom by itself.               (LOOP                 ;; Try matching the rest of the pattern at one spot.                 (LET ((TEM (LISP-STRING-BUFFER-MATCH BP LIMIT-BP PATTERN-STRING (+ I 2) END)))                   (WHEN TEM                     (RETURN-FROM OUTER TEM)))                 ;; Skip one more sexp and try again.                 (SETQ BP (FORWARD-SEXP BP 1 NIL 0 LIMIT-BP NIL T))                 (UNLESS BP (RETURN-FROM OUTER NIL))))              ((AND (NOT IN-ATOM)                    (<= (+ I 1) END)                    (STRING-EQUAL PATTERN-STRING "?" :START1 I :START2 0 :END1 (+ I 1))                    (OR (= (+ I 1) END)                        (NOT (MEMBER (LIST-SYNTAX (AREF PATTERN-STRING (+ I 1)))                                     '(#,LIST-ALPHABETIC #,LIST-SINGLE-QUOTE) :TEST #'EQUAL))))               ;; "?" has been encountered as an atom in the pattern.               ;; Skip it, and skip one sexp in the buffer, then keep matching.               (SETQ BP (FORWARD-SEXP BP 1 NIL 0 LIMIT-BP NIL T))               (SETQ P-SYN -1)               (UNLESS BP (RETURN NIL)))              (T               ;; Skip all delimiters here in the buffer, if not within an atom.               (UNLESS IN-ATOM                 (DO ((COUNT 0 (1+ COUNT)))     ;Count number of delimiters skipped.                     ((NOT (= LIST-DELIMITER (LIST-SYNTAX (BP-CHAR BP))))                      (AND (ZEROP COUNT)                           (= S-SYN LIST-ALPHABETIC)                           (= P-SYN LIST-ALPHABETIC)                           (RETURN-FROM OUTER NIL)))                   (IBP BP)))               ;; Set up syntax context of next pattern character.               (SELECT S-SYN                 (LIST-DOUBLE-QUOTE                  (SETQ IN-STRING T))                 (LIST-SLASH                  (SETQ QUOTED T))                 (LIST-COMMENT                  (SETQ IN-COMMENT T))                 (LIST-ALPHABETIC                  (SETQ IN-ATOM T))                 (LIST-OPEN                  (SETQ IN-ATOM NIL))                 (LIST-CLOSE                  (SETQ IN-ATOM NIL)))               (IF (CHAR= S-CHAR #\.)                   (SETQ IN-ATOM T))               ;; Now always match against buffer.               (UNLESS (CHAR-EQUAL S-CHAR (BP-CHAR BP))                 (RETURN NIL))               (IBP BP)               (SETQ P-SYN S-SYN))))))) ;;; Some random file viewing commands(DEFCOM COM-VIEW-DIRECTORY   "List contents of a file directory.While viewing, you can use Space and Control-V to scroll forwardand Meta-V to scroll backward.  Type End, Abort, or Rubout to exit." ()   (LET ((PATHNAME (READ-DIRECTORY-NAME "View directory" (DEFAULT-PATHNAME))))     (VIEW-DIRECTORY PATHNAME))) (DEFCOM COM-VIEW-LOGIN-DIRECTORY "List files in user's home directory." ()   (VIEW-DIRECTORY    (SEND (FS:USER-HOMEDIR) :NEW-PATHNAME :NAME :WILD :TYPE :WILD :VERSION :WILD))) (DEFUN NEW-MAIL-EXISTS-P ()  ;Perhaps args for machines or user to check for.  "Return T if there is new mail, otherwise return NIL."  (PROBE-FILE (SEND (FS:USER-HOMEDIR) :NEW-MAIL-PATHNAME))) (DEFCOM COM-VIEW-MAIL  "View any new mail (your inbox file).While viewing, you can use Space and Control-V to scroll forwardand Meta-V to scroll backward.  Type End, Abort, or Rubout to exit." ()  (LET ((PATHNAME (SEND (FS:USER-HOMEDIR) :SEND-IF-HANDLES :NEW-MAIL-PATHNAME)))    (COND ((NULL PATHNAME)   (FORMAT *QUERY-IO* "Your home directory doesn't handle mail in a known way."))  ((PROBE-FILE PATHNAME)   (VIEW-FILE PATHNAME))  (T   (FORMAT *QUERY-IO* "~&No new mail."))))  DIS-NONE) (DEFCOM COM-VIEW-OLD-MAIL "View old mail (your BABYL file, etc.).While viewing, you can use Space and Control-V to scroll forwardand Meta-V to scroll backward.  Type End, Abort, or Rubout to exit." ()  (LET ((PATHNAME-LIST (SEND (FS:USER-HOMEDIR) :SEND-IF-HANDLES :POSSIBLE-MAIL-FILE-NAMES)))    (IF (NULL PATHNAME-LIST)(FORMAT *QUERY-IO* "Your home directory doesn't handle old mail in a known way.")(LOOP FOR MAIL-FILE IN PATHNAME-LIST      WHEN (NOT (ERRORP (OPEN MAIL-FILE :CHARACTERS NIL :DIRECTION NIL :ERROR NIL)))      DO (VIEW-FILE MAIL-FILE) (SETQ MAIL-FILE :FOUND) (LOOP-FINISH)      FINALLY (IF (NOT (STRING-EQUAL MAIL-FILE :FOUND)) (FORMAT *QUERY-IO* "~&No old mail.")))))  DIS-NONE)(DEFUN STRING-STRIP-CHARS (CHAR-SET LINE &OPTIONAL (DELETE-LENGTH 1))  "COPIES line removing delete-length chars. beginning at each element of char-set,or at least up to next member of char-set found"  (DO (DEL-INDEX       (HEAD "")       (TAIL LINE)       FOUND-INDEX)      ((= (LENGTH TAIL) 0)       HEAD)    (SETQ FOUND-INDEX (OR (STRING-SEARCH-SET CHAR-SET TAIL) (LENGTH TAIL)))    (SETQ HEAD (STRING-APPEND HEAD (SUBSEQ TAIL 0 FOUND-INDEX)))    (SETQ DEL-INDEX (MIN (+ DELETE-LENGTH FOUND-INDEX) (OR (STRING-SEARCH-SET CHAR-SET TAIL (1+ FOUND-INDEX))     (LENGTH TAIL))))    (SETQ TAIL (SUBSEQ TAIL DEL-INDEX)))) ;;;Move this to the defsystem.;;;(GLOBALIZE "STRING-STRIP-CHARS") (DEFUN STRING-REPLACE-KEY (WAS WILL-BE STRING-IN;nice but not used here.   &OPTIONAL (FROM 0) (TO (LENGTH STRING-IN)))  "Replaces occurances of WAS with WILL-BE in STRING-IN between FROM and TO (TO non-inclusive)which default to 0. and the string length respectively."  (STRING-APPEND    (DO ((STRING (SUBSEQ STRING-IN FROM TO) (SUBSEQ STRING (+ INDEX (LENGTH (STRING WAS))))) (RESULT (SUBSEQ STRING-IN 0 FROM) (STRING-APPEND RESULT (SUBSEQ STRING 0 INDEX) (STRING WILL-BE))) INDEX)((NOT (SETQ INDEX (LISP:SEARCH (STRING WAS) (STRING STRING) :TEST #'CHAR-EQUAL))) (STRING-APPEND RESULT STRING)))    (SUBSEQ STRING-IN TO (LENGTH STRING-IN)))) ;;;Move this to the defsystem.;;;(GLOBALIZE "STRING-REPLACE-KEY")  END *STANDARD-OUTPUT* :ITEM-LIST 'FLAVOR-NAME TEM)))  (IF (NULL (DONT-OPTIMIZE (SI:FLAVOR-DEPENDS-