;;; -*- Mode:LISP; Package:HL; Readtable:CL; Base:10; Patch-file: T -*- ;(defun lisp:break (&optional format-string &rest args) ; (when format-string ; (apply #'format *error-output* format-string args)) ; (eh:debug)) ;(defun breakpoint-in-code-style-checker (form) ; (ignore form) ; (compiler:warn 'breakpoint-in-code ':implausible "Breakpoint in code")) ;(EVAL-WHEN (EVAL LOAD COMPILE) ; (zl:defprop lisp:break breakpoint-in-code-style-checker 'compiler:style-checker)) (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))))) (defmacro printing-package-names (&body body) `(let ((*package* nil)) ,@body)) TV: (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 am-or-pm (hours minutes seconds) (cond ((and (zerop seconds) (zerop minutes)) (if (= hours 0) "M " "N ")) ((>= hours 12.) "pm") (t "am"))) (defun hours-mod-12 (hours) (if (or (= hours 12) (= hours 0)) 12 (mod hours 12))) TV: (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 TV:*who-line-clock-style* ':old) (defvar TV:*reset-who-line-clock-style* nil) TV: (defun nwatch-who-function (who-sheet) (declare (:self-flavor who-line-sheet)) (funcall (case *who-line-clock-style* (:old 'tv:old-nwatch-who-function) (:new 'new-nwatch-who-function) (otherwise 'tv:bash-nwatch)) who-sheet)) (defun set-who-line-clock-style (style) (assert (member style '(:old :new))) (setq tv:*who-line-clock-style* nil) (sleep 1) (setq tv:*who-line-clock-style* style) (zl:send tv:nwatch-who-line-sheet ':clobbered)) TV: (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 tv:*show-readtable-in-who-line* nil) TV: (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 tv:*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)))))) ;;;; Edit history for HUNLA:L;LISP-PATCHES.LISP.27 ;;; ;;; [10/27/88 03:30 CStacy] Macro WITH-WHOSTATE: Added. ;;; [10/27/88 03:30 CStacy] Macro PRINTING-PACKAGE-NAMES: Added. ;;; [11/17/88 23:05 CStacy] NWATCH hacks for prettier who-line. ;;; [11/17/88 23:57 CStacy] Might as well fix the package display also.