;;; The system system. -*- Mode:LISP; Package:SYSTEM-INTERNALS -*-
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **

;;; Here for some bizarre reason
(DEFMACRO PUSH* (ITEM LIST)
  `(OR (MEMQ ,ITEM ,LIST) (PUSH ,ITEM ,LIST)))

;;; Define special variables bound during DEFSYSTEM and MAKE-SYSTEM
(DEFMACRO DEFINE-SPECIAL-VARIABLE (NAME INITIAL-VALUE WHERE &OPTIONAL (DEFVAR-P T))
  `(PROGN 'COMPILE
     ,(AND DEFVAR-P `(DEFVAR ,NAME))
     (DEFINE-SPECIAL-VARIABLE-1 ',NAME ',INITIAL-VALUE ',WHERE)))

(DEFUN DEFINE-SPECIAL-VARIABLE-1 (NAME INITIAL-VALUE WHERE &AUX ELEM)
  (IF (SETQ ELEM (ASSQ NAME (SYMEVAL WHERE)))
      (SETF (CDR ELEM) (NCONS INITIAL-VALUE))
      (PUSH (LIST NAME INITIAL-VALUE) (SYMEVAL WHERE))))

;;; Systems
(DEFSTRUCT (SYSTEM :ARRAY :NAMED :CONC-NAME
		   (:CONSTRUCTOR CONSTRUCT-SYSTEM-INTERNAL))
  NAME						;Symbol or string
  COMPONENT-SYSTEMS				;List of SYSTEM-NAME's
  MODULES					;List of MODULE's
  TOP-LEVEL-TRANSFORMATIONS			;List of TRANSFORMATION's
  TRANSFORMATIONS				;Those defined at any level
  PLIST)

(DEFSELECT ((SYSTEM NAMED-STRUCTURE-INVOKE))
  (:PRINT-SELF (SYSTEM STREAM PRINDEPTH SLASHIFY-P)
    PRINDEPTH SLASHIFY-P			;Not used
    (SI:PRINTING-RANDOM-OBJECT (SYSTEM STREAM)
      (PRINC (NAMED-STRUCTURE-SYMBOL SYSTEM) STREAM)
      (FUNCALL STREAM ':TYO #\SP)
      (PRINC (SYSTEM-NAME SYSTEM) STREAM))))

;;; Slots not actually in the defstruct
(DEFMACRO SYSTEM-PACKAGE-DEFAULT (SYSTEM)
  `(GET (LOCF (SYSTEM-PLIST ,SYSTEM)) ':PACKAGE))

(DEFSTRUCT (MODULE :ARRAY :NAMED :CONC-NAME)
  NAME						;A symbol
  SYSTEM					;A SYSTEM
  COMPONENTS					;A list of MODULE's, PATHNAME lists,
						;or (SYSTEM-NAME . MODULE names)
  PLIST)

(DEFSELECT ((MODULE NAMED-STRUCTURE-INVOKE))
  (:PRINT-SELF (MODULE STREAM IGNORE IGNORE)
    (SI:PRINTING-RANDOM-OBJECT (MODULE STREAM)
      (FORMAT STREAM "~A (~A ~A)"
	      (NAMED-STRUCTURE-SYMBOL MODULE)
	      (SYSTEM-NAME (MODULE-SYSTEM MODULE))
	      (MODULE-NAME MODULE)))))

(DEFSTRUCT (TRANSFORMATION :ARRAY :NAMED :CONC-NAME)
  TRANSFORMATION-TYPE				;A TRANSFORMATION-TYPE
  INPUT						;A MODULE or a TRANSFORMATION
  DEPENDENCIES					;A list of TRANSFORMATION's
  CONDITION-FUNCTION				;A symbol
  SYSTEM					;The system this belongs to
  )

(DEFSELECT ((TRANSFORMATION NAMED-STRUCTURE-INVOKE))
  (:PRINT-SELF (TRANSFORMATION STREAM IGNORE IGNORE &AUX TEMP)
    (SI:PRINTING-RANDOM-OBJECT (TRANSFORMATION STREAM)
      (FORMAT STREAM "~A~@[ ~A~]"
	      (NAMED-STRUCTURE-SYMBOL TRANSFORMATION)
	      (AND (SETQ TEMP (TRANSFORMATION-TRANSFORMATION-TYPE TRANSFORMATION))
		   (TRANSFORMATION-TYPE-NAME TEMP))))))

(DEFSTRUCT (TRANSFORMATION-TYPE :LIST :CONC-NAME)
  NAME						;A symbol (in the keyword package)
  PRETTY-NAMES					;("Foo" "Fooing" "fooed")
  FUNCTION					;A symbol
  INPUT-FILE-TYPES				;A list of strings
  OUTPUT-FILE-TYPES)

(DEFSTRUCT (TRANSFORMATION-TYPE-PRETTY-NAMES :LIST :CONC-NAME
					     (:CONSTRUCTOR NIL))
  IMPERATIVE					;Foo
  PRESENT-PARTICIPLE				;Fooing
  PAST-PARTICIPLE)				;fooed

(DEFMACRO TRANSFORMATION-TYPE-PRETTY-IMPERATIVE (TRANSFORMATION-TYPE)
  `(TRANSFORMATION-TYPE-PRETTY-NAMES-IMPERATIVE
     (TRANSFORMATION-TYPE-PRETTY-NAMES ,TRANSFORMATION-TYPE)))

(DEFMACRO TRANSFORMATION-TYPE-PRETTY-PRESENT-PARTICIPLE (TRANSFORMATION-TYPE)
  `(TRANSFORMATION-TYPE-PRETTY-NAMES-PRESENT-PARTICIPLE
     (TRANSFORMATION-TYPE-PRETTY-NAMES ,TRANSFORMATION-TYPE)))

(DEFMACRO TRANSFORMATION-TYPE-PRETTY-PAST-PARTICIPLE (TRANSFORMATION-TYPE)
  `(TRANSFORMATION-TYPE-PRETTY-NAMES-PAST-PARTICIPLE
     (TRANSFORMATION-TYPE-PRETTY-NAMES ,TRANSFORMATION-TYPE)))

(DEFSTRUCT (FILE-TRANSFORMATION :LIST* :CONC-NAME)
  STATE						;NIL, :PENDING, :DONE, :NOT-NEEDED or :REFUSED
  TRANSFORMATION-TYPE				;A TRANSFORMATION-TYPE
  FORCE-PACKAGE					;A symbol, transformation takes place there
  SYSTEM					;The one to perform within
  CONDITION-FUNCTION				;A symbol or closure
  OUTPUTS					;An NTHCDR of F-T-ARGS
  ARGS)

(DEFMACRO DEFSYSTEM (NAME &BODY OPTIONS)
  `(DEFSYSTEM-1 ',NAME ',(COPYLIST OPTIONS)))

;;; Variables that DEFSYSTEM-MACRO's can look at
(DEFVAR *DEFSYSTEM-SPECIAL-VARIABLES* NIL)

(DEFMACRO DEFINE-DEFSYSTEM-SPECIAL-VARIABLE (NAME FORM)
  `(DEFINE-SPECIAL-VARIABLE ,NAME ,FORM *DEFSYSTEM-SPECIAL-VARIABLES*))

;;; Save a little on evaluating macros
(DEFUN CONSTRUCT-SYSTEM ()
  (CONSTRUCT-SYSTEM-INTERNAL))

(DEFINE-DEFSYSTEM-SPECIAL-VARIABLE *SYSTEM-BEING-DEFINED* (CONSTRUCT-SYSTEM))

(DEFUN DEFSYSTEM-1 (NAME OPTIONS &OPTIONAL (ADD-P T))
  (RECORD-SOURCE-FILE-NAME NAME 'DEFSYSTEM)
  (PROGW *DEFSYSTEM-SPECIAL-VARIABLES*
    (SETF (SYSTEM-SYMBOLIC-NAME *SYSTEM-BEING-DEFINED*) NAME)
    (SETF (SYSTEM-NAME *SYSTEM-BEING-DEFINED*) (STRING NAME))
    (DOLIST (OPTION OPTIONS)
      (CALL-DEFSYSTEM-MACRO OPTION))
    ;; Put in the components if they weren't mentioned explicitly
    (AND (SYSTEM-COMPONENT-SYSTEMS *SYSTEM-BEING-DEFINED*)
	 (NOT *COMPONENTS-ALREADY-DONE*)
	 (CALL-DEFSYSTEM-MACRO '(DO-COMPONENTS-INTERNAL NIL)))
    ;; Put any patching transformations at the end
    (AND (SYSTEM-PATCHABLE-P *SYSTEM-BEING-DEFINED*)
	 (CALL-DEFSYSTEM-MACRO '(PATCHABLE-INTERNAL)))
    (AND ADD-P (ADD-SYSTEM *SYSTEM-BEING-DEFINED*)))
  NAME)

(DEFUN CALL-DEFSYSTEM-MACRO (FORM)
  (DO ((MACRO-FUNCTION)
       (VAL1) (VAL2))				;Kludge for multiple values
      ((NULL FORM) (VALUES VAL1 VAL2))
    (SETQ MACRO-FUNCTION (GET (CAR FORM) 'DEFSYSTEM-MACRO))
    (OR (EQ (CAR MACRO-FUNCTION) 'MACRO)
	(FERROR NIL "~S is not a valid DEFSYSTEM form" FORM))
    (MULTIPLE-VALUE (FORM VAL1 VAL2)
      (FUNCALL (CDR MACRO-FUNCTION) FORM))))

;;; All the systems in this world
(DEFVAR *SYSTEMS-LIST* NIL)

(DEFUN ADD-SYSTEM (SYSTEM)
  (SETQ *SYSTEMS-LIST* (CONS SYSTEM (DEL #'(LAMBDA (X Y)
					     (STRING-EQUAL (SYSTEM-NAME X) (SYSTEM-NAME Y)))
					 SYSTEM *SYSTEMS-LIST*))))

(DEFMACRO SYSTEM-SHORT-NAME-INTERNAL (SYSTEM)
  `(GET (LOCF (SYSTEM-PLIST ,SYSTEM)) ':SHORT-NAME))

(DEFMACRO SYSTEM-NICKNAMES (SYSTEM)
  `(GET (LOCF (SYSTEM-PLIST ,SYSTEM)) ':NICKNAMES))

(DEFMACRO SYSTEM-SYMBOLIC-NAME (SYSTEM)
  `(GET (LOCF (SYSTEM-PLIST ,SYSTEM)) ':SYMBOLIC-NAME))

;;; Some simple defsystem macros
(DEFMACRO (:NAME DEFSYSTEM-MACRO) (NAME)
  ;; If not just changing the case, add the old name as a nickname
  (AND (NOT (STRING-EQUAL NAME (SYSTEM-NAME *SYSTEM-BEING-DEFINED*)))
       (PUSH (SYSTEM-NAME *SYSTEM-BEING-DEFINED*) (SYSTEM-NICKNAMES *SYSTEM-BEING-DEFINED*)))
  (SETF (SYSTEM-NAME *SYSTEM-BEING-DEFINED*) NAME)
  NIL)

(DEFMACRO (:SHORT-NAME DEFSYSTEM-MACRO) (NAME)
  (SETF (SYSTEM-SHORT-NAME-INTERNAL *SYSTEM-BEING-DEFINED*) NAME)
  (PUSH NAME (SYSTEM-NICKNAMES *SYSTEM-BEING-DEFINED*))
  NIL)

(DEFMACRO (:NICKNAMES DEFSYSTEM-MACRO) (&REST NAMES)
  (SETF (SYSTEM-NICKNAMES *SYSTEM-BEING-DEFINED*) NAMES)
  NIL)

(DEFUN SYSTEM-SHORT-NAME (SYSTEM)
  (SETQ SYSTEM (FIND-SYSTEM-NAMED SYSTEM))
  (OR (SYSTEM-SHORT-NAME-INTERNAL SYSTEM)
      (SYSTEM-NAME SYSTEM)))

(DEFMACRO (:PACKAGE DEFSYSTEM-MACRO) (PKG)
  (SETF (SYSTEM-PACKAGE-DEFAULT *SYSTEM-BEING-DEFINED*) PKG)
  NIL)

(DEFINE-DEFSYSTEM-SPECIAL-VARIABLE *SYSTEM-PATHNAME-DEFAULT* (FS:MAKE-PATHNAME-DEFAULTS))

;;; Pathnames
(DEFMACRO (:PATHNAME-DEFAULT DEFSYSTEM-MACRO) (DEFAULT)
  (FS:MERGE-AND-SET-PATHNAME-DEFAULTS DEFAULT *SYSTEM-PATHNAME-DEFAULT*)
  NIL)

(DEFUN PATHNAME-P (X)
  (OR (STRINGP X) (TYPEP X 'FS:PATHNAME)))

(DEFUN CANONICALIZE-PATHNAME (PATHNAME &OPTIONAL (DEFAULT *SYSTEM-PATHNAME-DEFAULT*))
  (FS:MERGE-PATHNAME-DEFAULTS PATHNAME DEFAULT NIL))

(DEFUN MERGE-PATHNAME-TYPE (PATHNAME TYPE &AUX OTYPE)
  (FS:MERGE-PATHNAME-DEFAULTS
    (COND ((MEMQ (SETQ OTYPE (FUNCALL PATHNAME ':TYPE)) '(NIL :UNSPECIFIC))
	   (FUNCALL PATHNAME ':NEW-PATHNAME ':TYPE TYPE ':VERSION ':NEWEST))
	  ((EQUAL OTYPE TYPE)
	   PATHNAME)
	  (T
	   (FERROR NIL "Pathname types out of synch, want ~A for ~A" TYPE PATHNAME)))))

;;; Component systems
(DEFMACRO (:COMPONENT-SYSTEMS DEFSYSTEM-MACRO) (&REST COMPONENTS)
  (SETF (SYSTEM-COMPONENT-SYSTEMS *SYSTEM-BEING-DEFINED*) (COPYLIST COMPONENTS))
  NIL)

(DEFINE-DEFSYSTEM-SPECIAL-VARIABLE *COMPONENTS-ALREADY-DONE* NIL)

(DEFMACRO (:DO-COMPONENTS DEFSYSTEM-MACRO) (DEPENDENCIES)
  (SETQ *COMPONENTS-ALREADY-DONE* T)
  `(DO-COMPONENTS-INTERNAL NIL ,DEPENDENCIES))

;;; Add a new module
(DEFMACRO (:MODULE DEFSYSTEM-MACRO) (NAME COMPONENTS &REST PLIST)
  (ADD-MODULE NAME *SYSTEM-BEING-DEFINED* COMPONENTS (COPYLIST PLIST))
  NIL)

(DEFUN ADD-MODULE (NAME SYSTEM COMPONENTS &OPTIONAL PLIST &AUX MODULE)
  ;;Check for one already there
  (AND (FIND-MODULE-NAMED NAME SYSTEM T)
       (FERROR NIL "Duplicate module name ~A in system ~S" NAME SYSTEM))
  (SETQ MODULE (MAKE-MODULE NAME NAME SYSTEM SYSTEM PLIST PLIST
			    COMPONENTS (PARSE-MODULE-COMPONENTS COMPONENTS SYSTEM)))
  (PUSH MODULE (SYSTEM-MODULES SYSTEM))
  MODULE)

(DEFUN FIND-MODULE-NAMED (NAME SYSTEM &OPTIONAL NO-ERROR-P)
  (SETQ SYSTEM (FIND-SYSTEM-NAMED SYSTEM))
  (OR (DOLIST (MODULE (SYSTEM-MODULES SYSTEM))
	(AND (STRING-EQUAL (MODULE-NAME MODULE) NAME)
	     (RETURN MODULE)))
      (IF NO-ERROR-P NIL
	  (FERROR NIL "Module ~S not found in ~S" NAME SYSTEM))))

(DEFUN FIND-SYSTEM-NAMED (NAME &OPTIONAL NO-ERROR-P)
  (IF (TYPEP NAME 'SYSTEM) NAME
      (OR (DOLIST (SYSTEM *SYSTEMS-LIST*)
	    (AND (OR (STRING-EQUAL NAME (SYSTEM-NAME SYSTEM))
		     (MEM #'STRING-EQUAL NAME (SYSTEM-NICKNAMES SYSTEM)))
		 (RETURN SYSTEM)))
	  (IF NO-ERROR-P NIL
	      (FERROR NIL "System ~S not found" NAME)))))

;;; MODULE-SPECIFICATION := PATHNAME |
;;; 			    MODULE-NAME |
;;; 			    MODULE-EXTERNAL-COMPONENT |
;;; 			    (MODULE-COMPONENT-1 ... MODULE-COMPONENT-N)
;;; PATHNAME := "..."			;String merged into a pathname with the defaults
;;; MODULE-NAME := a symbol
;;; MODULE-EXTERNAL-COMPONENT := (SYSTEM-NAME &REST MODULE-NAMES)
;;; MODULE-COMPONENT := MODULE-NAME |
;;;			MODULE-EXTERNAL-COMPONENT |
;;;			MODULE-SINGLE-FILE
;;; MODULE-SINGLE-FILE := PATHNAME |
;;;			  (PATHNAME-1 ... PATHNAME-N)	;When source differs from output
;;; The idea is that you have to have two levels of list structure in the
;;; case where you have a source in a different place than the output.
(DEFUN PARSE-MODULE-COMPONENTS (COMPONENTS SYSTEM)
  (COND ((PATHNAME-P COMPONENTS)
	 ;;Single pathname
	 (LIST (LIST (CANONICALIZE-PATHNAME COMPONENTS))))
	((SYMBOLP COMPONENTS)
	 (LIST (FIND-MODULE-NAMED COMPONENTS SYSTEM)))	;Single other module
	((NLISTP COMPONENTS)
	 (FERROR NIL "~S is not a recognized module component specification" COMPONENTS))
	((AND (SYMBOLP (CAR COMPONENTS)) (NOT (FIND-MODULE-NAMED (CAR COMPONENTS) SYSTEM T)))
	 (DOLIST (NAME (CDR COMPONENTS))		;External modules
	   (OR (SYMBOLP NAME)
	       (FERROR NIL
		       "~S is not a recognized external module component specification in ~S"
		       NAME COMPONENTS)))
	 (LIST COMPONENTS))
	(T
	 (LOOP FOR COMPONENT IN COMPONENTS
	       WITH TEM
	       COLLECT (COND ((PATHNAME-P COMPONENT)
			      (LIST (CANONICALIZE-PATHNAME COMPONENT)))
			     ((SYMBOLP COMPONENT)
			      (FIND-MODULE-NAMED COMPONENT SYSTEM))
			     ((NLISTP COMPONENT)
			      (FERROR NIL
				      "~S is not a recognized module component specification"
				      COMPONENT))
			     ((SYMBOLP (SETQ TEM (CAR COMPONENT)))
			      (DOLIST (NAME (CDR COMPONENT))
				(OR (SYMBOLP NAME)
				    (FERROR NIL
			"~S is not a recognized external module component specification in ~S"
					    NAME COMPONENT)))
			      COMPONENT)
			     ((PATHNAME-P TEM)
			      (LOOP FOR PATHNAME IN COMPONENT
				    AND DEFAULT = *SYSTEM-PATHNAME-DEFAULT* THEN PATHNAME
				    COLLECT (SETQ PATHNAME (CANONICALIZE-PATHNAME PATHNAME
										  DEFAULT))))
			     (T
			      (FERROR NIL
				      "~S is not a recognized module component specification"
				      COMPONENT)))))))

(DEFVAR *MAKE-SYSTEM-SPECIAL-VARIABLES* NIL)

(DEFMACRO DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE (NAME FORM &OPTIONAL (DEFVAR-P T))
  `(DEFINE-SPECIAL-VARIABLE ,NAME ,FORM *MAKE-SYSTEM-SPECIAL-VARIABLES* ,DEFVAR-P))

(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *QUERY-TYPE* ':NORMAL)

(DEFUN (:NOCONFIRM MAKE-SYSTEM-KEYWORD) ()
  (SETQ *QUERY-TYPE* ':NOCONFIRM))

(DEFUN (:SELECTIVE MAKE-SYSTEM-KEYWORD) ()
  (SETQ *QUERY-TYPE* ':SELECTIVE))

(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *SILENT-P* NIL)

(DEFUN (:SILENT MAKE-SYSTEM-KEYWORD) ()
  (SETQ *SILENT-P* T))

(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *REDO-ALL* NIL)

(DEFUN (:RELOAD MAKE-SYSTEM-KEYWORD) ()
  (SETQ *REDO-ALL* T))

(DEFVAR *LOAD-TYPE-TRANSFORMATIONS* NIL)
(DEFVAR *COMPILE-TYPE-TRANSFORMATIONS* NIL)
(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *TOP-LEVEL-TRANSFORMATIONS*
				     `(,@*LOAD-TYPE-TRANSFORMATIONS* DO-COMPONENTS-INTERNAL))

(DEFUN (:NOLOAD MAKE-SYSTEM-KEYWORD) ()
  (SETQ *TOP-LEVEL-TRANSFORMATIONS*
	(DEL-IF #'(LAMBDA (X)
		    (MEMQ X *LOAD-TYPE-TRANSFORMATIONS*))
		*TOP-LEVEL-TRANSFORMATIONS*)))

(DEFUN (:COMPILE MAKE-SYSTEM-KEYWORD) ()
  (SETQ *TOP-LEVEL-TRANSFORMATIONS*
	(APPEND *COMPILE-TYPE-TRANSFORMATIONS*
		(DEL-IF #'(LAMBDA (X)
			    (MEMQ X *COMPILE-TYPE-TRANSFORMATIONS*))
			*TOP-LEVEL-TRANSFORMATIONS*)
		*TOP-LEVEL-TRANSFORMATIONS*)))

(DEFUN (:RECOMPILE MAKE-SYSTEM-KEYWORD) ()
  (FUNCALL (GET ':RELOAD 'MAKE-SYSTEM-KEYWORD))
  (FUNCALL (GET ':COMPILE 'MAKE-SYSTEM-KEYWORD)))

(DEFUN (:NO-INCREMENT-PATCH MAKE-SYSTEM-KEYWORD) ()
  (SETQ *TOP-LEVEL-TRANSFORMATIONS*
	(DEL-IF #'(LAMBDA (X) (MEMQ X '(INCREMENT-COMPILED-VERSION INCREMENT-LOADED-VERSION)))
		*TOP-LEVEL-TRANSFORMATIONS*)))

(DEFUN (:INCREMENT-PATCH MAKE-SYSTEM-KEYWORD) ()
  (SETQ *TOP-LEVEL-TRANSFORMATIONS*
	(APPEND '(INCREMENT-COMPILED-VERSION INCREMENT-LOADED-VERSION)
		*TOP-LEVEL-TRANSFORMATIONS*)))

(DEFUN (:DO-NOT-DO-COMPONENTS MAKE-SYSTEM-KEYWORD) ()
  (SETQ *TOP-LEVEL-TRANSFORMATIONS*
	(DELQ 'DO-COMPONENTS-INTERNAL *TOP-LEVEL-TRANSFORMATIONS*)))

(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *BATCH-MODE-P* NIL)
(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE INHIBIT-FDEFINE-WARNINGS INHIBIT-FDEFINE-WARNINGS NIL)
(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE COMPILER:COMPILER-WARNINGS-BUFFER
				     COMPILER:COMPILER-WARNINGS-BUFFER NIL)
(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE TV:MORE-PROCESSING-GLOBAL-ENABLE
				     TV:MORE-PROCESSING-GLOBAL-ENABLE NIL)

(DEFUN (:NOWARN MAKE-SYSTEM-KEYWORD) ()
  (SETQ INHIBIT-FDEFINE-WARNINGS ':JUST-WARN
	TV:MORE-PROCESSING-GLOBAL-ENABLE NIL
	*BATCH-MODE-P* T
	*QUERY-TYPE* ':NOCONFIRM))

(DEFUN (:BATCH MAKE-SYSTEM-KEYWORD) (&AUX PATHNAME)
  (SETQ PATHNAME (FUNCALL (FS:USER-HOMEDIR) ':NEW-PATHNAME ':NAME "CWARNS"
							   ':TYPE "TEXT"
							   ':VERSION ':NEWEST))
  (FORMAT QUERY-IO "~&Write compiler warnings to file: (default ~A) " PATHNAME)
  (SETQ PATHNAME (FS:MERGE-PATHNAME-DEFAULTS (READLINE QUERY-IO) PATHNAME))
  (FUNCALL ZWEI:*ZMACS-COMMAND-LOOP* ':FIND-EMPTY-FILE PATHNAME)
  (SETQ COMPILER:COMPILER-WARNINGS-BUFFER (FUNCALL PATHNAME ':STRING-FOR-EDITOR))
  (SETQ INHIBIT-FDEFINE-WARNINGS ':JUST-WARN
	TV:MORE-PROCESSING-GLOBAL-ENABLE NIL
	*BATCH-MODE-P* T
	*QUERY-TYPE* ':NOCONFIRM)
  (PUSH '(PRINT-BATCH-MAKE-SYSTEM-HEADER) *MAKE-SYSTEM-FORMS-TO-BE-EVALED-BEFORE*)
  (PUSH `(FUNCALL ',ZWEI:*ZMACS-COMMAND-LOOP* ':SAVE-FILE ',PATHNAME)
	*MAKE-SYSTEM-FORMS-TO-BE-EVALED-FINALLY*))

(DEFUN PRINT-BATCH-MAKE-SYSTEM-HEADER ()
  (FORMAT COMPILER:COMPILER-WARNINGS-INTERVAL-STREAM
	  "~&System ~A made by ~A at ~\DATIME\~%"
	  (SYSTEM-NAME *SYSTEM-BEING-MADE*) USER-ID))

(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *SYSTEM-BEING-MADE* NIL)
(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *MAKE-SYSTEM-FORMS-TO-BE-EVALED-BEFORE* NIL)
(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *MAKE-SYSTEM-FORMS-TO-BE-EVALED-AFTER* NIL)
(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *MAKE-SYSTEM-FORMS-TO-BE-EVALED-FINALLY* NIL)

(DEFUN MAKE-SYSTEM (SYSTEM &REST KEYWORDS)
  ;; First check whether there is a new system declaration that can be loaded
  (MAYBE-RELOAD-SYSTEM-DECLARATION SYSTEM KEYWORDS)
  (PROGW *MAKE-SYSTEM-SPECIAL-VARIABLES*
    (SETQ *SYSTEM-BEING-MADE* (FIND-SYSTEM-NAMED SYSTEM))
    ;; 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)))
    ;; Put all compiler messages together for this run
    (COMPILER:COMPILER-WARNINGS-CONTEXT-BIND
      ;; 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
    (DOLIST (FORM *MAKE-SYSTEM-FORMS-TO-BE-EVALED-FINALLY*)
      (EVAL FORM)))
  T)

(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *FORCE-PACKAGE* NIL)

;;; Get all the transformations mentioned in a system or its children
(DEFUN COLLECT-TOP-LEVEL-TRANSFORMATIONS (SYSTEM &OPTIONAL FORCE-DEPENDENCIES &AUX PKG)
  (SETQ SYSTEM (FIND-SYSTEM-NAMED SYSTEM)
	PKG (SYSTEM-PACKAGE-DEFAULT SYSTEM))
  (LET-IF PKG ((*FORCE-PACKAGE* PKG))
    (LOOP FOR XFORM IN (SYSTEM-TOP-LEVEL-TRANSFORMATIONS SYSTEM)
	  NCONC (IF (EQ (TRANSFORMATION-TYPE-NAME (TRANSFORMATION-TRANSFORMATION-TYPE XFORM))
			'DO-COMPONENTS-INTERNAL)
		    (AND (MEMQ 'DO-COMPONENTS-INTERNAL *TOP-LEVEL-TRANSFORMATIONS*)
			 (LOOP FOR SUBSYS IN (SYSTEM-COMPONENT-SYSTEMS SYSTEM)
			       WITH FORCE = (APPEND FORCE-DEPENDENCIES
						    (TRANSFORMATION-DEPENDENCIES XFORM))
			       NCONC (COLLECT-TOP-LEVEL-TRANSFORMATIONS SUBSYS FORCE)))
		    (NCONS (LIST XFORM *FORCE-PACKAGE* FORCE-DEPENDENCIES))))))

(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *FILE-TRANSFORMATION-LIST* NIL)
(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *FILE-TRANSFORMATION-FUNCTION* 'DO-FILE-TRANSFORMATIONS)

;;; Queue the transformations and pass the result onto the specified function
(DEFUN PERFORM-TRANSFORMATIONS (TRANSFORMATION-LIST)
  ;; First do the work on any transformations which are inputs to these
  (LET ((INPUTS (LOOP FOR ELEM IN TRANSFORMATION-LIST
		      AS XFORM = (FIRST ELEM)
		      AND PKG = (SECOND ELEM)
		      AND FORCE = (THIRD ELEM)
		      AS INPUT = (TRANSFORMATION-INPUT XFORM)
		      WHEN (TYPEP INPUT 'TRANSFORMATION) COLLECT (LIST INPUT PKG FORCE))))
    (AND INPUTS (PERFORM-TRANSFORMATIONS INPUTS)))
  ;;Add files to *FILE-TRANSFORMATION-LIST*
  (DOLIST (ELEM TRANSFORMATION-LIST)
    (LET ((*FORCE-PACKAGE* (SECOND ELEM))
	  (*SYSTEM-BEING-MADE* (TRANSFORMATION-SYSTEM (FIRST ELEM))))
      (QUEUE-ONE-TRANSFORMATION (FIRST ELEM) (THIRD ELEM))))
  (FUNCALL *FILE-TRANSFORMATION-FUNCTION*))

;;; This is the usual workhorse, it actually calls the TRANSFORMATION-TYPE-FUNCTION's
(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)))
	  (SELECTQ 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 "~&~\FILE-XFORM-TYPE\~:[ ~\FILE-XFORM-ARGS\~;~*~]~
				     ~:[~; in~:[to~] package ~A~]"
				  TYPE (NULL ARGS) FILE-TRANSFORMATION *FORCE-PACKAGE*
				  (FILE-TRANSFORMATION-OUTPUTS FILE-TRANSFORMATION)
				  *FORCE-PACKAGE*))
		      (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*)
			  (AND (MEMQ (FILE-TRANSFORMATION-STATE FILE-XFORM) '(:DONE :REFUSED))
			       (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)))))
      (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
(DEFUN QUERY-USER-LIST ()
  (DO ((FILE-TRANSFORMATION-LIST *FILE-TRANSFORMATION-LIST* (CDR FILE-TRANSFORMATION-LIST))
       (TYPES-FOUND NIL)
       (N-FOUND 0)
       (LAST-TRANSFORMATION NIL) (LAST-TYPE T)
       (TRANSFORMATION) (TRANSFORMATION-TYPE NIL)
       (FIRST-P T))
      (NIL)
    (SETQ TRANSFORMATION-TYPE (AND (NOT (NULL FILE-TRANSFORMATION-LIST))
			 (FILE-TRANSFORMATION-TRANSFORMATION-TYPE
			   (SETQ TRANSFORMATION (CAR FILE-TRANSFORMATION-LIST)))))
    (COND ((OR (NULL TRANSFORMATION-TYPE)
	       (MEMQ (FILE-TRANSFORMATION-STATE TRANSFORMATION) '(:PENDING :PROBABLY)))
	   (COND (LAST-TRANSFORMATION
		  (COND (FIRST-P
			 (FORMAT QUERY-IO "~2&")
			 (COND ((NULL (FILE-TRANSFORMATION-ARGS LAST-TRANSFORMATION))
				(FORMAT QUERY-IO "Going to ~\FILE-XFORM-ARGS\"
					LAST-TRANSFORMATION)
				(RPLACA TYPES-FOUND
					(SETQ LAST-TYPE (NCONS LAST-TRANSFORMATION))))
			       (T
				(FORMAT QUERY-IO "~2&File~:[s~] to be ~A:~%"
					(NEQ TRANSFORMATION-TYPE LAST-TYPE)
					(TRANSFORMATION-TYPE-PRETTY-PAST-PARTICIPLE
					  LAST-TYPE))
				(SETQ FIRST-P NIL)))
			 (FUNCALL QUERY-IO ':TYO #\CR)))
		  (AND (FILE-TRANSFORMATION-ARGS LAST-TRANSFORMATION)
		       (FORMAT QUERY-IO "~&~\FILE-XFORM-ARGS\" LAST-TRANSFORMATION))
		  (SETQ N-FOUND (1+ N-FOUND))))
	   (AND (NULL TRANSFORMATION-TYPE)
		(RETURN (AND (PLUSP N-FOUND)
			     (FQUERY NIL "~2&~\XFORM-TYPES\? "
				     (NREVERSE TYPES-FOUND) N-FOUND))))
	   (AND (SETQ FIRST-P (NEQ TRANSFORMATION-TYPE LAST-TYPE))
		(PUSH* TRANSFORMATION-TYPE TYPES-FOUND))
	   (SETQ LAST-TRANSFORMATION TRANSFORMATION
		 LAST-TYPE TRANSFORMATION-TYPE)))))

(DEFUN (FORMAT:XFORM-TYPES FORMAT:FORMAT-CTL-MULTI-ARG) (ARGS IGNORE &AUX TYPES N-FOUND)
  (SETF `(,TYPES ,N-FOUND) ARGS)
  (LOOP FOR PASS2 IN '(NIL T)
	DO (LOOP FOR TYPES ON TYPES
		 AS TYPE = (CAR TYPES)
		 WITH COMMA-P = (AND PASS2 (PLUSP N-FOUND))
		 WHEN (EQ PASS2 (LISTP (CAR TYPE)))
		    IF (NOT PASS2)
		    DO (IF COMMA-P (FUNCALL STANDARD-OUTPUT ':STRING-OUT
					    (IF (LOOP FOR TYP IN (CDR TYPES)
						      ALWAYS (LISTP (CAR TYP)))
						" or " ", "))
			 (SETQ COMMA-P T))
		       (FUNCALL STANDARD-OUTPUT ':STRING-OUT
				(TRANSFORMATION-TYPE-PRETTY-IMPERATIVE TYPE))
		    ELSE DO (IF COMMA-P (FUNCALL STANDARD-OUTPUT ':STRING-OUT
						 (IF (LOOP FOR TYP IN (CDR TYPES)
							   ALWAYS (NLISTP (CAR TYP)))
						     " and " ", "))
			      (SETQ COMMA-P T))
			    (FORMAT T "~\FILE-XFORM-ARGS\" (CAR TYPE))
		 ELSE IF (NOT PASS2) DO (DECF N-FOUND)
		 FINALLY (AND (NOT PASS2) (PLUSP N-FOUND)
			      (FORMAT T " ~:[it~;~:[both~;all ~R~] of them~]"
				      (> N-FOUND 1) (> N-FOUND 2) N-FOUND)))))

(DEFVAR *WHOLE-SYSTEM-TYPE-TRANSFORMATIONS*
	'(INCREMENT-LOADED-VERSION INCREMENT-COMPILED-VERSION))

(DEFUN (FORMAT:FILE-XFORM-ARGS FORMAT:FORMAT-CTL-ONE-ARG) (FILE-TRANSFORMATION IGNORE)
  (LET ((ARGS (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION)))
    (IF (NULL ARGS)
	(LET* ((TYPE (FILE-TRANSFORMATION-TRANSFORMATION-TYPE FILE-TRANSFORMATION))
	       (IMPERATIVE (TRANSFORMATION-TYPE-PRETTY-IMPERATIVE TYPE)))
	  (IF (MEMQ (TRANSFORMATION-TYPE-NAME TYPE) *WHOLE-SYSTEM-TYPE-TRANSFORMATIONS*)
	      (FORMAT T IMPERATIVE (SYSTEM-NAME
				     (FILE-TRANSFORMATION-SYSTEM FILE-TRANSFORMATION)))
	    (FUNCALL QUERY-IO ':STRING-OUT IMPERATIVE)))
      (DO ((FILE-LIST ARGS (CDR FILE-LIST))
	   (OUTPUTS (FILE-TRANSFORMATION-OUTPUTS FILE-TRANSFORMATION))
	   (FIRST-P T NIL))
	  ((EQ FILE-LIST OUTPUTS))
	(OR FIRST-P
	    (FUNCALL STANDARD-OUTPUT ':STRING-OUT (IF (EQ (CDR FILE-LIST) OUTPUTS)
						      " and " ", ")))
	(PRINC (CAR FILE-LIST))))))

(DEFUN (FORMAT:FILE-XFORM-TYPE FORMAT:FORMAT-CTL-ONE-ARG) (TYPE IGNORE &AUX STRING)
  (SETQ STRING (TRANSFORMATION-TYPE-PRETTY-PRESENT-PARTICIPLE TYPE))
  (IF (NOT (MEMQ (TRANSFORMATION-TYPE-NAME TYPE) *WHOLE-SYSTEM-TYPE-TRANSFORMATIONS*))
      (FUNCALL STANDARD-OUTPUT ':STRING-OUT STRING)
    (FORMAT T STRING (SYSTEM-NAME *SYSTEM-BEING-MADE*))))

(DEFUN (:PRINT-ONLY MAKE-SYSTEM-KEYWORD) ()
  (SETQ *FILE-TRANSFORMATION-FUNCTION* 'PRINT-FILE-TRANSFORMATIONS))

(DEFUN PRINT-FILE-TRANSFORMATIONS ()
  (DOLIST (FILE-TRANSFORMATION *FILE-TRANSFORMATION-LIST*)
    (LET ((STATE (FILE-TRANSFORMATION-STATE FILE-TRANSFORMATION)))
      (SELECTQ STATE
	((:DONE :REFUSED :NOT-NEEDED NIL))
	((:PENDING :PROBABLY)
	 (LET ((TYPE (FILE-TRANSFORMATION-TRANSFORMATION-TYPE FILE-TRANSFORMATION))
	       (ARGS (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION))
	       (OUTPUTS (FILE-TRANSFORMATION-OUTPUTS FILE-TRANSFORMATION))
	       (*FORCE-PACKAGE* (FILE-TRANSFORMATION-FORCE-PACKAGE FILE-TRANSFORMATION))
	       (*SYSTEM-BEING-MADE* (FILE-TRANSFORMATION-SYSTEM FILE-TRANSFORMATION)))
	   (COND ((NOT *SILENT-P*)
		  (IF (NULL (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION))
		      (FORMAT QUERY-IO "~&Need to ~\FILE-XFORM-ARGS\"
			      FILE-TRANSFORMATION)
		      (FORMAT T "~&~\FILE-XFORM-ARGS\~:[ probably then~] need~:[s~] to be ~A~
			         ~:[~; in~:[to~] package ~A~]"
			      FILE-TRANSFORMATION (NEQ STATE ':PROBABLY)
			      (NEQ (CDR ARGS) OUTPUTS)
			      (TRANSFORMATION-TYPE-PRETTY-PAST-PARTICIPLE TYPE)
			      *FORCE-PACKAGE*
			      (FILE-TRANSFORMATION-OUTPUTS FILE-TRANSFORMATION)
			      *FORCE-PACKAGE*)))))
	 (SETF (FILE-TRANSFORMATION-STATE FILE-TRANSFORMATION) ':DONE))
	(OTHERWISE
	 (FERROR NIL "Transformation ~S in bad state" FILE-TRANSFORMATION))))))

(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *TRANSFORMATION-OUTPUTS* NIL)

;;; List added by each call to QUEUE-ONE-TRANSFORMATION
(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *ADDED-FILE-TRANSFORMATIONS* NIL)

(DEFUN QUEUE-ONE-TRANSFORMATION (TRANSFORMATION FORCE-DEPENDENCIES &REST OTHERS
				 &AUX (*ADDED-FILE-TRANSFORMATIONS* NIL))
  (AND (MEMQ TRANSFORMATION OTHERS) (FERROR NIL "Recursive dependencies detected"))
  (OR (ASSQ TRANSFORMATION *TRANSFORMATION-OUTPUTS*)	;Unless already pending
      (LET ((INPUT (GET-TRANSFORMATION-INPUT-FILE-TRANSFORMATIONS TRANSFORMATION))
	    (NAME (TRANSFORMATION-TYPE-NAME (TRANSFORMATION-TRANSFORMATION-TYPE
					      TRANSFORMATION))))
	;;If allowed by user switches, or a dependency
	(COND ((AND (OR OTHERS (MEMQ NAME *TOP-LEVEL-TRANSFORMATIONS*))
		    ;;and some files in there need to be done,
		    (QUEUE-FILES-AS-NEEDED INPUT))
	       ;;must do the dependencies first
	       (DOLIST (DEPENDENCY FORCE-DEPENDENCIES)
		 (LEXPR-FUNCALL #'QUEUE-ONE-TRANSFORMATION (FIND-DEPENDENCY DEPENDENCY)
				NIL TRANSFORMATION OTHERS))
	       (DOLIST (DEPENDENCY (TRANSFORMATION-DEPENDENCIES TRANSFORMATION))
		 (LEXPR-FUNCALL #'QUEUE-ONE-TRANSFORMATION (FIND-DEPENDENCY DEPENDENCY)
				NIL TRANSFORMATION OTHERS))))))
  ;;These go at the end of the list
  (SETQ *FILE-TRANSFORMATION-LIST*
	(NCONC *FILE-TRANSFORMATION-LIST* (NREVERSE *ADDED-FILE-TRANSFORMATIONS*))))

;;; Get a list of FILE-TRANSFORMATION's from the INPUT to a single TRANSFORMATION
(DEFUN GET-TRANSFORMATION-INPUT-FILE-TRANSFORMATIONS (TRANSFORMATION &AUX INPUT PATHNAME-LIST)
  (COND ((SETQ INPUT (TRANSFORMATION-INPUT TRANSFORMATION))
	 (SELECTQ (TYPEP INPUT)
	   (TRANSFORMATION
	    (SETQ PATHNAME-LIST (GET-TRANSFORMATION-PATHNAMES INPUT)))
	   (MODULE
	    (SETQ PATHNAME-LIST (GET-MODULE-PATHNAMES INPUT)))
	   (OTHERWISE
	    (FERROR NIL "~S is not a valid transformation input" INPUT)))
	 (SETQ PATHNAME-LIST (LOOP FOR PATHNAME IN PATHNAME-LIST
				   COLLECT (ADD-FILE-TRANSFORMATION TRANSFORMATION
								    PATHNAME))))
	(T
	 (SETQ PATHNAME-LIST (NCONS (ADD-FILE-TRANSFORMATION TRANSFORMATION NIL)))))
  PATHNAME-LIST)

;;; This is until circular lists are supported better
(DEFMACRO POP-CAREFULLY (LIST)
  `(PROG1 (CAR ,LIST)
	  (SETQ ,LIST (OR (CDR ,LIST) ,LIST))))

;;; Get the pathnames for a transformation.  If it is pending, use that;
;;; else, compute the pathnames by applying the file type transformation for each level
(DEFUN GET-TRANSFORMATION-PATHNAMES (TRANSFORMATION &AUX PATHNAME-LIST)
  (IF (SETQ PATHNAME-LIST (CDR (ASSQ TRANSFORMATION *TRANSFORMATION-OUTPUTS*)))
      (VALUES PATHNAME-LIST T)
      (LET ((INPUT (TRANSFORMATION-INPUT TRANSFORMATION)))
	(SELECTQ (TYPEP INPUT)
	  (MODULE
	   (SETQ PATHNAME-LIST (GET-MODULE-PATHNAMES INPUT)))
	  (TRANSFORMATION
	   (SETQ PATHNAME-LIST (GET-TRANSFORMATION-PATHNAMES INPUT)))
	  (OTHERWISE
	   (FERROR NIL "~S is not a valid transformation input" INPUT))))
      (LOOP FOR PATHNAME IN PATHNAME-LIST
	    WITH TRANSFORMATION-TYPE = (TRANSFORMATION-TRANSFORMATION-TYPE TRANSFORMATION)
	    AS PKG = (POP PATHNAME)
	    ;;Take off as many inputs as would be used
	    DO (DO L (TRANSFORMATION-TYPE-INPUT-FILE-TYPES TRANSFORMATION-TYPE)
		   (CDR L) (NULL L)
		 (POP-CAREFULLY PATHNAME))
	    ;;Now accumulate output types
	    AS OUTPUTS = (LOOP FOR FILE-TYPE IN (TRANSFORMATION-TYPE-OUTPUT-FILE-TYPES
						  TRANSFORMATION-TYPE)
			       COLLECT (MERGE-PATHNAME-TYPE (POP-CAREFULLY PATHNAME)
							    FILE-TYPE))
	    COLLECT (CONS PKG (NCONC OUTPUTS PATHNAME)))))

;;; Get PATHNAME's from a MODULE.  Binding package property as we go down if necessary.
;;; OTHER-SYSTEMS-OK is for things like SYSTEM-SOURCE-FILES that only look locally.
(DEFUN GET-MODULE-PATHNAMES (MODULE &OPTIONAL (OTHER-SYSTEMS-OK T) &AUX PKGPROP)
  (LET-IF (SETQ PKGPROP (GETL (LOCF (MODULE-PLIST MODULE)) '(:PACKAGE)))
       ((*FORCE-PACKAGE* (CADR PKGPROP)))
    (GET-MODULE-COMPONENTS-PATHNAMES (MODULE-COMPONENTS MODULE) OTHER-SYSTEMS-OK)))

;;; Get a list of PATHNAME's from a MODULE's COMPONENTS
(DEFUN GET-MODULE-COMPONENTS-PATHNAMES (COMPONENTS &OPTIONAL (OTHER-SYSTEMS-OK T))
  (LOOP FOR COMPONENT IN COMPONENTS
	NCONC (COND ((TYPEP COMPONENT 'MODULE)
		     ;;Another module, get its components
		     (GET-MODULE-PATHNAMES COMPONENT))
		    ((NLISTP COMPONENT)
		     (FERROR NIL "~S is not a valid module component" COMPONENT))
		    ((SYMBOLP (CAR COMPONENT))
		     ;;(SYSTEM . MODULE-NAME's)
		     (AND OTHER-SYSTEMS-OK
			  (LOOP FOR NAME IN (CDR COMPONENT)
				WITH SYSTEM = (FIND-SYSTEM-NAMED (CAR COMPONENT))
				NCONC (GET-MODULE-PATHNAMES (FIND-MODULE-NAMED NAME
									       SYSTEM)))))
		    ;;Terminal nodes are pathname lists.  Collect (package . pathnames).
		    (T (NCONS (CONS *FORCE-PACKAGE* COMPONENT))))))

(DEFUN ADD-FILE-TRANSFORMATION (TRANSFORMATION PATHNAMES
				&AUX TRANSFORMATION-TYPE CONDITION-FUNCTION
				     INPUT-XFORM PKG INPUTS OUTPUTS ARGS FILE-TRANSFORMATION
				     SYSTEM)
  (SETQ TRANSFORMATION-TYPE (TRANSFORMATION-TRANSFORMATION-TYPE TRANSFORMATION)
	CONDITION-FUNCTION (TRANSFORMATION-CONDITION-FUNCTION TRANSFORMATION)
	SYSTEM (TRANSFORMATION-SYSTEM TRANSFORMATION))
  (SETQ PKG (POP PATHNAMES))
  (AND (LISTP PKG) (SETQ INPUT-XFORM PKG
			 PKG (FILE-TRANSFORMATION-FORCE-PACKAGE PKG)))
  (SETQ INPUTS (LOOP FOR FILE-TYPE IN (TRANSFORMATION-TYPE-INPUT-FILE-TYPES
				         TRANSFORMATION-TYPE)
		     COLLECT (MERGE-PATHNAME-TYPE (POP-CAREFULLY PATHNAMES) FILE-TYPE))
	OUTPUTS (LOOP FOR FILE-TYPE IN (TRANSFORMATION-TYPE-OUTPUT-FILE-TYPES
					  TRANSFORMATION-TYPE)
			  COLLECT (MERGE-PATHNAME-TYPE (POP-CAREFULLY PATHNAMES) FILE-TYPE))
	ARGS (NCONC INPUTS OUTPUTS))
  (COND ((SETQ FILE-TRANSFORMATION (DOLIST (FILE-XFORM *FILE-TRANSFORMATION-LIST*)
				     (AND (EQ (FILE-TRANSFORMATION-TRANSFORMATION-TYPE
						FILE-XFORM)
					      TRANSFORMATION-TYPE)
					  (EQUAL (FILE-TRANSFORMATION-ARGS FILE-XFORM) ARGS)
					  (EQ (FILE-TRANSFORMATION-FORCE-PACKAGE FILE-XFORM)
					      PKG)
					  (EQ (FILE-TRANSFORMATION-SYSTEM FILE-XFORM)
					      SYSTEM)
					  (RETURN FILE-XFORM))))
	 ;;Found, extend the condition
	 (SETF (FILE-TRANSFORMATION-CONDITION-FUNCTION FILE-TRANSFORMATION)
	       (LET ((OLD-CONDITION-FUNCTION (FILE-TRANSFORMATION-CONDITION-FUNCTION
					       FILE-TRANSFORMATION)))
		 (COND ((EQ OLD-CONDITION-FUNCTION CONDITION-FUNCTION)
			CONDITION-FUNCTION)	;The same
		       ((CLOSUREP OLD-CONDITION-FUNCTION)
			(PUSH* CONDITION-FUNCTION
			       (SYMEVAL-IN-CLOSURE OLD-CONDITION-FUNCTION
						   '*CONDITION-FUNCTIONS*)))
		       (T
			(LET-CLOSED ((*CONDITION-FUNCTIONS* (LIST OLD-CONDITION-FUNCTION
								  CONDITION-FUNCTION)))
			  'MULTIPLE-FILE-CONDITION)))))		     
	 (SETQ *FILE-TRANSFORMATION-LIST*
	       (DELQ FILE-TRANSFORMATION *FILE-TRANSFORMATION-LIST*)))
	(T
	 (SETQ FILE-TRANSFORMATION (MAKE-FILE-TRANSFORMATION TRANSFORMATION-TYPE
							       TRANSFORMATION-TYPE
							     FORCE-PACKAGE PKG
							     SYSTEM SYSTEM
							     CONDITION-FUNCTION
							       CONDITION-FUNCTION
							     OUTPUTS OUTPUTS
							     ARGS ARGS))))
  (PUSH FILE-TRANSFORMATION *ADDED-FILE-TRANSFORMATIONS*)
  (LET ((OUTPUT (CONS FILE-TRANSFORMATION (APPEND OUTPUTS PATHNAMES)))
	(ELEM (ASSQ TRANSFORMATION *TRANSFORMATION-OUTPUTS*)))
    (IF ELEM (NCONC ELEM (NCONS OUTPUT))
	(PUSH (LIST TRANSFORMATION OUTPUT) *TRANSFORMATION-OUTPUTS*)))
  (CONS INPUT-XFORM FILE-TRANSFORMATION))

;;; This is closed over when a file-transformation is added with two different conditions
;;; It OR's those conditions
(DEFUN MULTIPLE-FILE-CONDITION (&REST ARGS)
  (LOCAL-DECLARE ((SPECIAL *CONDITION-FUNCTIONS*))
    (DOLIST (FUNCTION *CONDITION-FUNCTIONS*)
      (AND (APPLY FUNCTION ARGS)
	   (RETURN T)))))

(DEFUN QUEUE-FILES-AS-NEEDED (LIST)
  (DO ((LIST LIST (CDR LIST))
       (FLAG NIL)
       (FILE-TRANSFORMATION) (STATE) (PROBABLY-P))
      ((NULL LIST) FLAG)
    (SETQ FILE-TRANSFORMATION (CAR LIST))
    ;; PROBABLY-P is a weird kludge.  It means we are processing a dependent transformation
    ;; whose input comes from the output of a transformation being done at this same level.
    ;; We cannot check file dates at this point, since they are likely to be invalidated.
    ;; Instead we remember for later that we were in this state and check then.
    (SETQ PROBABLY-P (MEMQ (FILE-TRANSFORMATION-STATE (CAR FILE-TRANSFORMATION))
			   '(:PENDING :PROBABLY))
	  FILE-TRANSFORMATION (CDR FILE-TRANSFORMATION))
    (COND ((NULL (FILE-TRANSFORMATION-STATE FILE-TRANSFORMATION))
	   (IF (NOT (OR *REDO-ALL*
			(LET ((*FORCE-PACKAGE* (FILE-TRANSFORMATION-FORCE-PACKAGE
						 FILE-TRANSFORMATION))
			      (*SYSTEM-BEING-MADE* (FILE-TRANSFORMATION-SYSTEM
						     FILE-TRANSFORMATION)))
			  (APPLY (FILE-TRANSFORMATION-CONDITION-FUNCTION FILE-TRANSFORMATION)
				 (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION)))))
	       (SETQ STATE (COND ((NOT PROBABLY-P) ':NOT-NEEDED)
				 ;;Not exactly right to ask at this point,
				 ;;but avoids asking questions after compilation has started.
				 ((QUERY-USER-SELECTIVE FILE-TRANSFORMATION)
				  (SETQ FLAG T)
				  ':PROBABLY)
				 (T ':REFUSED)))
	       (IF (NOT (QUERY-USER-SELECTIVE FILE-TRANSFORMATION))
		   (SETQ STATE ':REFUSED)
		   (SETQ STATE ':PENDING
			 FLAG T)))
	   (SETF (FILE-TRANSFORMATION-STATE FILE-TRANSFORMATION) STATE)))))

;;; Define terminal file transformation macro
(DEFMACRO DEFINE-SIMPLE-TRANSFORMATION (NAME FUNCTION DEFAULT-CONDITION
					INPUT-FILE-TYPES OUTPUT-FILE-TYPES
					&OPTIONAL PRETTY-NAMES
						  (COMPILE-LIKE T) (LOAD-LIKE NIL LL-P))
  (OR LL-P (SETQ LOAD-LIKE (NOT COMPILE-LIKE)))
  (OR PRETTY-NAMES (SETQ PRETTY-NAMES (STRING-DOWNCASE NAME)))
  (OR (LISTP PRETTY-NAMES)
      (LET* ((LENGTH (STRING-LENGTH PRETTY-NAMES))
	     (E-P (CHAR-EQUAL (AREF PRETTY-NAMES (1- LENGTH)) #/e))
	     (UPSTART (CHAR-UPCASE (AREF PRETTY-NAMES 0)))
	     (REST (NSUBSTRING PRETTY-NAMES 1))
	     (START (IF E-P (NSUBSTRING PRETTY-NAMES 1 (1- LENGTH)) REST)))
	(SETQ PRETTY-NAMES (LIST (STRING-APPEND UPSTART REST)
				 (STRING-APPEND UPSTART START "ing")
				 (STRING-APPEND (AREF PRETTY-NAMES 0) START "ed")))))
  `(PROGN 'COMPILE
     (ADD-SIMPLE-TRANSFORMATION ',NAME ',FUNCTION ',INPUT-FILE-TYPES ',OUTPUT-FILE-TYPES
				',PRETTY-NAMES ',COMPILE-LIKE ',LOAD-LIKE)
     (DEFMACRO (,NAME DEFSYSTEM-MACRO) (INPUT &OPTIONAL DEPENDENCIES CONDITION)
       (PARSE-TRANSFORMATION ',NAME INPUT DEPENDENCIES (OR CONDITION ',DEFAULT-CONDITION)))))

(DEFVAR *TRANSFORMATION-TYPE-ALIST* NIL)

(DEFUN ADD-SIMPLE-TRANSFORMATION (NAME FUNCTION INPUT-FILE-TYPES OUTPUT-FILE-TYPES
				  PRETTY-NAMES COMPILE-LIKE LOAD-LIKE
				  &AUX TRANSFORMATION-TYPE)
  (SETQ TRANSFORMATION-TYPE (MAKE-TRANSFORMATION-TYPE NAME NAME
						      PRETTY-NAMES PRETTY-NAMES
						      FUNCTION FUNCTION
						      INPUT-FILE-TYPES INPUT-FILE-TYPES
						      OUTPUT-FILE-TYPES OUTPUT-FILE-TYPES))
  (SETQ *TRANSFORMATION-TYPE-ALIST*
	(CONS TRANSFORMATION-TYPE
	      (DEL #'(LAMBDA (X Y) (EQ (TRANSFORMATION-TYPE-NAME X)
				       (TRANSFORMATION-TYPE-NAME Y)))
		   TRANSFORMATION-TYPE *TRANSFORMATION-TYPE-ALIST*)))
  (AND COMPILE-LIKE (PUSH* NAME *COMPILE-TYPE-TRANSFORMATIONS*))
  (AND LOAD-LIKE (PUSH* NAME *LOAD-TYPE-TRANSFORMATIONS*)))

;;; Here are the initial simple transformations
(DEFINE-SIMPLE-TRANSFORMATION :FASLOAD FASLOAD-1 FILE-NEWER-THAN-INSTALLED-P
			      ("QFASL") NIL "load" NIL)
(DEFINE-SIMPLE-TRANSFORMATION :READFILE READFILE-1 FILE-NEWER-THAN-INSTALLED-P
			      ("LISP") NIL ("Read" "Reading" "read") NIL)
(DEFINE-SIMPLE-TRANSFORMATION :COMPILE QC-FILE-1 FILE-NEWER-THAN-FILE-P
			      ("LISP") ("QFASL"))
(DEFINE-SIMPLE-TRANSFORMATION DO-COMPONENTS-INTERNAL IGNORE TRUE NIL NIL NIL NIL NIL)

;;; Some compound cases
(DEFMACRO (:COMPILE-LOAD DEFSYSTEM-MACRO) (INPUT &OPTIONAL COM-DEP LOAD-DEP
							   COM-COND LOAD-COND)
  `(:FASLOAD (:COMPILE ,INPUT ,COM-DEP ,COM-COND) ,LOAD-DEP ,LOAD-COND))

;;; The main transformation parser
(DEFINE-DEFSYSTEM-SPECIAL-VARIABLE *ADD-TRANSFORMATION-TO-SYSTEM* T)

(DEFUN PARSE-TRANSFORMATION (NAME INPUT DEPENDENCIES CONDITION
			     &AUX TRANSFORMATION-TYPE TRANSFORMATION)
  (OR (SETQ TRANSFORMATION-TYPE (ASSQ NAME *TRANSFORMATION-TYPE-ALIST*))
      (FERROR NIL "~S is not a known transformation type" NAME))
  ;;CONDITION is an atom of a function name or some lisp code
;  (AND (LISTP CONDITION)
;       (SETQ CONDITION (GENERATE-INTERNAL-CONDITION CONDITION INPUT TRANSFORMATION-TYPE)))
  ;;INPUT can be either a MODULE-SPECIFICATION or another transformation
  (LET ((*ADD-TRANSFORMATION-TO-SYSTEM* (IF (EQ *ADD-TRANSFORMATION-TO-SYSTEM* ':SKIP)
					    T NIL)))
    (SETQ INPUT (COND ((NULL INPUT) NIL)
		      ((NLISTP INPUT)		;A single module input
		       (FIND-MODULE-NAMED INPUT *SYSTEM-BEING-DEFINED*))
		      ((GET (CAR INPUT) 'DEFSYSTEM-MACRO)	;Another transformation
		       (CALL-DEFSYSTEM-MACRO INPUT))
		      (T			;Otherwise generate a new module to hold them
		       (ADD-MODULE (GENSYM) *SYSTEM-BEING-DEFINED* INPUT)))))
  ;;DEPENDENCIES is (TRANSFORMATION . MODULE-SPECS) or a list of those
  (LET ((*ADD-TRANSFORMATION-TO-SYSTEM* NIL))
    (OR (LISTP (CAR DEPENDENCIES)) (SETQ DEPENDENCIES (NCONS DEPENDENCIES)))
    (SETQ DEPENDENCIES (LOOP FOR DEPENDENCY IN DEPENDENCIES
			     NCONC (BUILD-DEPENDENCIES DEPENDENCY *SYSTEM-BEING-DEFINED*))))
  (SETQ TRANSFORMATION (MAKE-TRANSFORMATION TRANSFORMATION-TYPE TRANSFORMATION-TYPE
					    INPUT INPUT
					    DEPENDENCIES DEPENDENCIES
					    CONDITION-FUNCTION CONDITION
					    SYSTEM *SYSTEM-BEING-DEFINED*))
  (AND (EQ *ADD-TRANSFORMATION-TO-SYSTEM* T)
       (SETF (SYSTEM-TOP-LEVEL-TRANSFORMATIONS *SYSTEM-BEING-DEFINED*)
	     (NCONC (SYSTEM-TOP-LEVEL-TRANSFORMATIONS *SYSTEM-BEING-DEFINED*)
		    (NCONS TRANSFORMATION))))
  (SETF (SYSTEM-TRANSFORMATIONS *SYSTEM-BEING-DEFINED*)
	(NCONC (SYSTEM-TRANSFORMATIONS *SYSTEM-BEING-DEFINED*) (NCONS TRANSFORMATION)))
  (VALUES NIL TRANSFORMATION))

;;; Collect a set of dependencies
(DEFUN BUILD-DEPENDENCIES (DEPENDENCY SYSTEM)
  (AND DEPENDENCY
       (LOOP FOR MODULE IN (OR (CDR DEPENDENCY) '(NIL))
	     WITH TRANSFORMATION-TYPE = (OR (ASSQ (CAR DEPENDENCY)
						  *TRANSFORMATION-TYPE-ALIST*)
					    (FERROR NIL "Unknown transformation type ~S"
						    (CAR DEPENDENCY)))
	     NCONC (BUILD-DEPENDENCY TRANSFORMATION-TYPE SYSTEM MODULE))))

(DEFUN BUILD-DEPENDENCY (TRANSFORMATION-TYPE SYSTEM MODULE)
  (IF (LISTP MODULE)
      (LOOP FOR MODULE-NAME IN (CDR MODULE)
	    WITH SYSTEM-NAME = (CAR MODULE)
	    COLLECT `(,TRANSFORMATION-TYPE ,SYSTEM-NAME ,MODULE-NAME))
      (NCONS (FIND-DEPENDENCY-1 TRANSFORMATION-TYPE SYSTEM MODULE))))

(DEFUN FIND-DEPENDENCY (DEPENDENCY)
  (IF (TYPEP DEPENDENCY 'TRANSFORMATION)
      DEPENDENCY
      (APPLY #'FIND-DEPENDENCY-1 DEPENDENCY)))

(DEFUN FIND-DEPENDENCY-1 (TRANSFORMATION-TYPE SYSTEM MODULE)
  (SETQ SYSTEM (FIND-SYSTEM-NAMED SYSTEM)
	MODULE (AND MODULE (FIND-MODULE-NAMED MODULE SYSTEM)))
  (OR (DOLIST (TRANSFORMATION (SYSTEM-TRANSFORMATIONS (FIND-SYSTEM-NAMED SYSTEM)))
	(AND (EQ TRANSFORMATION-TYPE (TRANSFORMATION-TRANSFORMATION-TYPE TRANSFORMATION))
	     (EQ MODULE
		 (DO ((X TRANSFORMATION (TRANSFORMATION-INPUT X)))
		     ((NOT (TYPEP X 'TRANSFORMATION)) X)))
	     (RETURN TRANSFORMATION)))
      (FERROR NIL "Transformation ~S not found on ~S in ~S"
	      TRANSFORMATION-TYPE MODULE SYSTEM)))

;;; This perhaps needs a better name
(DEFMACRO (:COMPILE-LOAD-INIT DEFSYSTEM-MACRO) (INPUT ADD-DEP &OPTIONAL COM-DEP LOAD-DEP
							      &AUX FUNCTION)
  (SETQ FUNCTION (LET-CLOSED ((*ADDITIONAL-DEPENDENT-MODULES*
				(PARSE-MODULE-COMPONENTS ADD-DEP *SYSTEM-BEING-DEFINED*)))
		   'COMPILE-LOAD-INIT-CONDITION))
  `(:FASLOAD (:COMPILE ,INPUT ,COM-DEP ,FUNCTION) ,LOAD-DEP))

(DEFUN COMPILE-LOAD-INIT-CONDITION (SOURCE-FILE QFASL-FILE)
  (OR (FILE-NEWER-THAN-FILE-P SOURCE-FILE QFASL-FILE)
      (LOCAL-DECLARE ((SPECIAL *ADDITIONAL-DEPENDENT-MODULES*))
	(OTHER-FILES-NEWER-THAN-FILE-P *ADDITIONAL-DEPENDENT-MODULES* QFASL-FILE))))

;;; Have any files from which compile-flavor-methods or something in this file are generated
;;; changed?
(DEFUN OTHER-FILES-NEWER-THAN-FILE-P (MODULES FILE &AUX CREATION-DATE FILE-TYPE)
  (SETQ CREATION-DATE (SYSTEM-GET-CREATION-DATE FILE))
;;
(format t "~A ~A~%" file creation-date)
;;
  (DOLIST (MODULE MODULES)
    (OR (DOLIST (TRANSFORMATION (SYSTEM-TRANSFORMATIONS (MODULE-SYSTEM MODULE)))
	  (COND ((EQ (TRANSFORMATION-INPUT TRANSFORMATION) MODULE)
		 (SETQ FILE-TYPE (CAR (TRANSFORMATION-TYPE-INPUT-FILE-TYPES
					(TRANSFORMATION-TRANSFORMATION-TYPE TRANSFORMATION))))
		 (RETURN T))))
	(FERROR NIL "Module ~S not found in any transformation" MODULE))
;;
    (dolist (pathnames (get-module-pathnames module))
	    (let ((pn (merge-pathname-type (cadr pathnames)
					    (eval file-type))))
	      (format t "%A %A %A %A%~"
		      file pn creation-date (system-get-creation-date pn))))
;;
    (AND (DOLIST (PATHNAMES (GET-MODULE-PATHNAMES MODULE))
	   (AND (> (SYSTEM-GET-CREATION-DATE (MERGE-PATHNAME-TYPE (CADR PATHNAMES) FILE-TYPE))
		   CREATION-DATE)
		(RETURN T)))
	 (RETURN T))))

(COMMENT					;This is probably a bad idea
;;; This generates an special compound condition
(DEFINE-DEFSYSTEM-SPECIAL-VARIABLE *GENERATED-CONDITION-COUNTER* 0)

(DEFUN GENERATE-INTERNAL-CONDITION (SEXP INPUT TRANSFORMATION-TYPE &AUX SYMBOL NARGS FUNCTION)
  (SETQ SYMBOL (INTERN (FORMAT NIL "~A-TRANSFORMATION-INTERNAL-~D"
			       (STRING-UPCASE (SYSTEM-NAME *SYSTEM-BEING-DEFINED*))
			       (SETQ *GENERATED-CONDITION-COUNTER*
				     (1+ *GENERATED-CONDITION-COUNTER*))))
	NARGS (+ (LENGTH (TRANSFORMATION-TYPE-INPUT-FILE-TYPES TRANSFORMATION-TYPE))
		 (LENGTH (TRANSFORMATION-TYPE-OUTPUT-FILE-TYPES TRANSFORMATION-TYPE))))
  (SETQ FUNCTION `(LAMBDA (&REST .INPUTS.)
		    (OR (= (LENGTH .INPUTS.) ,NARGS)
			(CERROR T NIL ':WRONG-NUMBER-OF-ARGUMENTS
				"Function ~S given too many arguments (~D)"
				SYMBOL (LENGTH .INPUTS.)))
		    . ,(SUBST '.INPUTS. INPUT SEXP)))
  (IF COMPILER:QC-FILE-IN-PROGRESS
      ;; This case if in QC-FILE or editor-compile
      (COMPILER:QC-TRANSLATE-FUNCTION
	SYMBOL FUNCTION 'COMPILER:MACRO-COMPILE
	(IF (NOT COMPILER:QC-FILE-LOAD-FLAG) 'COMPILER:QFASL 'COMPILER:COMPILE-TO-CORE))
      ;; This case if not doing anything special
      (LET ((FDEFINE-FILE-PATHNAME NIL)
	    (INHIBIT-FDEFINE-WARNINGS T))
	(COMPILER:COMPILE SYMBOL FUNCTION)))
  SYMBOL)
)

;;; Add a transformation which isn't normally executed, but can be depended upon
(DEFMACRO (:SKIP DEFSYSTEM-MACRO) (&REST REST)
  (LET ((*ADD-TRANSFORMATION-TO-SYSTEM* ':SKIP))
    (MULTIPLE-VALUE-BIND (VAL1 VAL2) (CALL-DEFSYSTEM-MACRO REST)
      (VALUES NIL VAL1 VAL2))))

(DEFUN FASLOAD-1 (INFILE)
  (FASLOAD INFILE *FORCE-PACKAGE* T))

(DEFUN READFILE-1 (INFILE)
  (READFILE INFILE *FORCE-PACKAGE* T))

(DEFUN QC-FILE-1 (INFILE OUTFILE)
  (QC-FILE INFILE OUTFILE NIL NIL *FORCE-PACKAGE*))

(DEFUN LOAD-FONT-WIDTHS-1 (INFILE)
  (PKG-BIND *FORCE-PACKAGE*
    (PRESS:LOAD-FONT-WIDTHS INFILE)))

(DEFUN FILE-NEWER-THAN-INSTALLED-P (FILE)
  (NOT (EQUAL (SYSTEM-GET-FILE-INFO FILE)
	      (SYSTEM-GET-LOADED-ID FILE))))

;;; FILE-2 need not exist yet (it is assumed to be output from FILE-1 in some way).
(DEFUN FILE-NEWER-THAN-FILE-P (FILE-1 FILE-2)
  (> (SYSTEM-GET-CREATION-DATE FILE-1)
     (SYSTEM-GET-CREATION-DATE FILE-2 T)))

(DEFUN SYSTEM-GET-FILE-INFO (FILE)
  (LET ((PLIST (SYSTEM-GET-FILE-PROPERTY-LIST FILE)))
    (AND (CDR PLIST)
	 (OR (GET PLIST ':INFO)
	     (CONS (GET PLIST ':TRUENAME) (GET PLIST ':CREATION-DATE))))))

(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *JUST-ACCUMULATING-FILES* NIL)

(DEFUN SYSTEM-GET-LOADED-ID (FILE)
  (AND (NOT *JUST-ACCUMULATING-FILES*)
       (GET-FILE-LOADED-ID FILE *FORCE-PACKAGE*)))

(DEFUN SYSTEM-GET-CREATION-DATE (FILE &OPTIONAL NO-ERROR-P)
  (COND ((GET (SYSTEM-GET-FILE-PROPERTY-LIST FILE) ':CREATION-DATE))
	((OR NO-ERROR-P *JUST-ACCUMULATING-FILES*) -1)
	(T (FERROR NIL "File ~A does not exist" FILE))))

(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *INTERESTING-FILES* NIL)
(DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *INTERESTING-FILES-INFO* NIL)

(DEFUN SYSTEM-GET-FILE-PROPERTY-LIST (FILE &OPTIONAL ERROR-P)
  (COND ((ASSQ FILE *INTERESTING-FILES-INFO*))
	(*JUST-ACCUMULATING-FILES*
	 (PUSH FILE *INTERESTING-FILES*)
	 NIL)
	(ERROR-P
	 (FERROR NIL "File ~A not found in second pass" FILE))
	(T
	 ;;Found a file we didn't know about, accumulate a lot of info at once
	 (ACCUMULATE-INTERESTING-FILES *FILE-TRANSFORMATION-LIST* '(:PROBABLY))
	 (ACCUMULATE-INTERESTING-FILES *ADDED-FILE-TRANSFORMATIONS* '(NIL :PROBABLY))
	 (SETQ *INTERESTING-FILES-INFO*
	       (NCONC (FS:MULTIPLE-FILE-PLISTS *INTERESTING-FILES*) *INTERESTING-FILES-INFO*)
	       *INTERESTING-FILES* NIL)
	 (SYSTEM-GET-FILE-PROPERTY-LIST FILE T))))

(DEFUN ACCUMULATE-INTERESTING-FILES (LIST STATES)
  (LET ((*JUST-ACCUMULATING-FILES* T))
    (DOLIST (FILE-TRANSFORMATION LIST)
      (AND (MEMQ (FILE-TRANSFORMATION-STATE FILE-TRANSFORMATION) STATES)
	   (LET ((*FORCE-PACKAGE* (FILE-TRANSFORMATION-FORCE-PACKAGE FILE-TRANSFORMATION)))
	     (APPLY (FILE-TRANSFORMATION-CONDITION-FUNCTION FILE-TRANSFORMATION)
		    (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION)))))))

(DEFUN INVALIDATE-PATHNAME-INFO (FILE)
  (LOCAL-DECLARE ((SPECIAL *FILE*))
    (LET ((*FILE* FILE))
      (SETQ *INTERESTING-FILES-INFO*
	    (DEL-IF #'(LAMBDA (X) (EQ (CAR X) *FILE*)) *INTERESTING-FILES-INFO*)))))

(DEFVAR QUERY-USER-SELECTIVE-OPTIONS '(:CHOICES (((:YES "Yes.") #/Y #\SP)
						 ((:NO "No.") #/N #\RUBOUT)
						 ((:DIRECTORY "Directory.") #/D)
						 ((:EDIT "Edit.") #/E)
						 ((:SRCCOM "Srccom.") #/S))))
(DEFUN QUERY-USER-SELECTIVE (FILE-TRANSFORMATION)
  (IF (NOT (EQ *QUERY-TYPE* ':SELECTIVE)) T
      (DO () (NIL)
	(SELECTQ (FQUERY QUERY-USER-SELECTIVE-OPTIONS
			 "~&~:[~A ~;~*~]~\FILE-XFORM-ARGS\? "
			 (NULL (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION))
			 (TRANSFORMATION-TYPE-PRETTY-IMPERATIVE
			   (FILE-TRANSFORMATION-TRANSFORMATION-TYPE FILE-TRANSFORMATION))
			 FILE-TRANSFORMATION)
	  (:YES (RETURN T))
	  (:NO (RETURN NIL))
	  (:DIRECTORY
	   (PRINT-FILE-TRANSFORMATION-DIRECTORY FILE-TRANSFORMATION))
	  (:EDIT
	   (ED (FIRST (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION))))
	  (:SRCCOM
	   (LET ((DIRECTORY-LIST (PRINT-FILE-TRANSFORMATION-DIRECTORY FILE-TRANSFORMATION)))
	     (MULTIPLE-VALUE-BIND (FILE-1 FILE-2)
		 (FUNCALL (OR (GET (FILE-TRANSFORMATION-CONDITION-FUNCTION
				     FILE-TRANSFORMATION)
				   'FILE-TRANSFORMATION-SRCCOM-FILES-FUNCTION)
			      'DEFAULT-FILE-TRANSFORMATION-SRCCOM-FILES-FUNCTION)
			  FILE-TRANSFORMATION DIRECTORY-LIST)
	       (SRCCOM:PROMPTED-SOURCE-COMPARE FILE-1 FILE-2))))))))

(DEFUN PRINT-FILE-TRANSFORMATION-DIRECTORY (FILE-TRANSFORMATION &AUX DIRECTORY-LIST)
  (DOLIST (FILE (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION))
    (SETQ FILE (FUNCALL FILE ':GENERIC-PATHNAME))
    (OR (ASSQ FILE DIRECTORY-LIST)
	(PUSH (PRINT-FILE-TRANSFORMATION-DIRECTORY-1 FILE) DIRECTORY-LIST)))
  DIRECTORY-LIST)

(DEFUN PRINT-FILE-TRANSFORMATION-DIRECTORY-1 (FILE &AUX LIST)
  (FUNCALL STANDARD-OUTPUT ':FRESH-LINE)
  (SETQ LIST (FS:DIRECTORY-LIST (FUNCALL FILE ':NEW-PATHNAME ':TYPE ':WILD
							     ':VERSION ':WILD)))
  (SETQ LIST (DELQ (ASSQ NIL LIST) LIST))
  (DOLIST (FILE LIST)
    (FORMAT T "~&~A~15T~D ~D(~D)~30T"
	    (FUNCALL (CAR FILE) ':STRING-FOR-DIRED) (GET FILE ':LENGTH-IN-BLOCKS)
	    (GET FILE ':LENGTH-IN-BYTES) (GET FILE ':BYTE-SIZE))
    (TIME:PRINT-UNIVERSAL-TIME (GET FILE ':CREATION-DATE))
    (FORMAT T "~@[ ~A~]~%" (GET FILE ':AUTHOR)))
  (CONS FILE LIST))

(DEFUN DEFAULT-FILE-TRANSFORMATION-SRCCOM-FILES-FUNCTION (FILE-TRANSFORMATION DIRECTORY-LIST)
  DIRECTORY-LIST				;Not used in this simple-minded case
  (LET ((FILE (FIRST (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION))))
    (VALUES (FUNCALL FILE ':NEW-VERSION ':OLDEST)
	    (FUNCALL FILE ':NEW-VERSION ':NEWEST))))

(DEFUN (FILE-NEWER-THAN-FILE-P FILE-TRANSFORMATION-SRCCOM-FILES-FUNCTION)
       (FILE-TRANSFORMATION DIRECTORY-LIST)
  (SRCCOM-FILES-FUNCTION-NEWEST-FILE-OLDER-THAN-DATE
    FILE-TRANSFORMATION DIRECTORY-LIST
    (SYSTEM-GET-CREATION-DATE (SECOND (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION)))))

(DEFUN (FILE-NEWER-THAN-INSTALLED-P FILE-TRANSFORMATION-SRCCOM-FILES-FUNCTION)
       (FILE-TRANSFORMATION DIRECTORY-LIST)
  (SRCCOM-FILES-FUNCTION-NEWEST-FILE-OLDER-THAN-DATE
    FILE-TRANSFORMATION DIRECTORY-LIST
    (LET ((ID (SYSTEM-GET-LOADED-ID (FIRST (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION)))))
      (IF ID (CDR ID) -1))))				;File was never loaded

(DEFUN SRCCOM-FILES-FUNCTION-NEWEST-FILE-OLDER-THAN-DATE (FILE-TRANSFORMATION DIRECTORY-LIST
							  DATE)
  (LET* ((INPUT (FIRST (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION)))
	 (GENERIC-PATHNAME (FUNCALL INPUT ':GENERIC-PATHNAME))
	 (LIST (CDR (ASSQ GENERIC-PATHNAME DIRECTORY-LIST)))
	 (PATHNAME (FUNCALL INPUT ':NEW-VERSION ':OLDEST)))
    (DOLIST (FILE LIST)
      (LET ((FILENAME (CAR FILE)))
	(AND (MEMBER (FUNCALL FILENAME ':TYPE) '("LISP" NIL :UNSPECIFIC))
	     (< (GET FILE ':CREATION-DATE) DATE)
	     (SETQ PATHNAME FILENAME))))
    (AND (NOT (MEMQ (FUNCALL INPUT ':TYPE) '("LISP" NIL :UNSPECIFIC)))
	 (MEMQ (FUNCALL (CAAR LIST) ':TYPE) '("LISP" NIL :UNSPECIFIC))
	 (SETQ INPUT (CAAR LIST)))
    (VALUES PATHNAME
	    (FUNCALL INPUT ':NEW-VERSION ':NEWEST))))

;;; For things like M-X Select System as Tags Table
(DEFUN ALL-SYSTEMS-NAME-ALIST ()
  (LOOP FOR SYSTEM IN *SYSTEMS-LIST*
	COLLECT (CONS (STRING (SYSTEM-NAME SYSTEM)) SYSTEM)))

(DEFVAR *SOURCE-FILE-TYPES* '("LISP"))
(DEFUN SYSTEM-SOURCE-FILES (SYSTEM &OPTIONAL (TYPES *SOURCE-FILE-TYPES*))
  "TYPES is a list or :ALL."
  (SI:ELIMINATE-DUPLICATES (SYSTEM-SOURCE-FILES-1 SYSTEM TYPES)))

(DEFUN SYSTEM-SOURCE-FILES-1 (SYSTEM TYPES)
  (SETQ SYSTEM (FIND-SYSTEM-NAMED SYSTEM))
  (NCONC (LOOP FOR SUBSYS IN (SYSTEM-COMPONENT-SYSTEMS SYSTEM)
	       NCONC (SYSTEM-SOURCE-FILES-1 SUBSYS TYPES))
	 (LET ((*FORCE-PACKAGE* (SYSTEM-PACKAGE-DEFAULT SYSTEM)))
	   (LOOP FOR TRANSFORMATION IN (SYSTEM-TRANSFORMATIONS SYSTEM)
		 AS INPUT = (TRANSFORMATION-INPUT TRANSFORMATION)
		 AND FILE-TYPES = (TRANSFORMATION-TYPE-INPUT-FILE-TYPES
				    (TRANSFORMATION-TRANSFORMATION-TYPE TRANSFORMATION))
		 WHEN (TYPEP INPUT 'MODULE)
		      NCONC (LOOP FOR PATHNAMES IN (GET-MODULE-PATHNAMES INPUT NIL)
				  NCONC (LOOP FOR FILE-TYPE IN FILE-TYPES
					      AND PATHNAME IN (CDR PATHNAMES)
					      WHEN (OR (EQ TYPES ':ALL)
						       (MEMBER FILE-TYPE TYPES))
						    COLLECT (MERGE-PATHNAME-TYPE PATHNAME
										 FILE-TYPE))))
	   )))

;;; Automatical system declaration hackery
(DEFUN SET-SYSTEM-SOURCE-FILE (SYSTEM-NAME SOURCE-FILE)
  (LET ((FDEFINE-FILE-PATHNAME (FUNCALL (FS:MERGE-PATHNAME-DEFAULTS SOURCE-FILE)
					':GENERIC-PATHNAME)))
    (RECORD-SOURCE-FILE-NAME SYSTEM-NAME 'DEFSYSTEM)))

;;; This is really a dummy, since handled at a higher level
(DEFUN (:NO-RELOAD-SYSTEM-DECLARATION MAKE-SYSTEM-KEYWORD) ()
  NIL)

(DEFUN MAYBE-RELOAD-SYSTEM-DECLARATION (SYSTEM-NAME KEYWORDS &AUX FILE)
  ;; If we can, ignore package problems
  (LET ((SYSTEM (FIND-SYSTEM-NAMED SYSTEM-NAME T)))
    (AND SYSTEM (SETQ SYSTEM-NAME (SYSTEM-SYMBOLIC-NAME SYSTEM))))
  (AND (NOT (MEMQ ':NO-RELOAD-SYSTEM-DECLARATION KEYWORDS))
       (NOT (STRINGP SYSTEM-NAME))    ;PREVENT BOMBING OUT, THIS SHOULD BE FIXED BETTER
       (SETQ FILE (GET-SOURCE-FILE-NAME SYSTEM-NAME 'DEFSYSTEM))
       ;; To keep from blowing out, disable this whole feature if the FN2 isn't >.
       (EQ (FUNCALL FILE ':TYPE) ':UNSPECIFIC)
       ;; Also keep from losing when the same file has the defsystem and the make-system in it
       (NEQ FILE FDEFINE-FILE-PATHNAME)
       (MAYBE-RELOAD-FILE FILE KEYWORDS)))

(DEFUN MAYBE-RELOAD-FILE (FILE KEYWORDS &AUX SYSTEM)
  (OR (SETQ SYSTEM (FUNCALL FILE ':GET 'MAYBE-RELOAD-SYSTEM))
      (LET* ((LISP (FUNCALL FILE ':NEW-PATHNAME ':TYPE "LISP" ':VERSION ':NEWEST))
	     (QFASL (FUNCALL FILE ':NEW-PATHNAME ':TYPE "QFASL" ':VERSION ':NEWEST))
	     ;; Compiled if qfasl ever loaded, else interpreted if lisp ever loaded,
	     ;; else check file computer and default to interpreted.
	     (COMPILED (COND ((FUNCALL QFASL ':GET ':FILE-ID-PACKAGE-ALIST) T)
			     ((FUNCALL LISP ':GET ':FILE-ID-PACKAGE-ALIST) NIL)
			     ((PROBEF QFASL) T)
			     (T NIL))))
	(SETQ SYSTEM (GENSYM))
	(DEFSYSTEM-1 SYSTEM `((,(IF COMPILED ':COMPILE-LOAD ':READFILE)
			       (,(STRING FILE)))))
	(FUNCALL FILE ':PUTPROP SYSTEM 'MAYBE-RELOAD-SYSTEM)))
  (LEXPR-FUNCALL #'MAKE-SYSTEM SYSTEM
		 (NCONC (LOOP FOR KEY IN KEYWORDS
			      WHEN (EQ KEY ':BATCH) COLLECT ':NOWARN
			      ELSE UNLESS (MEMQ KEY '(:NOLOAD :RELOAD :RECOMPILE :PRINT-ONLY))
				   COLLECT KEY)
			'(:COMPILE :NO-RELOAD-SYSTEM-DECLARATION))))

;;; Patch system interface
(DEFMACRO SYSTEM-PATCH-DIRECTORY (SYSTEM)
  `(GET (LOCF (SYSTEM-PLIST ,SYSTEM)) ':PATCH-DIRECTORY))

(DEFMACRO SYSTEM-PATCHABLE-P (SYSTEM)
  `(NOT (NULL (SYSTEM-PATCH-DIRECTORY ,SYSTEM))))

(DEFSTRUCT (PATCH-DIRECTORY :LIST :CONC-NAME)
  PATHNAME
  SAME-DIRECTORY-P
  (:INITIAL-STATUS ':EXPERIMENTAL)
  (PATCH-ATOM "PATCH"))

(DEFMACRO (:PATCHABLE DEFSYSTEM-MACRO) (&OPTIONAL DIRECTORY PATCH-ATOM
					&AUX DEFAULT PATCH-DIRECTORY)
  (SETQ DEFAULT (FS:DEFAULT-PATHNAME *SYSTEM-PATHNAME-DEFAULT*)
	DIRECTORY (IF (NULL DIRECTORY) DEFAULT
		      (FS:MERGE-PATHNAME-DEFAULTS DIRECTORY *SYSTEM-PATHNAME-DEFAULT*)))
  (SETQ DIRECTORY (FUNCALL DIRECTORY ':NEW-PATHNAME ':NAME ':UNSPECIFIC ':TYPE ':UNSPECIFIC
			   ':VERSION ':UNSPECIFIC))
  (SETQ PATCH-DIRECTORY (MAKE-PATCH-DIRECTORY
			  PATHNAME DIRECTORY
			  SAME-DIRECTORY-P (OR (NOT (NULL PATCH-ATOM))
					       (AND (EQUAL (FUNCALL DIRECTORY ':HOST)
							   (FUNCALL DEFAULT ':HOST))
						    (EQUAL (FUNCALL DIRECTORY ':DEVICE)
							   (FUNCALL DEFAULT ':DEVICE))
						    (EQUAL (FUNCALL DIRECTORY ':DIRECTORY)
							   (FUNCALL DEFAULT ':DIRECTORY))))))
  (AND PATCH-ATOM (SETF (PATCH-DIRECTORY-PATCH-ATOM PATCH-DIRECTORY) PATCH-ATOM))
  (SETF (SYSTEM-PATCH-DIRECTORY *SYSTEM-BEING-DEFINED*) PATCH-DIRECTORY)
  NIL)

(DEFUN PATCH-SYSTEM-PATHNAME (NAME TYPE &REST ARGS &AUX PATCH-DIRECTORY)
  (OR (SETQ PATCH-DIRECTORY (SYSTEM-PATCH-DIRECTORY (FIND-SYSTEM-NAMED NAME)))
      (FERROR NIL "System ~A not patchable" NAME))
  (LEXPR-FUNCALL (PATCH-DIRECTORY-PATHNAME PATCH-DIRECTORY)
		 ':PATCH-FILE-PATHNAME NAME
		 (PATCH-DIRECTORY-SAME-DIRECTORY-P PATCH-DIRECTORY)
		 (PATCH-DIRECTORY-PATCH-ATOM PATCH-DIRECTORY)
		 TYPE ARGS))

(DEFMACRO (PATCHABLE-INTERNAL DEFSYSTEM-MACRO) (&OPTIONAL COMDEP)
  `(INCREMENT-LOADED-VERSION (INCREMENT-COMPILED-VERSION NIL ,COMDEP)))

(DEFMACRO (:INITIAL-STATUS DEFSYSTEM-MACRO) (STATUS &AUX PATCH-DIRECTORY)
  (OR (SETQ PATCH-DIRECTORY (SYSTEM-PATCH-DIRECTORY *SYSTEM-BEING-DEFINED*))
      (FERROR NIL "~S not patchable" *SYSTEM-BEING-DEFINED*))
  (SETF (PATCH-DIRECTORY-INITIAL-STATUS PATCH-DIRECTORY) STATUS)
  NIL)

(DEFINE-SIMPLE-TRANSFORMATION INCREMENT-LOADED-VERSION INCREMENT-LOADED-VERSION-1
			      PATCH-VERSION-NEWER-THAN-LOADED
			      NIL NIL
			      ("Make ~A patchable" "Making ~A patchable" "~A made patchable")
			      NIL)

(DEFUN INCREMENT-LOADED-VERSION-1 (&AUX NAME VERSION STATUS)
  (SETQ NAME (STRING (SYSTEM-NAME *SYSTEM-BEING-MADE*)))
  (MULTIPLE-VALUE (VERSION STATUS)
    (ADD-PATCH-SYSTEM NAME))
  (SETQ STATUS (CADR (ASSQ STATUS SYSTEM-STATUS-ALIST)))
  (COND ((NOT *SILENT-P*)
	 (FORMAT T "~&~A~:[ ~]~A version ~D. loaded~%"
		 STATUS (ZEROP (ARRAY-ACTIVE-LENGTH STATUS)) NAME VERSION))))

(DEFUN PATCH-VERSION-NEWER-THAN-LOADED (&AUX NAME)
  (SETQ NAME (SYSTEM-NAME *SYSTEM-BEING-MADE*))
  (NEQ (GET-PATCH-SYSTEM-MAJOR-VERSION NAME)
       (GET-SYSTEM-VERSION NAME)))

(DEFINE-SIMPLE-TRANSFORMATION INCREMENT-COMPILED-VERSION INCREMENT-COMPILED-VERSION-1
			      TRUE NIL NIL
			      ("Increment ~A patch version"
			       "Incrementing ~A patch version"
			       "~A patch version incremented")
			      T)

(DEFUN INCREMENT-COMPILED-VERSION-1 (&AUX NAME VERSION)
  (SETQ NAME (STRING (SYSTEM-NAME *SYSTEM-BEING-MADE*))
	VERSION (INCREMENT-PATCH-SYSTEM-MAJOR-VERSION
		  (SYSTEM-NAME *SYSTEM-BEING-MADE*)
		  (PATCH-DIRECTORY-INITIAL-STATUS
		    (SYSTEM-PATCH-DIRECTORY *SYSTEM-BEING-MADE*))))
  (OR *SILENT-P*
      (FORMAT T "~&~A version ~D. created~%" NAME VERSION)))


(DEFMACRO (:NOT-IN-DISK-LABEL DEFSYSTEM-MACRO) ()
  (PUTPROP (LOCF (SYSTEM-PLIST *SYSTEM-BEING-DEFINED*)) T ':NOT-IN-DISK-LABEL)
  NIL)

(DEFUN SYSTEM-SHOULD-NOT-APPEAR-IN-DISK-LABEL (SYSTEM)
  (GET (LOCF (SYSTEM-PLIST (FIND-SYSTEM-NAMED SYSTEM))) ':NOT-IN-DISK-LABEL))

;;; Some compatibility functions with the old stuff
(DEFUN (:NOOP MAKE-SYSTEM-KEYWORD) ())

(DEFUN COMPILE-FILE-ALIST (FILE-ALIST &OPTIONAL (DONT-ASK-P 0) (DONT-CARE-IF-UNCHANGED-P 0)
			     DONT-ASK-FOR-CONFIRMATION PACKAGE-SPEC &AUX SYSTEM)
  (SETQ SYSTEM (FIND-SYSTEM-FROM-FILE-LIST FILE-ALIST PACKAGE-SPEC NIL T))
  (AND (NUMBERP DONT-ASK-P)				;If not specified,
       (SETQ DONT-ASK-P (NOT (Y-OR-N-P "Should I ask you about each file? "))))
  (AND (NUMBERP DONT-CARE-IF-UNCHANGED-P)
       (SETQ DONT-CARE-IF-UNCHANGED-P
	     (Y-OR-N-P "Should I compile even if the file is unchanged? ")))
  (MAKE-SYSTEM SYSTEM ':COMPILE ':NOLOAD
		      (COND ((NOT DONT-ASK-P) ':SELECTIVE)
			    (DONT-ASK-FOR-CONFIRMATION ':NOCONFIRM)
			    (T ':NOOP))
		      (IF DONT-CARE-IF-UNCHANGED-P ':RELOAD ':NOOP)))

(DEFUN LOAD-FILE-ALIST (ALIST &OPTIONAL (DONT-ASK-INDIVIDUALLY 0) (DONT-CARE-IF-LOADED-P 0)
			  DONT-ASK-FOR-CONFIRMATION PKG &AUX SYSTEM)
  (SETQ SYSTEM (FIND-SYSTEM-FROM-FILE-LIST ALIST PKG NIL T))
  (AND (NUMBERP DONT-ASK-INDIVIDUALLY)
       (SETQ DONT-ASK-INDIVIDUALLY (NOT (Y-OR-N-P "Should I ask you about each file? "))))
  (AND (NUMBERP DONT-CARE-IF-LOADED-P)
       (SETQ DONT-CARE-IF-LOADED-P (Y-OR-N-P "Should I load even if the file is loaded? ")))
  (MAKE-SYSTEM SYSTEM (COND ((NOT DONT-ASK-INDIVIDUALLY) ':SELECTIVE)
			    (DONT-ASK-FOR-CONFIRMATION ':NOCONFIRM)
			    (T ':NOOP))
		      (IF DONT-CARE-IF-LOADED-P ':RELOAD ':NOOP)))

(DEFUN PKG-LOAD (PKG &OPTIONAL KEYLIST &AUX SYSTEM)
  (AND KEYLIST (NLISTP KEYLIST)
       (SETQ KEYLIST (LIST KEYLIST)))
  (SETQ SYSTEM (MAKE-SYSTEM-FROM-PACKAGE PKG))
  (LEXPR-FUNCALL #'MAKE-SYSTEM SYSTEM KEYLIST))

(DEFVAR *PACKAGES-MADE-INTO-SYSTEMS* NIL)

(DEFUN MAKE-SYSTEM-FROM-PACKAGE (PKG &AUX NAME OLD-P)
  (SETQ PKG (PKG-FIND-PACKAGE PKG)
	NAME (PKG-NAME PKG))
  ;; If the system was generated from the package automatically, make a new system if
  ;; the file-list has changed.  Otherwise use the system that has that name without
  ;; looking in the package.
  (COND ((AND (NOT (SETQ OLD-P (MEMBER NAME *PACKAGES-MADE-INTO-SYSTEMS*)))
	      (FIND-SYSTEM-NAMED NAME T)))
	(T
	 (OR OLD-P (PUSH NAME *PACKAGES-MADE-INTO-SYSTEMS*))
	 (FIND-SYSTEM-FROM-FILE-LIST (PKG-FILE-ALIST PKG) NAME NAME))))

(DEFUN LOAD-FILE-LIST (FILE-LIST &OPTIONAL KEYLIST &AUX SYSTEM)
  (AND KEYLIST (NLISTP KEYLIST)
       (SETQ KEYLIST (LIST KEYLIST)))
  (SETQ SYSTEM (FIND-SYSTEM-FROM-FILE-LIST FILE-LIST))
  (LEXPR-FUNCALL #'MAKE-SYSTEM SYSTEM KEYLIST))

(DEFVAR *FILE-LIST-SYSTEM-ALIST* NIL)

(DEFUN FIND-SYSTEM-FROM-FILE-LIST (FILE-LIST &OPTIONAL PACKAGE-SPEC NAME ALIST-P)
  (OR (DO L *FILE-LIST-SYSTEM-ALIST* (CDR L) (NULL L)
	  (AND (EQUAL (CDAR L) FILE-LIST) (RETURN (CAAR L))))
      (MAKE-SYSTEM-FROM-FILE-LIST FILE-LIST PACKAGE-SPEC (OR NAME (GENSYM)) ALIST-P)))

(DEFUN MAKE-SYSTEM-FROM-FILE-LIST (FILE-LIST PACKAGE-SPEC NAME ALIST-P &AUX OPTIONS)
  (AND PACKAGE-SPEC
       (PUSH `(:PACKAGE ,PACKAGE-SPEC) OPTIONS))
  (DO ((FILES FILE-LIST (CDR FILES))
       (FILE-ELEM) (FILE) (TYPE) (MODULE-NAME)
       (LAST-DEFS-TYPE) (LAST-DEFS-MODULE) (LAST-REGULAR-TYPE) (LAST-REGULAR-MODULE)
       (N-DEFS 0) (N-REGULAR 0) (COMPILED-DEFS NIL) (INTERPRETED-DEFS NIL)
       (DEFS-MODULES NIL) (DEFS-TRANSFORMATIONS NIL)
       (REGULAR-MODULES NIL) (REGULAR-TRANSFORMATIONS NIL))
      ((NULL FILES)
       (AND (OR COMPILED-DEFS INTERPRETED-DEFS)
	    (LET* ((TEM1 (AND COMPILED-DEFS `(:FASLOAD . ,(NREVERSE COMPILED-DEFS))))
		   (TEM2 (AND INTERPRETED-DEFS `(:READFILE . ,(NREVERSE INTERPRETED-DEFS))))
		   (TEM (COND ((AND TEM1 TEM2) (LIST TEM1 TEM2))
			      (TEM1)
			      (TEM2))))
	      (DOLIST (XFORM REGULAR-TRANSFORMATIONS)
		(AND (EQ (CAR XFORM) ':COMPILE-LOAD)
		     (NCONC XFORM (NCONS TEM))))))
       (SETQ OPTIONS (NCONC REGULAR-TRANSFORMATIONS DEFS-TRANSFORMATIONS
			    REGULAR-MODULES DEFS-MODULES
			    OPTIONS)))
    (SETQ FILE-ELEM (CAR FILES)
	  FILE (FS:MERGE-PATHNAME-DEFAULTS (CAR FILE-ELEM) FS:LOAD-PATHNAME-DEFAULTS
					   "LISP"))
    (SETQ TYPE (COND ((NOT (EQUAL (FUNCALL FILE ':TYPE) "QFASL")) ':READFILE)
		     ((AND (NOT ALIST-P)
			   (OR (MEM #'STRING-EQUAL 'NO-SOURCE-FILE (CDR FILE-ELEM))
			       (STRING-EQUAL NAME "FONTS")) ':FASLOAD))
		     (T ':COMPILE-LOAD)))
    (SETQ FILE (FUNCALL FILE ':NEW-PATHNAME ':TYPE NIL ':VERSION NIL))
    (IF (AND (NOT ALIST-P) (MEM #'STRING-EQUAL 'DEFS (CDR FILE-ELEM)))	;A DEFS file
	(IF (EQ LAST-DEFS-TYPE TYPE)
	    (SETF (THIRD LAST-DEFS-MODULE) (NCONC (THIRD LAST-DEFS-MODULE) (NCONS FILE)))
	    (SETQ LAST-DEFS-TYPE TYPE)
	    (SETQ MODULE-NAME (INTERN (FORMAT NIL "DEFS-~D" (SETQ N-DEFS (1+ N-DEFS)))))
	    (SETQ LAST-DEFS-MODULE `(:MODULE ,MODULE-NAME (,FILE)))
	    (PUSH LAST-DEFS-MODULE DEFS-MODULES)
	    (PUSH `(,TYPE ,MODULE-NAME) DEFS-TRANSFORMATIONS)
	    (IF (EQ TYPE ':READFILE)
		(PUSH MODULE-NAME INTERPRETED-DEFS)
		(PUSH MODULE-NAME COMPILED-DEFS)))
	(IF (EQ LAST-REGULAR-TYPE TYPE)
	    (SETF (THIRD LAST-REGULAR-MODULE) (NCONC (THIRD LAST-REGULAR-MODULE)
						     (NCONS FILE)))
	    (SETQ LAST-REGULAR-TYPE TYPE)
	    (SETQ MODULE-NAME (INTERN (FORMAT NIL "REGULAR-~D"
					      (SETQ N-REGULAR (1+ N-REGULAR)))))
	    (SETQ LAST-REGULAR-MODULE `(:MODULE ,MODULE-NAME (,FILE)))
	    (PUSH LAST-REGULAR-MODULE REGULAR-MODULES)
	    (PUSH `(,TYPE ,MODULE-NAME) REGULAR-TRANSFORMATIONS))))
  (PUSH (CONS NAME FILE-LIST) *FILE-LIST-SYSTEM-ALIST*)
  (LET ((FDEFINE-FILE-PATHNAME NIL))		;Prevent MAKE-SYSTEM trying to load bogus file
    (DEFSYSTEM-1 NAME (NREVERSE OPTIONS))))

(DEFINE-SIMPLE-TRANSFORMATION :GENERATE-HOST-TABLE CHAOS:GENERATE-HOST-TABLE-1
  FILE-NEWER-THAN-FILE-P ("TEXT") ("LISP") ("Generate host table from"
					    "Generating host table from"
					    "generated into host table"))

(DEFINE-SIMPLE-TRANSFORMATION :LOAD-FONTS-WIDTHS LOAD-FONT-WIDTHS-1
  FILE-NEWER-THAN-INSTALLED-P ("WIDTHS") NIL ("Load Fonts Widths from"
					      "Loading Fonts Widths from"
					      "loaded for fonts widths") NIL)

;;; A little in help in figuring out what is going on
;;; This is not DESCRIBE of a SYSTEM, since that can give other useful information.
(DEFUN DESCRIBE-SYSTEM (SYSTEM-NAME &AUX SYSTEM)
  (IF (NULL (SETQ SYSTEM (FIND-SYSTEM-NAMED SYSTEM-NAME)))
      (FORMAT T "~&There is no system named ~A.~%" SYSTEM-NAME)
      (SETQ SYSTEM-NAME (SYSTEM-NAME SYSTEM))
      (FORMAT T "~&System ~A~@[ is defined in file ~A~]~%"
	      SYSTEM-NAME
	      (GET-SOURCE-FILE-NAME (SYSTEM-SYMBOLIC-NAME SYSTEM) 'DEFSYSTEM))
      (MAKE-SYSTEM SYSTEM-NAME ':COMPILE ':RELOAD ':DO-NOT-DO-COMPONENTS
			       ':DESCRIBE ':NO-INCREMENT-PATCH ':NO-RELOAD-SYSTEM-DECLARATION)
      (LET ((COMPONENTS (SYSTEM-COMPONENT-SYSTEMS SYSTEM)))
	(COND (COMPONENTS
	       (FORMAT T " ~A is made up of component system~P "
		       SYSTEM-NAME (LENGTH COMPONENTS))
	       (FORMAT:PRINT-LIST T "~A" COMPONENTS)
	       (DOLIST (COMPONENT COMPONENTS)
		 (FORMAT T "~2&")
		 (DESCRIBE-SYSTEM COMPONENT)))))
      (COND ((SYSTEM-PATCHABLE-P SYSTEM)
	     (FORMAT T "~& ~A is patchable" SYSTEM-NAME)
	     (MULTIPLE-VALUE-BIND (MAJOR MINOR STATUS)
		 (GET-SYSTEM-VERSION SYSTEM)
	       (COND (MAJOR
		      (LET ((STATUS-NAME (OR (SECOND (ASSQ STATUS SYSTEM-STATUS-ALIST))
					     STATUS)))
			(FORMAT T ", ~A" STATUS-NAME)
			(OR (EQUAL STATUS-NAME "") (TYO #\SP)))
		      (FORMAT T "~D.~D is loaded." MAJOR MINOR)
		      (AND (FQUERY NIL "Do you want to see the patches for ~A? " SYSTEM-NAME)
			   (PRINT-PATCHES SYSTEM))))))))
  SYSTEM-NAME)

(DEFUN (:DESCRIBE MAKE-SYSTEM-KEYWORD) ()
  (SETQ *FILE-TRANSFORMATION-FUNCTION* 'DESCRIBE-FILE-TRANSFORMATIONS))

(DEFUN DESCRIBE-FILE-TRANSFORMATIONS ()
  (DOLIST (FILE-TRANSFORMATION *FILE-TRANSFORMATION-LIST*)
    (LET ((STATE (FILE-TRANSFORMATION-STATE FILE-TRANSFORMATION)))
      (SELECTQ STATE
	((:DONE :REFUSED :NOT-NEEDED NIL))
	((:PENDING :PROBABLY)
	 (LET ((TYPE (FILE-TRANSFORMATION-TRANSFORMATION-TYPE FILE-TRANSFORMATION))
	       (ARGS (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION))
	       (OUTPUTS (FILE-TRANSFORMATION-OUTPUTS FILE-TRANSFORMATION))
	       (*FORCE-PACKAGE* (FILE-TRANSFORMATION-FORCE-PACKAGE FILE-TRANSFORMATION))
	       (*SYSTEM-BEING-MADE* (FILE-TRANSFORMATION-SYSTEM FILE-TRANSFORMATION)))
	   (FORMAT T "~&~\FILE-XFORM-ARGS\~:[ ~:[are~;is~] ~A~
			         ~:[~; in~:[to~] package ~A~]~]"
		   FILE-TRANSFORMATION (NULL ARGS) (EQ (CDR ARGS) OUTPUTS)
		   (TRANSFORMATION-TYPE-PRETTY-PAST-PARTICIPLE TYPE)
		   *FORCE-PACKAGE*
		   (FILE-TRANSFORMATION-OUTPUTS FILE-TRANSFORMATION)
		   *FORCE-PACKAGE*)
	   (COND ((MEMQ (TRANSFORMATION-TYPE-NAME TYPE) *LOAD-TYPE-TRANSFORMATIONS*)
		  (DO L ARGS (CDR L) (EQ L OUTPUTS)
		      (DESCRIBE-FILE-TRANSFORMATION-LOADED-FILE (CAR L))))
		 ((EQ (TRANSFORMATION-TYPE-FUNCTION TYPE) 'QC-FILE-1)
		  (DESCRIBE-FILE-TRANSFORMATION-COMPILED-FILE (CAR ARGS)))))
	 (SETF (FILE-TRANSFORMATION-STATE FILE-TRANSFORMATION) ':DONE))
	(OTHERWISE
	 (FERROR NIL "Transformation ~S in bad state" FILE-TRANSFORMATION))))))

(DEFUN DESCRIBE-FILE-TRANSFORMATION-LOADED-FILE (FILE &AUX ID)
  (AND (SETQ ID (GET-FILE-LOADED-ID FILE *FORCE-PACKAGE*))
       (FORMAT T "~& ~A was created ~\TIME\~%" (CAR ID) (CDR ID))))

(DEFUN DESCRIBE-FILE-TRANSFORMATION-COMPILED-FILE (FILE &AUX SID CDATA)
  (LET ((GENERIC-PATHNAME (FUNCALL FILE ':GENERIC-PATHNAME)))
    (SETQ SID (FUNCALL GENERIC-PATHNAME ':GET ':QFASL-SOURCE-FILE-UNIQUE-ID)
	  CDATA (FUNCALL GENERIC-PATHNAME ':GET ':COMPILE-DATA)))
  (COND ((OR SID CDATA)
	 (FORMAT T "~& ~A was compiled" (OR SID FILE))
	 (AND CDATA
	      (LEXPR-FUNCALL #'FORMAT T
			     " by ~A on ~A at ~\TIME\~%~10Xwith system ~D.~D~%"
			     CDATA)))))