From a86c5ad1454445c63a796396ed2207d85539d0ca Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Sat, 16 Mar 2024 12:11:19 -0700 Subject: [PATCH] start with makefile new --- lispusers/WHO-LINE | 1147 +++++++++++++++++++++++--------------- lispusers/WHO-LINE.DFASL | Bin 36558 -> 36676 bytes 2 files changed, 698 insertions(+), 449 deletions(-) diff --git a/lispusers/WHO-LINE b/lispusers/WHO-LINE index 930e21dc..7ce762cf 100644 --- a/lispusers/WHO-LINE +++ b/lispusers/WHO-LINE @@ -1,18 +1,14 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "12-Apr-2023 22:10:58" {DSK}larry>il>medley>lispusers>WHO-LINE.;5 75086 +(FILECREATED "16-Mar-2024 12:08:24" {DSK}larry>il>medley>lispusers>WHO-LINE.;6 80801 :EDIT-BY "lmm" - :CHANGES-TO (FNS WHO-LINE-HOST-NAME SET-PACKAGE-INTERACTIVELY) + :CHANGES-TO (VARS WHO-LINECOMS) - :PREVIOUS-DATE "12-Apr-2023 17:45:36" {DSK}larry>il>medley>lispusers>WHO-LINE.;4) + :PREVIOUS-DATE "15-Mar-2024 07:19:58" {DSK}larry>il>medley>lispusers>WHO-LINE.;3) -(* ; " -Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. -") - (PRETTYCOMPRINT WHO-LINECOMS) (RPAQQ WHO-LINECOMS @@ -227,38 +223,38 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DEFINEQ -(INSTALL-WHO-LINE-OPTIONS - (LAMBDA NIL (* ; "Edited 16-May-88 14:19 by smL") +(INSTALL-WHO-LINE-OPTIONS + [LAMBDA NIL (* ; "Edited 16-May-88 14:19 by smL") -(* ;;; "") +(* ;;; "") -(* ;;; "Install new descriptions of the values to be displayed in the who-line.") +(* ;;; "Install new descriptions of the values to be displayed in the who-line.") -(* ;;; "Each description is a list of four items: then name of the value, a form that will compute the value, the maximum number of characters in the resulting value, and an optional function that will be FUNCALLed if/when that item is moused in the who-line.") +(* ;;; "Each description is a list of four items: then name of the value, a form that will compute the value, the maximum number of characters in the resulting value, and an optional function that will be FUNCALLed if/when that item is moused in the who-line.") -(* ;;; "") +(* ;;; "") - (* ;; "") + (* ;; "") - (* ;; "Create the who-line window if it isn't there already") + (* ;; "Create the who-line window if it isn't there already") - (* ;; "") + (* ;; "") - (if (NOT (AND (BOUNDP '*WHO-LINE*) + (if (NOT (AND (BOUNDP '*WHO-LINE*) (WINDOWP *WHO-LINE*))) - then (SETQ *WHO-LINE* (CREATEW (CREATEREGION 0 0 100 20) + then (SETQ *WHO-LINE* (CREATEW (CREATEREGION 0 0 100 20) NIL NIL T)) (WINDOWPROP *WHO-LINE* 'LOCK (CREATE.MONITORLOCK "WHO-LINE"))) - (WITH-WHO-LINE *WHO-LINE* (WINDOWPROP *WHO-LINE* 'VALID NIL) + (WITH-WHO-LINE *WHO-LINE* (WINDOWPROP *WHO-LINE* 'VALID NIL) (OPENW *WHO-LINE*) (LET ((CURRENT-LEFT 0) ENTRIES) - (* ;; "") + (* ;; "") - (* ;; "Make sure the who-line has all the correct window properties") + (* ;; "Make sure the who-line has all the correct window properties") - (* ;; "") + (* ;; "") (WINDOWPROP *WHO-LINE* 'REPAINTFN 'REDISPLAY-WHO-LINE) (WINDOWPROP *WHO-LINE* 'BUTTONEVENTFN 'WHEN-WHO-LINE-SELECTED-FN) @@ -271,17 +267,17 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (WINDOWPROP *WHO-LINE* 'BORDER *WHO-LINE-BORDER*) (WINDOWPROP *WHO-LINE* 'UPDATE-INTERVAL (FIX (TIMES *WHO-LINE-UPDATE-INTERVAL* \RCLKMILLISECOND))) - (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*)) + (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*)) - (* ;; "") + (* ;; "") - (* ;; "Create and fill in the who-line entries that go on the window.") + (* ;; "Create and fill in the who-line entries that go on the window.") - (* ;; "This entails computing the positions of the entries in the who-line") + (* ;; "This entails computing the positions of the entries in the who-line") - (* ;; "") + (* ;; "") - (SETQ ENTRIES (for ITEM in *WHO-LINE-ENTRIES* bind (DISPLAY-NAMES? + [SETQ ENTRIES (for ITEM in *WHO-LINE-ENTRIES* bind (DISPLAY-NAMES? _ (WINDOWPROP *WHO-LINE* 'DISPLAY-NAMES?)) @@ -291,130 +287,130 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (NAME-FONT _ (WINDOWPROP *WHO-LINE* 'NAME-FONT)) - collect (LET ((ENTRY (create WHO-LINE-ENTRY + collect (LET [(ENTRY (create WHO-LINE-ENTRY NAME _ (CL:FIRST ITEM) - FORM _ (CL:SECOND ITEM)))) - (with WHO-LINE-ENTRY ENTRY + FORM _ (CL:SECOND ITEM] + (with WHO-LINE-ENTRY ENTRY - (* ;; "") + (* ;; "") - (* ;; - "Leave a little space (the size of an %"A%") between the previous value and this name") + (* ;; + "Leave a little space (the size of an %"A%") between the previous value and this name") - (* ;; "") + (* ;; "") (SETQ NAME-START (PLUS (STRINGWIDTH "A" VALUE-FONT) CURRENT-LEFT)) - (if DISPLAY-NAMES? - then (SETQ CURRENT-LEFT + [if DISPLAY-NAMES? + then (SETQ CURRENT-LEFT (PLUS NAME-START (STRINGWIDTH NAME - NAME-FONT)))) + NAME-FONT] - (* ;; "") + (* ;; "") - (* ;; - "The value is displayed after the name, with a little space between them") + (* ;; + "The value is displayed after the name, with a little space between them") - (* ;; "") + (* ;; "") (SETQ VALUE-START (PLUS CURRENT-LEFT (STRINGWIDTH "A" VALUE-FONT))) - (SETQ VALUE-END (PLUS VALUE-START + [SETQ VALUE-END (PLUS VALUE-START (TIMES (CL:THIRD ITEM) (STRINGWIDTH "A" - VALUE-FONT))) - ) (* ; - "Leave a little extra space after each value") + VALUE-FONT] + (* ; + "Leave a little extra space after each value") (SETQ CURRENT-LEFT (PLUS VALUE-END (STRINGWIDTH "A" VALUE-FONT))) - (* ;; "") + (* ;; "") - (* ;; "Set the when-selected-fn") + (* ;; "Set the when-selected-fn") - (* ;; "") + (* ;; "") (SETQ WHEN-SELECTED-FN (CL:FOURTH ITEM)) - (* ;; "") + (* ;; "") - (* ;; "And the reset-form") + (* ;; "And the reset-form") - (* ;; "") + (* ;; "") (SETQ RESET-FORM (CL:FIFTH ITEM)) - (* ;; "") + (* ;; "") - (* ;; "And return the filled in entry") + (* ;; "And return the filled in entry") - (* ;; "") + (* ;; "") - ENTRY)))) + ENTRY] - (* ;; "") + (* ;; "") - (* ;; "Reshape the window to hold the new in info") + (* ;; "Reshape the window to hold the new in info") - (* ;; "") + (* ;; "") - (LET ((HORIZ-ANCHOR (if (POSITIONP (WINDOWPROP *WHO-LINE* 'ANCHOR)) - then (fetch XCOORD of (WINDOWPROP *WHO-LINE* 'ANCHOR)) - else (OR (for anchor in (WINDOWPROP *WHO-LINE* 'ANCHOR) - thereis (MEMB anchor '(:LEFT :CENTER :JUSTIFY - :RIGHT))) + (LET [[HORIZ-ANCHOR (if (POSITIONP (WINDOWPROP *WHO-LINE* 'ANCHOR)) + then (fetch XCOORD of (WINDOWPROP *WHO-LINE* 'ANCHOR)) + else (OR [for anchor in (WINDOWPROP *WHO-LINE* 'ANCHOR) + thereis (MEMB anchor '(:LEFT :CENTER :JUSTIFY + :RIGHT] (ERROR "No horizontal anchor specified" - (WINDOWPROP *WHO-LINE* 'ANCHOR))))) - (VERT-ANCHOR (if (POSITIONP (WINDOWPROP *WHO-LINE* 'ANCHOR)) - then (fetch YCOORD of (WINDOWPROP *WHO-LINE* 'ANCHOR)) - else (OR (for anchor in (WINDOWPROP *WHO-LINE* 'ANCHOR) - thereis (MEMB anchor '(:TOP :BOTTOM))) + (WINDOWPROP *WHO-LINE* 'ANCHOR] + [VERT-ANCHOR (if (POSITIONP (WINDOWPROP *WHO-LINE* 'ANCHOR)) + then (fetch YCOORD of (WINDOWPROP *WHO-LINE* 'ANCHOR)) + else (OR [for anchor in (WINDOWPROP *WHO-LINE* 'ANCHOR) + thereis (MEMB anchor '(:TOP :BOTTOM] (ERROR "No vertical anchor specified" - (WINDOWPROP *WHO-LINE* 'ANCHOR))))) - (WIDTH (WIDTHIFWINDOW CURRENT-LEFT (WINDOWPROP *WHO-LINE* 'BORDER))) + (WINDOWPROP *WHO-LINE* 'ANCHOR] + [WIDTH (WIDTHIFWINDOW CURRENT-LEFT (WINDOWPROP *WHO-LINE* 'BORDER] (HEIGHT (HEIGHTIFWINDOW (MAX (FONTPROP (WINDOWPROP *WHO-LINE* 'NAME-FONT) 'HEIGHT) (FONTPROP (WINDOWPROP *WHO-LINE* 'VALUE-FONT) 'HEIGHT)) (WINDOWPROP *WHO-LINE* 'TITLE) - (WINDOWPROP *WHO-LINE* 'BORDER)))) + (WINDOWPROP *WHO-LINE* 'BORDER] - (* ;; "") + (* ;; "") - (* ;; "Make sure the window fits on the screen (i.e. doesn't run off the edge, and is justified against left and right sides if the user wants).") + (* ;; "Make sure the window fits on the screen (i.e. doesn't run off the edge, and is justified against left and right sides if the user wants).") - (* ;; "If the items don't fit, change the length of each item so they do.") + (* ;; "If the items don't fit, change the length of each item so they do.") - (* ;; - "Do this by distributing the %"pain%" among all the entries in the who-line.") + (* ;; + "Do this by distributing the %"pain%" among all the entries in the who-line.") - (* ;; "") + (* ;; "") - (if (OR (GREATERP WIDTH SCREENWIDTH) + (if (OR (GREATERP WIDTH SCREENWIDTH) (EQ HORIZ-ANCHOR :JUSTIFY)) - then (for ENTRY in ENTRIES - bind (REMAINING-ADJUSTMENT _ (DIFFERENCE SCREENWIDTH WIDTH)) - (REMAINING-VALUE-SIZE _ (for ENTRY in ENTRIES - sum (with WHO-LINE-ENTRY ENTRY + then (for ENTRY in ENTRIES + bind (REMAINING-ADJUSTMENT _ (DIFFERENCE SCREENWIDTH WIDTH)) + [REMAINING-VALUE-SIZE _ (for ENTRY in ENTRIES + sum (with WHO-LINE-ENTRY ENTRY (DIFFERENCE VALUE-END - VALUE-START)))) + VALUE-START] (RUNNING-ADJUSTMENT _ 0) ENTRY-ADJUSTMENT - do (with WHO-LINE-ENTRY ENTRY + do (with WHO-LINE-ENTRY ENTRY - (* ;; "") + (* ;; "") - (* ;; "Figure out how much this entry value gets adjusted.") + (* ;; "Figure out how much this entry value gets adjusted.") - (* ;; "") + (* ;; "") - (* ;; - "Note that, by keeping track of the remaing adjustment needed, we avoid problems with round-off.") + (* ;; + "Note that, by keeping track of the remaing adjustment needed, we avoid problems with round-off.") - (* ;; "") + (* ;; "") (SETQ ENTRY-ADJUSTMENT (QUOTIENT (TIMES REMAINING-ADJUSTMENT @@ -424,37 +420,37 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. ) REMAINING-VALUE-SIZE)) - (* ;; "") + (* ;; "") - (* ;; "Update this entry size & position") + (* ;; "Update this entry size & position") - (* ;; "") + (* ;; "") - (add NAME-START RUNNING-ADJUSTMENT) - (add VALUE-START RUNNING-ADJUSTMENT) - (add RUNNING-ADJUSTMENT ENTRY-ADJUSTMENT) - (add VALUE-END RUNNING-ADJUSTMENT)) - finally (SETQ WIDTH SCREENWIDTH))) + (add NAME-START RUNNING-ADJUSTMENT) + (add VALUE-START RUNNING-ADJUSTMENT) + (add RUNNING-ADJUSTMENT ENTRY-ADJUSTMENT) + (add VALUE-END RUNNING-ADJUSTMENT)) + finally (SETQ WIDTH SCREENWIDTH))) - (* ;; "") + (* ;; "") - (* ;; "Set the who-line window size so it can't be reshaped") + (* ;; "Set the who-line window size so it can't be reshaped") - (* ;; "") + (* ;; "") (WINDOWPROP *WHO-LINE* 'MAXSIZE (CONS WIDTH HEIGHT)) (WINDOWPROP *WHO-LINE* 'MINSIZE (CONS WIDTH HEIGHT)) - (* ;; "") + (* ;; "") - (* ;; - "The anchor-point decribes where on the screen the who-line should be placed.") + (* ;; + "The anchor-point decribes where on the screen the who-line should be placed.") - (* ;; "The CAR should be one of :JUSTIFY, :LEFT, :RIGHT, or :CENTER.") + (* ;; "The CAR should be one of :JUSTIFY, :LEFT, :RIGHT, or :CENTER.") - (* ;; "The CADR should be one of :TOP, :BOTTOM, or :CENTER.") + (* ;; "The CADR should be one of :TOP, :BOTTOM, or :CENTER.") - (* ;; "") + (* ;; "") (SHAPEW *WHO-LINE* (CREATEREGION (SELECTQ HORIZ-ANCHOR ((:JUSTIFY :LEFT) @@ -473,12 +469,12 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. VERT-ANCHOR) WIDTH HEIGHT))) - (* ;; "") + (* ;; "") - (* ;; - "The values should be centered vertically between the top and the bottom of the window") + (* ;; + "The values should be centered vertically between the top and the bottom of the window") - (* ;; "") + (* ;; "") (WINDOWPROP *WHO-LINE* 'VALUE-BOTTOM (PLUS (FONTPROP (WINDOWPROP *WHO-LINE* 'VALUE-FONT) @@ -491,29 +487,29 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. 'HEIGHT)) 2))) - (* ;; "Cache a bitmap that is the same size as the inside of the who-line, and a display stream onto the bitmap.") + (* ;; "Cache a bitmap that is the same size as the inside of the who-line, and a display stream onto the bitmap.") - (WINDOWPROP *WHO-LINE* 'TEMP-STREAM (DSPCREATE (BITMAPCREATE (WINDOWPROP *WHO-LINE* + [WINDOWPROP *WHO-LINE* 'TEMP-STREAM (DSPCREATE (BITMAPCREATE (WINDOWPROP *WHO-LINE* 'WIDTH) (WINDOWPROP *WHO-LINE* - 'HEIGHT)))) + 'HEIGHT] - (* ;; "") + (* ;; "") - (* ;; "Install the entries") + (* ;; "Install the entries") - (* ;; "") + (* ;; "") (WINDOWPROP *WHO-LINE* 'ENTRIES ENTRIES) - (* ;; "") + (* ;; "") - (* ;; "Finally, update the window") + (* ;; "Finally, update the window") - (* ;; "") + (* ;; "") - (REDISPLAY-WHO-LINE *WHO-LINE*) - (WINDOWPROP *WHO-LINE* 'VALID T))))) + (REDISPLAY-WHO-LINE *WHO-LINE*) + (WINDOWPROP *WHO-LINE* 'VALID T]) ) @@ -537,33 +533,44 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DEFINEQ -(WHO-LINE-USERNAME - (LAMBDA NIL (* ; "Edited 30-Jun-88 15:41 by smL") +(WHO-LINE-USERNAME + [LAMBDA NIL (* ; "Edited 30-Jun-88 15:41 by smL") -(* ;;; "") +(* ;;; "") -(* ;;; "Return the name of the currently logged in user. Avoid consing up a new string if possible.") +(* ;;; "Return the name of the currently logged in user. Avoid consing up a new string if possible.") -(* ;;; "") - - (* ;; "The cached value in *WHO-LINE-CURRENT-USER* gets invalidated by an entry on the list of \SYSTEMCACHEVARS, and by a function on the list of \AFTERLOGINFNS") - - (* ;; "") +(* ;;; "") - (DECLARE (GLOBALVARS *WHO-LINE-CURRENT-USER*)) - (if *WHO-LINE-CURRENT-USER* - then *WHO-LINE-CURRENT-USER* - else (SETQ *WHO-LINE-CURRENT-USER* (USERNAME NIL NIL T))))) + (* ;; "The cached value in *WHO-LINE-CURRENT-USER* gets invalidated by an entry on the list of \SYSTEMCACHEVARS, and by a function on the list of \AFTERLOGINFNS") -(WHO-LINE-CHANGE-USER -(LAMBDA NIL (* smL "17-Nov-86 11:19") (* ;;; "") (* ;;; "Change the currently logged in user") (* ;;; "") (if (MENU (create MENU TITLE _ "Change user?" CENTERFLG _ T ITEMS _ (QUOTE (("Yes" T "Log in as a different user") ("No" NIL "Don't change the current user"))))) then (LOGIN))) -) + (* ;; "") -(WHO-LINE-USER-AFTER-LOGIN - (LAMBDA (HOST USER) (* ; "Edited 30-Jun-88 15:34 by smL") + (DECLARE (GLOBALVARS *WHO-LINE-CURRENT-USER*)) + (if *WHO-LINE-CURRENT-USER* + then *WHO-LINE-CURRENT-USER* + else (SETQ *WHO-LINE-CURRENT-USER* (USERNAME NIL NIL T]) +(WHO-LINE-CHANGE-USER + [LAMBDA NIL (* smL "17-Nov-86 11:19") + +(* ;;; "") + +(* ;;; "Change the currently logged in user") + +(* ;;; "") + + (if [MENU (create MENU + TITLE _ "Change user?" + CENTERFLG _ T + ITEMS _ '(("Yes" T "Log in as a different user") + ("No" NIL "Don't change the current user"] + then (LOGIN]) + +(WHO-LINE-USER-AFTER-LOGIN + [LAMBDA (HOST USER) (* ; "Edited 30-Jun-88 15:34 by smL") (CL:WHEN (NULL HOST) - (SETQ *WHO-LINE-CURRENT-USER* NIL)))) + (SETQ *WHO-LINE-CURRENT-USER* NIL]) ) (DEFGLOBALVAR *WHO-LINE-CURRENT-USER* NIL @@ -639,35 +646,36 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DEFINEQ -(CURRENT-TTY-PACKAGE - (LAMBDA NIL (* ; "Edited 17-Mar-87 17:52 by smL") +(CURRENT-TTY-PACKAGE + [LAMBDA NIL (* ; "Edited 17-Mar-87 17:52 by smL") -(* ;;; "") +(* ;;; "") -(* ;;; "Return the name of the current package of the current TTY process") +(* ;;; "Return the name of the current package of the current TTY process") -(* ;;; "") +(* ;;; "") - (LET ((PACKAGE (PROCESS.EVALV (TTY.PROCESS) - '*PACKAGE*))) - - (* ;; "") - - (* ;; "The *WHO-LINE-PACKAGE-NAME-CACHE* AList is used to cache computed package names with terminating %":%"'s.") - - (* ;; - "This lets us display the name with a colon w/o having to allocate new strings all the time.") - - (* ;; "") + (LET [(PACKAGE (PROCESS.EVALV (TTY.PROCESS) + '*PACKAGE*] + + (* ;; "") + + (* ;; "The *WHO-LINE-PACKAGE-NAME-CACHE* AList is used to cache computed package names with terminating %":%"'s.") + + (* ;; + "This lets us display the name with a colon w/o having to allocate new strings all the time.") + + (* ;; "") (OR (CDR (ASSOC PACKAGE *WHO-LINE-PACKAGE-NAME-CACHE*)) (PUTASSOC PACKAGE (CONCAT (OR (CAR (CL:PACKAGE-NICKNAMES PACKAGE)) (CL:PACKAGE-NAME PACKAGE)) ":") - *WHO-LINE-PACKAGE-NAME-CACHE*))))) + *WHO-LINE-PACKAGE-NAME-CACHE*]) (SET-PACKAGE-INTERACTIVELY - [LAMBDA NIL (* ; "Edited 12-Apr-2023 17:44 by lmm") + [LAMBDA NIL (* ; "Edited 15-Mar-2024 07:17 by lmm") + (* ; "Edited 12-Apr-2023 17:44 by lmm") (* ; "Edited 18-Mar-87 13:13 by smL") (* ;; "") @@ -681,8 +689,9 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. COLLECT (LIST PKG PN))) (SYSPKG (FOR PN IN '("LISP" "XEROX-COMMON-LISP" "D-ASSEM" "FASL" "KEYWORD" "CASH-FILE" - "SEDIT" "SYSTEM" "COMPILER" "HASH-FILE" "CONDITIONS" "DEBUGGER") - WHEN (SETQ PKG (CL:FIND-PACKAGE PN)) COLLECT (LIST PKG PN))) + "SEDIT" "SYSTEM" "COMPILER" "HASH-FILE" "CONDITIONS" "DEBUGGER" + "LOOP") WHEN (SETQ PKG (CL:FIND-PACKAGE PN)) + COLLECT (LIST PKG PN))) (BOTH (APPEND MAIN SYSPKG)) [UNSORTED (FOR PKG IN (CL:LIST-ALL-PACKAGES) WHEN (NOT (ASSOC PKG BOTH)) COLLECT (LIST PKG (OR (CAR (CL:PACKAGE-NICKNAMES PKG)) @@ -698,13 +707,22 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. CENTERFLG _ T] (IF SELECTION THEN (IF (SHIFTDOWNP 'SHIFT) - THEN (WHO-LINE-COPY-INSERT (CONCAT (CADR SELECTION) + THEN (WHO-LINE-COPY-INSERT (CONCAT (CL:PACKAGE-NAME SELECTION) ":")) - ELSE (CL:IN-PACKAGE (CAR SELECTION]) + ELSE (CL:IN-PACKAGE (CL:PACKAGE-NAME SELECTION]) -(SET-TTY-PACKAGE-INTERACTIVELY -(LAMBDA NIL (* smL "28-Oct-86 09:49") (* ;;; "") (* ;;; "Interactivly let the user change the package of the current TTY process") (* ;;; "") (PROCESS.EVAL (TTY.PROCESS) (QUOTE (SET-PACKAGE-INTERACTIVELY)) T)) -) +(SET-TTY-PACKAGE-INTERACTIVELY + [LAMBDA NIL (* smL "28-Oct-86 09:49") + +(* ;;; "") + +(* ;;; "Interactivly let the user change the package of the current TTY process") + +(* ;;; "") + + (PROCESS.EVAL (TTY.PROCESS) + '(SET-PACKAGE-INTERACTIVELY) + T]) ) (DEFGLOBALVAR *WHO-LINE-PACKAGE-NAME-CACHE* (LIST NIL) @@ -730,17 +748,57 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DEFINEQ -(CURRENT-TTY-READTABLE-NAME -(LAMBDA NIL (* smL "28-Oct-86 19:13") (* ;;; "") (* ;;; "Return the name of the readtable of the current TTY process") (* ;;; "") (OR (READTABLEPROP (PROCESS.EVALV (TTY.PROCESS) (QUOTE *READTABLE*)) (QUOTE NAME)) "Unknown")) -) +(CURRENT-TTY-READTABLE-NAME + [LAMBDA NIL (* smL "28-Oct-86 19:13") -(SET-READTABLE-INTERACTIVELY -(LAMBDA NIL (* smL "10-Nov-86 18:36") (* ;; "") (* ;; "Let the user interactivly change the current readtable") (* ;; "") (DECLARE (GLOBALVARS \READTABLEHASH)) (LET ((READTABLE (MENU (create MENU TITLE _ "Select readtable" ITEMS _ (LET ((READTABLES NIL)) (MAPHASH \READTABLEHASH (FUNCTION (LAMBDA (VALUE NAME) (push READTABLES (LIST NAME VALUE))))) (SORT READTABLES (FUNCTION (LAMBDA (X Y) (ALPHORDER (CAR X) (CAR Y)))))) CENTERFLG _ T)))) (if (READTABLEP READTABLE) then (SETQ *READTABLE* READTABLE)))) -) +(* ;;; "") -(SET-TTY-READTABLE-INTERACTIVELY -(LAMBDA NIL (* smL "28-Oct-86 09:51") (* ;;; "") (* ;;; "Interactivly let the user change the package of the current TTY readtable") (* ;;; "") (PROCESS.EVAL (TTY.PROCESS) (QUOTE (SET-READTABLE-INTERACTIVELY)) T)) -) +(* ;;; "Return the name of the readtable of the current TTY process") + +(* ;;; "") + + (OR (READTABLEPROP (PROCESS.EVALV (TTY.PROCESS) + '*READTABLE*) + 'NAME) + "Unknown"]) + +(SET-READTABLE-INTERACTIVELY + [LAMBDA NIL (* smL "10-Nov-86 18:36") + + (* ;; "") + + (* ;; "Let the user interactivly change the current readtable") + + (* ;; "") + + (DECLARE (GLOBALVARS \READTABLEHASH)) + (LET [(READTABLE (MENU (create MENU + TITLE _ "Select readtable" + ITEMS _ [LET ((READTABLES NIL)) + [MAPHASH \READTABLEHASH (FUNCTION (LAMBDA (VALUE + NAME) + (push READTABLES + (LIST NAME + VALUE] + (SORT READTABLES (FUNCTION (LAMBDA (X Y) + (ALPHORDER (CAR X) + (CAR Y] + CENTERFLG _ T] + (if (READTABLEP READTABLE) + then (SETQ *READTABLE* READTABLE]) + +(SET-TTY-READTABLE-INTERACTIVELY + [LAMBDA NIL (* smL "28-Oct-86 09:51") + +(* ;;; "") + +(* ;;; "Interactivly let the user change the package of the current TTY readtable") + +(* ;;; "") + + (PROCESS.EVAL (TTY.PROCESS) + '(SET-READTABLE-INTERACTIVELY) + T]) ) (CL:DEFPARAMETER *WHO-LINE-READTABLE-ENTRY* '("Rdtbl" (CURRENT-TTY-READTABLE-NAME) @@ -760,13 +818,32 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DEFINEQ -(WHO-LINE-TTY-PROCESS -(LAMBDA NIL (* smL "28-Oct-86 09:54") (* ;;; "") (* ;;; "Return the name of the current TTY process") (* ;;; "") (PROCESSPROP (TTY.PROCESS) (QUOTE NAME))) -) +(WHO-LINE-TTY-PROCESS + [LAMBDA NIL (* smL "28-Oct-86 09:54") -(CHANGE-TTY-PROCESS-INTERACTIVELY -(LAMBDA NIL (* smL "10-Nov-86 18:36") (DECLARE (GLOBALVARS \PROCESSES)) (LET ((NEW-PROC (MENU (create MENU TITLE _ "Give TTY to process" CENTERFLG _ T ITEMS _ (SORT (for PROC in \PROCESSES collect (LIST (PROCESSPROP PROC (QUOTE NAME)) PROC)) (FUNCTION (LAMBDA (X Y) (ALPHORDER (CAR X) (CAR Y))))))))) (if NEW-PROC then (TTY.PROCESS NEW-PROC)))) -) +(* ;;; "") + +(* ;;; "Return the name of the current TTY process") + +(* ;;; "") + + (PROCESSPROP (TTY.PROCESS) + 'NAME]) + +(CHANGE-TTY-PROCESS-INTERACTIVELY + [LAMBDA NIL (* smL "10-Nov-86 18:36") + (DECLARE (GLOBALVARS \PROCESSES)) + (LET [(NEW-PROC (MENU (create MENU + TITLE _ "Give TTY to process" + CENTERFLG _ T + ITEMS _ (SORT (for PROC in \PROCESSES + collect (LIST (PROCESSPROP PROC 'NAME) + PROC)) + (FUNCTION (LAMBDA (X Y) + (ALPHORDER (CAR X) + (CAR Y] + (if NEW-PROC + then (TTY.PROCESS NEW-PROC]) ) (CL:DEFPARAMETER *WHO-LINE-TTY-PROC-ENTRY* '("Tty" (WHO-LINE-TTY-PROCESS) @@ -786,9 +863,43 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DEFINEQ -(WHO-LINE-CURRENT-DIRECTORY -(LAMBDA NIL (* ; "Edited 3-Feb-89 14:52 by smL") (* ;;; "Get the currently connected directory") (* ;; "First, update the cached directory / namestring pair to reflect the current TTY proc") (DECLARE (GLOBALVARS *WHO-LINE-LAST-DIRECTORY*)) (* ;; "The connected directory is looked up in the TTY process, in case one day it becomes a per-process var") (LET ((CONNECTED-DIRECTORY (PROCESS.EVALV (TTY.PROCESS) (QUOTE *DEFAULT-PATHNAME-DEFAULTS*)))) (* ; "The CAR contains the path, the CDR contains a string version of the path") (if (NEQ CONNECTED-DIRECTORY (CAR *WHO-LINE-LAST-DIRECTORY*)) then (* ; "The connected directory has changed") (change (CAR *WHO-LINE-LAST-DIRECTORY*) CONNECTED-DIRECTORY) (* ; "Put the host name last, since that is least important") (change (CDR *WHO-LINE-LAST-DIRECTORY*) (if (CL:PATHNAME-DIRECTORY CONNECTED-DIRECTORY) then (CONCAT (CL:PATHNAME-DIRECTORY CONNECTED-DIRECTORY) " on {" (CL:PATHNAME-HOST CONNECTED-DIRECTORY) "}") else (CONCAT "{" (CL:PATHNAME-HOST CONNECTED-DIRECTORY) "}"))) (* ; "Update the list of known directories") (LET ((DIR-NAME (CL:NAMESTRING CONNECTED-DIRECTORY))) (if (NOT (CL:MEMBER DIR-NAME *WHO-LINE-DIRECTORIES* :TEST (CL:FUNCTION STRING-EQUAL))) then (MERGEINSERT DIR-NAME (SORT *WHO-LINE-DIRECTORIES* (CL:FUNCTION UALPHORDER))))))) (* ;; "Return the namestring of the current dir") (CDR *WHO-LINE-LAST-DIRECTORY*)) -) +(WHO-LINE-CURRENT-DIRECTORY + [LAMBDA NIL (* ; "Edited 3-Feb-89 14:52 by smL") + +(* ;;; "Get the currently connected directory") + + (* ;; "First, update the cached directory / namestring pair to reflect the current TTY proc") + + (DECLARE (GLOBALVARS *WHO-LINE-LAST-DIRECTORY*)) + + (* ;; "The connected directory is looked up in the TTY process, in case one day it becomes a per-process var") + + [LET [(CONNECTED-DIRECTORY (PROCESS.EVALV (TTY.PROCESS) + '*DEFAULT-PATHNAME-DEFAULTS*] + (* ; + "The CAR contains the path, the CDR contains a string version of the path") + (if (NEQ CONNECTED-DIRECTORY (CAR *WHO-LINE-LAST-DIRECTORY*)) + then (* ; + "The connected directory has changed") + (change (CAR *WHO-LINE-LAST-DIRECTORY*) + CONNECTED-DIRECTORY) (* ; + "Put the host name last, since that is least important") + (change (CDR *WHO-LINE-LAST-DIRECTORY*) + (if (CL:PATHNAME-DIRECTORY CONNECTED-DIRECTORY) + then (CONCAT (CL:PATHNAME-DIRECTORY CONNECTED-DIRECTORY) + " on {" + (CL:PATHNAME-HOST CONNECTED-DIRECTORY) + "}") + else (CONCAT "{" (CL:PATHNAME-HOST CONNECTED-DIRECTORY) + "}"))) (* ; + "Update the list of known directories") + (LET ((DIR-NAME (CL:NAMESTRING CONNECTED-DIRECTORY))) + (if (NOT (CL:MEMBER DIR-NAME *WHO-LINE-DIRECTORIES* :TEST #'STRING-EQUAL)) + then (MERGEINSERT DIR-NAME (SORT *WHO-LINE-DIRECTORIES* #'UALPHORDER] + + (* ;; "Return the namestring of the current dir") + + (CDR *WHO-LINE-LAST-DIRECTORY*]) (SET-CONNECTED-DIRECTORY-INTERACTIVELY [LAMBDA NIL (* ; "Edited 12-Apr-2023 08:00 by lmm") @@ -857,7 +968,7 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DEFINEQ (WHO-LINE-VMEM - [LAMBDA NIL (* ; "Edited 16-Jun-94 21:12 by kaplan") + [LAMBDA NIL (* ; "Edited 16-Jun-94 21:12 by kaplan") (* ;;; "") @@ -890,16 +1001,16 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (* ;; "") (if [NOT (AND (EQ VMEM-CONSISTENT? (CADR *WHO-LINE-LAST-VMEM*)) - (EQP VMEM-PERCENT (CAR *WHO-LINE-LAST-VMEM*] + (EQP VMEM-PERCENT (CAR *WHO-LINE-LAST-VMEM*] then (change (CAR *WHO-LINE-LAST-VMEM*) - VMEM-PERCENT) - (change (CADR *WHO-LINE-LAST-VMEM*) - VMEM-CONSISTENT?) - (change (CADDR *WHO-LINE-LAST-VMEM*) - (CONCAT (if VMEM-CONSISTENT? - then " " - else "*") - VMEM-PERCENT "%%"))) + VMEM-PERCENT) + (change (CADR *WHO-LINE-LAST-VMEM*) + VMEM-CONSISTENT?) + (change (CADDR *WHO-LINE-LAST-VMEM*) + (CONCAT (if VMEM-CONSISTENT? + then " " + else "*") + VMEM-PERCENT "%%"))) (* ;; "") @@ -909,9 +1020,21 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (CADDR *WHO-LINE-LAST-VMEM*]) -(WHO-LINE-SAVE-VMEM -(LAMBDA NIL (* smL "29-Oct-86 11:22") (* ;;; "") (* ;;; "Save the VMem, if the user really wants to") (* ;;; "") (if (MENU (create MENU TITLE _ "Save VMem?" CENTERFLG _ T ITEMS _ (QUOTE (("Yes" T) ("No" NIL))))) then (SAVEVM))) -) +(WHO-LINE-SAVE-VMEM + [LAMBDA NIL (* smL "29-Oct-86 11:22") + +(* ;;; "") + +(* ;;; "Save the VMem, if the user really wants to") + +(* ;;; "") + + (if [MENU (create MENU + TITLE _ "Save VMem?" + CENTERFLG _ T + ITEMS _ '(("Yes" T) + ("No" NIL] + then (SAVEVM]) ) (DEFGLOBALVAR *WHO-LINE-LAST-VMEM* (LIST 0 NIL NIL) @@ -985,34 +1108,64 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DEFINEQ -(WHO-LINE-TIME -(LAMBDA NIL (* ; "Edited 14-Jan-87 12:48 by smL") (* ;;; "") (* ;;; "Return the current time as a string. Avoid CONSing as much as possible.") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-TIMER* *WHO-LINE-OLD-TIME*)) (if (TIMEREXPIRED? *WHO-LINE-TIMER* (QUOTE SECONDS)) then (* ;; "") (* ;; "Reset the timer, and return the new time") (* ;; "") (LET ((NOW (IDATE))) (SETQ *WHO-LINE-TIMER* (SETUPTIMER (DIFFERENCE 60 (REMAINDER NOW 60)) (CONSTANT (SETUPTIMER 0 NIL (QUOTE SECONDS))) (QUOTE SECONDS))) (SETQ *WHO-LINE-OLD-TIME* (GDATE NOW (CONSTANT (DATEFORMAT NO.SECONDS)) *WHO-LINE-OLD-TIME*)) *WHO-LINE-OLD-TIME*) else (* ;; "") (* ;; "The timer hasn't expired, so the old time is good enough") (* ;; "") *WHO-LINE-OLD-TIME*)) -) +(WHO-LINE-TIME + [LAMBDA NIL (* ; "Edited 14-Jan-87 12:48 by smL") -(WHO-LINE-SET-TIME - (LAMBDA NIL (* ; "Edited 17-Mar-87 18:20 by smL") +(* ;;; "") -(* ;;; "") +(* ;;; "Return the current time as a string. Avoid CONSing as much as possible.") -(* ;;; "Set the time from the network, if the user really wants to") +(* ;;; "") -(* ;;; "") + (DECLARE (GLOBALVARS *WHO-LINE-TIMER* *WHO-LINE-OLD-TIME*)) + (if (TIMEREXPIRED? *WHO-LINE-TIMER* 'SECONDS) + then + (* ;; "") + + (* ;; "Reset the timer, and return the new time") + + (* ;; "") + + (LET ((NOW (IDATE))) + (SETQ *WHO-LINE-TIMER* (SETUPTIMER (DIFFERENCE 60 (REMAINDER NOW 60)) + (CONSTANT (SETUPTIMER 0 NIL 'SECONDS)) + 'SECONDS)) + (SETQ *WHO-LINE-OLD-TIME* (GDATE NOW (CONSTANT (DATEFORMAT NO.SECONDS)) + *WHO-LINE-OLD-TIME*)) + *WHO-LINE-OLD-TIME*) + else + (* ;; "") + + (* ;; "The timer hasn't expired, so the old time is good enough") + + (* ;; "") + + *WHO-LINE-OLD-TIME*]) + +(WHO-LINE-SET-TIME + [LAMBDA NIL (* ; "Edited 17-Mar-87 18:20 by smL") + +(* ;;; "") + +(* ;;; "Set the time from the network, if the user really wants to") + +(* ;;; "") (COND ((SHIFTDOWNP 'SHIFT) - - (* ;; "Selection with a shift key down causes the current time to be bksysbuf'ed") - (WHO-LINE-COPY-INSERT *WHO-LINE-OLD-TIME*)) - ((MENU (create MENU + (* ;; "Selection with a shift key down causes the current time to be bksysbuf'ed") + + (WHO-LINE-COPY-INSERT *WHO-LINE-OLD-TIME*)) + ([MENU (create MENU TITLE _ "Set time?" CENTERFLG _ T ITEMS _ '(("Yes" T) - ("No" NIL)))) - - (* ;; "The user wants to reset the time") + ("No" NIL] - (SETTIME))))) + (* ;; "The user wants to reset the time") + + (SETTIME]) ) (DEFGLOBALVAR *WHO-LINE-TIMER* (SETUPTIMER (DIFFERENCE 60 (REMAINDER (IDATE) @@ -1060,47 +1213,86 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DEFINEQ -(WHO-LINE-SHOW-ACTIVE - (LAMBDA NIL (* ; "Edited 20-Apr-87 09:58 by smL") +(WHO-LINE-SHOW-ACTIVE + [LAMBDA NIL (* ; "Edited 20-Apr-87 09:58 by smL") -(* ;;; "Update the who-line active indicator, if it is time") +(* ;;; "Update the who-line active indicator, if it is time") - (DECLARE (GLOBALVARS *WHO-LINE* *WHO-LINE-ACTIVE-TIMER* *WHO-LINE-ACTIVE-PERIOD*)) - (if (TIMEREXPIRED? *WHO-LINE-ACTIVE-TIMER* 'MILLISECONDS) - then - - (* ;; "A second has passed, so update the indicator if we can") + (DECLARE (GLOBALVARS *WHO-LINE* *WHO-LINE-ACTIVE-TIMER* *WHO-LINE-ACTIVE-PERIOD*)) + [if (TIMEREXPIRED? *WHO-LINE-ACTIVE-TIMER* 'MILLISECONDS) + then + (* ;; "A second has passed, so update the indicator if we can") - (\UPDATE-WHO-LINE-ACTIVE-FLAG *WHO-LINE*) - - (* ;; "Reset the timer") + (\UPDATE-WHO-LINE-ACTIVE-FLAG *WHO-LINE*) + + (* ;; "Reset the timer") (SETQ *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* - *WHO-LINE-ACTIVE-TIMER* 'MILLISECONDS))) - - (* ;; "Always return the same thing") + *WHO-LINE-ACTIVE-TIMER* 'MILLISECONDS] - " ")) + (* ;; "Always return the same thing") -(\UPDATE-WHO-LINE-ACTIVE-FLAG - (LAMBDA (WINDOW) (* ; "Edited 20-Apr-87 09:58 by smL") + " "]) -(* ;;; "Flip the active-indicator in the who-line") +(\UPDATE-WHO-LINE-ACTIVE-FLAG + [LAMBDA (WINDOW) (* ; "Edited 20-Apr-87 09:58 by smL") - (for ENTRY in (WINDOWPROP WINDOW 'ENTRIES) thereis (with WHO-LINE-ENTRY ENTRY +(* ;;; "Flip the active-indicator in the who-line") + + (for ENTRY in (WINDOWPROP WINDOW 'ENTRIES) thereis [with WHO-LINE-ENTRY ENTRY (AND (LISTP FORM) (EQ (CAR FORM) - 'WHO-LINE-SHOW-ACTIVE))) - finally (if $$VAL - then (with WHO-LINE-ENTRY $$VAL (BLTSHADE BLACKSHADE WINDOW VALUE-START 2 + 'WHO-LINE-SHOW-ACTIVE] + finally (if $$VAL + then (with WHO-LINE-ENTRY $$VAL (BLTSHADE BLACKSHADE WINDOW VALUE-START 2 (DIFFERENCE VALUE-END VALUE-START) (DIFFERENCE (WINDOWPROP WINDOW 'HEIGHT) 4) - 'INVERT)))))) + 'INVERT]) -(\PERIODICALLY-WHO-LINE-SHOW-ACTIVE -(LAMBDA NIL (* ; "Edited 14-Jan-87 12:50 by smL") (* ;;; "") (* ;;; "Update the who-line active indicator, if it is time") (* ;;; "This is designed to be run on the \PERIODIC.INTERRUPT hook.") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-ACTIVE-TIMER* *WHO-LINE* *WHO-LINE-ACTIVE-PERIOD*)) (if (TIMEREXPIRED? *WHO-LINE-ACTIVE-TIMER* (QUOTE MILLISECONDS)) then (* ;; "") (* ;; "A second has passed, so update the indicator if we can") (* ;; "") (* ;; "But only if the who-line is on the top") (* ;; "") (if (AND (OPENWP *WHO-LINE*) (TOPWP *WHO-LINE*)) then (* ;; "") (* ;; "The who-line is on the top, so we can update it") (* ;; "") (\UPDATE-WHO-LINE-ACTIVE-FLAG *WHO-LINE*)) (* ;; "") (* ;; "Reset the timer") (* ;; "") (SETQ *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* *WHO-LINE-ACTIVE-TIMER* (QUOTE MILLISECONDS))))) -) +(\PERIODICALLY-WHO-LINE-SHOW-ACTIVE + [LAMBDA NIL (* ; "Edited 14-Jan-87 12:50 by smL") + +(* ;;; "") + +(* ;;; "Update the who-line active indicator, if it is time") + +(* ;;; "This is designed to be run on the \PERIODIC.INTERRUPT hook.") + +(* ;;; "") + + (DECLARE (GLOBALVARS *WHO-LINE-ACTIVE-TIMER* *WHO-LINE* *WHO-LINE-ACTIVE-PERIOD*)) + (if (TIMEREXPIRED? *WHO-LINE-ACTIVE-TIMER* 'MILLISECONDS) + then + (* ;; "") + + (* ;; "A second has passed, so update the indicator if we can") + + (* ;; "") + + (* ;; "But only if the who-line is on the top") + + (* ;; "") + + (if (AND (OPENWP *WHO-LINE*) + (TOPWP *WHO-LINE*)) + then + (* ;; "") + + (* ;; "The who-line is on the top, so we can update it") + + (* ;; "") + + (\UPDATE-WHO-LINE-ACTIVE-FLAG *WHO-LINE*)) + + (* ;; "") + + (* ;; "Reset the timer") + + (* ;; "") + + (SETQ *WHO-LINE-ACTIVE-TIMER* (SETUPTIMER *WHO-LINE-ACTIVE-PERIOD* + *WHO-LINE-ACTIVE-TIMER* 'MILLISECONDS]) ) (DEFGLOBALVAR *WHO-LINE-ACTIVE-PERIOD* 500 @@ -1132,17 +1324,48 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DEFINEQ -(CURRENT-PROFILE -(LAMBDA NIL (* ; "Edited 12-Jan-87 14:36 by smL") (* ;;; "") (* ;;; "Return the name of the current reader profile of the current TTY process") (* ;;; "") (XCL:PROFILE-NAME (PROCESS.EVALV (TTY.PROCESS) (QUOTE XCL:*PROFILE*)))) -) +(CURRENT-PROFILE + [LAMBDA NIL (* ; "Edited 12-Jan-87 14:36 by smL") -(SET-PROFILE-INTERACTIVELY -(LAMBDA NIL (* ; "Edited 12-Jan-87 14:33 by smL") (* ;; "") (* ;; "Let the user interactivly change the current reader profile") (* ;; "") (LET ((PROFILE (MENU (create MENU TITLE _ "Select profile" ITEMS _ (SORT (for PROFILE in (XCL:LIST-ALL-PROFILES) bind PROFILE-NAME collect (XCL:PROFILE-NAME PROFILE))) CENTERFLG _ T)))) (if PROFILE then (XCL:RESTORE-PROFILE PROFILE)))) -) +(* ;;; "") -(SET-TTY-PROFILE-INTERACTIVELY -(LAMBDA NIL (* ; "Edited 12-Jan-87 14:33 by smL") (* ;;; "") (* ;;; "Interactivly let the user change the reader profile of the current TTY process") (* ;;; "") (PROCESS.EVAL (TTY.PROCESS) (QUOTE (SET-PROFILE-INTERACTIVELY)) T)) -) +(* ;;; "Return the name of the current reader profile of the current TTY process") + +(* ;;; "") + + (XCL:PROFILE-NAME (PROCESS.EVALV (TTY.PROCESS) + 'XCL:*PROFILE*]) + +(SET-PROFILE-INTERACTIVELY + [LAMBDA NIL (* ; "Edited 12-Jan-87 14:33 by smL") + + (* ;; "") + + (* ;; "Let the user interactivly change the current reader profile") + + (* ;; "") + + (LET [(PROFILE (MENU (create MENU + TITLE _ "Select profile" + ITEMS _ (SORT (for PROFILE in (XCL:LIST-ALL-PROFILES) bind + PROFILE-NAME + collect (XCL:PROFILE-NAME PROFILE))) + CENTERFLG _ T] + (if PROFILE + then (XCL:RESTORE-PROFILE PROFILE]) + +(SET-TTY-PROFILE-INTERACTIVELY + [LAMBDA NIL (* ; "Edited 12-Jan-87 14:33 by smL") + +(* ;;; "") + +(* ;;; "Interactivly let the user change the reader profile of the current TTY process") + +(* ;;; "") + + (PROCESS.EVAL (TTY.PROCESS) + '(SET-PROFILE-INTERACTIVELY) + T]) ) (CL:DEFPARAMETER *WHO-LINE-PROFILE-ENTRY* '("Profile" (CURRENT-PROFILE) @@ -1163,37 +1386,66 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DEFINEQ -(WHO-LINE-TTY-STATE - (LAMBDA NIL (* ; "Edited 17-Apr-87 18:26 by smL") +(WHO-LINE-TTY-STATE + [LAMBDA NIL (* ; "Edited 17-Apr-87 18:26 by smL") -(* ;;; "Find out what state the current TTY process is in") +(* ;;; "Find out what state the current TTY process is in") (LET ((PROC (TTY.PROCESS))) (COND ((NULL PROC) - - (* ;; " No tty process? Never happens now, but maybe allowed in future.") + + (* ;; " No tty process? Never happens now, but maybe allowed in future.") "") ((EQ PROC (THIS.PROCESS)) - - (* ;; " Check explicitly for us being tty, since in that case PROC is not a valid stack pointer (we're running).") + + (* ;; " Check explicitly for us being tty, since in that case PROC is not a valid stack pointer (we're running).") "Who-Line") ((PROCESS.EVALV PROC '*WHO-LINE-STATE*)) ((NOT (PROCESS.FINISHEDP PROC)) - (for I from 0 by -1 bind FRAMENAME while (SETQ FRAMENAME (STKNTHNAME I PROC)) - unless (MEMB FRAMENAME *WHO-LINE-STATE-UNINTERESTING-FNS*) - do - - (* ;; " Walk back process looking for interesting frame name. This search is non-linear in that each iteration takes a little longer, but we expect it to terminate early.") + (for I from 0 by -1 bind FRAMENAME while (SETQ FRAMENAME (STKNTHNAME I PROC)) + unless (MEMB FRAMENAME *WHO-LINE-STATE-UNINTERESTING-FNS*) + do + (* ;; " Walk back process looking for interesting frame name. This search is non-linear in that each iteration takes a little longer, but we expect it to terminate early.") (RETURN (OR (GETPROP FRAMENAME 'WHO-LINE-STATE) - FRAMENAME)))))))) + FRAMENAME]) -(WHO-LINE-WHAT-IS-RUNNING -(LAMBDA NIL (* ; "Edited 14-Jan-87 12:51 by smL") (* ;;; "") (* ;;; "When run under a (PROCESS.EVAL '(WHO-LINE-WHAT-IS-RUNNING) T), returns the name of the current running frame in the process") (* ;;; "") (DECLARE (GLOBALVARS *WHO-LINE-STATE-UNINTERESTING-FNS*)) (PROG ((POS-HOLDER (CONSTANT (LIST NIL))) POS) (* ;; "") (* ;; "We use the POS-HOLDER to hold an old stack pointer, so that we don't have to alloc one") (* ;; "") (SETQ POS (STKPOS (QUOTE \PROCESS.EVAL1) NIL NIL (CAR POS-HOLDER))) (COND (POS (change (CAR POS-HOLDER) POS)) (T (RETURN NIL))) LP (SETQ POS (STKNTH 1 POS POS)) (COND ((NULL POS) (RETURN NIL)) ((MEMB (STKNAME POS) *WHO-LINE-STATE-UNINTERESTING-FNS*) (* ; "Ignore any uninteresting fns") (GO LP)) (T (RETURN (PROG1 (STKNAME POS) (RELSTK POS))))))) -) +(WHO-LINE-WHAT-IS-RUNNING + [LAMBDA NIL (* ; "Edited 14-Jan-87 12:51 by smL") + +(* ;;; "") + +(* ;;; "When run under a (PROCESS.EVAL '(WHO-LINE-WHAT-IS-RUNNING) T), returns the name of the current running frame in the process") + +(* ;;; "") + + (DECLARE (GLOBALVARS *WHO-LINE-STATE-UNINTERESTING-FNS*)) + (PROG ((POS-HOLDER (CONSTANT (LIST NIL))) + POS) + + (* ;; "") + + (* ;; "We use the POS-HOLDER to hold an old stack pointer, so that we don't have to alloc one") + + (* ;; "") + + (SETQ POS (STKPOS '\PROCESS.EVAL1 NIL NIL (CAR POS-HOLDER))) + (COND + (POS (change (CAR POS-HOLDER) + POS)) + (T (RETURN NIL))) + LP (SETQ POS (STKNTH 1 POS POS)) + (COND + ((NULL POS) + (RETURN NIL)) + ((MEMB (STKNAME POS) + *WHO-LINE-STATE-UNINTERESTING-FNS*) (* ; "Ignore any uninteresting fns") + (GO LP)) + (T (RETURN (PROG1 (STKNAME POS) + (RELSTK POS]) ) (CL:DEFVAR *WHO-LINE-STATE* NIL @@ -1291,131 +1543,129 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DEFINEQ -(REDISPLAY-WHO-LINE - (LAMBDA (WINDOW) (* ; "Edited 17-Apr-87 19:06 by smL") +(REDISPLAY-WHO-LINE + [LAMBDA (WINDOW) (* ; "Edited 17-Apr-87 19:06 by smL") -(* ;;; "Redisplay the entire who-line, including the names of the fields") +(* ;;; "Redisplay the entire who-line, including the names of the fields") - (WITH-WHO-LINE WINDOW - - (* ;; "") - - (* ;; "Set the display characteristics of the window, according to its color") + (WITH-WHO-LINE WINDOW - (DSPSOURCETYPE (SELECTQ (WINDOWPROP WINDOW 'COLOR) + (* ;; "") + + (* ;; "Set the display characteristics of the window, according to its color") + + (DSPSOURCETYPE [SELECTQ (WINDOWPROP WINDOW 'COLOR) (:WHITE 'INPUT) (:BLACK 'INVERT) - (ERROR "Illegal color for Who-Line" (WINDOWPROP WINDOW 'COLOR))) + (ERROR "Illegal color for Who-Line" (WINDOWPROP WINDOW 'COLOR] WINDOW) - (DSPTEXTURE (SELECTQ (WINDOWPROP WINDOW 'COLOR) + (DSPTEXTURE [SELECTQ (WINDOWPROP WINDOW 'COLOR) (:WHITE WHITESHADE) (:BLACK BLACKSHADE) - (ERROR "Illegal color for Who-Line" (WINDOWPROP WINDOW 'COLOR))) + (ERROR "Illegal color for Who-Line" (WINDOWPROP WINDOW 'COLOR] WINDOW) - - (* ;; "") - - (* ;; "Clear the window") + + (* ;; "") + + (* ;; "Clear the window") (CLEARW WINDOW) - (for ITEM in (WINDOWPROP WINDOW 'ENTRIES) do (replace (WHO-LINE-ENTRY INVERTED?) - of ITEM with NIL)) - - (* ;; "") - - (* ;; "Display the labels if we should") + (for ITEM in (WINDOWPROP WINDOW 'ENTRIES) do (replace (WHO-LINE-ENTRY INVERTED?) + of ITEM with NIL)) - (if (WINDOWPROP WINDOW 'DISPLAY-NAMES?) - then (DSPFONT (WINDOWPROP WINDOW 'NAME-FONT) + (* ;; "") + + (* ;; "Display the labels if we should") + + (if (WINDOWPROP WINDOW 'DISPLAY-NAMES?) + then (DSPFONT (WINDOWPROP WINDOW 'NAME-FONT) WINDOW) - (for ITEM in (WINDOWPROP WINDOW 'ENTRIES) bind (FONT _ (WINDOWPROP WINDOW + (for ITEM in (WINDOWPROP WINDOW 'ENTRIES) bind (FONT _ (WINDOWPROP WINDOW 'NAME-FONT)) - do (MOVETO (fetch (WHO-LINE-ENTRY NAME-START) of ITEM) + do (MOVETO (fetch (WHO-LINE-ENTRY NAME-START) of ITEM) (PLUS (FONTPROP FONT 'DESCENT) (QUOTIENT (DIFFERENCE (WINDOWPROP *WHO-LINE* 'HEIGHT) (FONTPROP FONT 'HEIGHT)) 2)) WINDOW) - (PRIN1 (fetch (WHO-LINE-ENTRY NAME) of ITEM) + (PRIN1 (fetch (WHO-LINE-ENTRY NAME) of ITEM) WINDOW))) - - (* ;; "") - - (* ;; "Display the values") + + (* ;; "") + + (* ;; "Display the values") (DSPFONT (WINDOWPROP WINDOW 'VALUE-FONT) WINDOW) - (UPDATE-WHO-LINE WINDOW (WINDOWPROP WINDOW 'ENTRIES) + (UPDATE-WHO-LINE WINDOW (WINDOWPROP WINDOW 'ENTRIES) T) - - (* ;; "") - - (* ;; "Reset the timer for the next update") - (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*))))) + (* ;; "") -(PERIODICALLY-UPDATE-WHO-LINE - (LAMBDA NIL (* ; "Edited 27-Jan-88 10:11 by smL") + (* ;; "Reset the timer for the next update") -(* ;;; "") + (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*]) -(* ;;; "Update the current who-line window every so often. This is designed to be placed on the list of BACKBROUNDFNS.") +(PERIODICALLY-UPDATE-WHO-LINE + [LAMBDA NIL (* ; "Edited 27-Jan-88 10:11 by smL") -(* ;;; "") +(* ;;; "") - (DECLARE (GLOBALVARS \IDLING)) +(* ;;; "Update the current who-line window every so often. This is designed to be placed on the list of BACKBROUNDFNS.") + +(* ;;; "") + + (DECLARE (GLOBALVARS \IDLING)) (CL:WHEN (TIMEREXPIRED? *WHO-LINE-UPDATE-TIMER* 'TICKS) - (CL:WHEN (AND (BOUNDP '*WHO-LINE*) - (NOT \IDLING)) (* ; - "Don't bother to wait and update if the window is owned by someone.") + (CL:WHEN (AND (BOUNDP '*WHO-LINE*) + (NOT \IDLING)) (* ; + "Don't bother to wait and update if the window is owned by someone.") + [WITH-AVAILABLE-WHO-LINE *WHO-LINE* (if (AND (OPENWP *WHO-LINE*) + (GETWINDOWPROP *WHO-LINE* 'VALID)) + then (UPDATE-WHO-LINE *WHO-LINE* + (GETWINDOWPROP *WHO-LINE* + 'ENTRIES]) + (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*)))]) - (WITH-AVAILABLE-WHO-LINE *WHO-LINE* (if (AND (OPENWP *WHO-LINE*) - (GETWINDOWPROP *WHO-LINE* 'VALID)) - then (UPDATE-WHO-LINE *WHO-LINE* - (GETWINDOWPROP *WHO-LINE* - 'ENTRIES))))) - (SETQ *WHO-LINE-UPDATE-TIMER* (SETUP-WHOLINE-TIMER *WHO-LINE-UPDATE-TIMER*))))) - -(SETUP-WHOLINE-TIMER - (LAMBDA (OLD-TIMER) (* ; "Edited 18-Mar-87 11:14 by smL") +(SETUP-WHOLINE-TIMER + [LAMBDA (OLD-TIMER) (* ; "Edited 18-Mar-87 11:14 by smL") (SETUPTIMER (WINDOWPROP *WHO-LINE* 'UPDATE-INTERVAL) OLD-TIMER - 'TICKS))) + 'TICKS]) -(UPDATE-WHO-LINE - (LAMBDA (WINDOW WHO-LINE-ENTRIES ALWAYS?) (* ; "Edited 17-Apr-87 19:05 by smL") +(UPDATE-WHO-LINE + [LAMBDA (WINDOW WHO-LINE-ENTRIES ALWAYS?) (* ; "Edited 17-Apr-87 19:05 by smL") -(* ;;; "Update the window to show the current who-line stats") +(* ;;; "Update the window to show the current who-line stats") - (WITH-WHO-LINE + (WITH-WHO-LINE WINDOW - - (* ;; "") - - (* ;; "Update all the entries that have changed") - (for ENTRY in WHO-LINE-ENTRIES bind (VALUE-BOTTOM _ (GETWINDOWPROP WINDOW 'VALUE-BOTTOM)) + (* ;; "") + + (* ;; "Update all the entries that have changed") + + (for ENTRY in WHO-LINE-ENTRIES bind (VALUE-BOTTOM _ (GETWINDOWPROP WINDOW 'VALUE-BOTTOM)) (STREAM _ (GETWINDOWPROP WINDOW 'TEMP-STREAM)) (HEIGHT _ (GETWINDOWPROP WINDOW 'HEIGHT)) (BLACK-WINDOW-P _ (EQ (WINDOWPROP WINDOW 'COLOR) :BLACK)) - do (with WHO-LINE-ENTRY ENTRY (* ; - "If the node is inverted, the user is mousing it, so don't update it") - (if (NOT INVERTED?) - then (if ALWAYS? - then (EVAL RESET-FORM)) + do (with WHO-LINE-ENTRY ENTRY (* ; + "If the node is inverted, the user is mousing it, so don't update it") + (if (NOT INVERTED?) + then (if ALWAYS? + then (EVAL RESET-FORM)) (LET ((VALUE (EVAL FORM))) - - (* ;; "") - - (* ;; "Only update if the value has changed, or we are ordered to.") - (if (OR ALWAYS? (NOT (EQUAL VALUE PREV-VALUE))) - then - - (* ;; "") - - (* ;; "Print the new value") + (* ;; "") + + (* ;; "Only update if the value has changed, or we are ordered to.") + + (if (OR ALWAYS? (NOT (EQUAL VALUE PREV-VALUE))) + then + (* ;; "") + + (* ;; "Print the new value") (MOVETO VALUE-START VALUE-BOTTOM STREAM) (BLTSHADE BLACKSHADE STREAM VALUE-START 0 (DIFFERENCE @@ -1426,8 +1676,8 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DSPFONT (DSPFONT NIL WINDOW) STREAM) (PRIN1 VALUE STREAM) - (if BLACK-WINDOW-P - then (BLTSHADE BLACKSHADE STREAM VALUE-START 0 + (if BLACK-WINDOW-P + then (BLTSHADE BLACKSHADE STREAM VALUE-START 0 (DIFFERENCE VALUE-END VALUE-START) HEIGHT 'INVERT)) @@ -1435,90 +1685,92 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (DIFFERENCE VALUE-END VALUE-START) HEIGHT 'PAINT) - - (* ;; "") - - (* ;; "Save the value.") - - (* ;; "We are worried that a form may be re-using a value (to minimize CONS-ing), so we store a copy of the value rather than the real value.") - (SETQ PREV-VALUE (COPYALL VALUE)))))))))) + (* ;; "") -(WHEN-WHO-LINE-SELECTED-FN - (LAMBDA (WINDOW) (* ; "Edited 27-Jan-88 09:54 by smL") + (* ;; "Save the value.") -(* ;;; "") + (* ;; "We are worried that a form may be re-using a value (to minimize CONS-ing), so we store a copy of the value rather than the real value.") -(* ;;; "The button has gone down in the who-line window.") + (SETQ PREV-VALUE (COPYALL VALUE]) -(* ;;; "If the control or edit key is down, allow the user to change the entries in the who-line.") +(WHEN-WHO-LINE-SELECTED-FN + [LAMBDA (WINDOW) (* ; "Edited 27-Jan-88 09:54 by smL") -(* ;;; "If the user selects an item, and it has a when-selected-fn, funcall that fn.") +(* ;;; "") -(* ;;; "") +(* ;;; "The button has gone down in the who-line window.") - (WITH-WHO-LINE WINDOW (TOTOPW WINDOW) +(* ;;; "If the control or edit key is down, allow the user to change the entries in the who-line.") + +(* ;;; "If the user selects an item, and it has a when-selected-fn, funcall that fn.") + +(* ;;; "") + + (WITH-WHO-LINE WINDOW (TOTOPW WINDOW) (GETMOUSESTATE) - (if (OR (KEYDOWNP 'EDIT) + (if (OR (KEYDOWNP 'EDIT) (KEYDOWNP 'CTRL)) - then (WHO-LINE-CONTROL-SELECT) - else (bind (REGION _ (WINDOWPROP WINDOW 'REGION)) + then (WHO-LINE-CONTROL-SELECT) + else (bind (REGION _ (WINDOWPROP WINDOW 'REGION)) (ENTRIES _ (WINDOWPROP WINDOW 'ENTRIES)) - INVERTED-ITEM CURRENT-ITEM while (MOUSESTATE (NOT UP)) - do - (* ;; "") + INVERTED-ITEM CURRENT-ITEM while (MOUSESTATE (NOT UP)) + do + (* ;; "") - (* ;; "If cursor has left the window, quit tracking") + (* ;; "If cursor has left the window, quit tracking") - (* ;; "") + (* ;; "") - (if (NOT (INSIDEP REGION LASTMOUSEX LASTMOUSEY)) - then (SETQ CURRENT-ITEM NIL) + (if (NOT (INSIDEP REGION LASTMOUSEX LASTMOUSEY)) + then (SETQ CURRENT-ITEM NIL) (GO $$OUT)) - (* ;; "") - (* ;; "Find out what item we are currently on") + (* ;; "") - (* ;; "") + (* ;; "Find out what item we are currently on") - (SETQ CURRENT-ITEM (for ENTRY in ENTRIES - thereis (with WHO-LINE-ENTRY ENTRY + (* ;; "") + + [SETQ CURRENT-ITEM (for ENTRY in ENTRIES + thereis (with WHO-LINE-ENTRY ENTRY (AND (GEQ (LASTMOUSEX WINDOW) NAME-START) (LEQ (LASTMOUSEX WINDOW) VALUE-END) - (NOT (NULL WHEN-SELECTED-FN)))))) - (* ;; "") + (NOT (NULL WHEN-SELECTED-FN] - (* ;; "Invert the current choice") + (* ;; "") - (* ;; "") + (* ;; "Invert the current choice") - (if (NEQ INVERTED-ITEM CURRENT-ITEM) - then (if INVERTED-ITEM - then (INVERT-WHO-LINE-ENTRY INVERTED-ITEM WINDOW)) - (if CURRENT-ITEM - then (INVERT-WHO-LINE-ENTRY CURRENT-ITEM WINDOW)) + (* ;; "") + + (if (NEQ INVERTED-ITEM CURRENT-ITEM) + then (if INVERTED-ITEM + then (INVERT-WHO-LINE-ENTRY INVERTED-ITEM WINDOW)) + (if CURRENT-ITEM + then (INVERT-WHO-LINE-ENTRY CURRENT-ITEM WINDOW)) (SETQ INVERTED-ITEM CURRENT-ITEM)) - finally - (* ;; "") + finally - (* ;; "The button went up. If we were on an item, let it know") + (* ;; "") - (* ;; "") + (* ;; "The button went up. If we were on an item, let it know") - (if INVERTED-ITEM - then (INVERT-WHO-LINE-ENTRY INVERTED-ITEM WINDOW)) - (if CURRENT-ITEM - then (with WHO-LINE-ENTRY CURRENT-ITEM (if WHEN-SELECTED-FN - then (APPLY* + (* ;; "") + + (if INVERTED-ITEM + then (INVERT-WHO-LINE-ENTRY INVERTED-ITEM WINDOW)) + (if CURRENT-ITEM + then (with WHO-LINE-ENTRY CURRENT-ITEM (if WHEN-SELECTED-FN + then (APPLY* WHEN-SELECTED-FN ) - (EVAL RESET-FORM)))))) - ))) + (EVAL RESET-FORM]) (WHO-LINE-CONTROL-SELECT - [LAMBDA NIL (* ; "Edited 28-Dec-98 12:56 by rmk:") + [LAMBDA NIL (* ; "Edited 28-Dec-98 12:56 by rmk:") "Interactivly let the user add or delete an entry to the WHO-LINE." (CL:FLET [(ENTRY-DESCRIPTION (X) (OR (CL:SIXTH X) @@ -1531,58 +1783,56 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (:ADD (LET* [[ITEMS (for entry in *WHO-LINE-ENTRY-REGISTRY* unless (MEMBER entry *WHO-LINE-ENTRIES*) collect `(,(ENTRY-DESCRIPTION entry) - ',entry] + ',entry] (NEW-ENTRY (if ITEMS then (MENU (create MENU - ITEMS _ ITEMS - TITLE _ "Entry to add to WHO-LINE"] + ITEMS _ ITEMS + TITLE _ "Entry to add to WHO-LINE"] (if NEW-ENTRY then (SETQ *WHO-LINE-ENTRIES* (CONS NEW-ENTRY *WHO-LINE-ENTRIES*)) - (INSTALL-WHO-LINE-OPTIONS)))) + (INSTALL-WHO-LINE-OPTIONS)))) (:REMOVE (LET* [[ITEMS (for entry in *WHO-LINE-ENTRIES* collect `(,(ENTRY-DESCRIPTION entry) - ',entry] + ',entry] (BAD-ENTRY (if ITEMS then (MENU (create MENU - ITEMS _ ITEMS - TITLE _ - "Entry to remove from WHO-LINE"] + ITEMS _ ITEMS + TITLE _ + "Entry to remove from WHO-LINE"] (if BAD-ENTRY then (SETQ *WHO-LINE-ENTRIES* (CL:REMOVE BAD-ENTRY - *WHO-LINE-ENTRIES*)) - (INSTALL-WHO-LINE-OPTIONS)))))]) + *WHO-LINE-ENTRIES*)) + (INSTALL-WHO-LINE-OPTIONS)))))]) -(WHO-LINE-COPY-INSERT - (LAMBDA (X) (* ; "Edited 18-Mar-87 13:11 by smL") - (LET ((TTY-WINDOW (WFROMDS (PROCESS.TTY (TTY.PROCESS NIL))))) - (if (OR (IMAGEOBJP X) +(WHO-LINE-COPY-INSERT + [LAMBDA (X) (* ; "Edited 18-Mar-87 13:11 by smL") + (LET [(TTY-WINDOW (WFROMDS (PROCESS.TTY (TTY.PROCESS NIL] + (if [OR (IMAGEOBJP X) (AND (WINDOWP TTY-WINDOW) - (WINDOWPROP TTY-WINDOW 'COPYINSERTFN))) - then (COPYINSERT X) - else (BKSYSBUF X NIL))))) + (WINDOWPROP TTY-WINDOW 'COPYINSERTFN] + then (COPYINSERT X) + else (BKSYSBUF X NIL]) ) (DEFINEQ -(WHO-LINE-REDISPLAY-INTERRUPT - (LAMBDA NIL (* ; "Edited 20-Apr-87 11:32 by smL") +(WHO-LINE-REDISPLAY-INTERRUPT + [LAMBDA NIL (* ; "Edited 20-Apr-87 11:32 by smL") -(* ;;; "Update the current who-line window because the user has requested it via an interrupt.") +(* ;;; "Update the current who-line window because the user has requested it via an interrupt.") - (if (BOUNDP '*WHO-LINE*) - then - - (* ;; "Update the Who-Line, if it is available") + (if (BOUNDP '*WHO-LINE*) + then + (* ;; "Update the Who-Line, if it is available") - (WITH-AVAILABLE-WHO-LINE *WHO-LINE* (if (AND (OPENWP *WHO-LINE*) + (WITH-AVAILABLE-WHO-LINE *WHO-LINE* (if (AND (OPENWP *WHO-LINE*) (WINDOWPROP *WHO-LINE* 'VALID)) - then (* ; - "Flash the Who-line to let people know that it is being updated") + then (* ; + "Flash the Who-line to let people know that it is being updated") (CLOSEW *WHO-LINE*) (OPENW *WHO-LINE*) - (* ; "The update the entries") - (UPDATE-WHO-LINE *WHO-LINE* - (WINDOWPROP *WHO-LINE* 'ENTRIES))))) - )) + (* ; "The update the entries") + (UPDATE-WHO-LINE *WHO-LINE* + (WINDOWPROP *WHO-LINE* 'ENTRIES]) ) (DEFGLOBALVAR *WHO-LINE* NIL @@ -1679,25 +1929,24 @@ Copyright (c) 1986-1989, 1994, 1998, 2001, 2021, 2023 by Xerox Corporation. (PUTPROPS WHO-LINE FILETYPE :COMPILE-FILE) ) -(PUTPROPS WHO-LINE COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1989 1994 1998 2001 2021 2023)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (7838 23217 (INSTALL-WHO-LINE-OPTIONS 7848 . 23215)) (23493 24662 (WHO-LINE-USERNAME -23503 . 24150) (WHO-LINE-CHANGE-USER 24152 . 24458) (WHO-LINE-USER-AFTER-LOGIN 24460 . 24660)) (25470 -26206 (WHO-LINE-HOST-NAME 25480 . 26204)) (26906 30232 (CURRENT-TTY-PACKAGE 26916 . 27868) ( -SET-PACKAGE-INTERACTIVELY 27870 . 29986) (SET-TTY-PACKAGE-INTERACTIVELY 29988 . 30230)) (31132 32184 ( -CURRENT-TTY-READTABLE-NAME 31142 . 31396) (SET-READTABLE-INTERACTIVELY 31398 . 31932) ( -SET-TTY-READTABLE-INTERACTIVELY 31934 . 32182)) (32687 33259 (WHO-LINE-TTY-PROCESS 32697 . 32875) ( -CHANGE-TTY-PROCESS-INTERACTIVELY 32877 . 33257)) (33748 37557 (WHO-LINE-CURRENT-DIRECTORY 33758 . -35165) (SET-CONNECTED-DIRECTORY-INTERACTIVELY 35167 . 37555)) (38817 41270 (WHO-LINE-VMEM 38827 . -41017) (WHO-LINE-SAVE-VMEM 41019 . 41268)) (42132 43274 (WHO-LINE-SYMBOL-SPACE 42132 . 43274)) (44005 -45443 (WHO-LINE-TIME 44015 . 44757) (WHO-LINE-SET-TIME 44759 . 45441)) (46957 49590 ( -WHO-LINE-SHOW-ACTIVE 46967 . 47745) (\UPDATE-WHO-LINE-ACTIVE-FLAG 47747 . 48715) ( -\PERIODICALLY-WHO-LINE-SHOW-ACTIVE 48717 . 49588)) (50687 51612 (CURRENT-PROFILE 50697 . 50942) ( -SET-PROFILE-INTERACTIVELY 50944 . 51347) (SET-TTY-PROFILE-INTERACTIVELY 51349 . 51610)) (52162 54145 ( -WHO-LINE-TTY-STATE 52172 . 53333) (WHO-LINE-WHAT-IS-RUNNING 53335 . 54143)) (57628 70754 ( -REDISPLAY-WHO-LINE 57638 . 60198) (PERIODICALLY-UPDATE-WHO-LINE 60200 . 61338) (SETUP-WHOLINE-TIMER -61340 . 61558) (UPDATE-WHO-LINE 61560 . 64628) (WHEN-WHO-LINE-SELECTED-FN 64630 . 67897) ( -WHO-LINE-CONTROL-SELECT 67899 . 70358) (WHO-LINE-COPY-INSERT 70360 . 70752)) (70755 71889 ( -WHO-LINE-REDISPLAY-INTERRUPT 70765 . 71887)) (72291 72677 (INVERT-WHO-LINE-ENTRY 72291 . 72677)) ( -72981 73153 (WITH-WHO-LINE 72981 . 73153)) (73155 74399 (WITH-AVAILABLE-WHO-LINE 73155 . 74399))))) + (FILEMAP (NIL (7720 23538 (INSTALL-WHO-LINE-OPTIONS 7730 . 23536)) (23814 25183 (WHO-LINE-USERNAME +23824 . 24484) (WHO-LINE-CHANGE-USER 24486 . 24970) (WHO-LINE-USER-AFTER-LOGIN 24972 . 25181)) (25991 +26727 (WHO-LINE-HOST-NAME 26001 . 26725)) (27427 31018 (CURRENT-TTY-PACKAGE 27437 . 28384) ( +SET-PACKAGE-INTERACTIVELY 28386 . 30678) (SET-TTY-PACKAGE-INTERACTIVELY 30680 . 31016)) (31918 34010 ( +CURRENT-TTY-READTABLE-NAME 31928 . 32296) (SET-READTABLE-INTERACTIVELY 32298 . 33664) ( +SET-TTY-READTABLE-INTERACTIVELY 33666 . 34008)) (34513 35645 (WHO-LINE-TTY-PROCESS 34523 . 34780) ( +CHANGE-TTY-PROCESS-INTERACTIVELY 34782 . 35643)) (36134 40848 (WHO-LINE-CURRENT-DIRECTORY 36144 . +38456) (SET-CONNECTED-DIRECTORY-INTERACTIVELY 38458 . 40846)) (42108 44728 (WHO-LINE-VMEM 42118 . +44297) (WHO-LINE-SAVE-VMEM 44299 . 44726)) (45590 46732 (WHO-LINE-SYMBOL-SPACE 45590 . 46732)) (47463 +49332 (WHO-LINE-TIME 47473 . 48636) (WHO-LINE-SET-TIME 48638 . 49330)) (50846 54003 ( +WHO-LINE-SHOW-ACTIVE 50856 . 51645) (\UPDATE-WHO-LINE-ACTIVE-FLAG 51647 . 52657) ( +\PERIODICALLY-WHO-LINE-SHOW-ACTIVE 52659 . 54001)) (55100 56594 (CURRENT-PROFILE 55110 . 55455) ( +SET-PROFILE-INTERACTIVELY 55457 . 56231) (SET-TTY-PROFILE-INTERACTIVELY 56233 . 56592)) (57144 59497 ( +WHO-LINE-TTY-STATE 57154 . 58349) (WHO-LINE-WHAT-IS-RUNNING 58351 . 59495)) (62980 76528 ( +REDISPLAY-WHO-LINE 62990 . 65585) (PERIODICALLY-UPDATE-WHO-LINE 65587 . 66741) (SETUP-WHOLINE-TIMER +66743 . 66972) (UPDATE-WHO-LINE 66974 . 70234) (WHEN-WHO-LINE-SELECTED-FN 70236 . 73686) ( +WHO-LINE-CONTROL-SELECT 73688 . 76117) (WHO-LINE-COPY-INSERT 76119 . 76526)) (76529 77701 ( +WHO-LINE-REDISPLAY-INTERRUPT 76539 . 77699)) (78103 78489 (INVERT-WHO-LINE-ENTRY 78103 . 78489)) ( +78793 78965 (WITH-WHO-LINE 78793 . 78965)) (78967 80211 (WITH-AVAILABLE-WHO-LINE 78967 . 80211))))) STOP diff --git a/lispusers/WHO-LINE.DFASL b/lispusers/WHO-LINE.DFASL index 9ab904e6d5cc42a4087f330212e334690017568e..89e5c1da0cd2d5b655253980979996ef5c538b47 100644 GIT binary patch delta 6487 zcma)B3shCtnLhiR3l}b+fV|`(7b7M?k*ALk1uvHa9Ju$Mn|lu+iadfS5=93w4-LIY zOq7HgWhds6#7;2B;3lia2h=|7bfw8OV>23KyCycquG&mvXC}4Dw9Nni8#qZb zS!-OZyTAQE&))mr|No!kTgT*|d{aJL-@L-+-?6)=y~DnF>$VPidrwDOZ^tHk!HQgW zTTgCbeqph_ps*x=RY_s7t1hE;V!^{hR;Nq%*ZI^SXZSZ1>C*g0Zec;; z@^bWZE%@Y6RK3Ghr}}e|gS0Ebr-!Uf?)sVe#Sx&gmB>1eQ2K9#r%md2P51)nMppQ} zPTvC6VW=qhZ6HOLYlhna)EVM8_&;PM<_wWy6-xD(HabDUR;hc8YE`SMrblY$qZ#u9 zhAFOsOccsgsD7vFA)&Rz*3jBwV2Asw9bUBor&+`)0cbfs>&No-S*W}Q@^gect+GM$ zROqOuybR=+Ce4Ez*q{Yw$j_6a8zl}AtVTFU5Zx;em{hSYqPC*72Cc%V{=APy)0i6s z!c?D6_o0z$(_R`dEbf5n#xs-uI?Ir6nD8>lM0$0#Y=mSQSp$6RETv)m4z|#+V(BwA*-$oZH7sC>{bg~jXmX3mqVzI{5 zxtpl#QFet%EdWc=!cw_z7&>`cI?abO2#ZGnKinnNW3C|z?s_=h1QpL9Ov34`y5$q{ z)C3&MAAzG7I-a`a-*HjG(#)DI?~>?7WWPzU72$c%3iD}I0lJTtQ!ur-)Jj~Z zn&cN}^^{{K+)o0ywTfw2*$zG9$RsOT)4yItQI$sB9l0B;1(I) z0*2-PoYj>-G^y{K)L)uZdU#>tb(8w4DZ9m_()AFsbtaW=iWIc zTDRtcVxc;9PX#}J+bCPlA6R5(n|W}NJ!#8cVRI)9H|`_-PX5*+FRSC3*-O}6yf*u` z#H1jXiPb{C&EQOag+G#=z4~B~TZksohFE1gQQGj4{wp}d90-0r114qw=O2KBvQX^e zg%Rv(sAyR_vlQv+j2n5m>}Px+uXRb`7Kl|T5`V_$>vs^?fioNa&@^_M9172mVC!Ph z)nzD~HqDdkbvSDsRT$b#WZSn9(!G&BL-^11oWDdU5-$m0YO?vE3>Z*oC|R=;+*@#< zWE2=-#6S%Z#0L;kreOyW`pD#97~&tpO0lf54Lq)}gO%~P)pq_&VFHWc-zyxj2H}$G zx;M0}=zWD{@z|ATNF;~zXhm?Tc3EXWo3BX>^|e;NJS z`L9YB53kJPSMDyR^^{wi zh#uhIDlP~;u{uSD{Wwv&oHg^yr5UV+-zt52sTF*%M_a*>6vw2vSQZy6$HgkuFKE_i zHd;{4;+Vxn=gnRGR9O~#gI_62Q8!MwDI5~wCp~~kKfywnA}7KAIh;P}Ios9M9hic@ z&Q$m};cl5T>Gtrym81qpHM9AwXU3j;f)LSD&w4=8;|A0E9Pso1x1C@E4SMc47OBUN zZ`9+-EXD8mYO;=O{x56OML)?uTDw-+DqDEIWAW`H+fZ->54xW=arwSExKn#EHk_Uc zjY|41{-h(V3LCQ+I19JesMLK8x(}-_qZ}n;!C;i5*ad`?YZx9myBpNPoi5ek!ve_i z_)SMzAf22&1_bFOLb@)}OM)sIz2B9>Ewi{Be!~tHAY1uVr=j~AFQ@o=*Z9HZnXW65AtVdY)u>MtV$UZCK`l0G7jc(J5QBi%UskSK!)4-!1^u#nj~ z(!D|OL^=OR8|h{v-EloUp(y8$?(UBEUVHD3 zl1)6)xj>dmcveMH`1e{tL*fqS0wp+f8!u=`=0naHZqqWe!*a;+vFwrV%#rRCSZa(* zuhKl#y5Goyjfo!Vmh<=<&J(Pi@2uFsHimvtF&4&>`PXX7tWuva{KJ|DMY$VRzz-fd z>sLBqkHg_K-45ekFl(vQ*7=%%CTHhad(o-%lq!bRVki{DZDNQM0|QlClcRUX_R1dD zu3qK}9k1OfM(cJ5vLcCT77U(n%~P-X3=wY)i%4foWWRbISN|}($Pd*oWS2u@^{+8@F|=h} zKMeeLjeRUCw0ZqH##Zym4Xsea>`nV1B|hKu8y2}j7THwggUvb28+x@lkwti^gHxJA zZ@0{onZd8MEo7ykh*pZPq4@KGXeX#Md!J`Z({l@SENqln0v-X5) z)+mdAohg&m^2yOZ7?g)ZD%r{R?9AZ7og)EZrPRVCk&mHJeDUS7s3;vx?;&qagk1gi5MQ>%v9 zMTK4sCse4F&pgOxnuv`mvC&nu8?1_!z>EkXVne~oBCrwWb!hZ<%4pdNhM)8%GE|=f z8Z7eoo!&ztWOAi&pj>YWBND%HmpI78+Ub<&-psN+^ zODD}HyYcGPtEaYEwQbgG@1DM|_WJ3r+UlAgUHkY*SO0wu0)Lrpj{>=z#j4G4@jD>kaXQe;$6iA%2S#13b!JCp*t{p5ouxb4SWwYFkl*exeYa z=sYzh{kEE4-%}rT%2o66@R+pEHNJ))+`F{SHJuOHki+2F+-n8T;D@)0P8YvYaz5&BpCBh*mOdPiA7Sb*6T$oij<3 zSZO*g#Q~H?e)VN4OoXGB%jqng_$^0XPKS-JDRMSMK)A!}bv0t!!fp}=W01XULVAN! zh)Qiac4lt9&abXRLAn=~2!PUcux7=V{t6X8Gf;e4n=03s(~dc4cBAn z@R_4Q?99wfhyf`EcW@145K6uOgn9x}jS@HFD(Ks0*Vl+{e@zZ(eW&@6zJwJ>oX(`! zN?4qR&xK8BOcN@?pV8PR*z@AEl|Qv@#g|pDpF)6I6V6)x44)Rg7j%DsDGi8r+1$J z8OZ`C>?SsPJ{1cmPOtEj{ducC!H1GQM8Y3Tcm^T0$Ba^tc<&r0>L9W<^2~k1@X9*A zuZLyw?15Em0dF2C4yWL$=fQyz$PgC>mP8{#9GfMd+a7rt((LPxJTqG)idXRZ{h1Ml zs16$M+dmw*o7|K_(q@Fd)Lay=jJTILPElSfsJu$IM6J@OQ)2$xVc+4UL-(rqO-WO^VpurBAAd9oK1>{abXkUYlFyY7Y?wuyD>p*#KYEkRjiL&y zM2QwGiobv0C|k#uJzmJadoYP5@pA`DS?lm%+M>V0<3x&&da9=aomo2ir~6xpim;N* z%LWgD_FIE3Y!}%0*X-@#OGvVNF%B$A6s&XPlO>T)%dSxN6Y)&mZ{c~5=ku*Y^VkjE zHarjn1H+*2#=6JjJYPm%t>Y@GjoQSlS~2wNq}4?6cPvl zMFNvRL4r|{jhMJZyKXH@tF46bc8Q?D-fDYo?e!|6Sg&4tt9Ie4tMsl~7Pq~*-}mh# z2fO^I>&}|B_iul%{rdK|zkPoCg#4@1^6}=jN?W*Rckiaol7H;l)>*Qtx3iy#eK?RkrTrirA>i| zC*UdzhBRGu>ZPO587og?5*s-_Y<2pya8pPf;SB%7=7#0VR;^f#tsrD5zw(6kND4AbFEd2?^UYa6H=4TA}6euUV!a-+9b?7R}JqeW5 z)gImNxP|x_Z!5|vy`S{lD7Ditu>}-t^;$r8tDXio4QV5PqG(n;Y>2x+CIw|&YS^g; zNT`M73xIW6i5;NnF* z@hS3?q!>U6F#`|6BSgjSl|F(*?J=n9(OSgg(%rZA(QFv=f`C~Kg|rYFQ4P(Rz%cpa zsvq}EzB$d1e`mn=Kqfh;g+01Q3j|T_ZG(ACb2^ji}&!lEf3m zgK_V-0h-^!l>)c*xUlsL5}!aw6O{}O+K|A=V|&OG_2mHuk})tW|6y7|{x5`#s2>^B zHw`KcUYPi?K^-$>Hyczs9zr%`Q0b&dadd6D#vrenHo?{sbqkK9$)LK4iYvjK26ZLO zFx}+|2Yrs#GF*{xElMmmByK188B&YLgoMzVB`|;U_OomqKQOn1ZQ)Ns8RM7cX0tB- z?%W`2=JV$*Vk>!Q-t9SABU~nxb}HMzi2NKsHg8_d;Sp{k+9oPDP$`ySBX)ItWSBV+ zd@uzrOo8M43+SLOkvD%%68kVwy`+$tE3`ru2glCe0Kt1XmS z4?-IjM9k0@vP9OhB(^#oJGl%Oq0JL03p$*Qjs|pACc?`9Abgz$_ZGq*!^+vh5W;o1 zBq-3b@AF;D@2egIhM5>Bc9=BoL%5gVQH0_K8!{t)6=s815{$Z{ypz@O$I2^MD*w0g zgNc?EpD3(^SFgGV1r>kd~O1-R=pRb(=i01pH(9@O#DAmOk#| z?R9hF7XwpX33M!t&C(7Z=7gJ za7mgRb~%#G3mkPyOg8fkj`?>eHrSk0*c*RP7s<`&HXDs!<+%w z30(GW{;Z>*VH42OgmS$WifAFcbA>0%QH0`hdk3M5jG_OqJ3!6i^r?;zrc!JfPg`9O z7m?%$5Tx@cD&gspo+GUz6tvjyYQZT?K1W!e4Hh6qO*#d-NH7geMS-s9dMjeOO=XN1 z(oM30CrS#AsuM#Cbgm_2@?iWHkN4ukhhJsZ6-aFdOM!V^V){YG4ID5Lg zJ2&-}^!1c%?&<~9)4R6>%&S(vTh}&FGv5owB*E$wWq^M(NmdjuE)+%gom@AF<#1#e1*rJZUp6&I$zFm}= zN+*=b-Dd;JW>{_uY^>j*ZvatKy{9GA0yKHvQp*lp5$Plye(7YDXe|*{v8d8S#oQyq zrUNTn^Kc?kE*%pr__d0(gvIBVS#ClPbTQLs($!BBuWBdRj4N|cRerC4s`nF{*K{!J z2h{j=;+LTr%=hKw-62m>r-Ixw)aMhE_lJB1;~z}Y<*Bb%Lu$aO)=Wyu@4ocz8k>TmpIzZ^ zHP2yJ6aU@(&x~D3Jkv4&6)#=8pV<;muWe!MPR^q3tcq`p4nhF_ZS*6STq%o~?c%@K zP|DUMzS@w(lGZFnwn&9n8 zcHw%u<=MHa5Y3Cbg96Dm6cV|92f-UCu#Qyei4cGtvBHaTGOcDJp&`~PV3~vP4q1*m zOK|J_F|AqEHEdG`!|)Y0nZdXbrjzAHfRhmeElFQY_a}XfP1cs3Y;|*&~A*ZUh235)|S*5ql8fs=_%%b(q|-rdeUWrMEx1TE~GwX2pl1}y$`ee)jmjp zg!8>D{APQDU{_mOFY||X^};>>%7G$Y+_%eupBbu_^T+$< z=QdT41uvaHRx@?}-tT+Z^&8^UvTt;ks&dmxNq(ZKT4Z5P0o8q4JQZ#06v7+t;sKeak0<0;CT3#E{>Q{gbbI{?T*C?YY zE4gUzO=PGc2jpqg;|Cs6+g?Le%TlV=&Y>#GKi&(eHf`#{dn;hI*56x{E1dV%h#{LJ zb_yA1?oD@6WT3pH(&5H)wcQgF5qqO7v#n4-h49@NSxmE{-Z;^L z)t26tK84xCv4O6c|Dtd5-HnMcQV6v zTpD-B^0(Hdj}tdTn)E)g)V0aqd_F4Bao7ZH6@^pb!8eim8`x%xBN+6xmSXcc6jDf@ zqKkm!KM3K=!aJZ~!_3RCHHB3SEh29+SrI+~Tq{21T`EPr?_fJxzg7)tL3~)JHK;-{ ztizYTb{djbgua0ImZjDqQMy?T(n*bKD?Om-2%A!7$B}2U6#&noYw&?0@^zn10X92B zb3i9%bXkx;v)R*BX%y6rDYRmDC&{q27dRQylUv;cUseKPaa<#nz)Lqd^^k7?Ad~9y z=+kaLpIH;19$3aouC#+Oc!VTpX4o<_QZh4AHTxMY+nUABIy5^xX(|S)*?HbG@L_7M ztiVTEihnEly1}BnzmCqvG5-;Bt&r-6D+-(c!5ifpF|IB3R42Uj8ul%EE^+8 z??+A$vsku)e>Hdlo}NPodsz|x%fTvE$SV(3SQa8P!g~%?!>Rqjp+%`k5IL`D3IF8K zk09(F|IVW#I#==Khl`V%L|FFnmcu9FcTg9#5I`BBuU+3&cO-2js!MFFN_U!cLtGHv za^mT@h>-egVKpM+wRbXJC#@!d2&FI5gh(hS=(#6NP`r`&_9IpZ<-3n8DH0>OC6q%V zF~CGDzLvOj1p}SzAJ{~HV`xh8fviPc| z2I!e$+B7hkUrKcSDY^W%V-JG*50AC6onYkcdEd4yLi?s|^J(0<;`X>iow8i&)U-2U z8n!d}poyp7zl^&d$YR%c^nqe_jQ2kD;{$ag+i$oBIG zA8eD0lKAya`FuyInLl*2FiyLq^rw==b8K|BB-=63&BduXwO}iJpL6RY+%__t+0xnD zb5Du0r*}tBZ%1EO4?cpdKf&T(u=pt!uVL{97Qe#c-?8`