;;;-*- Mode:LISP; Package:USER -*-

;;; A useful function for this file
(DEFUN MAKE-SYS-HOST (NAME PHYSICAL-HOST)
  (SETQ PHYSICAL-HOST (FS:GET-PATHNAME-HOST PHYSICAL-HOST))
  (FS:ADD-LOGICAL-PATHNAME-HOST NAME PHYSICAL-HOST
				(SELECTQ (SI:HOST-SYSTEM-TYPE PHYSICAL-HOST)
				  (:ITS SI:ITS-LOGICAL-PATHNAME-TRANSLATIONS)
				  (:TENEX SI:SCRC-LOGICAL-PATHNAME-TRANSLATIONS)
				  (:LISPM SI:LISPM-LOGICAL-PATHNAME-TRANSLATIONS)
				  (OTHERWISE (FERROR NIL "Unknown translation type")))))

;;; Automatic bidirectional mover and merger
(DEFSTRUCT (FILE :LIST :CONC-NAME)
  GENERAL-FILE
  PATHNAME-1
  PATHNAME-2
  PLIST-1
  PLIST-2
  DIRECTORY-1
  DIRECTORY-2)

(DEFUN UPDATE-SYSTEM (SYSTEM HOST-1 HOST-2)
  (UPDATE-FILES (SYSTEM-FILES SYSTEM) HOST-1 HOST-2))

(DEFUN UPDATE-SINGLE-FILE (FILE HOST-1 HOST-2)
  (UPDATE-FILES (LIST (MAKE-FILE GENERAL-FILE (FS:PARSE-PATHNAME FILE)))
		HOST-1 HOST-2))

