;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*- ;;; Patch file for System version 78.18 ;;; Reason: Minor improvements to a few output formats. ;;; Written 12/17/81 00:54:55 by dlw, ;;; while running on Lisp Machine Eighteen from band 3 ;;; with System 78.17, ZMail 38.2, Local-File 30.3, microcode 836. ; From file WHOLIN > LMWIN; AI: #8R TV:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TV"))) (DEFMETHOD (WHO-LINE-FILE-SHEET :UPDATE) (&AUX (MAX-CHARS (// (SHEET-INSIDE-WIDTH) CHAR-WIDTH)) IDLE STRING) (COND (CURRENT-STREAM (LET ((OLD-STREAM WHO-LINE-ITEM-STATE) (PATHNAME) (DIRECTION) (PERCENT) (COUNT) (FILE-NAME) (SP-POS) (FNTRUNC)) (MULTIPLE-VALUE (PATHNAME DIRECTION COUNT PERCENT) (FUNCALL CURRENT-STREAM ':WHO-LINE-INFORMATION)) (SHEET-HOME SELF) (COND ((AND (EQ OLD-STREAM CURRENT-STREAM) (EQ PERCENT DISPLAYED-PERCENT) (EQ COUNT DISPLAYED-COUNT))) (T (OR (EQ OLD-STREAM CURRENT-STREAM) (SHEET-CLEAR-EOL SELF)) (SETQ WHO-LINE-ITEM-STATE CURRENT-STREAM DISPLAYED-PERCENT PERCENT DISPLAYED-COUNT COUNT) (SHEET-STRING-OUT SELF (SELECTQ DIRECTION (:INPUT " ") (:OUTPUT " ") (:BIDIRECTIONAL " "))) (SETQ FILE-NAME (FUNCALL PATHNAME ':STRING-FOR-WHOLINE)) (AND ( (STRING-LENGTH FILE-NAME) (- MAX-CHARS 4)) ;; If not enough room for filename, then truncate (SETQ FNTRUNC (- MAX-CHARS 7))) (SHEET-STRING-OUT SELF FILE-NAME 0 FNTRUNC) (SHEET-STRING-OUT SELF (IF FNTRUNC " " " ")) (SETQ SP-POS (+ 4 (OR FNTRUNC (STRING-LENGTH FILE-NAME)))) (SHEET-CLEAR-EOL SELF) (COND ((AND PERCENT ( (+ SP-POS (STRING-LENGTH (SETQ STRING (FORMAT NIL "~D% ~D" PERCENT COUNT)))) MAX-CHARS))) (PERCENT (WITHOUT-INTERRUPTS (RETURN-ARRAY STRING) (SETQ STRING (FORMAT NIL "~D%" PERCENT)))) (T (WITHOUT-INTERRUPTS (AND STRING (RETURN-ARRAY STRING)) (SETQ STRING (FORMAT NIL "~D" COUNT))))) (SHEET-STRING-OUT SELF STRING 0 (MIN (- MAX-CHARS SP-POS) (STRING-LENGTH STRING))) (WITHOUT-INTERRUPTS (RETURN-ARRAY STRING) (SETQ STRING NIL)))))) ((AND (NOT (NULL SERVERS-LIST)) (PROGN (PURGE-SERVERS) (NOT (NULL SERVERS-LIST)))) (COND ((= (LENGTH SERVERS-LIST) 1) (COND ((NEQ WHO-LINE-ITEM-STATE (CAAR SERVERS-LIST)) (SHEET-HOME SELF) (SHEET-CLEAR-EOL SELF) (SETQ STRING (FORMAT NIL "~A serving ~A" (CADDAR SERVERS-LIST) (CADAR SERVERS-LIST))) (SHEET-STRING-OUT SELF STRING 0 (MIN (STRING-LENGTH STRING) MAX-CHARS)) (RETURN-ARRAY (PROG1 STRING (SETQ STRING NIL))) (SETQ WHO-LINE-ITEM-STATE (CAAR SERVERS-LIST))))) ((NEQ WHO-LINE-ITEM-STATE (LENGTH SERVERS-LIST)) (SHEET-HOME SELF) (SHEET-HOME SELF) (SHEET-CLEAR-EOL SELF) (SETQ STRING (FORMAT NIL "~D Active Servers" (LENGTH SERVERS-LIST))) (SHEET-STRING-OUT SELF STRING 0 (MIN (STRING-LENGTH STRING) MAX-CHARS)) (RETURN-ARRAY (PROG1 STRING (SETQ STRING NIL))) (SETQ WHO-LINE-ITEM-STATE (LENGTH SERVERS-LIST))))) (SI:WHO-LINE-JUST-COLD-BOOTED-P (COND ((NEQ WHO-LINE-ITEM-STATE 'COLD) (SHEET-CLEAR SELF) (SETQ WHO-LINE-ITEM-STATE 'COLD) (SHEET-STRING-OUT SELF "Cold-booted")))) ((> (SETQ IDLE (// (TIME-DIFFERENCE (TIME) TV:KBD-LAST-ACTIVITY-TIME) 3600.)) 4) ;Display keyboard idle time (LET ((OLD-IDLE WHO-LINE-ITEM-STATE)) (COND ((OR (NOT (NUMBERP OLD-IDLE)) ( OLD-IDLE IDLE)) (SHEET-CLEAR SELF) (WITHOUT-INTERRUPTS (LET ((STRING (MAKE-IDLE-MESSAGE IDLE))) (SHEET-STRING-OUT SELF STRING) (RETURN-ARRAY STRING))) (SETQ WHO-LINE-ITEM-STATE IDLE))))) ((NEQ WHO-LINE-ITEM-STATE 'NULL) (SHEET-CLEAR SELF) (SETQ WHO-LINE-ITEM-STATE 'NULL)))) ) ; From file WHOLIN > LMWIN; AI: #8R TV:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "TV"))) (DEFUN MAKE-IDLE-MESSAGE (MINUTES) (COND ((< MINUTES 60.) (FORMAT NIL "Console idle ~D minute~:P" MINUTES)) (T (LET ((HOURS (// MINUTES 60.))) (FORMAT NIL "Console idle ~D hr ~D min~:P" HOURS (- MINUTES (* 60. HOURS))))))) ) ; From file FORMAT > LMIO; AI: #8R FORMAT:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "FORMAT"))) (DEFUN FORMAT-CTL-CHARACTER (ARG IGNORE &AUX CHNAME BITS) (SETQ ARG (CHARACTER ARG)) (COND ((LDB-TEST %%KBD-MOUSE ARG) (COND ((AND (NOT COLON-FLAG) ATSIGN-FLAG) (OR (SETQ CHNAME (FORMAT-GET-CHARACTER-NAME ARG)) (FORMAT-ERROR "~O unknown mouse character given to ~~@C" ARG)) (FUNCALL STANDARD-OUTPUT ':STRING-OUT "#\") (PRIN1 CHNAME)) (T (SETQ BITS (LDB %%KBD-CONTROL-META ARG)) (AND (BIT-TEST 8 BITS) (FUNCALL STANDARD-OUTPUT ':STRING-OUT "Hyper-")) (AND (BIT-TEST 4 BITS) (FUNCALL STANDARD-OUTPUT ':STRING-OUT "Super-")) (AND (BIT-TEST 1 BITS) (FUNCALL STANDARD-OUTPUT ':STRING-OUT "Control-")) (AND (BIT-TEST 2 BITS) (FUNCALL STANDARD-OUTPUT ':STRING-OUT "Meta-")) (FUNCALL STANDARD-OUTPUT ':STRING-OUT "Mouse-") (FUNCALL STANDARD-OUTPUT ':STRING-OUT (NTH (LDB 0003 ARG) '("Left" "Middle" "Right"))) (IF (SETQ CHNAME (NTH (SETQ BITS (LDB 0303 ARG)) '("" "-Twice" "-Thrice"))) (FUNCALL STANDARD-OUTPUT ':STRING-OUT CHNAME) (FUNCALL STANDARD-OUTPUT ':TYO #/-) (ENGLISH-PRINT (1+ BITS)) (FUNCALL STANDARD-OUTPUT ':STRING-OUT "-times"))))) ((NOT COLON-FLAG) (AND ATSIGN-FLAG (FUNCALL STANDARD-OUTPUT ':TYO #/#)) (SETQ BITS (LDB %%KBD-CONTROL-META ARG)) (IF (NOT (ZEROP BITS)) ;; For efficiency, don't send :string-out message just for null string. (FUNCALL STANDARD-OUTPUT ':STRING-OUT (NTH BITS '("" "c-" "m-" "c-m-" "s-" "c-s-" "m-s-" "c-m-s-" "h-" "c-h-" "m-h-" "c-m-h-" "s-h-" "c-s-h-" "m-s-h-" "c-m-s-h-")))) (COND ((AND ATSIGN-FLAG (SETQ CHNAME (FORMAT-GET-CHARACTER-NAME (LDB %%KBD-CHAR ARG)))) (FUNCALL STANDARD-OUTPUT ':TYO #/\) (PRIN1 CHNAME)) (T (COND (ATSIGN-FLAG (FUNCALL STANDARD-OUTPUT ':TYO #//)) ((MEMQ ARG '(#/ #/ #/ #/ #/ #/)) (FUNCALL STANDARD-OUTPUT ':TYO #/))) (FUNCALL STANDARD-OUTPUT ':TYO (LDB %%KBD-CHAR ARG))))) (T (SETQ BITS (LDB %%KBD-CONTROL-META ARG)) (AND (BIT-TEST 8 BITS) (FUNCALL STANDARD-OUTPUT ':STRING-OUT "Hyper-")) (AND (BIT-TEST 4 BITS) (FUNCALL STANDARD-OUTPUT ':STRING-OUT "Super-")) (AND (BIT-TEST 1 BITS) (FUNCALL STANDARD-OUTPUT ':STRING-OUT "Control-")) (AND (BIT-TEST 2 BITS) (FUNCALL STANDARD-OUTPUT ':STRING-OUT "Meta-")) (SETQ ARG (LDB %%KBD-CHAR ARG)) (COND ((SETQ CHNAME (FORMAT-GET-CHARACTER-NAME ARG)) (LET ((DEFAULT-CONS-AREA FORMAT-TEMPORARY-AREA)) (LET ((STR (STRING-DOWNCASE CHNAME))) (ASET (CHAR-UPCASE (AREF STR 0)) STR 0) (FUNCALL STANDARD-OUTPUT ':STRING-OUT STR) (RETURN-ARRAY STR))) (AND ATSIGN-FLAG (FORMAT-PRINT-TOP-CHARACTER ARG))) ((AND ATSIGN-FLAG (< ARG 40) ( ARG #/)) (FUNCALL STANDARD-OUTPUT ':TYO ARG) (FORMAT-PRINT-TOP-CHARACTER ARG)) (T (FUNCALL STANDARD-OUTPUT ':TYO ARG)))))) ) ; From file COMD > ZWEI; AI: #8R ZWEI:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI"))) (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) (AND INITIAL-COMPLETE (MULTIPLE-VALUE (CONTENTS NIL NIL NIL CHAR-POS) (COMPLETE-STRING "" *COMPLETING-ALIST* *COMPLETING-DELIMS* T 0))) (EDIT-IN-MINI-BUFFER *COMPLETING-READER-COMTAB* CONTENTS CHAR-POS (IF PROMPT `(,PROMPT (:RIGHT-FLUSH " (Completion)")) '(:RIGHT-FLUSH " (Completion)")))) ) ; From file FILES > ZWEI; AI: #8R ZWEI:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI"))) (DEFUN READ-DEFAULTED-PATHNAME (PROMPT *READING-PATHNAME-DEFAULTS* &OPTIONAL *READING-PATHNAME-SPECIAL-TYPE* *READING-PATHNAME-SPECIAL-VERSION* (*READING-PATHNAME-DIRECTION* ':READ) (MERGE-IN-SPECIAL-VERSION T) &AUX (SPECIAL-VERSION *READING-PATHNAME-SPECIAL-VERSION*)) (SETQ PROMPT (FORMAT NIL "~A (Default is ~A)" PROMPT (FS:DEFAULT-PATHNAME *READING-PATHNAME-DEFAULTS* NIL *READING-PATHNAME-SPECIAL-TYPE* *READING-PATHNAME-SPECIAL-VERSION*))) ;; MERGE-IN-SPECIAL-VERSION is for the case of wanting the default to have :OLDEST, but ;; not having pathnames typed in keeping to this. (AND (NOT MERGE-IN-SPECIAL-VERSION) (SETQ *READING-PATHNAME-SPECIAL-VERSION* NIL)) ;Don't complete from this (TEMP-KILL-RING *LAST-FILE-NAME-TYPED* (MULTIPLE-VALUE-BIND (NIL NIL INTERVAL) (EDIT-IN-MINI-BUFFER *PATHNAME-READING-COMTAB* NIL NIL (LIST PROMPT '(:RIGHT-FLUSH " (Completion)"))) (MAKE-DEFAULTED-PATHNAME (STRING-INTERVAL INTERVAL) *READING-PATHNAME-DEFAULTS* *READING-PATHNAME-SPECIAL-TYPE* SPECIAL-VERSION MERGE-IN-SPECIAL-VERSION)))) ) ; From file SEARCH > ZWEI; AI: #8R ZWEI:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI"))) (DEFUN GET-EXTENDED-SEARCH-STRINGS (*SEARCH-MINI-BUFFER-NAME* &AUX STR STRINGS EXPR CR-P FUNCTION) (DECLARE (RETURN-LIST FUNCTION ARG)) (LET ((*MINI-BUFFER-WINDOW* (GET-SEARCH-MINI-BUFFER-WINDOW))) (EDIT-IN-MINI-BUFFER *SEARCH-MINI-BUFFER-COMTAB* NIL NIL '(*SEARCH-MINI-BUFFER-NAME* (:RIGHT-FLUSH " (Extended search characters)")))) (SETQ STR (SEARCH-MINI-BUFFER-STRING-INTERVAL)) (MULTIPLE-VALUE (STRINGS EXPR CR-P) (PARSE-EXTENDED-SEARCH-STRING STR)) (IF (OR (LISTP STRINGS) CR-P) (SETQ FUNCTION 'FSM-STRING-SEARCH STRINGS (LIST (IF (LISTP STRINGS) STRINGS (NCONS STRINGS)) EXPR CR-P)) (SETQ FUNCTION 'STRING-SEARCH)) (VALUES FUNCTION STRINGS STR)) ) ; From file SEARCH > ZWEI; AI: #8R ZWEI:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI"))) ;;; Read a string for string search and then return the function to use (DEFUN GET-EXTENDED-STRING-SEARCH-STRINGS (&OPTIONAL *EXTENDED-STRING-SEARCH-REVERSE-P* (*SEARCH-MINI-BUFFER-NAME* "Search:") (COMTAB *STRING-SEARCH-MINI-BUFFER-COMTAB*) &AUX (*EXTENDED-STRING-SEARCH-BJ-P* NIL) (*EXTENDED-STRING-SEARCH-ZJ-P* NIL) (*EXTENDED-STRING-SEARCH-TOP-LINE-P* NIL) STRINGS EXPR CR-P FUNCTION) (DECLARE (RETURN-LIST FUNCTION ARG REVERSE-P BJ-P TOP-LINE-P)) (LET ((*MINI-BUFFER-WINDOW* (GET-SEARCH-MINI-BUFFER-WINDOW))) (EDIT-IN-MINI-BUFFER COMTAB NIL NIL '((*EXTENDED-STRING-SEARCH-BJ-P* "BJ ") (*EXTENDED-STRING-SEARCH-ZJ-P* "ZJ ") (*EXTENDED-STRING-SEARCH-REVERSE-P* "Reverse ") (*EXTENDED-STRING-SEARCH-TOP-LINE-P* "Top line ") *SEARCH-MINI-BUFFER-NAME* (:RIGHT-FLUSH " (Extended search characters)")))) (MULTIPLE-VALUE (STRINGS EXPR CR-P) (PARSE-EXTENDED-SEARCH-STRING)) (IF (LISTP STRINGS) (IF EXPR (SETQ FUNCTION 'FSM-SEARCH-WITHIN-LINES STRINGS (LIST STRINGS EXPR CR-P)) (SETQ FUNCTION 'FSM-SEARCH)) (SETQ FUNCTION 'SEARCH)) (VALUES FUNCTION STRINGS *EXTENDED-STRING-SEARCH-REVERSE-P* (OR *EXTENDED-STRING-SEARCH-BJ-P* *EXTENDED-STRING-SEARCH-ZJ-P*) *EXTENDED-STRING-SEARCH-TOP-LINE-P*)) ) ; From file SEARCH > ZWEI; AI: #8R ZWEI:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI"))) ;;; Return a string itself, suitable for printing and reading back (DEFUN GET-EXTENDED-SEARCH-16B-STRING (*SEARCH-MINI-BUFFER-NAME*) (LET ((*MINI-BUFFER-WINDOW* (GET-SEARCH-MINI-BUFFER-WINDOW))) (EDIT-IN-MINI-BUFFER *SEARCH-MINI-BUFFER-COMTAB* NIL NIL '(*SEARCH-MINI-BUFFER-NAME* (:RIGHT-FLUSH " (Extended search characters)")))) (SEARCH-MINI-BUFFER-STRING-INTERVAL)) )