1;;; -*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved. ;;; This file contains all of the functions for accessing and creating ;;; initialization lists and the initial definitions for the system-defined ;;; initialization lists.* ;;; 04/11/89 jlm Changed (PUTPROP ... to (SETF (GET ... (Defvar Before-Cold-Initialization-List :Unbound 1"Initializations to be run before doing a DISK-SAVE."*) (Defvar Cold-Initialization-List :Unbound 1"Initializations to be run on cold boot."*) (Defvar Warm-Initialization-List :Unbound 1"Initializations to be run on warm or cold boot."*) (Defvar Once-Only-Initialization-List :Unbound 1"Initializations to be run only once. They have indeed been run if they are here."*) (Defvar System-Initialization-List :Unbound 1"Initializations to be run on warm boot, before the cold and warm ones."*) (Defvar Login-Initialization-List :Unbound 1"Initializations to be run on logging in."*) (Defvar Logout-Initialization-List :Unbound 1"Initializations to be run on logging out."*) (Defvar User-Application-Initialization-List :Unbound 1"Initializations for user applications to be run on warm or cold boot."*) ;; Some code relies on INIT-NAME being the CAR of the init entry. **DO NOT CHANGE THIS** (DEFSTRUCT (INIT-LIST-ENTRY :LIST (:CONSTRUCTOR MAKE-INIT-LIST-ENTRY (NAME FORM FLAG SOURCE-FILE)) (:CONC-NAME "INIT-") (:ALTERANT NIL)) NAME FORM FLAG ;Non-NIL means init has been run. SOURCE-FILE) (DEFMACRO INIT-LIST-CHECK (name) `(PROGN (UNLESS (BOUNDP ,name) (SET ,name NIL)) (UNLESS (GET ,name 'INITIALIZATION-LIST) ;;(PUTPROP ,name T 'INITIALIZATION-LIST) ; jlm 4/11/89 (setf (get ,name 'INITIALIZATION-LIST) T)))) (DEFUN INITIALIZATIONS (list-name &OPTIONAL (redo-flag NIL) (flag T)) 1"Run the inits in the initialization list whose name is LIST-NAME. REDO-FLAG if non-NIL says rerun inits that are marked as already run. If FLAG is T, inits are marked as run; if NIL, they are marked as not already run."* (declare (special qld-mini-done)) (INIT-LIST-CHECK LIST-NAME) (DOLIST (INIT (SYMBOL-VALUE LIST-NAME)) (WHEN (OR (NULL (INIT-FLAG INIT)) REDO-FLAG) (CATCH-ERROR-RESTART ((ERROR) "Abort the ~A initialization." (INIT-NAME INIT)) (if (and (boundp '*standard-output*) (boundp '*terminal-io*) (not qld-mini-done) ) (print INIT)) (*EVAL (INIT-FORM INIT))) (SETF (INIT-FLAG INIT) FLAG)))) 1;;; Adds a new init to the list. ;;; Keywords are: ;;; NOW* 1 Run the init now ;;; FIRST* 1 Run the init now if this is the first entry for the specified name ;;; NORMAL* 1 Do the "normal" thing (init when initializations normally run) ;;; REDO* 1 Do nothing now, but set up things so init gets redone ;;; COLD Use the cold boot list ;;; WARM* 1 Use the warm boot list ;;; USER-APPLICATION Use the user application list ;;; ONCE* 1 Use the once-only list ;;; SYSTEM* 1 Use the system list ;;; BEFORE-COLD* 1 The list that gets done before disk-save'ing out ;;; LOGIN Use the login list ;;; LOGOUT Use the logout list ;;; SITE* 1 Use the site list (also run once) ;;; SITE-OPTION Use the site-option list (also run once) ;;; HEAD-OF-LIST If entry not presently on list, add it to front instead of the end of list. ;;; If neither WARM nor COLD are specified, warm is assumed. If a fourth argument ;;; is given, then it is the list to use. WARM and COLD will override the fourth argument.* (Defvar Initialization-Keywords '((Site Site-Initialization-List) (Site-Option Site-Option-Initialization-List) (System System-Initialization-List First) (Full-Gc Full-Gc-Initialization-List) (After-Full-Gc After-Full-Gc-Initialization-List) (After-Flip After-Flip-Initialization-List) (Once Once-Only-Initialization-List First) (Login Login-Initialization-List) (Logout Logout-Initialization-List) (User-Application User-Application-Initialization-List) (Warm Warm-Initialization-List) (Cold Cold-Initialization-List) (Before-Cold Before-Cold-Initialization-List) ) 1"Alist defining keywords accepted by ADD-INITIALIZATION. Each element looks like (KEYWORD LIST-VARIABLE-NAME [TIME-TO-RUN]) TIME-TO-RUN should be NOW, FIRST, NORMAL or REDO, or omitted. It is a default in case the ADD-INITIALIZATION doesn't specify any of them."*) (DEFUN ADD-INITIALIZATION (NAME FORM &OPTIONAL KEYWORDS (LIST-NAME 'WARM-INITIALIZATION-LIST) &AUX WHEN DEFAULT-WHEN INIT HEAD-OF-LIST) 1"Add an initialization with name NAME and definition FORM to an initialization list. NAME should be a string and FORM an expression to be evaluated later. KEYWORDS can be one keyword or a list of them. These keywords can be in any package. Keywords can either be HEAD-OF-LIST, meaning add to front of list rather than the end, COLD, WARM, ONCE, SYSTEM, BEFORE-COLD, LOGIN, LOGOUT, SITE, SITE-OPTION, FULL-GC or AFTER-FULL-GC, specifying a list (note that only *ONE* initialization list name keyword is allowed in a keyword list), or NOW, FIRST, NORMAL or REDO, saying when to run the init. NOW means run the init as well as adding to the list; FIRST means run the init now if it isn't on the list; NORMAL means don't run the init now; REDO means don't run it now, but mark it as never having been run even if it is already on the list and has been run. If the keywords do not specify the list, LIST-NAME is used. The default for it is WARM-INITIALIZATION-LIST."* (WHEN KEYWORDS (DO ((L (IF (listP KEYWORDS) KEYWORDS (LIST KEYWORDS)) (CDR L)) V KEYDEF) ((NULL L)) (SETQ V (SYMBOL-NAME (CAR L))) (IF (SETQ KEYDEF (ASSOC V INITIALIZATION-KEYWORDS :TEST #'STRING-EQUAL)) (SETQ LIST-NAME (CADR KEYDEF) DEFAULT-WHEN (CADDR KEYDEF)) (COND ((MEMBER V '("NOW" "FIRST" "NORMAL" "REDO") :TEST #'STRING-EQUAL) (SETQ WHEN V)) ((STRING-EQUAL "HEAD-OF-LIST" V) (SETQ HEAD-OF-LIST T)) (T (FERROR NIL "Illegal keyword ~S" (CAR L))))))) (SETQ when (SELECTOR (OR when default-when) STRING-EQUAL (("NORMAL" "NIL") nil) (("NOW") 'now) (("REDO") 'redo) (("FIRST") 'first))) (INIT-LIST-CHECK LIST-NAME) (SETQ INIT (DO ((L (SYMBOL-VALUE LIST-NAME) (CDR L))) ((NULL L) (COND ((OR HEAD-OF-LIST (NULL (SYMBOL-VALUE LIST-NAME))) (CAR (SET LIST-NAME (CONS (MAKE-INIT-LIST-ENTRY NAME FORM NIL FDEFINE-FILE-PATHNAME) (SYMBOL-VALUE LIST-NAME))))) (T (CADR (RPLACD (LAST (SYMBOL-VALUE LIST-NAME)) (LIST (MAKE-INIT-LIST-ENTRY NAME FORM NIL FDEFINE-FILE-PATHNAME))))))) (WHEN (STRING-EQUAL (INIT-NAME (CAR L)) NAME) (SETF (INIT-FORM (CAR L)) FORM) (SETF (INIT-SOURCE-FILE (CAR L)) FDEFINE-FILE-PATHNAME) (RETURN (CAR L))))) (COND ((EQ WHEN 'REDO) (SETF (INIT-FLAG INIT) NIL)) ((OR (EQ WHEN 'NOW) (AND (EQ WHEN 'FIRST) (NULL (INIT-FLAG INIT)))) (*EVAL (INIT-FORM INIT)) (SETF (INIT-FLAG INIT) T)))) ;;; Deletes an init from the list. ;;; All list-name keywords (see INITIALIZATION-KEYWORDS) are allowed. ;;; If there is one, it overrides the third argument. (DEFUN DELETE-INITIALIZATION (NAME &OPTIONAL KEYWORDS (LIST-NAME 'WARM-INITIALIZATION-LIST)) 1"Remove any initialization named NAME from an initialization list. NAME should be a string. KEYWORDS can be a keyword or a list of them; packages do not matter. The only thing you can specify with one is what list to remove from. Or let KEYWORDS be NIL and supply the list name symbol as LIST-NAME."* (DO ((L (if (listp KEYWORDS) keywords (list keywords)) (CDR L)) ;allowed single keyword PMH KEYDEF V) ((NULL L)) (SETQ V (SYMBOL-NAME (CAR L))) (IF (SETQ KEYDEF (ASSOC V INITIALIZATION-KEYWORDS :TEST #'STRING-EQUAL)) (SETQ LIST-NAME (CADR KEYDEF)) (FERROR NIL "Illegal keyword ~S" (CAR L)))) (INIT-LIST-CHECK LIST-NAME) (DO ((L (SYMBOL-VALUE LIST-NAME) (CDR L)) (FLAG NIL)) ((NULL L) FLAG) (WHEN (STRING-EQUAL (INIT-NAME (CAR L)) NAME) (SET LIST-NAME (DELETE (CAR L) (SYMBOL-VALUE LIST-NAME) :TEST #'EQ)) (SETQ FLAG T)))) (DEFUN RESET-INITIALIZATIONS (list-name) 1"Mark all the inits in the initialization list named LIST-NAME as not yet run."* (INIT-LIST-CHECK list-name) (DO ((L (SYMBOL-VALUE list-name) (CDR L))) ((NULL L)) (SETF (INIT-FLAG (CAR L)) NIL)))