;	Saturday  Aug 1,1981  17:33  NM+1D.10H.47M.0S.  -*- Lisp -*-

;;;; Patch System

(eval-when (eval compile)
  (or (status feature patch-definitions)
      (load '((dsk lsb1) patdef))))	;Have to say DSK or it doesn't work on Tenex

;This file is the basic runtime support for the Patch System.
;In Maclisp, the Patch System's purpose in life is to maintain system
; versions (for dumping), and allow an easy-to-use and canonical way
; for versions to have "statuses" and "patches".  Patches correspond
; to minor version numbers.  Much stuff comes from the Lispm patch
; system, q.v., however we do not support as high-level an interface.
;When you go to make a dump of a new system, you should do
; (new-patch-system <system-name> <pathname>).  That file supposedly
; contains the "patch system definition", which tells various attributes
; about the patchable-system, especially where the patch versions
; directories and patch-files are kept.  Because the runtime support
; here is broken off from the support code for manipulating the patch
; system (for system maintainers), NEW-PATCH-SYSTEM does not
; automatically create that file;  you may use
; INITIALIZE-PATCH-SYSTEM, in ADDPAT, to do that (again, q.v.).
; NEW-PATCH-SYSTEM actually is a bit hairier;  see it.

;The function SI:SYSTEM-VERSION-INFO is essentially the same as that
; on the Lisp Machine.  To allow it to return a "string", it is
; actually a simple call to FORMAT, and the SYSVER format operator
; does all the work.  It may be a good idea for this to be a "public"
; facility.

;The function SI:GET-SYSTEM-VERSION is like the lispm one.  It also
; returns an upwards (sideways?) compatible third value which is the
; system status.
;The function SI:GET-SYSTEM-VERSION-LIST is for those who don't want
; to have to hack Maclisp multiple-values.  It is defined as returning
; the list of values which SI:GET-SYSTEM-VERSION returns.  The reason
; this is useful is that SI:GET-SYSTEM-VERSION is typically called in
; dump setup, which typically runs interpreted, and the dump may not
; want to have to autoload the macros for receiving multiple values.

;Note that unless, when starting up a dumped job, you use some
; standard interface which knows about the patch system (like that in
; LSB1;START), it will be necessary to do (SI:UPDATE-SYSTEM-STATUSES
; NIL) to get the statuses of all the systems updated in core.

;Unlike the Lisp Machine, there is no basic pre-supplied system;
; instead, code (e.g., SI:SYSTEM-VERSION-INFO) which thinks there is a
; "default" uses the value of *DEFAULT-SYSTEM, which is by default
; SYSTEM.  Knowledgable system maintainers should set it to something
; useful.

;This file is designed to not need to be recompiled to be transported
; between PDP10 Maclisps.  If the amount of runtime hackery gets out
; of hand, however, that may be changed.


;;;; Patch-system filenames

;;; Patch system definition file:
;The patch-system definition file is only used when the system version
; is incremented and the patchable-system defined, by
; NEW-PATCH-SYSTEM.  The default filename is a directory and filename
; same as the system name, and a file-type of PATCH-DIRECTORY
; (dec20), "(PDIR)" (ITS), or PDR (losers).  Thus, one can call
; NEW-PATCH-SYSTEM like (new-patch-system 'lsb '((lsb) lsb)), and the
; right thing will happen.  In fact, the filename here could have been
; NIL, is recognized (HERE!) to mean default all the components.

;;; Patch directory file:
;Each major version of a system has a patch directory file.  This file
; essentially contains the status (see lispm doc) of that system
; version, and a list of the patches to it.  Presumably the name of
; this file is a function of the major system version.  The default
; name is "<system>PATCH-nnn.DIRECTORY" (dec20), "system;PATnnn
; (PDIR)" (ITS).  Elsewhere it must be specified fully.  Note that the
; "default" here is what INITIALIZE-PATCH-SYSTEM (q.v.) defaults it
; to;  it is fully specified in the patch-system-definition-file.

;;; Patch files:
;Each patch to a system corresponds to a new minor version number.  It
; is also expected to be compiled, no matter how gratuitous such a
; compilation may seem.  The reason for this is that the pathnames are
; allowed to be different for the source and the fasl of the patch
; files.  The default name for a patch file for a system of major
; version mm and minor version nn is "<system>PATCH-mm-nn" (DEC20)
; and "system;mm.nn" (ITS).  The file-type will be automatically
; defaulted to the appropriate value depending on whether a source or
; fasl file is expected.

;;; General filename crocks:
;The typical way in which a general pathname is specified to the patch
; system is as a format string, which will get some canonical set of
; arguments;  e.g., for a patch-directory file, it will get the major
; version number, and for a patch-file, the major and minor version
; numbers.  Thus the ITS specification for a patch file pathname looks
; like "system;~D.~D" for whatever "system" is.  The patch system
; definition file may be shared across operating systems.
; Essentially, the specification of one of these format-strings may be
; an a-list of filesystem names (DEC20, ITS are recognized mostly),
; and format-strings.  In this context, a list of the source and fasl
; specification format-strings may be given in place of a single
; format string.  See INITIALIZE-PATCH-SYSTEM.


;;;; Random Runtime Stuff


; Runtime support for patch-openo.
; (defun patch-openo-exit (file)
;    (and (not (null file)) (status filemode file) (deletef file)))
; See? it's simpler in lap.
(deflap patch-openo-exit subr
    (args patch-openo-exit (nil . 1))
	(movsi t #o40000)
	(skipe 0 a)
	 (tdne t 1 a)
	   (popj p)
	(jcall 1 'deletef)
    )

;Make an uppercasified pname so we can use equal.
; This is a real pdp10 maclisp pname, i.e. a list of fixnums.
; Note that it is important that we use EXPLODEN as a primitive,
; so that we can interface to "user strings" should they be used.
(deflap patch-pname subr
    (args patch-pname (nil . 1))
	(call 1 'exploden)
	(push p a)
	(skipn b a)
	  (jrst 0 dun)
    lp	(hlrz c 0 b)
	(move tt 0 c)
	(cail tt #/a)
	  (caile tt #/z)
	    (jrst 0 nxt)
	(subi tt 32.)
	(jsp t fxcons)
	(hrlm a 0 b)
    nxt	(hrrz b 0 b)
	(jumpn b lp)
    dun (pop p a)
	(call 1 'maknam)
	(movei b '7)
	(jcall 2 'pnget)
    )


(defvar *patch-systems
  ())

(deflap si:patch-system-info subr
    (args si:patch-system-info (nil . 1))
    patch-system-info
	(push p a)
	(call 1 'patch-pname)
	(move b (special *patch-systems))
	(call 2 'assoc)
	(hrrz a 0 a)
	(pop p b)
	(jumpn a cpopj)
	(movei a 0 b)
	(erint 2 (% sixbit |UNKNOWN SYSTEM!|))
	(jrst 0 patch-system-info)
    )


;This kludgery is so we can, for example, always check EQness of the symbol
; :EXPERIMENTAL, without having Jonl fuck us over because of the way he
; makes up a complr.
(defconst *patch-obarray
  obarray)

(defun si:patch-1read (pathname)
  (patch-openi (f pathname)
     (let ((readtable (get 'readtable 'array))
	   (obarray *patch-obarray))
       (read f))))


(defvar *patch-filesystem
  (cond ((status status files) (status files))
	(t (car (last (status features))))))

(defun si:patch-fspec (alist flag)
  (let ((tem (assq *patch-filesystem alist)))
    (cond ((null tem)
	     (error (format nil '|doesn't work on ~A| *patch-filesystem)
		    alist))
	  ((not (consp (setq tem (cdr tem)))) tem)
	  ((or (null flag) (null (cdr tem))) (car tem))
	  (t (cadr tem)))))


(defvar *default-system
  'system)

; Random extra string used by si:system-version-info, q.v.
(defvar si:system-additional-info
  '||)

(defvar si:system-status-alist
  '((:experimental |Experimental| |Exp| |Experimental|)
    (:released || || |Released|)
    (:obsolete |Obsolete| |Obs| |Obsolete|)
    (:broken |Broken| |Broke| |Broken|)))

; I can't stand a losing compiler.
;(defun si:system-version-info n
;  (format nil '((sysver)) (and (plusp n) (arg 1))))
(deflap si:system-version-info lsubr
	(jsp tt lwnack)
	  (#o000006_22 0 'si:system-version-info)
	(skipn 0 t)
	  (tdza a a)
	    (pop p a)
	(push p (% 0 0 'nil))
	(push p (% 0 0 '((sysver))))
	(push p a)
	(movni t 3)
	(jcall 14. 'format)
    )


(format nil 'format)
; (format destination "~\sysver\" briefp) formats the stuff returned by
; (si:system-version-info briefp) to destination.
; Note to load this in we need to autoload format first.
(define-format-op sysver (ignore briefp)
   (declare (special standard-output))
   (and briefp (setq briefp (patch-pname *default-system)))
   (loop for frob on (reverse *patch-systems)
	 as patdef = (cdar frob)
	 as foo = (assq (patdef-status) si:system-status-alist)
	 do (setq foo (or (cadr (if briefp (cdr foo) foo)) (car foo)))
	 when (plusp (flatc foo)) do (?format standard-output '|~A | foo)
	 do (?format standard-output '|~:[~A ~;~*~]~D.~D~:[~;~:[,~] ~]|
		     (equal briefp (caar frob)) (patdef-name)
		     (patdef-version) (patver-version (car (patdef-versions)))
		     (cdr frob) briefp))
   (or briefp
       (?format standard-output '|~:[~;, ~]~:[~;Experimental ~]Lisp ~A|
		*patch-systems (status feature experimental) (status lispv)))
   (and (plusp (flatc si:system-additional-info))
	(?format standard-output '|~:[~;, ~]~A|
		(or *patch-systems (not briefp))
		si:system-additional-info)))

(defun si:patch-comment (stream
			 &aux (daytime (status daytime))
			      (date (status date)))
  (format stream
     '|~&;;; Written ~D//~2,'0D//~2,'0D ~2,'0D:~2,'0D:~2,'0D by ~A~%;;; ~\sysver\~%|
     (cadr date) (caddr date) (car date) (car daytime) (cadr daytime)
     (caddr daytime) (status uname) nil))


; (si:get-system-version-list sys) is defined to be the same as doing
; (multiple-value-list (si:get-system-version sys)), except the system
; argument is required.
(defun si:get-system-version-list (system)
  (let ((patdef (cdr (assoc (patch-pname system) *patch-systems))))
    (let (major minor status)
      (and patdef (setq major (patdef-version)
			minor (patver-version (car (patdef-versions)))
			status (patdef-status)))
      (list major minor status))))

(deflap si:get-system-version lsubr
    (args si:get-system-version (0 . 1))
	(jsp tt lwnack)
	  (#o000006_22 0 'si:get-system-version)
	(skipn 0 t)
	  (skipa a (special *default-system))
	    (pop p a)
	(call 1 'si:get-system-version-list)
	(hrrz b 0 a)
	(hlrz a 0 a)
	(hrrz c 0 b)
	(hlrz b 0 b)
	(hlrz c 0 c)
	(movei ar1 '1)
	(movem b (special *:ar2))
	(movem c (special *:ar3))
	(movem ar1 (special *:arn))
	(popj p)
    )


;;;; read, write, update stuff

(defun si:patch-write-pdir (pdir patdef)
  (patch-openo (f (format nil (si:patch-fspec (patdef-dir-fspecs) nil)
			  (patdef-version)))
     (format f '|;;; Patch directory for ~A ~D		-*- Lisp -*-~%|
	     (patdef-name) (patdef-version))
     (si:patch-comment f)
     (let ((base 10.) (*nopoint nil) (readtable (get 'readtable 'array)))
       (print (cons (patdef-status) pdir) f))))


(defun si:patch-read-pdir (patdef)
  (let ((versions (si:patch-1read
		     (format nil (si:patch-fspec (patdef-dir-fspecs) nil)
			     (patdef-version))))
	(status nil))
    (cond ((atom (car versions))
	     ;Old style pdir.
	     (setq versions (cdr versions) status (car versions)))
	  (t ;New style pdir.
	     (setq status
		   (patver-status (assoc (patver-version (patdef-versions))
					 versions)))))
    (setf (patdef-status) status)
    versions))

(defun si:patch-write-psys (patdef system-definition-file)
  (let ((base 10.) (*nopoint nil) (readtable (get 'readtable 'array)))
    (patch-openo (f system-definition-file)
      (si:patch-comment f)
      (print patdef f))))


(defun si:update-system-statuses (systems?)
  (mapc 'si:patch-read-pdir (or (mapcar 'si:patch-system-info systems?)
				(mapcar 'cdr *patch-systems)))
  t)


;;;; Note a new system.

;Define a new patch system.
; Third arg may be:
;   :INCREMENT-AND-DEFINE - the version number is incremented on disk,
; and the system defined in core.  This is what you get with NIL or no third
; arg.
;   :INCREMENT - same, without in-core definition.
;   :PROBE - no increment at all, no in-core definition.
; Good for getting the latest version number.
;   :DEFINE - no increment, but in-core definition.
;   A fixnum - is like :DEFINE, and overrides the in-core version to be
; that number.  (Had better be reasonable!)
; In all cases, the version number is returned.

(defun new-patch-system (name system-definition-file &optional (versionp nil)
			 &aux canon crap patdef p)
  (si:update-system-statuses nil)
  (setq system-definition-file
	(mergef (or system-definition-file '*) ; maybe completely default
		(mergef (list (list name) name)
			(caseq *patch-filesystem
			  (ITS '((DSK *) * |(PDIR)|))
			  (DEC10 '(* pdr))
			  (t '(* patch-directory))))))
  (setq p (si:patch-1read system-definition-file))
  (setq patdef
	(if (new-style-patdefp p)
	    p	; new-style patchsystem (whatever it happens to be)
	    (make-patdef	; old-style patchsystem (list of 5 elements)
	       patdef-name (car p)
	       patdef-version (cadr p)
	       patdef-dir-fspecs (list (cons *patch-filesystem (caddr p)))
	       patdef-patch-fspecs (list (cons *patch-filesystem
					       (cadddr p))))))
  (or (equal (patch-pname (patdef-name)) (setq canon (patch-pname name)))
      (error '|Mismatch| (list name p)))
  (or (and (null versionp) (setq versionp ':increment-and-define))
      (memq versionp '(:increment :probe :define :increment-and-define))
      (and (fixp versionp) (plusp versionp) (not (> versionp (patdef-version)))
	   (progn (setf (patdef-version) versionp) t))
      (error '|You lose|
	     (list 'new-patch-system name system-definition-file versionp)))
  (setf (patdef-versions)
	(if (memq versionp '(:increment-and-define :increment))
	    (let ((pdir (list (make-patver
				 patver-version 0
				 patver-description
				   (format nil '|~A Loaded| name)
				 patver-culprit (status uname)))))
	      (setf (patdef-version) (1+ (patdef-version)))
	      (setf (patdef-status) ':experimental)
	      (si:patch-write-pdir pdir patdef)
	      (si:patch-write-psys patdef system-definition-file)
	      pdir)
	    (si:patch-read-pdir patdef)))
  (or (memq versionp '(:probe :increment))
      (if (setq crap (assoc canon *patch-systems))
	  (rplacd crap patdef)
	  (setq *patch-systems (nconc *patch-systems
				      (list (cons canon patdef))))))
  (patdef-version))


;;;; load-patches

(defvar *patch-loader
  'load)

(defun load-patches (&rest options
		     &aux (systems ()) (selective t) (verbose t))
  (do () ((null options))
    (caseq (car options)
      (:systems (setq systems (car (setq options (cdr options)))))
      (:verbose (setq verbose t))
      (:selective (setq selective t))
      (:silent (setq verbose nil))
      (:noselective (setq selective nil))
      (t (error '|Bad option - load-patches| (car options))))
    (setq options (cdr options)))
  (loop with ch fixnum = 0
    for patdef in (or (mapcar 'si:patch-system-info systems)
		      (mapcar 'cdr *patch-systems))
    as name = (patdef-name)
    as major = (patdef-version)
    as patch-fspec = (si:patch-fspec (patdef-patch-fspecs) t)
    as versions = (patdef-versions)
    as minor = (patver-version (car versions))
    as external-versions = (si:patch-read-pdir patdef)
    as new-minor = (patver-version (car (last external-versions)))
    as ask = selective
    when (setq external-versions (cdr (memq (assoc minor external-versions)
					    external-versions)))
      do (or (null verbose)
	     (?format nil '|~&Patches for ~A (current version is ~D.~D):|
		      name major new-minor))
	 (loop
	  for patver in external-versions
	  as this-minor = (patver-version)
	  when (patver-lockedp)
	    do (or (null verbose)
		   (?format nil
		      '|~&~A hasn't finished patch for ~D.~D, ~A.~%|
		      (patver-culprit) major this-minor (patver-description)))
	       (return nil)
	  do (cond ((not ask)
		      (or (not verbose)
			  (?format nil
			    '|~&  Loading patches for ~D.~D: ~A  --~A~%|
			    major this-minor (patver-description)
			    (patver-culprit)))
		      (setq ch #/Y))
		   ((loop 
		      do (?format nil
			   '|~&  ~D.~D: ~A (made by ~A) -- Load?|
			   major this-minor (patver-description)
			   (patver-culprit))
		         (setq ch (tyi tyi))
		      when (lessp #.(1- #/a) ch #.(1+ #/z))
		        do (setq ch (- ch 32.))
		      when (or (= ch #/Y) (= ch #/N) (= ch #/P)) return nil
		      when (or (= ch #/T) (= ch #\sp))
		        do (setq ch #/Y) and return nil
		      when (= ch #\rubout) do (setq ch #/N) and return nil
		      do (princ '|/ answer Y, N, or P|))))
	     (if (not (= ch #/N))
		 (let (#+PDP10 (fasload nil))
		   (and (= ch #/P) (setq ask nil))
		   (funcall *patch-loader
			    (mergef (format nil patch-fspec major this-minor)
				    '((dsk *) * fasl)))
		   (rplacd versions (cons (car versions) (cdr versions)))
		   (rplaca versions patver)
		   (sstatus uuoli))
		 (return nil)))))