;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.57
;;; Reason:
;;;  Tighten up use of SI:*RELEASE-STATUS* in PRINT-HERALD.  Make a list of
;;;  standard release keywords, SI:RELEASE-STATUS-KEYWORDS.  Add :OBSOLETE
;;;  keyword.
;;;  
;;;  Also, first shot at the Falcon's herald, almost the same as Lambda's.
;;; Written 17-Aug-88 17:39:41 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 2
;;; with Experimental System 126.55, ZMail 73.2, Local-File 75.2, File-Server 24.1, Unix-Interface 13.0, Tape 24.2, Lambda-Diag 17.0, Experimental ZWEI 126.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103.



; From modified file DJ: L.IO; DISK.LISP#421 at 17-Aug-88 17:39:41
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "


(defconstant release-status-keywords  '(:development :released :alpha :beta :obsolete))

(defun release-status ()
  (CASE *RELEASE-STATUS*
    (nil)
    (:DEVELOPMENT "(Development System)")
    (:ALPHA "(Alpha Test)")
    (:BETA "(Beta Test)")
    (:obsolete "(Obsolete System)")
    (:released "")
    (otherwise (if (member *release-status* release-status-keywords)
		   (format nil "(~A System)"*release-status*)
		 (format nil "(~A?)" *release-status*)))))

))

; From modified file DJ: L.SYS; LAST.LISP#3 at 17-Aug-88 17:43:17
#10R SYSTEM-INTERNALS#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; LAST  "

(defun maybe-set-systems-released ()
  ;;Status of patchable systems
  (let ((systems-to-release nil) answer)
    (dolist (s patch-systems-list)
      (and (neq (patch-status s) :released)
	   (push s systems-to-release)))
    (when (setq answer
		(and systems-to-release
		     (fquery `(:type :tyi :choices (((:all "All")   #\A)
						    ((:some "Some") #\S)
						    ((nil "None")   #\N))
				     :clear-input t
				     :timeout ,(* 5 60 60)
				     :default-value nil)
			     "Release patchable systems? ")))
      (dolist (s (nreverse systems-to-release))
	(when (or (eq answer :all)
		  (let ((proceed
			  (fquery `(:type :tyi :choices (((t "Yes")      #\Y)
							 ((nil "No")     #\N)
							 ((:quit "Quit") #\Q)
							 ((:proceed "Proceed") #\P))
					  :clear-input t
					  :timeout ,(* 2 60 60)
					  :default-value nil)
				  "~A ~A (version ~D.~D)~&  Release it? "
				  (patch-status s)
				  (patch-name s)
				  (patch-version s)
				  (version-number (first (patch-version-list s))))))
		    (case proceed
		      (:quit (return))
		      (:proceed (setq answer :all)))
		    proceed))
	  (set-system-status (patch-name s) :released)
	  (format t "~A. ~&Released" (patch-name s))))))
  ;;Status keyword
  (when (yes-or-no-p-with-timeout (* 5 60 60) nil
				  "~2&Current release status is ~S~@[ ~A~].  Change it ?"
				  si:*release-status*
				  (release-status))
    (let* ((statuslist release-status-keywords)
	   (choices (loop for status in statuslist
			  as str = (format nil "~1(~A~)" status)
			  collect (list
				    (list status str)
				    (char str 0)))))
      (format t "~%The release status should be one of the following:~%~{~%~3T- ~1(~A~)~}" statuslist)
      (setq si:*release-status*
	    (fquery `(:type :tyi
		      :choices ,choices
		      :clear-input t
		      :timeout ,(* 2 60 60)
		      :default-value :released)
		    "~%Set release status - specify first character: "))))
  (format t "~2&")
  ;;Show results
  (print-herald)
  nil)

))

; From modified file DJ: L.IO; DISK.LISP#421 at 17-Aug-88 17:48:59
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "

(DEFUN PRINT-HERALD (&OPTIONAL (STREAM STANDARD-OUTPUT))
  "Print on STREAM a description of the versions of all software running."
  (UNLESS (ZEROP %LOADED-BAND)
    (SETQ CURRENT-LOADED-BAND %LOADED-BAND))
  (UNLESS (BOUNDP 'CURRENT-LOADED-BAND)
    (SETQ CURRENT-LOADED-BAND 0))
  (SELECT-PROCESSOR
    (:CADR
      ;; Give MIT credit for all the CADR systems.
      (FORMAT STREAM "~&MIT System, band ~C of ~A."
	      (LDB (BYTE 8. 16.) CURRENT-LOADED-BAND)
	      DISK-PACK-NAME))
    ((:LAMBDA :falcon)
      (FORMAT STREAM "~&GigaMos ~A Release ~D.~D~@[ ~A~]~@[, band ~C of ~A~]."
	      (select-processor (:lambda "Lambda") (:falcon "Falcon"))
	      *RELEASE-MAJOR-VERSION*
	      *RELEASE-MINOR-VERSION*
	      (release-status)
	      (select-processor
		(:lambda (LDB (BYTE 8. 16.) CURRENT-LOADED-BAND)))
	      DISK-PACK-NAME))
    (:EXPLORER
      (FORMAT STREAM "~&LMI Explorer Release ~D.~D~@[ ~A~], band ~C of ~A."
	      *RELEASE-MAJOR-VERSION*
	      *RELEASE-MINOR-VERSION*
	      (release-status)
	      (LDB (BYTE 8. 16.) CURRENT-LOADED-BAND)
	      DISK-PACK-NAME)))
  (AND (BOUNDP 'SYSTEM-ADDITIONAL-INFO)
       (PLUSP (ARRAY-ACTIVE-LENGTH SYSTEM-ADDITIONAL-INFO))
       (FORMAT STREAM " (~A)" SYSTEM-ADDITIONAL-INFO))
  (IF (NOT (FBOUNDP 'DESCRIBE-SYSTEM-VERSIONS))
      (FORMAT STREAM "~%Fresh Cold Load~%")
    (SELECT-PROCESSOR
      (:CADR
	(FORMAT STREAM "~&~DK physical memory, ~DK virtual memory."
		(TRUNCATE (SYSTEM-COMMUNICATION-AREA %SYS-COM-MEMORY-SIZE) #O2000)
		(TRUNCATE VIRTUAL-MEMORY-SIZE #O2000)))
      ((:LAMBDA :EXPLORER)
	(FORMAT STREAM "~&~DK physical memory, ~DK virtual memory, NuBus slot ~D."
		(TRUNCATE (SYSTEM-COMMUNICATION-AREA %SYS-COM-MEMORY-SIZE) #O2000)
		(TRUNCATE VIRTUAL-MEMORY-SIZE #O2000)
		(LOGXOR #XF0 RG-QUAD-SLOT))))
    (DESCRIBE-SYSTEM-VERSIONS STREAM t)
    (FORMAT STREAM "~%~A ~A, with associated machine ~A.~%"
	    (OR (GET-SITE-OPTION :SITE-PRETTY-NAME) SITE-NAME)
	    LOCAL-PRETTY-HOST-NAME
	    (SEND ASSOCIATED-MACHINE :NAME-AS-FILE-COMPUTER))
    (select-processor
      (:explorer (Check-For-Abnormal-Shutdown))
      ((:lambda :cadr)))))

))