diff --git a/library/SAMEDIR b/library/SAMEDIR index 1ff27939..1b1e67fa 100644 --- a/library/SAMEDIR +++ b/library/SAMEDIR @@ -1,15 +1,13 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10) -(FILECREATED "31-Oct-2022 13:09:14" {WMEDLEY}SAMEDIR.;4 6221 +(FILECREATED "27-Apr-2026 21:18:26" {WMEDLEY}SAMEDIR.;6 6540 - :CHANGES-TO (FNS CHECKSAMEDIR HOST&DIRECTORYFIELD) + :EDIT-BY rmk - :PREVIOUS-DATE "25-Apr-2022 09:23:16" {WMEDLEY}SAMEDIR.;3) + :CHANGES-TO (FNS CHECKSAMEDIR) + :PREVIOUS-DATE "31-Oct-2022 13:09:14" {MEDLEY}SAMEDIR.;4) -(* ; " -Copyright (c) 1982, 1984-1987, 1990, 2018, 2020 by Venue & Xerox Corporation. -") (PRETTYCOMPRINT SAMEDIRCOMS) @@ -24,7 +22,8 @@ Copyright (c) 1982, 1984-1987, 1990, 2018, 2020 by Venue & Xerox Corporation. (DEFINEQ (CHECKSAMEDIR - [LAMBDA (FILE) (* ; "Edited 31-Oct-2022 13:08 by rmk") + [LAMBDA (FILE) (* ; "Edited 27-Apr-2026 21:18 by rmk") + (* ; "Edited 31-Oct-2022 13:08 by rmk") (* ; "Edited 25-Apr-2022 09:16 by rmk") (* ; "Edited 1-Sep-2020 11:40 by rmk:") @@ -32,70 +31,75 @@ Copyright (c) 1982, 1984-1987, 1990, 2018, 2020 by Venue & Xerox Corporation. (* ;; " OKHOST/DIRS is a list of places it's OK for the file to be winding up, so if your'e migrating code from one place ot another, you can do it gracefully.") + (* ;; + "MIGRATIONS may be provided as a global variable, to suppress the askusers. See documentation. ") + [RESETSAVE (DIRECTORYNAME T) - '(PROGN (CNDIR OLDVALUE] (* ; + '(PROGN (CNDIR OLDVALUE] + (SETQ FILE (ROOTFILENAME FILE)) (* ;  "Assumes that MAKEFILE has RESETLST") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) - (DATES (GET (SETQ FILE (ROOTFILENAME FILE)) - 'FILEDATES)) - HOST/DIR HOST DIR NEWV OKHOST/DIRS) + [OLDFILE (CDAR (LISTP (GET FILE 'FILEDATES] + PREVPDIRS HOST/DIR NEWV OKHOST/DIRS OLDDIR) + (CL:UNLESS OLDFILE (RETURN)) + + (* ;; "Only the first previor location matters. If we moved it, we don't want to move it back.") + + (SETQ OLDDIR (HOST&DIRECTORYFIELD OLDFILE)) + + (* ;; "PREVPDIRS is a list of all possible pseudohost synonyms for the previous location of FILE. Use HOST&DIRECTORYFIELD to canonicalize both file and connected directory") + + (SETQ PREVPDIRS (PSEUDOFILENAMES OLDDIR)) (* ; + "Any pseudohost or migrating pseudohost is good") + (SETQ OKHOST/DIRS (APPEND (for M in MIGRATIONS when (CL:MEMBER (CAR M) + PREVPDIRS :TEST + (FUNCTION STRING-EQUAL)) + collect (CDR M)) + PREVPDIRS)) AGAIN - (OR (LISTP DATES) - (RETURN)) (* ; - "RMK: Use HOST&DIRECTORYFIELD to canonicalize both file and connected directory") - [SETQ OKHOST/DIRS (CONS (SETQ HOST/DIR (HOST&DIRECTORYFIELD (DIRECTORYNAME T))) - (MKLIST (CDR (OR (ASSOC HOST/DIR MIGRATIONS :TEST 'STRING-EQUAL) - (ASSOC (TRUEFILENAME HOST/DIR) - MIGRATIONS :TEST 'STRING-EQUAL) - (ASSOC (PSEUDOFILENAME HOST/DIR) - MIGRATIONS :TEST 'STRING-EQUAL] - (COND - ([for OLDFILE in DATES bind HOST DIR - never (OR (CL:MEMBER (HOST&DIRECTORYFIELD (CDR OLDFILE)) - OKHOST/DIRS :TEST 'STRING-EQUAL) - (CL:MEMBER (TRUEFILENAME (HOST&DIRECTORYFIELD (CDR OLDFILE))) - OKHOST/DIRS :TEST 'STRING-EQUAL) - (CL:MEMBER (PSEUDOFILENAME (HOST&DIRECTORYFIELD (CDR OLDFILE))) - OKHOST/DIRS :TEST 'STRING-EQUAL] + (* ; "Come here on new directory") + (SETQ HOST/DIR (DIRECTORYNAME T)) (* ; + "Current directory, maybe newly connected") + (if (NOT (CL:MEMBER HOST/DIR OKHOST/DIRS :TEST (FUNCTION STRING-EQUAL))) + then + (* ;; "The file would go somewhere new. Is that what the user really wants?") - (* ;; "The file is going somewhere it has never been before. ") + (SELECTQ (ASKUSER SAMEDIRWAIT SAMEDIRDEFAULT (LIST "You haven't loaded or written" + FILE + "in your connected directory" + HOST/DIR + "-- write it out anyway") + `[[O ,(CONCAT "Oops! Make file on " (SETQ HOST/DIR OLDDIR] + (C "Make file on other directory: ") + (Y ,(CONCAT "Yes, write it here") + (CHARACTER (CHARCODE EOL))) + (N ,(CONCAT "No, abort MAKEFILE") + (CHARACTER (CHARCODE EOL] + NIL NIL '(NOECHOFLG T)) + (Y (RETURN)) + (N (ERROR!)) + (C (SETQ HOST/DIR NIL)) + (O (* ; + "Choose DATE directory above, switch in NLSETQ below, switch back in RESETSAVE above") + (TERPRI T)) + (SHOULDNT)) + (CL:WHEN [NLSETQ (CNDIR (OR HOST/DIR (READ T T] + (RETURN)) + (GO AGAIN) + elseif (AND (SETQ NEWV (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY OLDFILE))) + (NOT (STRING-EQUAL NEWV OLDFILE))) + then + (* ;; "A newer version appeared while the user was editing this file.") - (* ;; "Check that that is really what the user wants.") + (* ;; "Ask if he should over-write it.") - (SELECTQ (ASKUSER SAMEDIRWAIT SAMEDIRDEFAULT (LIST "You haven't loaded or written" FILE - "in your connected directory" - HOST/DIR "-- write it out anyway") - `[[O ,(CONCAT "Oops! Make file on " (SETQ HOST/DIR ( - HOST&DIRECTORYFIELD - (CDAR DATES] - (C "Make file on other directory: ") - (Y ,(CONCAT "Yes, write it here") - (CHARACTER (CHARCODE EOL))) - (N ,(CONCAT "No, abort MAKEFILE") - (CHARACTER (CHARCODE EOL] - NIL NIL '(NOECHOFLG T)) - (Y (RETURN)) - (N (ERROR!)) - (C (SETQ HOST/DIR)) - (O (TERPRI T)) - (SHOULDNT)) - [NLSETQ (CNDIR (OR HOST/DIR (READ T T] - (GO AGAIN)) - ([AND [SETQ NEWV (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY (CDAR DATES] - (NOT (STRING-EQUAL NEWV (CDAR DATES] - - (* ;; "A newer version appeared while the user was editing this file.") - - (* ;; "Ask if he should over-write it.") - - (SELECTQ (ASKUSER 15 'Y (LIST (CDAR DATES) - "is not the most recent version (version" - (FILENAMEFIELD.STRING NEWV 'VERSION) - "has since appeared)." - "Do you want to make the file anyway")) - (Y) - (N (ERROR!)) - (SHOULDNT]) + (SELECTQ (ASKUSER 15 'Y (LIST OLDFILE "is not the most recent version (version" + (FILENAMEFIELD.STRING NEWV 'VERSION) + "has since appeared)." + "Do you want to make the file anyway")) + (Y) + (N (ERROR!)) + (SHOULDNT]) (HOST&DIRECTORYFIELD [LAMBDA (FILENAME) (* ; "Edited 31-Oct-2022 13:03 by rmk") @@ -120,7 +124,6 @@ Copyright (c) 1982, 1984-1987, 1990, 2018, 2020 by Venue & Xerox Corporation. (GLOBALVARS MIGRATIONS) ) -(PUTPROPS SAMEDIR COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1985 1986 1987 1990 2018 2020)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (731 5838 (CHECKSAMEDIR 741 . 5249) (HOST&DIRECTORYFIELD 5251 . 5836))))) + (FILEMAP (NIL (641 6256 (CHECKSAMEDIR 651 . 5667) (HOST&DIRECTORYFIELD 5669 . 6254))))) STOP diff --git a/library/SAMEDIR.LCOM b/library/SAMEDIR.LCOM index 3185b143..32bfbbfe 100644 Binary files a/library/SAMEDIR.LCOM and b/library/SAMEDIR.LCOM differ