;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 123.242
;;; Reason:
;;;  Fix error messages from MAKE-SYSTEM and its friend, DO-FILE-TRANSFORMATIONS.
;;;  1. In MAKE-SYSTEM's error catcher, if it can, the proceed message prints
;;;  the system name, rather than whatever was passed as the SYSTEM argument to
;;;  MAKE-SYSTEM (which can be a system object and thus ugly).
;;;  2. Where a transformation pretty name contains a format descriptor (e.g.
;;;  "increment patch number for ~a"), FORMAT is now applied to the pretty name
;;;  with the system symbolic name as an argument, providing the intended effect
;;;  that error proceed messages include the system name.
;;; Written 27-Apr-88 13:06:35 by keith at site Gigamos Cambridge
;;; while running on Azathoth from band 1
;;; with Experimental System 123.240, Experimental Local-File 73.4, Experimental FILE-Server 22.2, Experimental Unix-Interface 11.0, Experimental KERMIT 34.3, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, Experimental Tape 22.1, Experimental KMC 1.0, microcode 1755, SDU Boot Tape 3.14, SDU ROM 8, the old ones.



; From modified file DJ: L.SYS2; MAKSYS.LISP#205 at 27-Apr-88 13:06:52
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; MAKSYS  "


(DEFUN MAKE-SYSTEM (SYSTEM &REST KEYWORDS &AUX *SOMETHING-LOADED*)
  "Operate on the files of the system SYSTEM.
Most commonly used to compile or load those files which need it.
Keywords are not followed by values.
Commonly used keywords include:
 :COMPILE - recompile source files.
 :NOLOAD - don't load compiled files.
 :RELOAD - load even files already loaded.
 :RECOMPILE - recompile files already compiled.
 :SELECTIVE - ask user about each file individually.
 :NOCONFIRM - do not ask for confirmation at all.
 :NO-INCREMENT-PATCH - don't increment the patch version number of a patchable system.
 :INCREMENT-PATCH - do increment the patch version number.
 :NO-LOAD-PATCHES - do not load patches for patchable system being loaded.
 :NO-RELOAD-SYSTEM-DECLARATION - don't reload the file that contains the DEFSYSTEM.
 :PRINT-ONLY - don't load or compile anything, just say what needs to be done.
 :DESCRIBE - say when files were compiled or loaded, etc.
 :SILENT - don't print lists of files on the terminal at all.
 :BATCH - write a file containing any warnings produced by compilation.
      Just load the file, as lisp code, to reload the warnings.
 :DO-NOT-DO-COMPONENTS - omit subsystems."
  (catch-error-restart (eh:debugger-condition
			 "Give up on making the ~A system."
			 (let ((sys (find-system-named system t)))
			   (if sys (system-name sys) system)))
    ;; Force the system-defining file to get loaded
    ;; before we bind the variables or anything like that.
    (FIND-SYSTEM-NAMED SYSTEM)
    ;; First check whether there is a new system declaration that can be loaded
    (MAYBE-RELOAD-SYSTEM-DECLARATION SYSTEM KEYWORDS)
    (PROGW *MAKE-SYSTEM-SPECIAL-VARIABLES*
      (UNWIND-PROTECT
	  (PROGN
	    (SETQ *SYSTEM-BEING-MADE* (FIND-SYSTEM-NAMED SYSTEM))
	    (SETQ *SYSTEM-DEFAULT-BINARY-FILE-TYPE*
		  (system-default-binary-file-type *SYSTEM-BEING-MADE*))
	    (SETQ *TOP-LEVEL-TRANSFORMATIONS*
		  `(,@*LOAD-TYPE-TRANSFORMATIONS* DO-COMPONENTS-INTERNAL))
	    ;; Do all the keywords
	    (DOLIST (KEYWORD KEYWORDS)
	      (LET ((FUNCTION (GET KEYWORD 'MAKE-SYSTEM-KEYWORD)))
		(OR FUNCTION
		    (FERROR NIL "~S is not a recognized option" KEYWORD))
		(FUNCALL FUNCTION)))
	    ;; Make :NO-INCREMENT-PATCH override :COMPILE even if :COMPILE comes later.
	    (WHEN *NO-INCREMENT-PATCH*
	      (SETQ *TOP-LEVEL-TRANSFORMATIONS*
		    (DEL-IF #'(LAMBDA (X)
				(MEMQ X '(INCREMENT-COMPILED-VERSION)))
			    *TOP-LEVEL-TRANSFORMATIONS*)))
	    ;; Process forms with compiler context
	    (DOLIST (FORM *MAKE-SYSTEM-FORMS-TO-BE-EVALED-BEFORE*)
	      (EVAL FORM))
	    ;; Do the work of the transformations
	    (PERFORM-TRANSFORMATIONS (COLLECT-TOP-LEVEL-TRANSFORMATIONS
				       *SYSTEM-BEING-MADE*))
	    ;; Finally process any forms queued by the keywords with compiler context
	    (DOLIST (FORM *MAKE-SYSTEM-FORMS-TO-BE-EVALED-AFTER*)
	      (EVAL FORM)))
	;; Now forms outside of compiler context
	;; These are done even if there was an error.
	(DOLIST (FORM *MAKE-SYSTEM-FORMS-TO-BE-EVALED-FINALLY*)
	  (EVAL FORM))))
    *SOMETHING-LOADED*))

))

; From modified file DJ: L.SYS2; MAKSYS.LISP#205 at 27-Apr-88 13:06:54
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; MAKSYS  "

(DEFUN DO-FILE-TRANSFORMATIONS ()
  (IF (OR (EQ *QUERY-TYPE* :NOCONFIRM)
	   (QUERY-USER-LIST))
      ;;Now actually do the work
      (DOLIST (FILE-TRANSFORMATION *FILE-TRANSFORMATION-LIST*)
	(LET ((STATE (FILE-TRANSFORMATION-STATE FILE-TRANSFORMATION)))
	  (case STATE
	    ((:DONE :REFUSED :NOT-NEEDED NIL))	;Already done or user said no
	    ((:PENDING :PROBABLY)
	     (LET ((TYPE (FILE-TRANSFORMATION-TRANSFORMATION-TYPE FILE-TRANSFORMATION))
		   (ARGS (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION))
		   (*FORCE-PACKAGE* (FILE-TRANSFORMATION-FORCE-PACKAGE FILE-TRANSFORMATION))
		   (*SYSTEM-BEING-MADE* (FILE-TRANSFORMATION-SYSTEM FILE-TRANSFORMATION)))
	       (COND ((IF (EQ STATE :PROBABLY)	;If we suspected something would change
			  (IF (APPLY (FILE-TRANSFORMATION-CONDITION-FUNCTION	;check again
				       FILE-TRANSFORMATION)
				     ARGS)
			      T
			      (SETQ STATE :NOT-NEEDED)	;Turned out it didn't
			      NIL)		;Don't do it
			  T)
		      ;;Otherwise perform the transformation
		      (OR *SILENT-P*
			  (FORMAT T "~&~\SI::FILE-XFORM-TYPE\~:[ ~\SI::FILE-XFORM-ARGS\~;~*~]~
				     ~:[~; in~:[to~] package ~A~]"
				  TYPE (NULL ARGS) FILE-TRANSFORMATION *FORCE-PACKAGE*
				  (FILE-TRANSFORMATION-OUTPUTS FILE-TRANSFORMATION)
				  *FORCE-PACKAGE*))
		      (CATCH-ERROR-RESTART
			;;Fix to previous fix:
			;; Added the extra call to FORMAT to handle the simple-transformations
			;; whose pretty-name(s) have format directives that, apparently, should
			;; be applied to some form of the system name.  Prevents weird error 
			;; proceed messages.  Also made the printing of transformation arguments
			;; occur only when non-NIL.  -KmC
			(error "Give up ~(~A~)~@[ ~A~]."
			       (format nil
				       (transformation-type-pretty-present-participle type)
				       (system-symbolic-name *system-being-made*))
			       (car args))
			(error-restart
			  (error "Retry ~(~A~)~@[ ~A~]."
				 (format nil
					 (transformation-type-pretty-present-participle type)
					 (system-symbolic-name *system-being-made*))
				 (car args))
  			  (APPLY (TRANSFORMATION-TYPE-FUNCTION TYPE) ARGS))
			(SETQ STATE :DONE)
			;;That probably made new versions of the outputs files
			(DOLIST (PATHNAME (FILE-TRANSFORMATION-OUTPUTS FILE-TRANSFORMATION))
			  ;; So, forget any file info for the file.
			  (INVALIDATE-PATHNAME-INFO PATHNAME)
			  ;; Any transformation already done will need to be redone.
			  (DOLIST (FILE-XFORM *FILE-TRANSFORMATION-LIST*)
			    ;; Removed a check for :REFUSED here, 1/25/84,
			    ;; so that once a user says No, the transformation WILL NOT go.
			    (AND (MEMQ (FILE-TRANSFORMATION-STATE FILE-XFORM) '(:DONE))
				 (DO ((L (FILE-TRANSFORMATION-ARGS FILE-XFORM) (CDR L))
				      (TAIL (FILE-TRANSFORMATION-OUTPUTS FILE-XFORM)))
				     ((EQ L TAIL) NIL)
				   (AND (EQ PATHNAME (CAR L)) (RETURN T)))
				 (SETF (FILE-TRANSFORMATION-STATE FILE-XFORM) :PROBABLY))))))))
	     (SETF (FILE-TRANSFORMATION-STATE FILE-TRANSFORMATION) STATE))
	    (OTHERWISE
	     (FERROR NIL "Transformation ~S in bad state" FILE-TRANSFORMATION)))))
    ;; If user says No to the entire bunch of transformations
    (DOLIST (FILE-TRANSFORMATION *FILE-TRANSFORMATION-LIST*)
      (AND (MEMQ (FILE-TRANSFORMATION-STATE FILE-TRANSFORMATION) '(:PENDING :PROBABLY))
	   (SETF (FILE-TRANSFORMATION-STATE FILE-TRANSFORMATION) :REFUSED)))))

;;; Ask the user about a set of transformations pending

))