;;; The system system. -*- Mode:LISP; Package:SYSTEM-INTERNALS; Base:8; Readtable:ZL -*- ;;; ** (c) Copyright 1980, 1981, 1982 Massachusetts Institute of Technology ** ;; We need this during system building, before window system is loaded. (PROCLAIM '(SPECIAL TV:MORE-PROCESSING-GLOBAL-ENABLE)) ;;; 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) (:ALTERANT NIL)) (NAME nil :documentation "Name of this system, a symbol or string") (COMPONENT-SYSTEMS nil :documentation "List of system names") MODULES TOP-LEVEL-TRANSFORMATIONS TRANSFORMATIONS PLIST) (DEFSELECT ((SYSTEM NAMED-STRUCTURE-INVOKE)) (:PRINT-SELF (SYSTEM STREAM PRINDEPTH SLASHIFY-P) PRINDEPTH SLASHIFY-P ;Not used (SI:PRINTING-RANDOM-OBJECT (SYSTEM STREAM :TYPEP) (PRINC (SYSTEM-NAME SYSTEM) STREAM)))) ;;; Slots not actually in the defstruct (DEFMACRO SYSTEM-PACKAGE-DEFAULT (SYSTEM) `(GETF (SYSTEM-PLIST ,SYSTEM) :PACKAGE)) (DEFSTRUCT (MODULE :NAMED-ARRAY :CONC-NAME (:ALTERANT NIL)) (NAME nil :documentation "A symbol") (SYSTEM nil :documentation "A SYSTEM object") (COMPONENTS nil :documentation "A list of MODULE's, PATHNAME lists,or (SYSTEM-NAME . MODULE names)") PLIST) (DEFSELECT ((:PROPERTY MODULE NAMED-STRUCTURE-INVOKE)) (:PRINT-SELF (MODULE STREAM IGNORE IGNORE) (SI:PRINTING-RANDOM-OBJECT (MODULE STREAM) (FORMAT STREAM "~A (~A ~A)" (NAMED-STRUCTURE-P MODULE) (SYSTEM-NAME (MODULE-SYSTEM MODULE)) (MODULE-NAME MODULE))))) (DEFSTRUCT (TRANSFORMATION :ARRAY :NAMED :CONC-NAME (:ALTERANT NIL)) TRANSFORMATION-TYPE ;A TRANSFORMATION-TYPE (INPUT nil :documentation "A MODULE or a TRANSFORMATION") DEPENDENCIES ;A list of TRANSFORMATION's (CONDITION-FUNCTION nil :documentation "A symbol") (SYSTEM nil :documentation "The system this module belongs to.") ) (DEFSELECT ((:PROPERTY TRANSFORMATION NAMED-STRUCTURE-INVOKE)) (:PRINT-SELF (TRANSFORMATION STREAM IGNORE IGNORE &AUX TEMP) (SI:PRINTING-RANDOM-OBJECT (TRANSFORMATION STREAM) (FORMAT STREAM "~A~@[ ~A~]" (NAMED-STRUCTURE-P TRANSFORMATION) (AND (SETQ TEMP (TRANSFORMATION-TRANSFORMATION-TYPE TRANSFORMATION)) (TRANSFORMATION-TYPE-NAME TEMP)))))) (DEFSTRUCT (TRANSFORMATION-TYPE :LIST :CONC-NAME (:ALTERANT NIL)) (NAME nil :documentation "A keyword") (PRETTY-NAMES nil :documentation "(/"Foo/" /"Fooing/" /"fooed/")") (FUNCTION nil :documentation "A symbol") (INPUT-FILE-TYPES nil :documentation "A list of string") OUTPUT-FILE-TYPES) (DEFSTRUCT (TRANSFORMATION-TYPE-PRETTY-NAMES :LIST :CONC-NAME (:ALTERANT NIL) (: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 (:ALTERANT NIL)) (STATE nil :documentation "One of NIL, :PENDING, :DONE, :NOT-NEEDED or :REFUSED") TRANSFORMATION-TYPE ;A TRANSFORMATION-TYPE (FORCE-PACKAGE nil :documentation "A symbol; transformation takes place there") SYSTEM ;The one to perform within (CONDITION-FUNCTION nil :documentation "A symbol or closure") (OUTPUTS nil :documentation "An NTHCDR of FILE-TRANSFORMATION-ARGS") ARGS) ;a list of all input files followed by all output files. (DEFPROP DEFSYSTEM "System" DEFINITION-TYPE-NAME) (DEFMACRO DEFSYSTEM (NAME &BODY OPTIONS) "Define a system, a bunch of files and how to compile or load them." (LET ((NAMESYMBOL (INTERN (STRING NAME) PKG-KEYWORD-PACKAGE))) `(DEFSYSTEM-1 ',NAMESYMBOL ',(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)) ;;; record the system name in the :SYSTEMS property of the generic pathname of ;;; each file in the system. (DEFUN RECORD-SYSTEM-NAME-IN-PATHNAMES (NAME SYSTEM) "Record a system's name in all its files' pathnames. NAME should be the system name and SYSTEM should be the system object." (LET ((DBFT (GETF (SYSTEM-PLIST SYSTEM) 'DEFAULT-BINARY-FILE-TYPE))) (MAPC #'(LAMBDA (PATHNAME) (LET* ((GENERIC-PATHNAME (SEND PATHNAME :GENERIC-PATHNAME)) (SYSTEMS (SEND GENERIC-PATHNAME :GET :SYSTEMS))) ;;if it already has a :SYSTEMS property, push onto it. (OR (MEMQ NAME SYSTEMS) (SEND GENERIC-PATHNAME :PUTPROP (CONS NAME SYSTEMS) :SYSTEMS)) (IF DBFT (SEND GENERIC-PATHNAME :PUTPROP DBFT :DEFAULT-BINARY-FILE-TYPE) (SEND GENERIC-PATHNAME :REMPROP :DEFAULT-BINARY-FILE-TYPE)))) (SYSTEM-SOURCE-FILES SYSTEM :ALL NIL NIL)))) (DEFUN DEFSYSTEM-1 (NAME OPTIONS &OPTIONAL (ADD-P T) DONT-RECORD-IN-PATHNAMES) (AND (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*)) (UNLESS DONT-RECORD-IN-PATHNAMES (RECORD-SYSTEM-NAME-IN-PATHNAMES NAME *SYSTEM-BEING-DEFINED*)))) NAME) ;;; Don't record a DEFSYSTEM-1 as a random form, since it records a DEFSYSTEM as a definition. (DEFPROP DEFSYSTEM-1 T QFASL-DONT-RECORD) (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. Items in this list can be either a SYSTEM ;;; structure, or a string, or even a symbol. If a string or a symbol, its the ;;; name of the system, and its DEFSYSTEM hasn't even been loaded yet. (DEFVAR *SYSTEMS-LIST* NIL "A list of all the systems in this world. Each entry can be either a system structure, a string, or a symbol. A string or symbol indicates that the system hasn't yet been loaded.") (DEFUN ADD-SYSTEM (SYSTEM) (SETQ *SYSTEMS-LIST* (CONS SYSTEM (DEL #'(LAMBDA (X Y) ;;this should NOT be STRING-EQUAL, which would break on ;;systems with names that are symbols. (EQUALP (IF (TYPEP X 'SYSTEM) (SYSTEM-NAME X) X) (IF (TYPEP Y 'SYSTEM) (SYSTEM-NAME Y) Y))) SYSTEM *SYSTEMS-LIST*)))) (DEFMACRO SYSTEM-SHORT-NAME-INTERNAL (SYSTEM) `(GETF (SYSTEM-PLIST ,SYSTEM) :SHORT-NAME)) (DEFMACRO SYSTEM-NICKNAMES (SYSTEM) `(GETF (SYSTEM-PLIST ,SYSTEM) :NICKNAMES)) (DEFMACRO SYSTEM-SYMBOLIC-NAME (SYSTEM) `(GETF (SYSTEM-PLIST ,SYSTEM) :SYMBOLIC-NAME)) (DEFMACRO SYSTEM-WARNINGS-PATHNAME-DEFAULT (SYSTEM) `(GETF (SYSTEM-PLIST ,SYSTEM) :WARNINGS-PATHNAME-DEFAULT)) (defmacro system-maintaining-sites (system) `(getf (system-plist ,system) :maintaining-sites)) ;;; 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) (defmacro (:maintaining-sites defsystem-macro) (&rest site-names) (setf (system-maintaining-sites *system-being-defined*) site-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) ;used by LAMLP (DEFMACRO (:USE-FAST-READER DEFSYSTEM-MACRO) (T-OR-NIL) (SETF (GETF (SI:SYSTEM-PLIST SI:*SYSTEM-BEING-DEFINED*) ':FAST-READ-SWITCH) T-OR-NIL) NIL) (DEFINE-DEFSYSTEM-SPECIAL-VARIABLE *SYSTEM-PATHNAME-DEFAULT* (FS:MAKE-PATHNAME-DEFAULTS)) (DEFINE-DEFSYSTEM-SPECIAL-VARIABLE *SYSTEM-PATHNAME-DEFAULT-SPECIFIED* NIL) ;;; Pathnames (DEFMACRO (:PATHNAME-DEFAULT DEFSYSTEM-MACRO) (DEFAULT) (SETQ *SYSTEM-PATHNAME-DEFAULT-SPECIFIED* T) (FS:MERGE-AND-SET-PATHNAME-DEFAULTS DEFAULT *SYSTEM-PATHNAME-DEFAULT*) NIL) ;;; Pathnames (DEFMACRO (:WARNINGS-PATHNAME-DEFAULT DEFSYSTEM-MACRO) (DEFAULT) (SETF (SYSTEM-WARNINGS-PATHNAME-DEFAULT *SYSTEM-BEING-DEFINED*) (FS:MERGE-PATHNAME-DEFAULTS DEFAULT *SYSTEM-PATHNAME-DEFAULT*)) NIL) (DEFINE-DEFSYSTEM-SPECIAL-VARIABLE *SYSTEM-DEFAULT-BINARY-FILE-TYPE* :QFASL) (defvar *known-binary-file-producers* nil) ;list ( ) (defsubst system-default-binary-file-type (system) (getf (system-plist system) 'default-binary-file-type :qfasl)) (defun make-system-binary-pathname (system pathname) (send pathname :new-type (system-default-binary-file-type system))) (DEFMACRO (:DEFAULT-BINARY-FILE-TYPE DEFSYSTEM-MACRO) (TYPE) (SETF (system-default-binary-file-type *SYSTEM-BEING-DEFINED*) TYPE) (SETQ *SYSTEM-DEFAULT-BINARY-FILE-TYPE* TYPE) NIL) (DEFUN PATHNAME-DEFAULT-BINARY-FILE-TYPE (PATHNAME) "Given a pathname, return the default binary file type (possibly canonical) to use with it. This is computed from the SYSTEM which the pathname belongs to." (OR (SEND (SEND PATHNAME :GENERIC-PATHNAME) :GET :DEFAULT-BINARY-FILE-TYPE) :QFASL)) ;used by LAMLP (DEFMACRO (:OUTPUT-PATHNAME DEFSYSTEM-MACRO) (PATHNAME) (SETF (GETF (SI:SYSTEM-PLIST SI:*SYSTEM-BEING-DEFINED*) ':OUTPUT-PATHSTRING) PATHNAME) NIL) (DEFUN PATHNAME-P (X) (OR (STRINGP X) (TYPEP X 'PATHNAME))) (DEFUN CANONICALIZE-PATHNAME (PATHNAME &OPTIONAL (DEFAULT *SYSTEM-PATHNAME-DEFAULT*)) (LET ((FS:*ALWAYS-MERGE-TYPE-AND-VERSION* NIL)) (FS:MERGE-PATHNAME-DEFAULTS PATHNAME DEFAULT NIL))) (DEFUN MERGE-PATHNAME-TYPE (PATHNAME TYPE &AUX OTYPE) (FS:MERGE-PATHNAME-DEFAULTS (COND ((MEMQ (SETQ OTYPE (SEND PATHNAME :CANONICAL-TYPE)) '(NIL :UNSPECIFIC)) (SEND PATHNAME :NEW-PATHNAME :TYPE TYPE :VERSION :NEWEST)) ((OR (STRING-EQUAL OTYPE TYPE) (EQ TYPE :WILD) (EQ OTYPE :WILD)) PATHNAME) (T (FERROR NIL "Pathname types don't match, ~A is required, ~A is specified." TYPE PATHNAME))))) ;;; Component systems (DEFMACRO (:COMPONENT-SYSTEMS DEFSYSTEM-MACRO) (&REST COMPONENTS) (SETF (SYSTEM-COMPONENT-SYSTEMS *SYSTEM-BEING-DEFINED*) (COPY-LIST 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 LOADED-ONLY) "Return the system object whose name is NAME. NO-ERROR-P says return NIL if no such system, rather than getting error. LOADED-ONLY says ignore systems whose DEFSYSTEMs have not been executed." ;; LOADED-ONLY = SI:FOO used internally to mean ;; do reload system source file but don't check SYS: SITE;. (IF (TYPEP NAME 'SYSTEM) NAME (OR (DOLIST (SYSTEM *SYSTEMS-LIST*) (COND ((TYPEP SYSTEM 'SYSTEM) (AND (OR (STRING-EQUAL NAME (SYSTEM-NAME SYSTEM)) (MEM #'STRING-EQUAL NAME (SYSTEM-NICKNAMES SYSTEM))) (RETURN SYSTEM))) ((AND (MEMQ LOADED-ONLY '(NIL FOO)) (STRING-EQUAL NAME SYSTEM)) (MAYBE-RELOAD-SYSTEM-DECLARATION SYSTEM '(:NOCONFIRM)) (LET ((RETRY (FIND-SYSTEM-NAMED NAME T T))) (IF RETRY (RETURN RETRY) (FERROR NIL "~A did not contain a definition of ~A." (SEND (GET-SOURCE-FILE-NAME SYSTEM 'DEFSYSTEM) :SOURCE-PATHNAME) SYSTEM)))))) (AND (NOT LOADED-ONLY) (LET ((PATHNAME (FS:PARSE-PATHNAME (STRING-APPEND "SYS: SITE; " NAME " SYSTEM")))) (IF (LOAD PATHNAME :IF-DOES-NOT-EXIST NIL :SET-DEFAULT-PATHNAME NIL :VERBOSE T) (FIND-SYSTEM-NAMED NAME NO-ERROR-P 'FOO) (IF NO-ERROR-P NIL (FERROR NIL "System ~S not found" NAME))))) (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 ; WITH DEFAULTS = *SYSTEM-PATHNAME-DEFAULT* COLLECT (COND ((PATHNAME-P COMPONENT) ; (SETQ DEFAULTS ; (LET ((FS:*ALWAYS-MERGE-TYPE-AND-VERSION* NIL)) ; (FS:MERGE-PATHNAME-DEFAULTS ; COMPONENT DEFAULTS NIL))) ; (LIST DEFAULTS)) (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* NIL) (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))) (DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *NO-INCREMENT-PATCH* NIL) (DEFUN (:NO-INCREMENT-PATCH MAKE-SYSTEM-KEYWORD) () (SETQ *NO-INCREMENT-PATCH* T)) (DEFUN (:INCREMENT-PATCH MAKE-SYSTEM-KEYWORD) () (SETQ *TOP-LEVEL-TRANSFORMATIONS* (APPEND '(INCREMENT-COMPILED-VERSION) *TOP-LEVEL-TRANSFORMATIONS*))) (DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *LOAD-PATCHES* T) (DEFUN (:NO-LOAD-PATCHES MAKE-SYSTEM-KEYWORD) () (SETQ *LOAD-PATCHES* NIL)) (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 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)) (DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *WARNINGS-STREAM* NIL) (DEFUN (:DEFAULTED-BATCH MAKE-SYSTEM-KEYWORD) (&AUX PATHNAME) (SETQ PATHNAME (OR (SYSTEM-WARNINGS-PATHNAME-DEFAULT *SYSTEM-BEING-MADE*) (SEND (FS:USER-HOMEDIR) :NEW-PATHNAME :NAME (format nil "~A-CWARNS" (string-upcase (or (si:system-symbolic-name *system-being-made*) (si:system-short-name *system-being-made*)))) :TYPE :LISP :VERSION :NEWEST))) (SETQ INHIBIT-FDEFINE-WARNINGS :JUST-WARN TV:MORE-PROCESSING-GLOBAL-ENABLE NIL *BATCH-MODE-P* T *QUERY-TYPE* :NOCONFIRM) (FORMAT *QUERY-IO* "~&Writing compiler warnings data base to file ~A.~%" PATHNAME) (SETQ *WARNINGS-STREAM* (OPEN PATHNAME :DIRECTION :OUTPUT :CHARACTERS T)) (FORMAT *WARNINGS-STREAM* "~&;System ~A made by ~A at ~\DATIME\ -*-Mode: Lisp; Package: User; Base: 10-*-~%" (SYSTEM-NAME *SYSTEM-BEING-MADE*) USER-ID) (PUSH `(CLOSE *WARNINGS-STREAM*) *MAKE-SYSTEM-FORMS-TO-BE-EVALED-FINALLY*)) (DEFUN (:BATCH MAKE-SYSTEM-KEYWORD) (&AUX PATHNAME) (SETQ PATHNAME (OR (SYSTEM-WARNINGS-PATHNAME-DEFAULT *SYSTEM-BEING-MADE*) (SEND (FS:USER-HOMEDIR) :NEW-PATHNAME :NAME (format nil "~A-CWARNS" (string-upcase (or (si:system-symbolic-name *system-being-made*) (si:system-short-name *system-being-made*)))) :TYPE :LISP :VERSION :NEWEST))) (SETQ PATHNAME (PROMPT-AND-READ `(:PATHNAME :DEFAULTS ,PATHNAME) "~&Write compiler warnings data base to file: (default ~A) " PATHNAME)) (SETQ *WARNINGS-STREAM* (OPEN PATHNAME :DIRECTION :OUTPUT :CHARACTERS T)) (SETQ INHIBIT-FDEFINE-WARNINGS :JUST-WARN TV:MORE-PROCESSING-GLOBAL-ENABLE NIL *BATCH-MODE-P* T *QUERY-TYPE* :NOCONFIRM) (FORMAT *WARNINGS-STREAM* "~&;System ~A made by ~A at ~\DATIME\ -*-Mode: Lisp; Package: User; Base: 10-*-~%" (SYSTEM-NAME *SYSTEM-BEING-MADE*) USER-ID) (PUSH `(CLOSE *WARNINGS-STREAM*) *MAKE-SYSTEM-FORMS-TO-BE-EVALED-FINALLY*)) (DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *SYSTEM-BEING-MADE* NIL) (DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *MAKE-SYSTEM-FORMS-TO-BE-EVALED-BEFORE* NIL) ;The forms that the keywords put on this list ;will be evaluated after all transformations, ;within the compiler warnings context, ;only if we are not aborted. (DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *MAKE-SYSTEM-FORMS-TO-BE-EVALED-AFTER* NIL) ;The forms that the keywords put on this list ;will be evaluated by an UNWIND-PROTECT at the very end of MAKE-SYSTEM. (DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *MAKE-SYSTEM-FORMS-TO-BE-EVALED-FINALLY* NIL) (DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *SYSTEM-DEFAULT-BINARY-FILE-TYPE* NIL) (DEFVAR *SOMETHING-LOADED* :UNBOUND "Bound by MAKE-SYSTEM, set to T if any file is loaded.") (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*)) (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))) (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 (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 ~\SI::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))) (SEND *QUERY-IO* :TYO #/NEWLINE))) (AND (FILE-TRANSFORMATION-ARGS LAST-TRANSFORMATION) (FORMAT *QUERY-IO* "~&~\SI::FILE-XFORM-ARGS\" LAST-TRANSFORMATION)) (SETQ N-FOUND (1+ N-FOUND)))) (AND (NULL TRANSFORMATION-TYPE) (RETURN (AND (PLUSP N-FOUND) (SELECTQ (FQUERY `(:timeout #.(* 5 60. 60.) :default-value t :CHOICES (((S "Selective") #/S) . ,FORMAT:Y-OR-N-P-CHOICES)) "~2&~\XFORM-TYPES\? " (NREVERSE TYPES-FOUND) N-FOUND) ((T) T) (S (LET ((*QUERY-TYPE* :SELECTIVE)) (REQUERY-SELECTIVE *FILE-TRANSFORMATION-LIST*)) (QUERY-USER-LIST)))))) (AND (SETQ FIRST-P (NEQ TRANSFORMATION-TYPE LAST-TYPE)) (PUSH* TRANSFORMATION-TYPE TYPES-FOUND)) (SETQ LAST-TRANSFORMATION TRANSFORMATION LAST-TYPE TRANSFORMATION-TYPE))))) (DEFUN REQUERY-SELECTIVE (TRANSFORMATIONS) (DOLIST (TRANS TRANSFORMATIONS) (WHEN (MEMQ (FILE-TRANSFORMATION-STATE TRANS) '(:PROBABLY :PENDING)) (UNLESS (QUERY-USER-SELECTIVE TRANS) (SETF (FILE-TRANSFORMATION-STATE TRANS) :REFUSED))))) (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 (SEND *STANDARD-OUTPUT* :STRING-OUT (IF (LOOP FOR TYP IN (CDR TYPES) ALWAYS (LISTP (CAR TYP))) " or " ", ")) (SETQ COMMA-P T)) (SEND *STANDARD-OUTPUT* :STRING-OUT (TRANSFORMATION-TYPE-PRETTY-IMPERATIVE TYPE)) ELSE DO (IF COMMA-P (SEND *STANDARD-OUTPUT* :STRING-OUT (IF (LOOP FOR TYP IN (CDR TYPES) ALWAYS (NLISTP (CAR TYP))) " and " ", ")) (SETQ COMMA-P T)) (FORMAT T "~\SI::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)) (FORMAT:DEFFORMAT FILE-XFORM-ARGS (: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))) (SEND *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 (SEND *STANDARD-OUTPUT* :STRING-OUT (IF (EQ (CDR FILE-LIST) OUTPUTS) " and " ", "))) (PRINC (CAR FILE-LIST)))))) (FORMAT:DEFFORMAT FILE-XFORM-TYPE (: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*)) (SEND *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 () "Implements the :PRINT-ONLY keyword of MAKE-SYSTEM. This keyword causes MAKE-SYSTEM to print what it would do but not do it." (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 ~\SI::FILE-XFORM-ARGS\" FILE-TRANSFORMATION) (FORMAT T "~&~\SI::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*))) ('ELSE (SETQ *SOMETHING-LOADED* (NCONC *SOMETHING-LOADED* (NCONS FILE-TRANSFORMATION)))))) (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) ;;Queue one transformation of a system to be done -- if it needs to be done. ;;We also take care of queueing its dependencies. ;;FORCE-DEPENDENCIES is a list of other transformations ;; to be treated as if they were dependencies of this one. ;;But the dependencies are only queued if it appears this transformation ;; really has work to do. We check that there is ;; (1) a file in this transformation that hasn't been loaded/compiled, and ;; (2) a reason to want the results of this transformation in the first place. ;;REST should be any transformations that depend on this one. (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) (APPLY 'QUEUE-ONE-TRANSFORMATION (FIND-DEPENDENCY DEPENDENCY) NIL TRANSFORMATION OTHERS)) (DOLIST (DEPENDENCY (TRANSFORMATION-DEPENDENCIES TRANSFORMATION)) (APPLY '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 (TYPE-OF 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 (TYPE-OF 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) (EVAL 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) (EVAL FILE-TYPE))) OUTPUTS (LOOP FOR FILE-TYPE IN (TRANSFORMATION-TYPE-OUTPUT-FILE-TYPES TRANSFORMATION-TYPE) COLLECT (MERGE-PATHNAME-TYPE (POP-CAREFULLY PATHNAMES) (EVAL 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 (*SYSTEM-DEFAULT-BINARY-FILE-TYPE*) 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) (*SYSTEM-DEFAULT-BINARY-FILE-TYPE*)) ;:COMPAT-COMPILE, etc., are obsolete as of system 92, but not flushed yet (DEFINE-SIMPLE-TRANSFORMATION :COMPAT-COMPILE QC-FILE-1 FILE-NEWER-THAN-FILE-P (:LISP) (*SYSTEM-DEFAULT-BINARY-FILE-TYPE*)) (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)) (DEFMACRO (:COMPAT-COMPILE-LOAD DEFSYSTEM-MACRO) (INPUT &OPTIONAL COM-DEP LOAD-DEP COM-COND LOAD-COND) `(:FASLOAD (:COMPAT-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*)) ((AND (SYMBOLP (CAR INPUT)) (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)) (DEFMACRO (:COMPAT-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 (:COMPAT-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)))) ;;;readfile-init (DEFMACRO (:READFILE-INIT DEFSYSTEM-MACRO) (INPUT ADD-DEP &OPTIONAL READ-DEP &AUX FUNCTION) (SETQ FUNCTION (LET-CLOSED ((*ADDITIONAL-DEPENDENT-MODULES* (PARSE-MODULE-COMPONENTS ADD-DEP *SYSTEM-BEING-DEFINED*))) 'READFILE-INIT-CONDITION)) `(:READFILE ,INPUT ,READ-DEP ,FUNCTION)) (DEFUN READFILE-INIT-CONDITION (SOURCE-FILE) (OR (FILE-NEWER-THAN-INSTALLED-P SOURCE-FILE) (LOCAL-DECLARE ((SPECIAL *ADDITIONAL-DEPENDENT-MODULES*)) (OTHER-FILES-NEWER-THAN-FILE-P *ADDITIONAL-DEPENDENT-MODULES* SOURCE-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)) (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)) (AND (DOLIST (PATHNAMES (GET-MODULE-PATHNAMES MODULE)) (AND (> (SYSTEM-GET-CREATION-DATE (MERGE-PATHNAME-TYPE (CADR PATHNAMES) (EVAL FILE-TYPE))) CREATION-DATE) (RETURN T))) (RETURN T)))) #| ;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)))) (DEFINE-SIMPLE-TRANSFORMATION :READ-FOR-COMPILATION ReadForCompilation ReadForCompilation? ("") () ("Read for compilation" "Reading for compilation" "read for compilation") NIL) (DEFUN ReadForCompilation? (Name &AUX (Source (FUNCALL Name ':NEW-TYPE "LISP")) (Binary (FUNCALL Name ':NEW-TYPE *SYSTEM-DEFAULT-BINARY-FILE-TYPE*))) (COND ((FILE-NEWER-THAN-FILE-P Source Binary) (FILE-NEWER-THAN-INSTALLED-P Source)) (T (FILE-NEWER-THAN-INSTALLED-P Binary)))) (DEFUN ReadForCompilation (Name &AUX (Source (FUNCALL Name ':NEW-TYPE "LISP")) (Binary (FUNCALL Name ':NEW-TYPE *SYSTEM-DEFAULT-BINARY-FILE-TYPE*))) (COND ((FILE-NEWER-THAN-FILE-P Source Binary) (READFILE-1 Source)) (T (FASLOAD-1 Binary)))) (DEFMACRO (:PROPERTY :PROGN DEFSYSTEM-MACRO) (&REST Transformations &AUX Values) (DOLIST (Transformation Transformations) (SETQ Values (MULTIPLE-VALUE-LIST (CALL-DEFSYSTEM-MACRO Transformation)))) (VALUES-LIST (LIST* NIL Values))) (DEFMACRO (:PROPERTY :READ-COMPILE-LOAD DEFSYSTEM-MACRO) (Input &OPTIONAL Read-Dependencies Compile-Dependencies Load-Dependencies Read-Condition Compile-Condition Load-Condition) `(:PROGN (:SKIP :READ-FOR-COMPILATION ,Input ,Read-Dependencies ,Read-Condition) (:FASLOAD (:COMPILE ,Input ((:READ-FOR-COMPILATION ,Input) ,@Compile-Dependencies) ,Compile-Condition) ,Load-Dependencies ,Load-Condition))) (DEFUN FASLOAD-1 (INFILE) (SETQ *SOMETHING-LOADED* T) (FASLOAD INFILE *FORCE-PACKAGE* T)) (DEFUN READFILE-1 (INFILE) (SETQ *SOMETHING-LOADED* T) (READFILE INFILE *FORCE-PACKAGE* T)) (DEFUN QC-FILE-1 (INFILE OUTFILE) (let* ((type *SYSTEM-DEFAULT-BINARY-FILE-TYPE*) (special-compiler (assq type *known-binary-file-producers*))) (if special-compiler (funcall (second special-compiler) infile outfile) (COMPILE-FILE INFILE :OUTPUT-FILE (SEND OUTFILE :NEW-VERSION NIL) :PACKAGE *FORCE-PACKAGE*))) (WHEN *WARNINGS-STREAM* (PRINT-FILE-WARNINGS INFILE *WARNINGS-STREAM*) (SEND-IF-HANDLES *WARNINGS-STREAM* :FORCE-OUTPUT) (SEND-IF-HANDLES *WARNINGS-STREAM* :FINISH))) (DEFUN LOAD-FONT-WIDTHS-1 (INFILE) (SETQ *SOMETHING-LOADED* T) (PKG-BIND *FORCE-PACKAGE* (if (fboundp 'press:load-font-widths) (PRESS:LOAD-FONT-WIDTHS INFILE NIL T)))) (DEFVAR MAKSYS-BREAKPOINT-FLAG NIL) (DEFUN FILE-NEWER-THAN-INSTALLED-P (FILE &AUX (LOADED-ID (GET-FILE-LOADED-ID FILE *FORCE-PACKAGE*))) (AND (NOT *JUST-ACCUMULATING-FILES*) MAKSYS-BREAKPOINT-FLAG LOADED-ID (NOT (EQUAL LOADED-ID (SYSTEM-GET-FILE-INFO FILE))) (ERROR "TESTING MAKSYS")) (IF LOADED-ID (NOT (EQUAL LOADED-ID (SYSTEM-GET-FILE-INFO FILE))) T)) ;;; 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) (IF (PROBEF FILE-2) (> (SYSTEM-GET-CREATION-DATE FILE-1) (SYSTEM-GET-CREATION-DATE FILE-2 T)) 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-CREATION-DATE (FILE &OPTIONAL NO-ERROR-P) (LET ((PLIST (SYSTEM-GET-FILE-PROPERTY-LIST FILE))) (COND ((GET PLIST :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) (do ((info (assq file *interesting-files-info*) (assq file *interesting-files-info*)) (first-time t (setq first-time nil))) (info info) (cond (*just-accumulating-files* (push file *interesting-files*) (return nil))) (cond ((null first-time) (cerror "Look again for the file." "File ~A not found." file))) ;;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)) (let ((plists (FS:MULTIPLE-FILE-PLISTS *INTERESTING-FILES*)) still-interesting-files) ;;remember any files that weren't found (setq plists (loop for plist in plists when (null (cdr plist)) do (push (car plist) still-interesting-files) else collect plist)) (SETQ *INTERESTING-FILES-INFO* (NCONC plists *INTERESTING-FILES-INFO*) *INTERESTING-FILES* still-interesting-files)) )) (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) (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 ~;~*~]~\SI::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 (SEND 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) (SEND *STANDARD-OUTPUT* :FRESH-LINE) (SETQ LIST (FS:DIRECTORY-LIST (SEND FILE :NEW-PATHNAME :TYPE :WILD :VERSION :WILD) :SORTED)) (SETQ LIST (DELQ (ASSQ NIL LIST) LIST)) (DOLIST (FILE LIST) (FORMAT T "~&~A~15T~D ~D(~D)~30T" (SEND (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 (SEND FILE :NEW-VERSION :OLDEST) (SEND 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 (OR (CDR (GET-FILE-LOADED-ID (FIRST (FILE-TRANSFORMATION-ARGS FILE-TRANSFORMATION)) *FORCE-PACKAGE*)) -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 (SEND INPUT :GENERIC-PATHNAME)) (LIST (CDR (ASSQ GENERIC-PATHNAME DIRECTORY-LIST))) (PATHNAME (SEND INPUT :NEW-VERSION :OLDEST))) (DOLIST (FILE LIST) (LET ((FILENAME (CAR FILE))) (AND (MEMBER (SEND FILENAME :CANONICAL-TYPE) '(:LISP NIL :UNSPECIFIC)) (< (GET FILE :CREATION-DATE) DATE) (SETQ PATHNAME FILENAME)))) (AND (NOT (MEMQ (SEND INPUT :CANONICAL-TYPE) '(:LISP NIL :UNSPECIFIC))) (MEMQ (SEND (CAAR LIST) :CANONICAL-TYPE) '(:LISP NIL :UNSPECIFIC)) (SETQ INPUT (CAAR LIST))) (VALUES PATHNAME (SEND INPUT :NEW-VERSION :NEWEST)))) ;;; For things like M-X Select System as Tags Table (DEFUN ALL-SYSTEMS-NAME-ALIST () "Return an alist of all system names and system objects." (LOOP FOR SYSTEM IN *SYSTEMS-LIST* NCONC (CONS (CONS (STRING (IF (TYPEP SYSTEM 'SYSTEM) (SYSTEM-NAME SYSTEM) SYSTEM)) SYSTEM) (MAPCAR #'(LAMBDA (NICKNAME) (CONS NICKNAME SYSTEM)) (IF (TYPEP SYSTEM 'SYSTEM) (SYSTEM-NICKNAMES SYSTEM)))))) (DEFVAR *SOURCE-FILE-TYPES* '(:LISP)) (DEFUN SYSTEM-SOURCE-FILES (SYSTEM &OPTIONAL (TYPES *SOURCE-FILE-TYPES*) INTERMEDIATE-TOO (INCLUDE-SUBSYSTEMS T)) "Return the list of all source file pathnames of SYSTEM which have types in TYPES. TYPES defaults to SI:*SOURCE-FILE-TYPES*, initially (:LISP). TYPES can also be :ALL, meaning don't filter by filetype. INTERMEDIATE-TOO says whether to count files produced from others but then used as sources to make yet more files. INCLUDE-SUBSYSTEMS (default T) says whether to include source files of subsystems of this one." (SI:ELIMINATE-DUPLICATES (SYSTEM-SOURCE-FILES-1 SYSTEM TYPES INTERMEDIATE-TOO INCLUDE-SUBSYSTEMS))) (DEFUN SYSTEM-SOURCE-FILES-1 (SYSTEM TYPES INTERMEDIATE-TOO INCLUDE-SUBSYSTEMS &AUX *SYSTEM-DEFAULT-BINARY-FILE-TYPE*) (SETQ SYSTEM (FIND-SYSTEM-NAMED SYSTEM)) (SETQ *SYSTEM-DEFAULT-BINARY-FILE-TYPE* (system-default-binary-file-type system)) (NCONC (LET ((SYMBOL (SYSTEM-SYMBOLIC-NAME SYSTEM))) (AND SYMBOL (LET ((FILE (GET-SOURCE-FILE-NAME SYMBOL 'DEFSYSTEM))) (AND FILE (LET ((DEFINING-SYSTEM (SEND FILE :GET 'MAYBE-RELOAD-SYSTEM))) (AND DEFINING-SYSTEM (SYSTEM-SOURCE-FILES-1 DEFINING-SYSTEM TYPES INTERMEDIATE-TOO INCLUDE-SUBSYSTEMS))) )))) ;; First get inputs that come from files in modules ;; We get them from transformations, but the order we consider ;; the transformations is the order the modules were specified. (LET ((*FORCE-PACKAGE* (SYSTEM-PACKAGE-DEFAULT SYSTEM))) (LOOP FOR MODULE IN (REVERSE (SYSTEM-MODULES SYSTEM)) NCONC (LOOP FOR TRANSFORMATION IN (SYSTEM-TRANSFORMATIONS SYSTEM) WHEN (EQ (TRANSFORMATION-INPUT TRANSFORMATION) MODULE) NCONC (TRANSFORMATION-SOURCE-FILES TRANSFORMATION TYPES NIL)))) ;; Now get intermediate source files if wanted. ;; Those are files that are "sources" for some transformations ;; but are produced by others rather than specified in modules. (AND INTERMEDIATE-TOO (LET ((*FORCE-PACKAGE* (SYSTEM-PACKAGE-DEFAULT SYSTEM))) (LOOP FOR TRANSFORMATION IN (SYSTEM-TRANSFORMATIONS SYSTEM) WHEN (NOT (TYPEP (TRANSFORMATION-INPUT TRANSFORMATION) 'MODULE)) NCONC (TRANSFORMATION-SOURCE-FILES TRANSFORMATION TYPES T)))) (AND INCLUDE-SUBSYSTEMS (LOOP FOR SUBSYS IN (SYSTEM-COMPONENT-SYSTEMS SYSTEM) NCONC (SYSTEM-SOURCE-FILES-1 SUBSYS TYPES INTERMEDIATE-TOO INCLUDE-SUBSYSTEMS))))) (DEFUN TRANSFORMATION-SOURCE-FILES (TRANSFORMATION TYPES INTERMEDIATE-TOO) (LET* ((INPUT (TRANSFORMATION-INPUT TRANSFORMATION)) (TRANSFORMATION-TYPE (TRANSFORMATION-TRANSFORMATION-TYPE TRANSFORMATION)) (FILE-TYPES (TRANSFORMATION-TYPE-INPUT-FILE-TYPES TRANSFORMATION-TYPE)) (*FORCE-PACKAGE* NIL) (*TRANSFORMATION-OUTPUTS* NIL)) (AND FILE-TYPES (OR INTERMEDIATE-TOO (TYPEP INPUT 'MODULE)) (LET ((PATHNAME-LIST (SELECTQ (TYPE-OF INPUT) (MODULE (GET-MODULE-PATHNAMES INPUT)) (TRANSFORMATION (GET-TRANSFORMATION-PATHNAMES INPUT)) (OTHERWISE (FERROR NIL "~S is not a valid transformation input" INPUT))))) (LOOP FOR PATHNAME IN PATHNAME-LIST AS PKG = (POP PATHNAME) NCONC (LOOP FOR FILE-TYPE IN FILE-TYPES AS PATH = (POP-CAREFULLY PATHNAME) AS REAL-TYPE = (EVAL FILE-TYPE) WHEN (OR (EQ TYPES :ALL) (MEMBER REAL-TYPE TYPES)) COLLECT (MERGE-PATHNAME-TYPE PATH REAL-TYPE))))))) ;;; Automatical system declaration hackery (DEFUN SET-SYSTEM-SOURCE-FILE (SYSTEM-NAME SOURCE-FILE) "Record what file contains the DEFSYSTEM for SYSTEM-NAME. If a MAKE-SYSTEM is done on that system, the source file will be loaded automatically." (IF (STRINGP SYSTEM-NAME) (SETQ SYSTEM-NAME (INTERN (STRING-UPCASE SYSTEM-NAME) PKG-KEYWORD-PACKAGE))) (LET ((FDEFINE-FILE-PATHNAME (SEND (FS:MERGE-PATHNAME-DEFAULTS SOURCE-FILE) :GENERIC-PATHNAME))) (RECORD-SOURCE-FILE-NAME SYSTEM-NAME 'DEFSYSTEM) (OR (FIND-SYSTEM-NAMED SYSTEM-NAME T T) (ADD-SYSTEM SYSTEM-NAME)))) ;;; 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 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 (SEND 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) (let ((*standard-output* *query-io*)) (MAYBE-RELOAD-FILE FILE KEYWORDS)))) (DEFUN MAYBE-RELOAD-FILE (FILE KEYWORDS &AUX SYSTEM) (OR (SETQ SYSTEM (SEND FILE :GET 'MAYBE-RELOAD-SYSTEM)) (LET* ((LISP (SEND FILE :SOURCE-PATHNAME)) (QFASL (SEND 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. ;** this doesnt really win with new GENERIC-PATHNAME scheme. ; should be fixed by adding mode of loading to :FILE-ID-PACKAGE-ALIST element, ; I guess. Seems pretty random anyway. (COMPILED (COND ((SEND QFASL :GET :FILE-ID-PACKAGE-ALIST) T) ((SEND 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)))) T NIL) (SEND FILE :PUTPROP SYSTEM 'MAYBE-RELOAD-SYSTEM))) (APPLY 'MAKE-SYSTEM SYSTEM (NCONC (LOOP FOR KEY IN KEYWORDS WHEN (memq KEY '(:BATCH :DEFAULTED-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) "Returns the specified patch directory of the system object SYSTEM." `(GETF (SYSTEM-PLIST ,SYSTEM) :PATCH-DIRECTORY)) (DEFMACRO SYSTEM-PATCHABLE-P (SYSTEM) "T if SYSTEM (a system object) is a patchable system." `(NOT (NULL (SYSTEM-PATCH-DIRECTORY ,SYSTEM)))) (DEFUN SYSTEM-PATCHABLE-SUPERSYSTEM (SYSTEM-NAME-OR-SYSTEM) "Return the patchable system which is a supersystem of SYSTEM-NAME-OR-SYSTEM. SYSTEM is used as the value only as a last resort. The value is a system object, not a name." (LET ((SYSTEM (FIND-SYSTEM-NAMED SYSTEM-NAME-OR-SYSTEM)) (SYSTEM-SYSTEM (FIND-SYSTEM-NAMED 'SYSTEM))) ;;if we're a patchable system, just return us (IF (SYSTEM-PATCHABLE-P SYSTEM) SYSTEM (OR (DOLIST (SYS *SYSTEMS-LIST*) (LET ((MAYBE-SUPERIOR (FIND-SYSTEM-NAMED SYS T T))) ;;don't consider the SYSTEM system, because there may be a smaller ;;enclosing system. (IF (AND MAYBE-SUPERIOR (NEQ MAYBE-SUPERIOR SYSTEM-SYSTEM) (SYSTEM-SUBSYSTEM-P SYSTEM MAYBE-SUPERIOR)) ;;if we're a subsystem of this one, get it if it's patchable, ;;or its patchable superior if not. (LET ((PATCHABLE (SYSTEM-PATCHABLE-SUPERSYSTEM MAYBE-SUPERIOR))) (IF (NEQ PATCHABLE SYSTEM-SYSTEM) (RETURN PATCHABLE)))))) SYSTEM-SYSTEM)))) (DEFSTRUCT (PATCH-DIRECTORY :LIST :CONC-NAME (:ALTERANT NIL)) 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 DIRECTORY (FS:MERGE-PATHNAME-DEFAULTS DIRECTORY *SYSTEM-PATHNAME-DEFAULT*) (OR DEFAULT (FERROR NIL "Patch directory pathname not specified in patchable DEFSYSTEM")))) (SETQ DIRECTORY (SEND DIRECTORY :NEW-PATHNAME :NAME :UNSPECIFIC :TYPE :UNSPECIFIC :VERSION :UNSPECIFIC)) (SETQ PATCH-DIRECTORY (MAKE-PATCH-DIRECTORY PATHNAME DIRECTORY SAME-DIRECTORY-P (AND *SYSTEM-PATHNAME-DEFAULT-SPECIFIED* (OR PATCH-ATOM (AND (EQUAL (SEND DIRECTORY :HOST) (SEND DEFAULT :HOST)) (EQUAL (SEND DIRECTORY :DEVICE) (SEND DEFAULT :DEVICE)) (EQUAL (SEND DIRECTORY :DIRECTORY) (SEND 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) "Return the pathname to use for the system NAME, for purpose TYPE. TYPE can be :SYSTEM-DIRECTORY, with no args, or :VERSION-DIRECTORY, with the major version number as arg, or :PATCH-FILE, with major and minor version numbers and filetype as three args." (OR (SETQ PATCH-DIRECTORY (SYSTEM-PATCH-DIRECTORY (FIND-SYSTEM-NAMED NAME))) (FERROR NIL "System ~A not patchable" NAME)) (LEXPR-SEND (PATCH-DIRECTORY-PATHNAME PATCH-DIRECTORY) :PATCH-FILE-PATHNAME (STRING-UPCASE 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))) (WHEN *LOAD-PATCHES* (IF *SILENT-P* (LOAD-PATCHES :SYSTEMS (LIST (SYSTEM-NAME *SYSTEM-BEING-MADE*)) :SILENT) (IF (EQ *QUERY-TYPE* :SELECTIVE) (LOAD-PATCHES :SYSTEMS (LIST (SYSTEM-NAME *SYSTEM-BEING-MADE*))) (LOAD-PATCHES :SYSTEMS (LIST (SYSTEM-NAME *SYSTEM-BEING-MADE*)) :NOSELECTIVE))))) (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) () (SETF (GETF (SYSTEM-PLIST *SYSTEM-BEING-DEFINED*) ':NOT-IN-DISK-LABEL) T) NIL) (DEFUN SYSTEM-SHOULD-NOT-APPEAR-IN-DISK-LABEL (SYSTEM) (GETF (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) "Compile all the files in ALIST that aren't compiled or have changed. Each element of ALIST is a list whose car is a filename string. DONT-ASK-INDIVIDUALY says whether to refrain from asking about each file. DONT-CARE-IF-LOADED-P says whether to recompile unchanged files. DONT-ASK-FOR-CONFIRMATION says whether to refrain from asking for one final confirmation. PACKAGE-SPEC is the package to load into." (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) "Load all the files in ALIST that aren't loaded or have changed. Each element of ALIST is a list whose car is a filename string. DONT-ASK-INDIVIDUALY says whether to refrain from asking about each file. DONT-CARE-IF-LOADED-P says whether to reload unchanged files. DONT-ASK-FOR-CONFIRMATION says whether to refrain from asking for one final confirmation. PKG is the package to load into." (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 LOAD-FILE-LIST (FILE-LIST &OPTIONAL KEYLIST &AUX SYSTEM) "Load all the files in FILE-LIST that aren't loaded or have changed. Each element of FILE-LIST is a list containing a filename string. KEYLIST is a MAKE-SYSTEM keyword or a list of such, or NIL for none." (AND KEYLIST (NLISTP KEYLIST) (SETQ KEYLIST (LIST KEYLIST))) (SETQ SYSTEM (FIND-SYSTEM-FROM-FILE-LIST FILE-LIST)) (APPLY #'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 (EQ (SEND FILE :CANONICAL-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 (SEND 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 NET:GENERATE-FROM-HOSTS2-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) (DEFINE-SIMPLE-TRANSFORMATION LOAD-SITE-FILE LOAD-SITE-FILE-1 FILE-NEWER-THAN-INSTALLED-P (:QFASL) NIL ("Load site files because of changes in" "Loading site files on account of" "loaded") NIL) (DEFUN LOAD-SITE-FILE-1 (&REST IGNORE) (SETQ *SOMETHING-LOADED* T) (PUSH* '(UPDATE-SITE-CONFIGURATION-INFO) *MAKE-SYSTEM-FORMS-TO-BE-EVALED-AFTER*)) (DEFUN DESCRIBE-SYSTEM (SYSTEM-NAME &KEY (SHOW-FILES T) (SHOW-TRANSFORMATIONS T) &AUX SYSTEM) "Print all about the system named SYSTEM-NAME. SHOW-FILES is T to give the history of each file in the system, NIL not to, or :ASK meaning query the user whether to. SHOW-TRANSFORMATIONS is similar, for whether to show the transformations which MAKE-SYSTEM would execute. Note that calling DESCRIBE on a system-object prints somewhat lower level information." (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)) (LET* ((SYSTEM-SOURCE-FILE (GET-SOURCE-FILE-NAME (SYSTEM-SYMBOLIC-NAME SYSTEM) 'DEFSYSTEM)) (*FORCE-PACKAGE* (PKG-FIND-PACKAGE (OR (AND SYSTEM-SOURCE-FILE (GET SYSTEM-SOURCE-FILE ':PACKAGE)) "USER")))) (WHEN SYSTEM-SOURCE-FILE (FORMAT T "~&System ~A~@[ is defined in file ~A~]~%" SYSTEM-NAME SYSTEM-SOURCE-FILE) (DESCRIBE-FILE-TRANSFORMATION-COMPILED-FILE SYSTEM-SOURCE-FILE) (DESCRIBE-FILE-TRANSFORMATION-LOADED-FILE SYSTEM-SOURCE-FILE))) (COND ((SYSTEM-PATCHABLE-P SYSTEM) (FORMAT T "~&~%~A is patchable" SYSTEM-NAME) (MULTIPLE-VALUE-BIND (MAJOR MINOR STATUS) (GET-SYSTEM-VERSION SYSTEM) (LET ((STATUS-NAME (OR (SECOND (ASSQ STATUS SYSTEM-STATUS-ALIST)) STATUS))) (OR (EQUAL STATUS-NAME "") (FORMAT T ", ~A" STATUS-NAME))) (IF MAJOR (FORMAT T ", ~D.~D is loaded" MAJOR MINOR)) (FORMAT T ";~% a typical patch file is ~A~%" (PATCH-SYSTEM-PATHNAME SYSTEM-NAME ':PATCH-FILE (OR MAJOR 1) (OR MINOR 0) ':LISP)) (AND MAJOR (FQUERY NIL "Do you want to see the patches for ~A? " SYSTEM-NAME) (PRINT-PATCHES SYSTEM))))) (IF (SYSTEM-PACKAGE-DEFAULT SYSTEM) (FORMAT T "~& Files in ~A are forcibly read in package ~A.~%" SYSTEM-NAME (SYSTEM-PACKAGE-DEFAULT SYSTEM))) (WHEN SHOW-FILES (FORMAT T "~%Compilation and loading of files in this system:~2%") (MAKE-SYSTEM SYSTEM-NAME ':COMPILE ':RELOAD ':DO-NOT-DO-COMPONENTS ':DESCRIBE ':NO-INCREMENT-PATCH ':NO-RELOAD-SYSTEM-DECLARATION)) (WHEN SHOW-TRANSFORMATIONS (FORMAT T "~%Transformations required to MAKE-SYSTEM now:~2%") (MAKE-SYSTEM SYSTEM-NAME ':COMPILE ':DO-NOT-DO-COMPONENTS ':PRINT-ONLY ':NO-RELOAD-SYSTEM-DECLARATION)) (LET ((COMPONENTS (SYSTEM-COMPONENT-SYSTEMS SYSTEM))) (COND (COMPONENTS (FORMAT T "~2&~A is made up of component system~P " SYSTEM-NAME (LENGTH COMPONENTS)) (FORMAT:PRINT-LIST T "~A" COMPONENTS) (WHEN (Y-OR-N-P "Describe the component system~P?" (LENGTH COMPONENTS)) (DOLIST (COMPONENT COMPONENTS) (FORMAT T "~2&") (DESCRIBE-SYSTEM COMPONENT ':SHOW-FILES SHOW-FILES ':SHOW-TRANSFORMATIONS SHOW-TRANSFORMATIONS))))))) 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 "~&~\SI::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 (SEND FILE :GENERIC-PATHNAME))) (SETQ SID (SEND GENERIC-PATHNAME :GET :QFASL-SOURCE-FILE-UNIQUE-ID) CDATA (SEND GENERIC-PATHNAME :GET :COMPILE-DATA))) (COND ((OR SID CDATA) (FORMAT T "~& ~A was compiled" (OR SID FILE)) (AND CDATA (APPLY 'FORMAT T " by ~A on ~A at ~\TIME\~%~10@Twith system ~D.~D~%" CDATA))))) (DEFUN SYSTEM-SUBSYSTEM-P (MAYBE-SUBSYSTEM SUPERSYSTEM) "Non-NIL if the system MAYBE-SUBSYSTEM is a subsystem of SUPERSYSTEM. The actual value is the subsystem. Both arguments may be systems or names of systems." ;;get the actual system objects for the systems. (LET* ((SUPERSYSTEM-SYSTEM (FIND-SYSTEM-NAMED SUPERSYSTEM)) (MAYBE-SUBSYSTEM (FIND-SYSTEM-NAMED MAYBE-SUBSYSTEM)) (MAYBE-SUBSYSTEM-NAME (SYSTEM-NAME MAYBE-SUBSYSTEM))) (DOLIST (SUBSYSTEM-NAME (SYSTEM-COMPONENT-SYSTEMS SUPERSYSTEM-SYSTEM)) ;;COMPONENT-SYSTEMS is a list of system names, first try seeing if the ;;name of MAYBE-SUBSYSTEM is the same as that of the system under ;;consideration. (IF (and (or (stringp subsystem-name) ;a bit of defensive programming.. (symbolp subsystem-name)) ; dont allow a wedged system somebody ; defined to wedge everything.. (OR (EQUALP SUBSYSTEM-NAME MAYBE-SUBSYSTEM-NAME)) (EQ (FIND-SYSTEM-NAMED SUBSYSTEM-NAME) MAYBE-SUBSYSTEM)) (RETURN MAYBE-SUBSYSTEM))))) (DEFUN TRANSFORMATIONS-THAT-COMPILE (TRANSFORMATIONS) ;; THIS IS USEFUL: ;; (TRANSFORMATIONS-THAT-COMPILE (MAKE-SYSTEM'FOO :RECOMPILE :PRINT-ONLY :SILENT)) ;; (MAPCAN #'(LAMBDA (TRANSFORMATION) (WHEN (EQ (CAR (FILE-TRANSFORMATION-TRANSFORMATION-TYPE TRANSFORMATION)) :COMPILE) (LIST (FILE-TRANSFORMATION-ARGS TRANSFORMATION)))) TRANSFORMATIONS))