;;; -*- Mode:LISP; Package:TV; Readtable:CL; Base:10; Patch-file: T -*- (DEFMACRO WITH-WHOSTATE (WHOSTATE &BODY BODY) (LET ((^OLD-WHOSTATE (COMPILER:GENSYMBOL "OLD-WHOSTATE")) (^WHOSTATE (COMPILER:GENSYMBOL "WHOSTATE"))) `(LET ((,^OLD-WHOSTATE (SI:PROCESS-RUN-WHOSTATE SI:CURRENT-PROCESS)) (,^WHOSTATE ,WHOSTATE)) (UNWIND-PROTECT (PROGN (SETF (SI:PROCESS-RUN-WHOSTATE SI:CURRENT-PROCESS) ,WHOSTATE) ,@BODY) (SETF (SI:PROCESS-RUN-WHOSTATE SI:CURRENT-PROCESS) ,^OLD-WHOSTATE))))) (DEFVAR *WHOLINE-DOCUMENTATION-FONT*) (DEFVAR *WHOSTATE-AWAITING-KEYBOARD-INPUT* "TYPEIN") (DEFUN KBD-PROCESS-MAIN-LOOP () "This function runs in the keyboard process. It is responsible for reading characters from the hardware, and performing any immediate processing associated with the character." (ERROR-RESTART-LOOP ((SYS:ABORT ERROR) "Return to top level of KBD-PROCESS.") (IO-BUFFER-CLEAR KBD-IO-BUFFER) (SETQ KBD-ESC-HAPPENED NIL) (DO-FOREVER (PROCESS-WAIT *whostate-awaiting-keyboard-input* #'(LAMBDA () (OR KBD-ESC-HAPPENED (AND (NOT COLD-LOAD-STREAM-OWNS-KEYBOARD) (NOT (IO-BUFFER-FULL-P KBD-IO-BUFFER)) (KBD-HARDWARE-CHAR-AVAILABLE))))) (WHEN KBD-ESC-HAPPENED (APPLY (CADR KBD-ESC-HAPPENED) (CAR KBD-ESC-HAPPENED) SELECTED-WINDOW (CDDR KBD-ESC-HAPPENED)) (PROCESS-WAIT-WITH-TIMEOUT "ESC Finish" 600. ;wait at most 10 sec #'(LAMBDA () (NULL KBD-ESC-TIME))) (SETQ KBD-ESC-HAPPENED NIL)) (KBD-PROCESS-MAIN-LOOP-INTERNAL)))) (DEFVAR *SHOW-CURRENT-PROCESS-IN-WHOLINE* T) (DEFUN WHO-LINE-USER-OR-PROCESS (WHO-SHEET) (LET (( (WHO-LINE-STRING WHO-SHEET (COND (WHO-LINE-PROCESS (PROCESS-NAME WHO-LINE-PROCESS)) (*SHOW-CURRENT-PROCESS-IN-WHOLINE* "Current") (T SI:USER-ID)))) (setq last-who-line-process (or who-line-process (and selected-io-buffer (io-buffer-last-output-process selected-io-buffer)))) (when last-who-line-process ;--- Sometimes this gets bashed, messing up SG below? (let* ((sg (process-stack-group last-who-line-process)) (pkg (cond ((eq sg %current-stack-group) *package*) ((typep sg 'stack-group) (symeval-in-stack-group '*package* sg)) (t package))) (rdtbl (cond ((eq sg %current-stack-group) *readtable*) (DEFUN LAST-CURRENT-PROCESS () (AND SELECTED-IO-BUFFER (IO-BUFFER-LAST-OUTPUT-PROCESS SELECTED-IO-BUFFER))) ;If the selected window or who-line-process is in the RUN state, ; if (DEFUN OLD-NWATCH-WHO-FUNCTION (WHO-SHEET &AUX LEFTX) (DECLARE (:SELF-FLAVOR WHO-LINE-SHEET)) (OR WHO-LINE-EXTRA-STATE (LET ((DEFAULT-CONS-AREA WHO-LINE-AREA)) (SETQ WHO-LINE-EXTRA-STATE (STRING-APPEND "MM/DD/YY HH:MM:SS")))) ; Errgghhh! Krazy Backwards Amerikan dates. (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR) (TIME:GET-TIME) (COND ((NULL SECONDS) (SHEET-CLEAR WHO-SHEET) (COPY-ARRAY-CONTENTS "MM/DD/YY HH:MM:SS" WHO-LINE-EXTRA-STATE)) (T (SETQ YEAR (MOD YEAR 100.)) (SETQ LEFTX (MIN (NWATCH-N MONTH WHO-LINE-EXTRA-STATE 0) (NWATCH-N DAY WHO-LINE-EXTRA-STATE 3) (NWATCH-N YEAR WHO-LINE-EXTRA-STATE 6) (NWATCH-N HOURS WHO-LINE-EXTRA-STATE 9) (NWATCH-N MINUTES WHO-LINE-EXTRA-STATE 12.) (NWATCH-N SECONDS WHO-LINE-EXTRA-STATE 15.))) (UNLESS WHO-LINE-ITEM-STATE (SETQ LEFTX 0)) ;was clobbered, redisplay all (SHEET-SET-CURSORPOS WHO-SHEET (* LEFTX CHAR-WIDTH) 0) (SHEET-CLEAR-EOL WHO-SHEET) (SHEET-STRING-OUT WHO-SHEET WHO-LINE-EXTRA-STATE LEFTX) (SETQ WHO-LINE-ITEM-STATE T))))) (defun new-nwatch-who-function (who-sheet) (declare (:self-flavor who-line-sheet)) (or who-line-extra-state (let ((si:default-cons-area who-line-area)) (setq who-line-extra-state (si:string-append "mon dd hh:mm:ssAM")))) (multiple-value-bind (seconds minutes hours day month) (time:get-time) (cond ((null seconds) (sheet-clear who-sheet) (zl:copy-array-contents "mon dd hh:mm:ssAM" who-line-extra-state)) (t (let ((leftx (min (hl:nwatch-delta (time:month-string month ':short) who-line-extra-state 0) (hl:nwatch-delta day who-line-extra-state 4) (hl:nwatch-delta (hl:hours-mod-12 hours) who-line-extra-state 7) (hl:nwatch-delta minutes who-line-extra-state 10.) (hl:nwatch-delta seconds who-line-extra-state 13.) (hl:nwatch-delta (hl:am-or-pm hours minutes seconds) who-line-extra-state 15.)))) (unless who-line-item-state (setq leftx 0)) (sheet-set-cursorpos who-sheet (* leftx char-width) 0) (sheet-clear-eol who-sheet) (sheet-string-out who-sheet who-line-extra-state leftx) (setq who-line-item-state t)))))) (defun nwatch-delta (new str idx) (cond ((numberp new) (let ((dig1 (int-char (+ (zl:truncate new 10.) (char-int #\0)))) (dig2 (int-char (+ (rem new 10.) (char-int #\0))))) (prog1 (cond ((not (equal (char str idx) dig1)) idx) ((not (equal (char str (1+ idx)) dig2)) (1+ idx)) (t (si:array-length str))) (setf (char str idx) dig1) (setf (char str (1+ idx)) dig2)))) (t (loop with delta finally (return (or delta 0)) for i from 0 below (length new) do (when (not (char= (char str (+ idx i)) (char new i))) (setf (char str (+ idx i)) (char new i))))))) (defvar *who-line-clock-style* ':old) (defvar *reset-who-line-clock-style* nil) (defun nwatch-who-function (who-sheet) (declare (:self-flavor who-line-sheet)) (funcall (case *who-line-clock-style* (:old 'old-nwatch-who-function) (:new 'new-nwatch-who-function) (otherwise 'bash-nwatch)) who-sheet)) (defun set-who-line-clock-style (style) (assert (member style '(:old :new))) (setq *who-line-clock-style* nil) (sleep 1) (setq *who-line-clock-style* style) (zl:send nwatch-who-line-sheet ':clobbered)) (defun bash-nwatch (who-sheet) (declare (:self-flavor who-line-sheet)) (setq who-line-item-state nil who-line-extra-state nil) (sheet-set-cursorpos who-sheet 0 0) (sheet-clear-eol who-sheet) (sheet-string-out who-sheet who-line-extra-state 0)) (defun rdtbl-shortest-name (&optional (readtable *readtable*)) (let ((shortest-name (first (si:rdtbl-names readtable)))) (dolist (nick (si:rdtbl-names readtable)) (if (and (not (string-equal nick "T")) ;ZL idiocy (< (zl:string-length nick) (zl:string-length shortest-name))) (setq shortest-name nick))) shortest-name)) (defvar *show-readtable-in-who-line* nil) (defun who-line-package (who-sheet) (declare (:self-flavor who-line-sheet)) (setq last-who-line-process (or who-line-process (and selected-io-buffer (io-buffer-last-output-process selected-io-buffer)))) (when last-who-line-process ;--- Sometimes this gets bashed, messing up SG below? (let* ((sg (process-stack-group last-who-line-process)) (pkg (cond ((eq sg %current-stack-group) *package*) ((typep sg 'stack-group) (symeval-in-stack-group '*package* sg)) (t package))) (rdtbl (cond ((eq sg %current-stack-group) *readtable*) ((typep sg 'stack-group) (symeval-in-stack-group '*readtable* sg)) (t readtable)))) (when (or (and pkg (packagep pkg) (neq who-line-item-state pkg)) (and rdtbl (neq who-line-extra-state rdtbl))) (let ((rdtbl-part (hl:rdtbl-shortest-name rdtbl)) (pkg-part (si:pkg-shortest-name pkg)) (chars (truncate (sheet-inside-width who-sheet) (sheet-char-width who-sheet)))) (prepare-sheet (who-sheet) (sheet-clear who-sheet) (when *show-readtable-in-who-line* (sheet-string-out who-sheet rdtbl-part 0 (min (string-length rdtbl-part) 3 (- chars 4))) (sheet-string-out who-sheet " ")) (sheet-string-out who-sheet pkg-part 0 (min (string-length pkg-part) (- chars (if si::*read-single-colon-allow-internal-symbol* 1 2)))) (sheet-tyo who-sheet #\:) (unless si::*read-single-colon-allow-internal-symbol* (sheet-tyo who-sheet #\:))) (setq who-line-item-state pkg who-line-extra-state rdtbl))))))