;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.137
;;; Reason:
;;;  add :host-name-for-translations keyword arg to make-logical-pathname-host.  This allows you to
;;;  define a variant system with the same logical host name but a different set of translations.
;;; Written 31-Oct-88 11:17:36 by rg at site Gigamos Cambridge
;;; while running on Lambda Four A from band 2
;;; with Experimental System 126.136, ZWEI 125.20, ZMail 73.2, Local-File 75.2, File-Server 24.1, Unix-Interface 13.0, Tape 24.2, Lambda-Diag 17.0, Microcode 1762, SDU Boot Tape 3.14, SDU ROM 102.



; From file DJ: L.IO.FILE; PATHST.LISP#220 at 31-Oct-88 11:17:37
#8R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FILE; PATHST  "

(defun make-logical-pathname-host (host-name &key (warn-about-redefinition t) host-name-for-translations)
  "Defines HOST-NAME to be the name of a logical host.
If this conflicts the name or nickname of any physical host,
then and error is signalled, and the new logical host may be allowed to
override that name of the physical host.
This function loads the file SYS: SITE; host-name TRANSLATIONS, (or host-name-for-translations,
if specified), which should contain
a call to FS:SET-LOGICAL-PATHNAME-HOST to set up the translations for the host."
  (setq host-name (string-upcase (string host-name)))
  (if host-name-for-translations (setq host-name-for-translations (string-upcase (string host-name-for-translations))))
  (let ((old (get-pathname-host host-name t))
	new file-id loaded-id)
    (catch-error-restart ((fs:remote-network-error fs:file-not-found)
			  "Give up loading logical pathname translations for ~A" host-name)
      (when (typep old 'logical-host)
	(setq loaded-id (send old :get 'make-logical-pathname-host))
	;; if previously defined by hand, don't load translations and clobber it
	(cond ((not loaded-id)
	       (return-from make-logical-pathname-host old))
	      (warn-about-redefinition
	       (format *error-output* "~&Warning: The logical host ~A is being redefined"
		       old))))
      ;; no need to give error if redefining physical host, as set-logical-pathname-host errs
      ;;can't make the sys pathname below if we are here to create the SYS host itself !!
      ;;also, this means, for now, that any information in the SITE;SYS.TRANSLATIONS file must
      ;;also be in SITE;SITE
      (cond ((get-pathname-host "SYS" t)
	     (let ((pathname (make-pathname :host "SYS"
					    :device :unspecific
					    :directory '("SITE")
					    :name (if host-name-for-translations host-name-for-translations host-name)
					    :canonical-type :logical-pathname-translations
					    :version :newest)))
	       (setq file-id (with-open-file (stream pathname :direction :probe
						     :if-does-not-exist :error)
			       (send stream :info)))
	       (unless (equal loaded-id file-id)
		 (load pathname :verbose nil :package (symbol-package 'foo)))))))
    (cond ((typep (setq new (get-pathname-host host-name nil)) 'logical-host)
	   (send new :set :get 'make-logical-pathname-host file-id)
	   new)
	  (t (format *error-output*
		     "~&Warning: The logical host ~S was not defined by ~S."
		     host-name 'make-logical-pathname-host)
	     nil))))

))