;;; -*- Mode:LISP; Package:USER; Readtable:CL; Base:10 -*-


(defun writesys(&optional (spec "SYS:SITE;foo.bar#>"))
  (let*((path (fs:translated-pathname (pathname spec)))
	(host (pathname-host path))
	(fn (namestring path))
	(abort-msg "before startup")
	(*readtable* (si:find-readtable-named "CL" t))
	temp)
    (unwind-protect
	(block nil
	  (macrolet((insist(form fmt &rest args)
			   `(unless ,form
			      (setq abort-msg (format nil ,fmt ,@args))
			      (return nil))))
	    (insist (fs:get-pathname-host host t) "invalid host ~a" host)
	    (insist (eq (setq temp(send host :system-type)) :lispm)
		    "Cannot generate ~a for non-LISPM host ~a [type ~a]"
		    fn host temp)
	    (setq abort-msg (format nil "trying to write ~a" path))
	    (with-open-file(out path :direction :output :error :reprompt)
	      (format out "~%
;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:CL; -*-
\	      
;;; SYS.TRANSLATIONS automatically generated.
\
")
	      (si:write-responsibility-comment out)
	      (format out "~2%
;;; Defines the translations for the SYS logical host.~2%")
	      (pprint `(fs:set-logical-pathname-host
			 "SYS"
			 :physical-host ,(send host :name)
			 :translations
			 '(("CHAOS;" ,(directory-namestring path))
			   ("SITE;"  ,(directory-namestring path))
			   ("*;*;*;*;*;" "<RELEASE-4.*.*.*.*.*>")
			   ("*;*;*;*;" "<RELEASE-4.*.*.*.*>")
			   ("*;*;*;" "<RELEASE-4.*.*.*>")
			   ("*;*;" "<RELEASE-4.*.*>")
			   ("*;" "<RELEASE-4.*>")))
		      out))
	    (setq abort-msg nil)
	    path))
      (if abort-msg
	  (warn "Abort-msg ~a" abort-msg)
	(format t "~%Done.")))))