(DEFUN UPDATE-SINGLE-DIRECTORY (WILD-PATHNAME HOST-1 HOST-2)
  (SETQ WILD-PATHNAME (FS:MERGE-PATHNAME-DEFAULTS WILD-PATHNAME
			(FUNCALL (FS:USER-HOMEDIR) ':NEW-NAME ':WILD) ':WILD))
  (UPDATE-FILES (LOOP FOR (X) IN (CDR (FS:DIRECTORY-LIST WILD-PATHNAME ':NO-EXTRA-INFO))
		      COLLECT (MAKE-FILE GENERAL-FILE X))
		HOST-1 HOST-2))

(DEFUN SYSTEM-FILES (SYSTEM)
  (LOOP FOR FILE IN (SI:SYSTEM-SOURCE-FILES SYSTEM)
	COLLECT (MAKE-FILE GENERAL-FILE FILE)))

(DEFUN UPDATE-FILES (FILES HOST-1 HOST-2)
  (SET-FILE-HOSTS FILES HOST-1 HOST-2)
  (UPDATE-FILES-1 FILES))

(DEFUN UPDATE-FILES-1 (FILES)
  (GET-FILE-PLISTS FILES)
  (LOOP FOR FILE IN FILES
	WHEN (NOT (COMPARE-FILE-INFO (FILE-PLIST-1 FILE) (FILE-PLIST-2 FILE)))
	DO (UPDATE-FILE FILE)))

(DEFUN SET-FILE-HOSTS (FILES HOST-1 HOST-2)
  (SETQ HOST-1 (OR (FS:GET-PATHNAME-HOST HOST-1)
		      (FERROR NIL "No host named ~A" HOST-1)))
  (SETQ HOST-2 (OR (FS:GET-PATHNAME-HOST HOST-2)
		      (FERROR NIL "No host named ~A" HOST-2)))
  (LOOP FOR FILE IN FILES
	AS GENERAL-FILE = (FILE-GENERAL-FILE FILE)
	DO (SETF (FILE-PATHNAME-1 FILE) (FUNCALL (FUNCALL GENERAL-FILE ':NEW-PATHNAME
							  ':HOST HOST-1)
						 ':TRANSLATED-PATHNAME))
	   (SETF (FILE-PATHNAME-2 FILE) (FUNCALL (FUNCALL GENERAL-FILE ':NEW-PATHNAME
							  ':HOST HOST-2)
						 ':TRANSLATED-PATHNAME))))

(DEFUN GET-FILE-PLISTS (FILES)
  (LET* ((PATHS (NCONC (LOOP FOR FILE IN FILES COLLECT (FILE-PATHNAME-1 FILE))
		       (LOOP FOR FILE IN FILES COLLECT (FILE-PATHNAME-2 FILE))))
	 (PLISTS (FS:MULTIPLE-FILE-PLISTS PATHS)))
    (LOOP FOR FILE IN FILES
	  DO (SETF (FILE-PLIST-1 FILE) (OR (ASSQ (FILE-PATHNAME-1 FILE) PLISTS)
					   (FERROR NIL "No plist found for ~A" 
						   (FILE-PATHNAME-1 FILE))))
	     (SETF (FILE-PLIST-2 FILE) (OR (ASSQ (FILE-PATHNAME-2 FILE) PLISTS)
					   (FERROR NIL "No plist found for ~A" 
						   (FILE-PATHNAME-2 FILE)))))))

;;; This works with either a MULTIPLE-FILE-PLISTS or DIRECTORY-LIST type entry.
;;; These EQUAL's should be EQL's when that exists.
(DEFUN COMPARE-FILE-INFO (PLIST-1 PLIST-2)
  (AND (LET ((TRUE-1 (OR (GET PLIST-1 ':TRUENAME) (CAR PLIST-1)))
	     (TRUE-2 (OR (GET PLIST-2 ':TRUENAME) (CAR PLIST-2))))
	 (AND TRUE-1 TRUE-2
	      (EQUAL (FUNCALL TRUE-1 ':VERSION) (FUNCALL TRUE-2 ':VERSION))))
       (EQUAL (GET PLIST-1 ':CREATION-DATE)
	      (GET PLIST-2 ':CREATION-DATE))))

(DEFUN UPDATE-FILE (FILE)
  (GET-FILE-DIRECTORIES FILE)
  (LET ((NEWEST-1 (GET-NEWEST-FILE (FILE-DIRECTORY-1 FILE) (FILE-PATHNAME-1 FILE)))
	(NEWEST-2 (GET-NEWEST-FILE (FILE-DIRECTORY-2 FILE) (FILE-PATHNAME-2 FILE))))
    (LET ((VERSION-1 (IF (NULL NEWEST-1) 0 (FUNCALL (CAR NEWEST-1) ':VERSION)))
	  (VERSION-2 (IF (NULL NEWEST-2) 0 (FUNCALL (CAR NEWEST-2) ':VERSION))))
      (COND ((> VERSION-2 VERSION-1)
	     (SWAPF VERSION-1 VERSION-2)
	     (SWAPF NEWEST-1 NEWEST-2)
	     (SWAPF (FILE-PATHNAME-1 FILE) (FILE-PATHNAME-2 FILE))
	     (SWAPF (FILE-PLIST-1 FILE) (FILE-PLIST-2 FILE))
	     (SWAPF (FILE-DIRECTORY-1 FILE) (FILE-DIRECTORY-2 FILE))))
      (OR NEWEST-1 (FERROR NIL "No versions of ~A anywhere" (FILE-GENERAL-FILE FILE)))
      ;; NEWEST-1 is now the newer file.  If the older file exists in the newer directory,
      ;; then there is no skew and the newer one can be copied over.
      (IF (OR (NULL NEWEST-2)
	      (LET ((ELEM (ASSQ (FUNCALL (CAR NEWEST-1) ':NEW-VERSION VERSION-2)
				(FILE-DIRECTORY-1 FILE))))
		(AND ELEM (COMPARE-FILE-INFO ELEM NEWEST-2))))
	  (OFFER-TO-COPY-UPDATE (FILE-DIRECTORY-1 FILE) (FILE-DIRECTORY-2 FILE)
				NEWEST-1 NEWEST-2
				(FUNCALL (FILE-PATHNAME-2 FILE) ':NEW-VERSION VERSION-1))
	  (AND (OFFER-TO-MERGE-UPDATE (FILE-DIRECTORY-1 FILE) (FILE-DIRECTORY-2 FILE)
				      NEWEST-1 NEWEST-2 (FILE-PATHNAME-1 FILE))
	       ;; After merging, repeat the directory process to copy the merged
	       (UPDATE-FILE FILE))))))

(DEFUN GET-FILE-DIRECTORIES (FILE)
  (SETF (FILE-DIRECTORY-1 FILE) (GET-FILE-DIRECTORY (FILE-PATHNAME-1 FILE)))
  (SETF (FILE-DIRECTORY-2 FILE) (GET-FILE-DIRECTORY (FILE-PATHNAME-2 FILE))))

(DEFUN GET-FILE-DIRECTORY (PATHNAME)
  (LET ((LIST (CDR (FS:DIRECTORY-LIST (FUNCALL PATHNAME ':NEW-PATHNAME ':TYPE ':WILD
								       ':VERSION ':WILD)))))
    (SETQ LIST (SORTCAR LIST #'ZWEI:DIRED-PATHNAME-LESSP))
    (ZWEI:DIRED-COMPUTE-GREATER-THANS LIST)
    LIST))

(DEFUN GET-NEWEST-FILE (LIST PATHNAME)
  (LOOP FOR ENTRY IN LIST
	WHEN (AND (GET ENTRY ':NEWEST)
		  (LET ((FILE-TYPE (FUNCALL (CAR ENTRY) ':TYPE)))
		    (OR (EQ FILE-TYPE ':UNSPECIFIC)
			(EQUAL FILE-TYPE (FUNCALL PATHNAME ':TYPE)))))
	RETURN ENTRY))

(DEFUN OFFER-TO-COPY-UPDATE (NEW-DIRECTORY OLD-DIRECTORY
			     NEW-DIRECTORY-ELEM OLD-DIRECTORY-ELEM
			     NEW-OLD-PATHNAME &AUX NEW-FILE OLD-FILE)
  (DECLARE (SPECIAL NEW-FILE OLD-FILE NEW-OLD-PATHNAME))
  (SETQ NEW-FILE (CAR NEW-DIRECTORY-ELEM)
	OLD-FILE (CAR OLD-DIRECTORY-ELEM))
  (*CATCH 'SYS:COMMAND-LEVEL
    (LOOP DOING
      (SELECTQ (FQUERY `(:CHOICES (((:COPY "Yes.") #/Y #/C #\SP)
				   ((:DIRECTORY "Directory.") #/D)
				   ,@(AND OLD-FILE '(((:SRCCOM "Source compare.") #/S)))
				   ((NIL "No.") #/N #\RUBOUT))
			 :HELP-FUNCTION OFFER-TO-COPY-UPDATE-HELP-FUNCTION)
		       "Copy ~A to ~A? " NEW-FILE NEW-OLD-PATHNAME)
	((NIL)
	 (RETURN NIL))
	((:COPY)
	 (COPY-GIVEN-DIRECTORY-ELEM NEW-DIRECTORY-ELEM NEW-OLD-PATHNAME)
	 (RETURN NIL))
	((:DIRECTORY)
	 (DISPLAY-DIRECTORY NEW-DIRECTORY)
	 (DISPLAY-DIRECTORY OLD-DIRECTORY))
	((:SRCCOM)
	 (SOURCE-COMPARE-UPDATE NEW-DIRECTORY OLD-DIRECTORY NEW-FILE OLD-FILE))))))

(DEFUN OFFER-TO-COPY-UPDATE-HELP-FUNCTION (STREAM CHOICES TYPE)
  (DECLARE (SPECIAL NEW-FILE OLD-FILE NEW-OLD-PATHNAME))
  TYPE						;Not needed
  (LOOP FOR ((KEY PROMPT) CHAR) IN CHOICES
	DO (FORMAT STREAM "~&~:C~2X" CHAR)
	   (SELECTQ KEY
	     ((:COPY) (FORMAT STREAM "Yes.  Copy ~A to ~A.~%" NEW-FILE NEW-OLD-PATHNAME))
	     ((NIL) (FORMAT STREAM "No.  Do nothing.~%"))
	     ((:DIRECTORY) (FORMAT STREAM "Directory.  Display list of relevant files.~%"))
	     ((:SRCCOM) (FORMAT STREAM "Source compare.  Compare ~A with ~A.~%"
				NEW-FILE OLD-FILE))
	     (OTHERWISE (FORMAT STREAM "~A~%" PROMPT)))))

(DEFUN OFFER-TO-MERGE-UPDATE (NEW-DIRECTORY OLD-DIRECTORY
			      NEW-DIRECTORY-ELEM OLD-DIRECTORY-ELEM MERGE-OUTPUT
			      &AUX NEW-FILE OLD-FILE SAME-VERSION-NUMBER-P)
  (DECLARE (SPECIAL MERGE-OUTPUT NEW-FILE OLD-FILE))
  (SETQ NEW-FILE (CAR NEW-DIRECTORY-ELEM)
	OLD-FILE (CAR OLD-DIRECTORY-ELEM)
	SAME-VERSION-NUMBER-P (= (FUNCALL NEW-FILE ':VERSION)
				 (FUNCALL OLD-FILE ':VERSION)))
  (*CATCH 'SYS:COMMAND-LEVEL
    (LOOP DOING
      (SELECTQ (FQUERY `(:CHOICES (((:MERGE "Yes.") #/Y #/M #\SP)
				   ((:COPY-NEW "Copy 12.") #/1)
				   ((:COPY-OLD "Copy 21.") #/2)
				   ((:DIRECTORY "Directory.") #/D)
				   ((:SRCCOM "Source compare.") #/S)
				   ,@(AND SAME-VERSION-NUMBER-P
					  '(((:SYNCHRONIZE-DATES "Synchronize dates.") #/=)))
				   ((NIL "No.") #/N #\RUBOUT))
			 :HELP-FUNCTION OFFER-TO-MERGE-UPDATE-HELP-FUNCTION)
		       "Merge ~A and ~A into ~A? " NEW-FILE OLD-FILE MERGE-OUTPUT)
	((NIL)
	 (RETURN NIL))
	((:MERGE)
	 (ZWEI:SOURCE-COMPARE-MERGE NEW-FILE OLD-FILE MERGE-OUTPUT)
	 (RETURN T))
	((:COPY-NEW)
	 (COPY-GIVEN-DIRECTORY-ELEM NEW-DIRECTORY-ELEM (FUNCALL OLD-FILE ':NEW-VERSION
								(FUNCALL NEW-FILE ':VERSION)))
	 (RETURN NIL))
	((:COPY-OLD)
	 (AND (NOT SAME-VERSION-NUMBER-P)
	      (LET* ((TO (FUNCALL OLD-FILE ':NEW-VERSION (1+ (FUNCALL NEW-FILE ':VERSION)))))
		(FORMAT T "~&Renaming ~A to ~A.~%" OLD-FILE TO)
		(RENAMEF OLD-FILE TO)
		(SETQ OLD-FILE TO)
		(RPLACA OLD-DIRECTORY-ELEM OLD-FILE)))
	 (COPY-GIVEN-DIRECTORY-ELEM OLD-DIRECTORY-ELEM (FUNCALL NEW-FILE ':NEW-VERSION
								(FUNCALL OLD-FILE ':VERSION)))
	 (RETURN NIL))
	((:SYNCHRONIZE-DATES)
	 (UPDATE-FILE-PROPERTIES NEW-DIRECTORY-ELEM OLD-FILE)
	 (RETURN NIL))
	((:DIRECTORY)
	 (DISPLAY-DIRECTORY NEW-DIRECTORY)
	 (DISPLAY-DIRECTORY OLD-DIRECTORY))
	((:SRCCOM)
	 (SOURCE-COMPARE-UPDATE NEW-DIRECTORY OLD-DIRECTORY NEW-FILE OLD-FILE))))))

(DEFUN OFFER-TO-MERGE-UPDATE-HELP-FUNCTION (STREAM CHOICES TYPE)
  (DECLARE (SPECIAL MERGE-OUTPUT NEW-FILE OLD-FILE))
  TYPE						;Not needed
  (LOOP FOR ((KEY PROMPT) CHAR) IN CHOICES
	DO (FORMAT STREAM "~&~:C~2X" CHAR)
	   (SELECTQ KEY
	     ((:MERGE) (FORMAT STREAM "Yes.  Source compare merge ~A and ~A into ~A.~%"
			       NEW-FILE OLD-FILE MERGE-OUTPUT))
	     ((NIL) (FORMAT STREAM "No.  Do nothing.~%"))
	     ((:COPY-NEW) (FORMAT STREAM "Copy 12.  Copy ~A to ~A.~%"
				  NEW-FILE (FUNCALL OLD-FILE ':NEW-VERSION
						    (FUNCALL NEW-FILE ':VERSION))))
	     ((:COPY-OLD)
	      (PRINC "Copy 21.  " STREAM)
	      (LET ((OF OLD-FILE))
		(AND ( (FUNCALL NEW-FILE ':VERSION) (FUNCALL OLD-FILE ':VERSION))
		     (FORMAT STREAM "Rename ~A to ~A,~%~14XThen " OLD-FILE
			     (SETQ OF (FUNCALL OLD-FILE ':NEW-VERSION
					       (1+ (FUNCALL OLD-FILE ':VERSION))))))
		(FORMAT STREAM "Copy ~A to ~A.~%" OF (FUNCALL NEW-FILE ':NEW-VERSION
							      (FUNCALL OF ':VERSION)))))
	     ((:SYNCHRONIZE-DATES)
	      (FORMAT STREAM "Change dates on ~A to match ~A.~%" OLD-FILE NEW-FILE))
	     ((:DIRECTORY) (FORMAT STREAM "Directory.  Display list of relevant files.~%"))
	     ((:SRCCOM) (FORMAT STREAM "Source compare.  Compare ~A with ~A.~%"
				NEW-FILE OLD-FILE))
	     (OTHERWISE (FORMAT STREAM "~A~%" PROMPT)))))

(DEFUN COPY-GIVEN-DIRECTORY-ELEM (DIRECTORY-ELEM &OPTIONAL TO-PATHNAME &AUX FROM-PATHNAME)
  (SETQ FROM-PATHNAME (CAR DIRECTORY-ELEM))
  (OR TO-PATHNAME
      (SETQ TO-PATHNAME (OR (GET DIRECTORY-ELEM ':COPY-TO)
			    (FERROR NIL "Don't know where to copy ~A to" FROM-PATHNAME))))
  (LET* ((BYTE-SIZE (GET DIRECTORY-ELEM ':BYTE-SIZE))
	 (BINARY-P (COND ((MEMQ BYTE-SIZE '(8 7)) NIL)
			 ((EQ BYTE-SIZE 16.) T)
			 ((EQUAL (FUNCALL FROM-PATHNAME ':TYPE) "QFASL") T)
			 ((EQUAL (FUNCALL FROM-PATHNAME ':TYPE) "LISP") NIL)
			 ((FQUERY '(:BEEP T) "Binary-P for ~A? " FROM-PATHNAME)))))
    (COPY-FILE FROM-PATHNAME TO-PATHNAME BINARY-P))
  (UPDATE-FILE-PROPERTIES DIRECTORY-ELEM TO-PATHNAME))

(DEFUN UPDATE-FILE-PROPERTIES (DIRECTORY-ELEM PATHNAME)
  (LOOP FOR PROP IN '(:AUTHOR :CREATION-DATE)
	COLLECT PROP INTO PLIST
	COLLECT (GET DIRECTORY-ELEM PROP) INTO PLIST
	FINALLY (LEXPR-FUNCALL #'FS:CHANGE-FILE-PROPERTIES PATHNAME NIL PLIST)))

(DEFUN COPY-FILE (FROM-PATHNAME TO-PATHNAME BINARY-P &OPTIONAL (TELL-P T))
  (AND TELL-P (FORMAT T "~&Copying ~A  ~A (~:[ascii~;binary~])"
		      FROM-PATHNAME TO-PATHNAME BINARY-P))
  (WITH-OPEN-FILE (INFILE FROM-PATHNAME ':DIRECTION ':IN ':CHARACTERS (NOT BINARY-P))
    (WITH-OPEN-FILE (OUTFILE TO-PATHNAME ':DIRECTION ':OUT ':CHARACTERS (NOT BINARY-P))
      (STREAM-COPY-UNTIL-EOF INFILE OUTFILE))))

(DEFUN SOURCE-COMPARE-UPDATE (DIRECTORY-1 DIRECTORY-2 FILE-1 FILE-2)
  (DISPLAY-DIRECTORY DIRECTORY-1)
  (DISPLAY-DIRECTORY DIRECTORY-2)
  (SRCCOM:PROMPTED-SOURCE-COMPARE FILE-1 FILE-2))

(DEFUN DISPLAY-DIRECTORY (DIRECTORY &OPTIONAL (STREAM STANDARD-OUTPUT))
  (AND DIRECTORY
       (FORMAT STREAM "~&On ~A:~%" (FUNCALL (FUNCALL (CAAR DIRECTORY) ':HOST)
					    ':NAME-AS-FILE-COMPUTER)))
  (DOLIST (FILE DIRECTORY)
    (FORMAT STREAM "~&~A~15T~D ~D(~D)~30T"
	    (FUNCALL (CAR FILE) ':STRING-FOR-DIRED) (GET FILE ':LENGTH-IN-BLOCKS)
	    (GET FILE ':LENGTH-IN-BYTES) (GET FILE ':BYTE-SIZE))
    (TIME:PRINT-UNIVERSAL-TIME (GET FILE ':CREATION-DATE) STREAM)
    (FORMAT STREAM "~@[ ~A~]~%" (GET FILE ':AUTHOR))))

(DEFUN COPY-ALL-PATCHES (HOST-1 HOST-2)
  (DOLIST (PATCH SI:PATCH-SYSTEMS-LIST)
    (COPY-PATCHES (SI:PATCH-NAME PATCH) (SI:PATCH-VERSION PATCH) HOST-1 HOST-2)))

(DEFUN COPY-PATCHES (SYSTEM MAJOR-VERSION HOST-1 HOST-2 &AUX PATCH-ATOM SAME-DIRECTORY-P
							     PATCH-PATH-1 PATCH-PATH-2
							     FILES-TO-COPY)
  (LET ((PATCH-DIRECTORY (SI:SYSTEM-PATCH-DIRECTORY (SI:FIND-SYSTEM-NAMED SYSTEM))))
    (OR PATCH-DIRECTORY (FERROR NIL "System ~A not patchable" SYSTEM))
    (SETQ SAME-DIRECTORY-P (SI:PATCH-DIRECTORY-SAME-DIRECTORY-P PATCH-DIRECTORY)
	  PATCH-ATOM (SI:PATCH-DIRECTORY-PATCH-ATOM PATCH-DIRECTORY))
    (LET ((PATCH-PATHNAME (SI:PATCH-DIRECTORY-PATHNAME PATCH-DIRECTORY)))
      (SETQ PATCH-PATH-1 (FUNCALL PATCH-PATHNAME ':NEW-PATHNAME ':HOST HOST-1)
	    PATCH-PATH-2 (FUNCALL PATCH-PATHNAME ':NEW-PATHNAME ':HOST HOST-2))))
  (LET ((PATCH-DIRECTORY-1 NIL)
	(PATCH-DIRECTORY-2 NIL))
    (WITH-OPEN-FILE (STREAM (FUNCALL PATCH-PATH-1 ':PATCH-FILE-PATHNAME SYSTEM
				     SAME-DIRECTORY-P PATCH-ATOM ':VERSION-DIRECTORY
				     MAJOR-VERSION)
			    '(:IN :NOERROR))
      (AND (NOT (ERRORP STREAM))
	   (SETQ PATCH-DIRECTORY-1 (PKG-BIND "" (LET ((IBASE 10.)) (READ STREAM))))))
    (WITH-OPEN-FILE (STREAM (FUNCALL PATCH-PATH-2 ':PATCH-FILE-PATHNAME SYSTEM
				     SAME-DIRECTORY-P PATCH-ATOM ':VERSION-DIRECTORY
				     MAJOR-VERSION)
			    '(:IN :NOERROR))
      (AND (NOT (ERRORP STREAM))
	   (SETQ PATCH-DIRECTORY-2 (PKG-BIND "" (LET ((IBASE 10.)) (READ STREAM))))))
    (COND ((< (LOOP FOR (VER) IN (SI:PATCH-DIR-VERSION-LIST PATCH-DIRECTORY-1)
		    MAXIMIZE VER)
	      (LOOP FOR (VER) IN (SI:PATCH-DIR-VERSION-LIST PATCH-DIRECTORY-2)
		    MAXIMIZE VER))
	   (SWAPF HOST-1 HOST-2)
	   (SWAPF PATCH-PATH-1 PATCH-PATH-2)
	   (SWAPF PATCH-DIRECTORY-1 PATCH-DIRECTORY-2)))
    (DOLIST (ELEM-1 (SI:PATCH-DIR-VERSION-LIST PATCH-DIRECTORY-1))
      (COND ((SI:VERSION-EXPLANATION ELEM-1)
	     (LET ((ELEM-2 (ASSQ (SI:VERSION-NUMBER ELEM-1)
				 (SI:PATCH-DIR-VERSION-LIST PATCH-DIRECTORY-2))))
	       (AND ELEM-1 ELEM-2 (NOT (EQUAL ELEM-1 ELEM-2))
		    (FERROR NIL "Patch version skew, ~S and ~S" ELEM-1 ELEM-2)))
	     (PUSH (SETUP-PATCH-COPY SYSTEM PATCH-PATH-1 PATCH-PATH-2
				     SAME-DIRECTORY-P PATCH-ATOM
				     ':PATCH-FILE MAJOR-VERSION
				     (SI:VERSION-NUMBER ELEM-1) "LISP")
		   FILES-TO-COPY)
	     (PUSH (SETUP-PATCH-COPY SYSTEM PATCH-PATH-1 PATCH-PATH-2
				     SAME-DIRECTORY-P PATCH-ATOM
				     ':PATCH-FILE MAJOR-VERSION
				     (SI:VERSION-NUMBER ELEM-1) "QFASL")
		   FILES-TO-COPY)))))
  (PUSH (SETUP-PATCH-COPY SYSTEM PATCH-PATH-1 PATCH-PATH-2
			  SAME-DIRECTORY-P PATCH-ATOM
			  ':VERSION-DIRECTORY MAJOR-VERSION)
	FILES-TO-COPY)
  (SETQ FILES-TO-COPY (NREVERSE FILES-TO-COPY))
  (UPDATE-FILES-1 FILES-TO-COPY))

(DEFUN SETUP-PATCH-COPY (SYSTEM PATH-1 PATH-2 SAME-DIRECTORY-P PATCH-ATOM TYPE &REST ARGS)
  (MAKE-FILE PATHNAME-1 (LEXPR-FUNCALL PATH-1 ':PATCH-FILE-PATHNAME SYSTEM
				       SAME-DIRECTORY-P PATCH-ATOM TYPE ARGS)
	     PATHNAME-2 (LEXPR-FUNCALL PATH-2 ':PATCH-FILE-PATHNAME SYSTEM
				       SAME-DIRECTORY-P PATCH-ATOM TYPE ARGS)))

(DEFUN COPY-UCADR (VERSION HOST-1 HOST-2 &AUX FILES-TO-COPY)
  (LET ((PATH (FS:MERGE-PATHNAME-DEFAULTS "SYS: UCADR; UCADR LISP >")))
    (PUSH (MAKE-FILE GENERAL-FILE PATH
		     PATHNAME-1 (FUNCALL PATH ':NEW-PATHNAME ':HOST HOST-1 ':VERSION VERSION)
		     PATHNAME-2 (FUNCALL PATH ':NEW-PATHNAME ':HOST HOST-2 ':VERSION VERSION))
	  FILES-TO-COPY))
  (LET ((PATH (FS:MERGE-PATHNAME-DEFAULTS "SYS: UBIN; UCADR FOO >")))
    (DOLIST (TYPE '("MCR" "TBL" "SYM"))
      (PUSH (MAKE-FILE GENERAL-FILE (FUNCALL PATH ':NEW-PATHNAME ':TYPE TYPE
								 ':VERSION VERSION)
		       PATHNAME-1 (FUNCALL (FUNCALL PATH ':NEW-PATHNAME ':HOST HOST-1)
					   ':NEW-TYPE-AND-VERSION TYPE VERSION)
		       PATHNAME-2 (FUNCALL (FUNCALL PATH ':NEW-PATHNAME ':HOST HOST-2)
					   ':NEW-TYPE-AND-VERSION TYPE VERSION))
	    FILES-TO-COPY)))
  (SETQ FILES-TO-COPY (NREVERSE FILES-TO-COPY))
  (UPDATE-FILES-1 FILES-TO-COPY))