;;; -*- Mode:Common-Lisp; Package:SYSTEM; Patch-file:T; Base:10; Fonts:(CPTFONT HL12B CPTFONTI) -*- ;1;;********************************************************************************** ;1;; Defsystem Macros to support each option* ;1;;********************************************************************************** ;1;;2 *Documentation -- used in the mouse line for the System Menu and* ;1;; in SYSTEM-†.* (DEFMACRO (:PROPERTY :DOCUMENTATION DEFSYSTEM-MACRO) (DOC-STRING) (WHEN (TYPEP DOC-STRING 'STRING) (SETF (GETF (SYSTEM-PLIST *SYSTEM-BEING-DEFINED*) :DOCUMENTATION) DOC-STRING)) NIL) ;1;; Default Menu Column -- the column in the System Menu in which this* ;1;; system should appear by default.* (DEFMACRO (:PROPERTY :DEFAULT-MENU-COLUMN DEFSYSTEM-MACRO) (COLUMN) (WHEN (MEMBER COLUMN '(:PROGRAMS :USER-AIDS :DEBUG :NONE)) (SETF (GETF (SYSTEM-PLIST *SYSTEM-BEING-DEFINED*) :DEFAULT-MENU-COLUMN) COLUMN)) NIL) ;1;; Default Menu Key -- the SYSTEM- that should access this system* ;1;; by default.* (DEFMACRO (:PROPERTY :DEFAULT-SYSTEM-KEY DEFSYSTEM-MACRO) (KEY) (WHEN (TYPEP KEY 'CHARACTER) (SETF (GETF (SYSTEM-PLIST *SYSTEM-BEING-DEFINED*) :DEFAULT-SYSTEM-KEY) (SET-CHAR-BIT KEY :CONTROL NIL))) NIL) ;1;; Type -- the type of facility this system uses to be launced. It could* ;1;; be a Flavor, Window, or form to be Evaluated.* (DEFMACRO (:PROPERTY :INSTANCE-TYPE DEFSYSTEM-MACRO) (LAUNCH-TYPE) (WHEN (MEMBER LAUNCH-TYPE '(:EVAL :WINDOW :FLAVOR)) (SETF (GETF (SYSTEM-PLIST *SYSTEM-BEING-DEFINED*) :INSTANCE-TYPE) LAUNCH-TYPE)) NIL) ;1;; Finder -- how to find an instance of this system.* (DEFMACRO (:PROPERTY :INSTANCE-FINDER DEFSYSTEM-MACRO) (FORM) (WHEN FORM (SETF (GETF (SYSTEM-PLIST *SYSTEM-BEING-DEFINED*) :INSTANCE-FINDER) FORM)) NIL) ;1;; Creator -- how to create a new instance of this system.* (DEFMACRO (:PROPERTY :INSTANCE-CREATOR DEFSYSTEM-MACRO) (FORM) (WHEN FORM (SETF (GETF (SYSTEM-PLIST *SYSTEM-BEING-DEFINED*) :INSTANCE-CREATOR) FORM)) NIL) ;1;;Defsystem functions* (DEFMACRO DEFSYSTEM (NAME &BODY OPTIONS) "2Define a system, a bunch of files and how to compile or load them. Options: :name - The pretty name for the system. Defaults to the name in Defsystem call. :short-name - A shorter name, for the disk label etc. :nicknames - List of other names you want this system to be known by. :documentation - A string displayed in mouse-documentation of System Menu and in ;;;BMK help screen for System Keys. ;;;BMK :default-menu-column - The column in which this system should appear if made accessible. ;;;BMK One of :USER-AIDS, :PROGRAMS, :DEBUG*, or :NONE2. ;;;BMK :default-system-key - If made accessible, what System Key should access it. ;;;BMK :output-version - How to create output file. :same, :newest, :higher, :ask-same, :ask-higher. If not specified, defaults to compiler:*output-version-behavior*. :component-systems - List of other systems to be included in this system. :package - Package to do the transformations in, overiding the -*- line in the file being transformed. :pathname-default - Default directory. So you don't have to specify the directory on each module. :default-output-directory - Alternate directory for binary files. Applies to compiler output and fasloads. This is over-ridden by alternate pathnames specified in a module specification. :warnings-pathname-default - Pathname for compiler warnings when using make-system :defaulted-batch option. :patchable - Makes the system patchable. Optional pathname indicates where the patch files are put. :initial-status - What to set the status to when a major version is made. This defaults to :experimental. :not-in-disk-label - If the system is patchable this keeps it out of the disk label. :compile-defsystem - Maintains your defsystem compiled. Defaults to read the most recent definition :module - Assigns a name to a list of files. Accepts file names or other* 2module names. Also handles a :package option. - see manual. Instance Access Options: :instance-type - How system is launched: :FLAVOR, :WINDOW, :EVAL, or *NIL2. ;;;BMK :instance-finder - How an old instance of the system is found. ;;;BMK :instance-creator - How a new instance of the system is created. ;;;BMK If :instance-type is :EVAL, :instance-finder should be a form to evaluate that will find an instance of the system; :instance-creator should be a form to evaluate that will create a new instance of the system, NIL to indicate a new instance cannot be created, or T to indicate that :instance-finder should be used. If :instance-type is :WINDOW, :instance-finder should be a window or a form that returns a window; :instance-creator should be a window, a form that returns a window, NIL to indicate a new instance of the system cannot be created, or T to indicate that :instance-finder should be used. If :instance-type is :FLAVOR, :instance-finder should be a window flavor; :instance-creator should be a window flavor, NIL to indicate that a new instance of the system cannot be created, T to indicate that :instance- finder should be used, or a form to evaluate that will create a new instance of the system. Simple transformations: Format - (transformation modules &optional dependent-translations condition-function) :auxiliary - Calls probe to verify the existence of a file. :readfile - Calls readfile for lisp source files. Condition defaults to sys:file-newer-than-installed-p. :compile - Calls compile-file for lisp source files. Condition defaults to sys:file-newer-than-file-p. :fasload - Calls fasload to load object files. Condition defaults to sys:file-newer-than-installed-p. Special simple transformation: Format - (:do-components dependencies) :do-components - causes the dependencies to be done before anything in component systems. Complex transformations: :compile-load - Equivalent to (:fasload (:compile ...)..) . Syntax: (:compile-load module &optional (compile-dependencies)* 2(load-dependencies)* 2compile-condition* 2load-condition) :compile-load-init - Compiles module if it or any of OTHER-MODULES source files have changed. Syntax - (:compile-load-init module (other modules)* 2 &optional (compile dep)* 2 (load dep) Sample Defsystem: (DEFSYSTEM my-system* 2 (:short-name \"foo-sys\")* 2 (:pathname-default \"foo:bar;\")* 2 (:module module-a \"font.bin\")* 2 (:module module-b (\"file1\" \"file2\" ... ))* 2 (:fasload modula-a)* 2 (:compile-load module-b (:fasload module-a)) )*" (LET ((namesymbol (force-to-keyword-symbol name))) `(DEFSYSTEM-1 ',namesymbol ',(COPY-LIST OPTIONS)))) (DEFUN DEFSYSTEM-1 (NAME OPTIONS &OPTIONAL (ADD-P T) DONT-RECORD-IN-PATHNAMES &AUX PLIST) (AND (RECORD-SOURCE-FILE-NAME NAME 'DEFSYSTEM) (PROGW *DEFSYSTEM-SPECIAL-VARIABLES* (SETQ *SYSTEM-BEING-DEFINED* (CONSTRUCT-SYSTEM-INTERNAL)) ;1get new system object* (SETF (SYSTEM-SYMBOLIC-NAME *SYSTEM-BEING-DEFINED*) NAME);1 and init it's name* (SETF (SYSTEM-NAME *SYSTEM-BEING-DEFINED*) (STRING NAME)) 1 *;;1process the defsystem options* (DOLIST (OPTION OPTIONS) (CALL-DEFSYSTEM-MACRO OPTION)) 1;; Put in the components if they weren't mentioned explicitly* 1 * (AND (SYSTEM-COMPONENT-SYSTEMS *SYSTEM-BEING-DEFINED*) (NOT *COMPONENTS-ALREADY-DONE*) (CALL-DEFSYSTEM-MACRO '(DO-COMPONENTS-INTERNAL NIL))) 1;; Put any patching transformations at the end* 1 * (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*)) ;1; Check for sanity* (SETQ PLIST (SYSTEM-PLIST *SYSTEM-BEING-DEFINED*)) (WHEN (AND ;1;; *(NULL *SILENT-P*) ;1;; *(NULL *WARNINGS-STREAM*) (OR (GETF PLIST :INSTANCE-TYPE) (GETF PLIST :INSTANCE-FINDER) (GETF PLIST :INSTANCE-CREATOR) (GETF PLIST :DEFAULT-SYSTEM-KEY) (GETF PLIST :DEFAULT-MENU-COLUMN))) (UNLESS (GETF PLIST :INSTANCE-TYPE) (WARN "Warning: system access information incomplete.~%~ :INSTANCE-TYPE should be defined.")) (UNLESS (GETF PLIST :INSTANCE-FINDER) (WARN "Warning: system access information incomplete.~%~ :INSTANCE-FINDER should be defined.") (SETF (GETF PLIST :INSTANCE-TYPE) NIL)) (UNLESS (GETF PLIST :DOCUMENTATION) (WARN "Warning: system access information incomplete.~%~ :DOCUMENTATION should be defined.") (SETF (GETF PLIST :INSTANCE-TYPE) NIL))) )) NAME) ;1;;******************************************************************************************* ;1;; Make-System* ;1;;******************************************************************************************* (DEFUN MAKE-SYSTEM (SYSTEM &REST KEYWORDS &AUX *SOMETHING-LOADED*) "2Operate 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 that have been changed since last make-system. '(:COMPILE :compiler-keyword1 value1 :compiler-keyword2 value2 ...) - pass these options to the compiler. :RECOMPILE - recompile and reload all files for this system. '(:RECOMPILE :compiler-keyword1 value1 :compiler-keyword2 value2 ...) - pass these options to the compiler. :NOLOAD - don't load compiled files. :RELOAD - load even files already loaded. :SELECTIVE - ask user about each file individually. :NOCONFIRM - do not ask for confirmation of make-system files. :NOWARN - do not prompt for ANY confirmations, including loader redefinition* 2 warnings. :SILENT - don't print lists of files or loader warnings on the terminal 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. :BATCH - write a file containing any warnings produced by compilation. Just load the file, as lisp code, to reload the warnings. :DEFAULTED-BATCH - like :BATCH except warnings file is defaulted instead of asked for. :DO-NOT-DO-COMPONENTS - do not include systems defined by :component-systems. :RECORD - record the file version numbers for the current system (:VERSION [num]) - remake an old major version of a system if that previous system was recorded via the :RECORD option. :SAFE - in determining source later than object, go by the creation date. The default depends on :OUTPUT-VERSION from the DEFSYSTEM :NOOP - this option is ignored.*" ;1*********************** (PROGW *MAKE-SYSTEM-SPECIAL-VARIABLES* (UNWIND-PROTECT (CATCH 'EXIT-MAKE-SYSTEM (SETQ KEYWORDS (COPY-LIST KEYWORDS)) ;1get copy of &rest arg to be safe* (FIND-SYSTEM-NAMED SYSTEM NIL NIL KEYWORDS) ;1be sure the defsystem is loaded* (MAYBE-RELOAD-SYSTEM-DECLARATION SYSTEM KEYWORDS) ;1 and that it is current* ;1;initialize some make-system-special-variables* ;1get the real system, in case new one loaded* (SETQ *SYSTEM-BEING-MADE* (FIND-SYSTEM-NAMED SYSTEM t t KEYWORDS)) (SETQ *SYSTEM-DEFAULT-BINARY-FILE-TYPE* (OR (GETF (SYSTEM-PLIST *SYSTEM-BEING-MADE*) 'DEFAULT-BINARY-FILE-TYPE) (LOCAL-BINARY-FILE-TYPE))) (SETQ *TOP-LEVEL-TRANSFORMATIONS* `(,@*LOAD-TYPE-TRANSFORMATIONS* DO-COMPONENTS-INTERNAL)) ;1; Do all the keywords* 1 * (DO-THE-KEYWORDS KEYWORDS) (SETUP-FOR-OUTPUT-VERSION) ;1;If we are doing an old version (via :VERSION keyword), get all that setup* (AND *USE-OLD-VERSION* (DO-VERSION-KEYWORD)) ;1; Make :NO-INCREMENT-PATCH override :COMPILE even if :COMPILE comes later.* (WHEN *NO-INCREMENT-PATCH* (SETQ *TOP-LEVEL-TRANSFORMATIONS* (DELETE-IF #'(LAMBDA (X) (MEMBER X '(INCREMENT-COMPILED-VERSION) :TEST #'EQ)) *TOP-LEVEL-TRANSFORMATIONS*))) ;1; If this is a patchable system, let's be sure the patch files are * ;1; around now instead of waiting for all the other transformations to* ;1; finish before finding this out. This isn't necessary, but it is a* ;1; convience for the user to know of this situation early.* ;1 (AND (SYSTEM-PATCHABLE-P *SYSTEM-BEING-MADE*) ;all we care about is the side effect* ;1 (PATCH-VERSION-NEWER-THAN-LOADED)) ;of insuring the patch directories are* ;1 out there* ;1; Process forms with compiler context* 1 * (DOLIST (FORM *MAKE-SYSTEM-FORMS-TO-BE-EVALED-BEFORE*) (eval form)) (IF (FBOUNDP 'COMPILER:COMPILER-WARNINGS-CONTEXT-BIND) (COMPILER:COMPILER-WARNINGS-CONTEXT-BIND (PERFORM-TRANSFORMATIONS (COLLECT-TOP-LEVEL-TRANSFORMATIONS *SYSTEM-BEING-MADE*))) ;1;Compiler isn't around. Go without it.* (PERFORM-TRANSFORMATIONS (COLLECT-TOP-LEVEL-TRANSFORMATIONS *SYSTEM-BEING-MADE*))) ;1; Finally process any forms queued by the keywords with compiler context* 1 * (DOLIST (FORM *MAKE-SYSTEM-FORMS-TO-BE-EVALED-AFTER*) (eval form)) ;1; See if any patches need to be loaded for this system.* (WHEN (AND *LOAD-PATCHES* (GET-PATCH-SYSTEM-NAMED *SYSTEM-BEING-MADE* T T) (SYSTEM-PATCHABLE-P *SYSTEM-BEING-MADE*)) (LET ((LOAD-PATCHES-ARGS NIL)) (AND *SILENT-P* (PUSH :SILENT LOAD-PATCHES-ARGS)) (AND (EQ *QUERY-TYPE* :NOCONFIRM) (PUSH :NOCONFIRM LOAD-PATCHES-ARGS)) (APPLY #'LOAD-PATCHES :SYSTEMS (LIST (SYSTEM-SYMBOLIC-NAME *SYSTEM-BEING-MADE*)) LOAD-PATCHES-ARGS))) ;1;If :RECORD option was specified, do it.* (AND *RECORD-VERSION-NUMBERS* (RECORD-SYSTEM-IN-LOG)) ;1; System has been made! Set :MADE-P flag to T ;;;;; BMK -- 8/26/87 * (SETF (GETF (SYSTEM-PLIST *SYSTEM-BEING-MADE*) :MADE-P) ;1;;;;* T) ;1;;;;* (PUSHNEW (STRING (SYSTEM-SYMBOLIC-NAME *SYSTEM-BEING-MADE*)) ;1;;;;* *MODULES*)) ;1;;;;* ;1; Now forms outside of compiler context* ;1; These are done even if there was an error.* 1 * (DOLIST (FORM *MAKE-SYSTEM-FORMS-TO-BE-EVALED-FINALLY*) (eval form))) *SOMETHING-LOADED*)) ;1;;* (DEFMACRO SYSTEM-MADE-P (SYSTEM-NAME) "2Has the system been made from the system's current DEFSYSTEM? This is generally set to T by MAKE-SYSTEM, and to NIL by DEFSYSTEM.*" `(LET ((SYSTEM (FIND-SYSTEM-NAMED ,SYSTEM-NAME T T))) (AND SYSTEM (GETF (SYSTEM-PLIST SYSTEM) :MADE-P)))) (DEFMACRO SET-SYSTEM-MADE-P (SYSTEM-NAME NEW-VALUE) "2Set the value accessed by SYS:SYSTEM-MADE-P.*" `(LET ((SYSTEM (FIND-SYSTEM-NAMED ,SYSTEM-NAME T T))) (AND SYSTEM (SETF (GETF (SYSTEM-PLIST SYSTEM) :MADE-P) ,NEW-VALUE)))) (DEFSETF SYSTEM-MADE-P (SYSTEM-NAME) (NEW-VALUE) `(SET-SYSTEM-MADE-P ,SYSTEM-NAME ,NEW-VALUE)) ;1;;* (DEFUN FIND-SYSTEM-NAMED (NAME &OPTIONAL NO-ERROR-P LOADED-ONLY (KEYWORDS '(:NOCONFIRM))) 2"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 loaded." 1 ;; LOADED-ONLY = SI:FOO used internally to mean ;; do reload system source file but don't check SYS: SITE;. ** (DECLARE (SPECIAL *SYSTEM-NAME*)) (IF (TYPEP NAME 'SYSTEM) NAME ;1passed us a system object.* (IF (EQUAL NAME 'SYSTEM) (SETQ NAME *SYSTEM-NAME*)) ;1standard system name* (OR (DOLIST (SYSTEM *SYSTEMS-LIST*) (COND ((TYPEP SYSTEM 'SYSTEM) ;1loaded system object* (AND (OR (STRING-EQUAL NAME (SYSTEM-SYMBOLIC-NAME SYSTEM)) ;1;;; BMK -- 8/26/87* (STRING-EQUAL NAME (SYSTEM-NAME SYSTEM)) (MEMBER NAME (SYSTEM-NICKNAMES SYSTEM) :TEST #'STRING-EQUAL)) (RETURN SYSTEM))) ((AND (MEMBER LOADED-ONLY '(NIL FOO) :TEST #'EQ) ;1system defined but not loaded* (STRING-EQUAL NAME SYSTEM)) ;1; System name is a symbol. Go load the real defsystem. Maybe-Reload-System-Declaration* ;1; uses some make-system variables - The progw will bind them if someone is calling this * ;1; outside of make-system itself.* (IF (BOUNDP '*SYSTEM-BEING-MADE*) (MAYBE-RELOAD-SYSTEM-DECLARATION SYSTEM KEYWORDS) ;1loads the defsystem if not current* (PROGW *MAKE-SYSTEM-SPECIAL-VARIABLES* (MAYBE-RELOAD-SYSTEM-DECLARATION SYSTEM KEYWORDS))) (LET ((RETRY (FIND-SYSTEM-NAMED NAME T T))) ;1see if system really was loaded* (IF RETRY (RETURN RETRY) (FERROR nil "~A did not contain a definition of ~A." (SEND (GET-SOURCE-FILE-NAME SYSTEM 'DEFSYSTEM) :SOURCE-PATHNAME) SYSTEM)))))) ;1;System NAME was not found in the loaded systems and it's defsystem source not available* ;1;This will attempt to load "sys:site;NAME.system" which either contains the defsystem or a pointer to it.* (LET ((PATHNAME (MAKE-PATHNAME :HOST "SYS" :DIRECTORY "SITE" :NAME (STRING NAME) :TYPE :SYSTEM :VERSION :NEWEST))) (AND (NOT LOADED-ONLY) (LOAD PATHNAME :IF-DOES-NOT-EXIST T :SET-DEFAULT-PATHNAME nil :VERBOSE T) (RETURN-FROM FIND-SYSTEM-NAMED (FIND-SYSTEM-NAMED NAME NO-ERROR-P 'FOO KEYWORDS))) (IF NO-ERROR-P nil (IF (EQUAL LOADED-ONLY 'FOO) (FERROR nil "~A did not contain a definition of ~A." PATHNAME NAME) (FERROR nil "System ~S not found" NAME))))))) ;1;; SYSTEM ACCESS INFORMATION* (DEFVAR *ACCESS-PROPERTIES* '(:DOCUMENTATION :DEFAULT-MENU-COLUMN :DEFAULT-SYSTEM-KEY :INSTANCE-TYPE :INSTANCE-FINDER :INSTANCE-CREATOR) "2A list of the defsystem properties that hold the access information concerning the system.*") (DEFUN GET-SYSTEM-ACCESS-LIST (SYSTEM-NAME &OPTIONAL (LOAD-IF-NEEDED T) &AUX SYSTEM) "2Returns a property list containing any access information available for the system named SYSTEM-NAME. If LOAD-IF-NEEDED is T and the system's DEFSYSTEM has not been loaded, this function will attempt to load it. If no system is found, the function returns NIL.*" (WHEN (SETQ SYSTEM (FIND-SYSTEM-NAMED SYSTEM-NAME T LOAD-IF-NEEDED)) (DO* ((*ACCESS-PROPERTIES* (CONS :MADE-P *ACCESS-PROPERTIES*)) (PLIST (SYSTEM-PLIST SYSTEM) (CDDR PLIST)) PROP VALUE ACCESS) ((NULL PLIST) (CONS :NAME (CONS (SYSTEM-NAME SYSTEM) ACCESS))) (SETQ PROP (CAR PLIST)) (SETQ VALUE (CADR PLIST)) (SETQ ACCESS (IF (MEMBER PROP *ACCESS-PROPERTIES*) (CONS PROP (CONS VALUE ACCESS)) ACCESS)) ))) (DEFUN SET-SYSTEM-ACCESS-LIST (SYSTEM-NAME &KEY NAME DOCUMENTATION DEFAULT-SYSTEM-KEY DEFAULT-MENU-COLUMN INSTANCE-TYPE INSTANCE-FINDER INSTANCE-CREATOR) "2Record the access information listed in the keywords on the DEFSYSTEM of the system named SYSTEM-NAME. If a system named SYSTEM-NAME is not found, one is created via DEFSYSTEM.*" (ASSERT (MEMBER INSTANCE-TYPE '(:EVAL :WINDOW :FLAVOR)) NIL ":INSTANCE-TYPE must be one of :EVAL, :WINDOW, or :FLAVOR") (LET ((SYSTEM (FIND-SYSTEM-NAMED SYSTEM-NAME T T))) (IF SYSTEM (PROGN (SETQ *SYSTEM-BEING-DEFINED* SYSTEM) (MAPCAR #'CALL-DEFSYSTEM-MACRO (PAIRLIS *ACCESS-PROPERTIES* `((,DOCUMENTATION) (,DEFAULT-MENU-COLUMN) (,DEFAULT-SYSTEM-KEY) (,INSTANCE-TYPE) (,INSTANCE-FINDER) (,INSTANCE-CREATOR)))) (SETF (SYSTEM-NAME SYSTEM) NAME)) (PROGN (EVAL `(DEFSYSTEM ,SYSTEM-NAME (:NAME ,NAME) (:DOCUMENTATION ,DOCUMENTATION) (:DEFAULT-SYSTEM-KEY ,DEFAULT-SYSTEM-KEY) (:DEFAULT-MENU-COLUMN ,DEFAULT-MENU-COLUMN) (:INSTANCE-TYPE ,INSTANCE-TYPE) (:INSTANCE-FINDER ,INSTANCE-FINDER) (:INSTANCE-CREATOR ,INSTANCE-CREATOR))) (SETF (SYSTEM-MADE-P SYSTEM-NAME) T)))))