(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)


(FILECREATED "27-Apr-2026 21:18:26" {WMEDLEY}<library>SAMEDIR.;6
 6540   

      :EDIT-BY rmk

      :CHANGES-TO (FNS CHECKSAMEDIR)

      :PREVIOUS-DATE "31-Oct-2022 13:09:14" {MEDLEY}<library>SAMEDIR.;4)


(PRETTYCOMPRINT SAMEDIRCOMS)

(RPAQQ SAMEDIRCOMS

       ((FNS CHECKSAMEDIR HOST&DIRECTORYFIELD)
        (INITVARS (SAMEDIRWAIT 10)
               (SAMEDIRDEFAULT 'O))
        (ADDVARS [MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE))
                                    (RETFROM 'MAKEFILE]
               (MIGRATIONS))
        (GLOBALVARS MIGRATIONS)))
(DEFINEQ

(CHECKSAMEDIR

  [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:")


    (* ;; "Check (a) that we are writing FILE to the same directory we last read/wrote it and (b) that a version newer than the current one has not since appeared.")


    (* ;; " 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]
    (SETQ FILE (ROOTFILENAME FILE))                          (* ; 

                                                             "Assumes that MAKEFILE has  RESETLST")

    (PROG ((*UPPER-CASE-FILE-NAMES* NIL)
           [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
                                                             (* ; "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?")


                   (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.")


                   (* ;; "Ask if he should over-write it.")


                   (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")


                                                             (* ; "Edited 25-Apr-2022 09:22 by rmk")


                                                            (* ; "Edited 15-Apr-2018 19:05 by rmk:")

    (PACKFILENAME.STRING 'DEVICE (U-CASE (FILENAMEFIELD.STRING FILENAME 'DEVICE))
           'HOST
           (U-CASE (FILENAMEFIELD.STRING FILENAME 'HOST))
           'DIRECTORY
           (FILENAMEFIELD.STRING FILENAME 'DIRECTORY])
)

(RPAQ? SAMEDIRWAIT
 10)

(RPAQ? SAMEDIRDEFAULT
 'O)

(ADDTOVAR MAKEFILEFORMS
 (OR (NLSETQ (CHECKSAMEDIR FILE))
                            (RETFROM 'MAKEFILE)))

(ADDTOVAR MIGRATIONS
 )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS MIGRATIONS)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (641 6256 (CHECKSAMEDIR 651 . 5667) (HOST&DIRECTORYFIELD 5669 . 6254)))))
STOP