;;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10; Cold-load:T -*- ;;; 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) 1984-1989 Texas Instruments Incorporated. All rights reserved. ;;; 04/29/89 JLM Changed Hardware-Boot-Initializations to not spin if not MP, and to support CSIB. ;;; 04-24-89 DAB Added all function, variables, flavors and instances that are documented to export list. ;;; 04-20-89 DAB Changed lisp-reinitialize. Move initialization of user-application-initialization-list above ;;; cond that sets *terminal-io* to a background-window. ;;; Initialization & top-level READ-EVAL-PRINT loop (PROCLAIM '(SPECIAL *INTERPRETER-ENVIRONMENT* *INTERPRETER-FUNCTION-ENVIRONMENT*)) (DEFVAR SYN-TERMINAL-IO (MAKE-SYNONYM-STREAM '*TERMINAL-IO*) "A synonym stream that points to the value of *TERMINAL-IO*.") (DEFVAR LISP-TOP-LEVEL-INSIDE-EVAL :UNBOUND "Bound to T while within EVAL inside the top-level loop.") (DEFVAR *SYSTEM-NAME* :UNBOUND "The name of the system.") (DEFVAR * NIL "Value of last expression evaluated by read-eval-print loop.") (DEFVAR ** NIL "Value of next-to-last expression evaluated by read-eval-print loop.") (DEFVAR *** NIL "Value of third-to-last expression evaluated by read-eval-print loop.") (DEFVAR + NIL "Last expression evaluated by read-eval-print loop.") (DEFVAR ++ NIL "Next-to-last expression evaluated by read-eval-print loop.") (DEFVAR +++ NIL "Third-to-last expression evaluated by read-eval-print loop.") (DEFVAR / NIL "All values of last expression evaluated by read-eval-print loop.") (DEFVAR cli:// NIL "All values of next-to-last expression evaluated by read-eval-print loop.") (DEFVAR /// NIL "All values of third-to-last expression evaluated by read-eval-print loop.") (DEFVAR global:/ NIL "All values of last expression evaluated by read-eval-print loop.") (FORWARD-VALUE-CELL 'global:/ '/) (DEFVAR - NIL "Expression currently being evaluated by read-eval-print loop.") (DEFVAR *VALUES* NIL "List of all lists-of-values produced by the expressions evaluated in this listen loop. Most recent evaluations come first on the list.") (DEFVAR LISP-CRASH-LIST :UNBOUND "List of forms to be evaluated at next warm or cold boot.") (DEFVAR ORIGINAL-LISP-CRASH-LIST :UNBOUND "List of forms that was evaluated when the cold load was first booted.") (DEFVAR ERROR-STACK-GROUP :UNBOUND "The first level error handler stack group that handles traps from the microcode.") (DEFVAR %ERROR-HANDLER-STACK-GROUP :UNBOUND "Microcode variable that is initialized by warm boot to be ERROR-STACK-GROUP.") (DEFVAR COLD-BOOT-HISTORY NIL "List of elements (HOST UNIVERSAL-TIME), one for each time this band was cold-booted.") (DEFVAR COLD-BOOTING T "T while booting if this is a cold boot. Always NIL except when booting or disk-saving.") (DEFVAR REALLY-RUN-LIGHT :UNBOUND "Virtual address of the RUN light on the screen.") (DEFVAR QLD-MINI-DONE :UNBOUND "NIL until after the first cold boot of a new Lisp world.") ;ab 6/25/87 (ADD-INITIALIZATION "Next boot is a cold boot" '(SETQ COLD-BOOTING T) '(:BEFORE-COLD)) ;;; ;;; Lisp Reinitialize & Lisp-Top-Level ;;; ;Come here when machine starts. Provides a base frame. (DEFUN LISP-TOP-LEVEL () (LISP-REINITIALIZE NIL) ;(Re)Initialize critical variables and things (TERPRI (OR TV:INITIAL-LISP-LISTENER *TERMINAL-IO*)) ;; LISP-TOP-LEVEL1 supposedly never returns, but loop anyway in case ;; someone forces it to return with the error-handler. (LOOP DOING (IF (FBOUNDP 'PROCESS-TOP-LEVEL) (PROCESS-TOP-LEVEL) (LISP-TOP-LEVEL1 (OR TV:INITIAL-LISP-LISTENER *TERMINAL-IO*))))) ;Called when the main process is reset. (DEFUN LISP-TOP-LEVEL2 () (LISP-TOP-LEVEL1 (OR TV:INITIAL-LISP-LISTENER *TERMINAL-IO*))) ;;ab 1/12/88. New function called by LISP-REINITIALIZE and INITIALIZE-COLD-LOAD ;;ab 2/2/88. Initialize Cold Load stream correctly. (DEFUN init-cold-load-disk-and-paging (&optional (cold-boot nil)) (when (AND (addin-p) (fboundp 'micronet-channel-boot-initialize)) (micronet-channel-boot-initialize)) (WHEN (AND (addin-p) ;Turn on module-ops once MAC-WINDOWS is in. (ZEROP si:module-op-override) (find-system-named 'window-mx t t)) ;ab 2/16/88 (SETQ si:module-op-override 1)) (SETQ TV:MOUSE-WINDOW NIL) ;This gets looked at before the mouse process is turned on (WHEN cold-boot ;ab 2/16/88 (SETQ tv:mouse-sheet nil tv:default-screen nil)) (SETQ si:cold-load-stream-owns-keyboard t) (COND ((AND (addin-p) (fboundp 'micronet-channel-boot-initialize)) ;ab 2/19/88 (install-mx-cold-load)) (t (install-exp-cold-load))) ;;attach IO streams. Note that *TERMINAL-IO* will be fixed later to go to a window. (SETQ *TERMINAL-IO* COLD-LOAD-STREAM ;set up in crash list *STANDARD-OUTPUT* SYN-TERMINAL-IO *STANDARD-INPUT* SYN-TERMINAL-IO *QUERY-IO* SYN-TERMINAL-IO *DEBUG-IO* SYN-TERMINAL-IO *TRACE-OUTPUT* SYN-TERMINAL-IO *ERROR-OUTPUT* SYN-TERMINAL-IO) (SEND *TERMINAL-IO* :HOME-CURSOR) (WHEN cold-boot ;; When this is nil, *default-disk-unit* will be set from a-memory (SETQ *default-unit-from-mem* nil) (initialize-disk-system) (CONFIGURE-PAGE-BANDS)) ) ;; Function to reset various things, do initialization that's inconvenient in cold load, etc. ;; COLD-BOOT is T if this is for a cold boot. ;;AB 6/25/87. Cleaned up compiler warnings. ;;AB 1/12/88. Call new INIT-COLD-LOAD-DISK-AND-PAGING function. ;;JLM 2/27/89 added support for MP. (DEFUN LISP-REINITIALIZE (&OPTIONAL (CALLED-BY-USER T) &AUX (COLD-BOOT COLD-BOOTING)) (SETQ INHIBIT-SCHEDULING-FLAG T) ;In case called by the user (SETQ ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON NIL) ;; If these are set wrong, all sorts of things don't work. (SETQ LOCAL-DECLARATIONS NIL FILE-LOCAL-DECLARATIONS NIL UNDO-DECLARATIONS-FLAG NIL COMPILER:QC-FILE-IN-PROGRESS NIL) (Unless CALLED-BY-USER (SETQ *INTERPRETER-ENVIRONMENT* NIL *INTERPRETER-FUNCTION-ENVIRONMENT* NIL *INTERPRETER-MAXIMUM-ERROR-CHECKING* NIL) (SETQ *LISP-MODE* :common-lisp *READTABLE* common-lisp-READTABLE *READER-SYMBOL-SUBSTITUTIONS* *common-lisp-symbol-substitutions* ZWEI:*DEFAULT-MAJOR-MODE* :common-lisp)) ;; Initialize the NuBus slots, currently inits ENC only. RAF 3/5/85. (Unless CALLED-BY-USER (Hardware-Boot-Initializations COLD-BOOT)) (UNCLOSUREBIND '(* ** *** + ++ +++ / // /// *VALUES*)) (SETQ DEFAULT-CONS-AREA WORKING-STORAGE-AREA) ;Reset default areas. (NUMBER-GC-ON t) ;;Flush any closure binding forwarding pointers ;;left around from a closure we were in when we warm booted. (UNCLOSUREBIND '(PRIN1 *PRINT-BASE* *NOPOINT FDEFINE-FILE-PATHNAME INHIBIT-FDEFINE-WARNINGS SELF sys:self-mapping-table SI:PRINT-READABLY *PACKAGE* *READTABLE*)) ;; Flush bindings of EH variables. (unclosurebind 'eh:(*error-message-hook* *error-depth* *errset-status* *error-handler-running* *condition-handlers* *condition-default-handlers* *condition-resume-handlers*)) ;; EH initializations, cannot be put in an initialisation because the function ;; INITIALIZATIONS has a catch-error-restart that binds one or more of them. (setq eh:*condition-handlers* nil eh:*condition-default-handlers* nil eh:*condition-resume-handlers* nil) (WHEN (VARIABLE-BOUNDP ZWEI:*LOCAL-BOUND-VARIABLES*) (UNCLOSUREBIND ZWEI:*LOCAL-BOUND-VARIABLES*)) (UNCLOSUREBIND '(ZWEI:*LOCAL-VARIABLES* ZWEI:*LOCAL-BOUND-VARIABLES*)) ;; Initialize the rubout handler. (SETQ RUBOUT-HANDLER NIL TV:RUBOUT-HANDLER-INSIDE NIL) ;We're not in it now ;And all kinds of randomness... (init-random-variables) (SETQ *PACKAGE* PKG-USER-PACKAGE) (makunbound 'lisp-crash-list) ;Reattach IO streams. Note that *TERMINAL-IO* will be fixed later to go to a window. (COND ((NOT CALLED-BY-USER) (UNCLOSUREBIND '(*TERMINAL-IO* *STANDARD-OUTPUT* *STANDARD-INPUT* *QUERY-IO* *TRACE-OUTPUT* *ERROR-OUTPUT* *DEBUG-IO*)) )) ;; Find page partitions. Must be done before SYSTEM inits are run. (WHEN (NOT CALLED-BY-USER) (INIT-COLD-LOAD-DISK-AND-PAGING cold-boot)) ;; *ab* ;; These are initializations that have to be done before other initializations (INITIALIZATIONS 'SYSTEM-INITIALIZATION-LIST T) ;; At this point if the window system is loaded, it is all ready to go ;; and the initial Lisp listener has been exposed and selected. So do ;; any future typeout on it. But if any typeout happened on the cold-load ;; stream, leave it there (clobbering the Lisp listener's bits). This does not ;; normally happen, but just in case we do the set-cursorpos below so that ;; if anything strange gets typed out it won't get erased. Note that normally ;; we do not do any typeout nor erasing on the cold-load-stream, to avoid bashing ;; the bits of whatever window was exposed before a warm boot. (COND (CALLED-BY-USER) ((FBOUNDP 'TV:WINDOW-INITIALIZE) (MULTIPLE-VALUE-BIND (X Y) (FUNCALL *TERMINAL-IO* :READ-CURSORPOS) (FUNCALL TV:INITIAL-LISP-LISTENER :SET-CURSORPOS X Y)) (SETQ *TERMINAL-IO* TV:INITIAL-LISP-LISTENER) (FUNCALL *TERMINAL-IO* :SEND-IF-HANDLES :SET-PACKAGE *PACKAGE*) (unless (si:cool-boot-p) (FUNCALL *TERMINAL-IO* :FRESH-LINE))) (T (SETQ TV:INITIAL-LISP-LISTENER NIL) ;Not created yet (FUNCALL *TERMINAL-IO* :CLEAR-EOL))) (AND CURRENT-PROCESS (FUNCALL CURRENT-PROCESS :RUN-REASON 'LISP-INITIALIZE)) ; prevent screw from things being traced during initialization (if (fboundp 'untrace-1) (untrace)) (if (fboundp 'breakon) (unbreakon)) (IF COLD-BOOTING (INITIALIZATIONS 'COLD-INITIALIZATION-LIST)) ;; ;; As soon as the initial lisp listener is available, set up the ;; initial screen heading. ;; Added by Ken Bice 1/19/87 ;; (UNLESS (or (EQ *terminal-io* cold-load-stream) (null (send tv:*initial-screen* :exposed-p))) (send *terminal-io* :clear-screen) (Initial-Screen-Heading)) (INITIALIZATIONS 'WARM-INITIALIZATION-LIST T) (SETQ COLD-BOOTING NIL) ;; DAB 04-20-89 This used to be the last thing done, but I don't what the message being displayed on a background window. (Initializations 'user-application-initialization-list T) ;04-18-89 DAB ;; ;; The first print herald differs from the print herald only in printing ;; some extra information (eg, how to login, how to print complete print herald). ;; Added by Ken Bice 1/19/87 ;; (cond ((and (si:mp-system-p) (null (send tv:*initial-screen* :exposed-p)))) ((FBOUNDP 'First-PRINT-HERALD) (First-PRINT-HERALD)) (:else (FUNCALL *STANDARD-OUTPUT* :CLEAR-EOL) (TERPRI) (PRINC "Lispm Kernel Environment"))) (AND (BOUNDP 'TIME:*LAST-TIME-UPDATE-TIME*) (NULL (CAR COLD-BOOT-HISTORY)) (SETF (CAR COLD-BOOT-HISTORY) (CATCH-ERROR (LIST SI:LOCAL-HOST (GET-UNIVERSAL-TIME))))) ;; This process no longer needs to be able to run except for the usual reasons. ;; The delayed-restart processes may now be allowed to run (COND (CURRENT-PROCESS (FUNCALL CURRENT-PROCESS :REVOKE-RUN-REASON 'LISP-INITIALIZE) (WHEN WARM-BOOTED-PROCESS (FORMAT T "Warm boot while running ~S. Its variable bindings remain in effect; its unwind-protects have been lost.~%" WARM-BOOTED-PROCESS) (WHEN (NOT (OR (EQ (PROCESS-WARM-BOOT-ACTION WARM-BOOTED-PROCESS) 'PROCESS-WARM-BOOT-RESTART) (EQ WARM-BOOTED-PROCESS INITIAL-PROCESS) (TYPEP WARM-BOOTED-PROCESS 'SI:SIMPLE-PROCESS))) (IF (YES-OR-NO-P "Do you want to Debug it? ") (PROGN (FORMAT T "~%~&The state available in the debugger is not quite the latest one.~%~%") (DEBUG-WARM-BOOTED-PROCESS) (format t "~2&Type (SI:RESET-WARM-BOOTED-PROCESS) to reset the process.~2%")) (RESET-WARM-BOOTED-PROCESS)))) (LOOP FOR (P . RR) IN DELAYED-RESTART-PROCESSES DO (WITHOUT-INTERRUPTS (SETF (PROCESS-RUN-REASONS P) RR) (PROCESS-CONSIDER-RUNNABILITY P))) (SETQ DELAYED-RESTART-PROCESSES NIL))) ;; The global value of *TERMINAL-IO* is a stream which goes to an auto-exposing ;; window. Some processes, such as Lisp listeners, rebind it to something else. ;; CALLED-BY-USER is T if called from inside one of those. (COND ((AND (NOT CALLED-BY-USER) (FBOUNDP TV:DEFAULT-BACKGROUND-STREAM)) (SETQ *TERMINAL-IO* TV:DEFAULT-BACKGROUND-STREAM))) ;; Now that -all- initialization has been completed, allow network servers (SETQ CHAOS:CHAOS-SERVERS-ENABLED T) ) ;;; cold load setup and initialization function ;; Function to reset various things, do initialization that's inconvenient in cold load, etc. ;; 4/3/87 DNG - PROCLAIM dummy functions NOTINLINE to make sure the compiler ;; doesn't try to expand the dummy definition inline before the ;; real function is installed. [SPR 4600] ;;AB 6/25/87. Cleaned up compiler warnings. ;;AB 1/12/88. Call new INIT-COLD-LOAD-DISK-AND-PAGING function. (DEFUN INITIALIZE-COLD-LOAD () (SETQ ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON NIL) ;shouldn't be needed, ucode boots up this way?? ;; Provide ucode with space to keep EVCPs stuck into a-memory locations ;; by closure-binding the variables that forward there. (SETQ AMEM-EVCP-VECTOR (MAKE-ARRAY (+ (LENGTH SYS:A-MEMORY-LOCATION-NAMES) 64. 16.) ;16 in case ucode grows. :AREA PERMANENT-STORAGE-AREA)) ;; These cross load to the crash list but need them to run EVAL to run the crash list... catch22 ;; can go away when cold loader handles DEFCONSTANT ;; SETQd variables and constants below used by Interpreter - 4-30-85 SJF,DRH (SETQ *LISP-MODE* :common-lisp *READTABLE* common-lisp-READTABLE *READER-SYMBOL-SUBSTITUTIONS* *common-lisp-symbol-substitutions* ZWEI:*DEFAULT-MAJOR-MODE* :common-lisp) ;; remove this and you will die in TURN-ZETALISP-ON (SETQ *READ-BASE* 10. *PRINT-BASE* 10. *NOPOINT T) ;; Needed by the evaluator (SETQ LOCAL-DECLARATIONS NIL FILE-LOCAL-DECLARATIONS NIL UNDO-DECLARATIONS-FLAG NIL COMPILER:QC-FILE-IN-PROGRESS NIL) (Hardware-Boot-Initializations T) ;; Do something at least if errors occur during loading (UNLESS (FBOUNDP 'FERROR) (FSET 'FERROR #'FERROR-COLD-LOAD) (PROCLAIM '(NOTINLINE FERROR))) (UNLESS (FBOUNDP 'CERROR) (FSET 'CERROR #'CERROR-COLD-LOAD) (PROCLAIM '(NOTINLINE CERROR))) (UNLESS (FBOUNDP 'UNENCAPSULATE-FUNCTION-SPEC) ;<<============= why not defined?? (FSET 'UNENCAPSULATE-FUNCTION-SPEC #'(LAMBDA (X) X)) (PROCLAIM '(NOTINLINE UNENCAPSULATE-FUNCTION-SPEC))) (UNLESS (FBOUNDP 'FS:MAKE-PATHNAME-INTERNAL) (FSET 'FS:MAKE-PATHNAME-INTERNAL #'LIST) (PROCLAIM '(NOTINLINE FS:MAKE-PATHNAME-INTERNAL))) (UNLESS (FBOUNDP 'FS:MAKE-FASLOAD-PATHNAME) (FSET 'FS:MAKE-FASLOAD-PATHNAME #'LIST) (PROCLAIM '(NOTINLINE FS:MAKE-FASLOAD-PATHNAME))) ;; Allow streams to work before WHOLIN loaded (UNLESS (BOUNDP 'TV:WHO-LINE-FILE-STATE-SHEET) (SETQ TV:WHO-LINE-FILE-STATE-SHEET #'(LAMBDA (&REST IGNORE) NIL))) (UNLESS (FBOUNDP 'TV:WHO-LINE-RUN-STATE-UPDATE) (FSET 'TV:WHO-LINE-RUN-STATE-UPDATE #'(LAMBDA (&REST IGNORE) NIL)) (PROCLAIM '(NOTINLINE TV:WHO-LINE-RUN-STATE-UPDATE))) (SETQ DEFAULT-CONS-AREA WORKING-STORAGE-AREA) ;Reset default areas. (PKG-INITIALIZE) (SETQ QLD-MINI-DONE nil) (SETQ SCHEDULER-EXISTS NIL CURRENT-PROCESS NIL TV:WHO-LINE-PROCESS NIL TV:LAST-WHO-LINE-PROCESS NIL) ;Get the right readtable. (OR (VARIABLE-BOUNDP INITIAL-READTABLE) (SETQ INITIAL-READTABLE STANDARD-READTABLE)) (WHEN (VARIABLE-BOUNDP COMMON-LISP-READTABLE) (UNLESS (VARIABLE-BOUNDP INITIAL-COMMON-LISP-READTABLE) (SETQ INITIAL-COMMON-LISP-READTABLE COMMON-LISP-READTABLE))) ;; Initialize the rubout handler. ;; Needed before you can print anything. (SETQ RUBOUT-HANDLER NIL TV:RUBOUT-HANDLER-INSIDE NIL) ;We're not in it now ;; For some reason, these aren't being initialised properly by default, so lets ;; force it. - pf, Aug 8, 1986 (setq eh:*condition-handlers* nil eh:*condition-default-handlers* nil eh:*condition-resume-handlers* nil) ;;; ;And all kinds of randomness... (init-random-variables) ;; ************************** blast after initial debugging **************************** ;; The first time, this does top-level SETQ's from the cold-load files * (OR (BOUNDP 'ORIGINAL-LISP-CRASH-LIST) ;Save it for possible later inspection * (SETQ ORIGINAL-LISP-CRASH-LIST LISP-CRASH-LIST)) ; * (MAPC (FUNCTION *EVAL) LISP-CRASH-LIST) (SETQ LISP-CRASH-LIST NIL) ;make the crash list into garbage ;; Find page partitions. Must be done before SYSTEM inits are run. (init-cold-load-disk-and-paging t) ;;*ab* ;; These are initializations that have to be done before other initializations (INITIALIZATIONS 'SYSTEM-INITIALIZATION-LIST T) (SETQ TV:INITIAL-LISP-LISTENER NIL) ;Not created yet (FUNCALL *TERMINAL-IO* :CLEAR-EOL) (INITIALIZATIONS 'COLD-INITIALIZATION-LIST) (INITIALIZATIONS 'WARM-INITIALIZATION-LIST T) (SETQ COLD-BOOTING NIL) (FUNCALL *STANDARD-OUTPUT* :CLEAR-EOL) (terpri) (PRINC "Lispm Kernel Environment") (setq qld-mini-done t) ;;;; WERE ALL DID!!!!!!!!!!!!!!! ;; DON'T EVER CALL ME HERE AGAIN!!!! ;; store lisp-top-level into the initial function slot of the scratch-pad init area (let ((%inhibit-read-only t)) (DECLARE (SPECIAL scratch-pad-pointers)) (SETF (aref #'scratch-pad-init-area (position 'initial-top-level-function (the list scratch-pad-pointers) :test #'eq)) (lisp-object-as-32b-number (function-cell-location 'LISP-TOP-LEVEL)))) (TERPRI (OR TV:INITIAL-LISP-LISTENER *TERMINAL-IO*)) ;; LISP-TOP-LEVEL1 supposedly never returns, but loop anyway in case ;; someone forces it to return with the error-handler. (LOOP DOING (LISP-TOP-LEVEL1 (OR TV:INITIAL-LISP-LISTENER *TERMINAL-IO*)))) (Defun Lisp-Object-as-32b-Number (obj) (let* ((dt (%data-type obj)) (ptr (%pointer obj)) (nptr (dpb (%logldb #o3001 ptr) #o3001 (ldb #o0030 ptr))) ) (dpb dt %%q-data-type nptr))) ;;; ;;; Auto-Config code for the contents of NuBus slots. ;;; (Defvar *NuBUS-BOARD-ALIST* nil "Alist of (STRING . FUNCTION). FUNCTION will be called with one argument, the slot, whenever a board is found whose CODE is string-equal to STRING.") (DEFUN slot-owned-p (slot) ; 10 APR 87 MMG "Returns T if SLOT is owned by this processor." (LET ((A-Memory-Address (%pointer-plus A-Memory-Virtual-Address (+ %COUNTER-BLOCK-A-MEM-ADDRESS %SLOTS-I-OWN)))) (LOGBITP (LOGAND #x0F Slot) (WITHOUT-INTERRUPTS (DPB (%P-LDB %%Q-High-Half A-Memory-Address) %%Q-High-Half (%P-LDB %%Q-Low-Half A-Memory-Address)))))) (DEFUN valid-crom-p (slot) ; 10 APR 87 MMG "Returns T if the board in SLOT contains a valid Configuration ROM." (EQUAL (%Nubus-Read-8b-Careful (DPB Slot (BYTE (BYTE-SIZE %%nubus-slot-bits) 0) #xf0) CROMO-ID-BYTE) CROM-ROM-VALID-FLAG)) (DEFUN cfg-register (Slot) ; 10 APR 87 MMG "Returns the value of the Configuration Register of the board in SLOT. If the Config Register could not be found, NIL is returned." (Let ((CFR-Addr 0) Addr-Byte CFR) (Dotimes (Index CROMO-CONFIG-REGISTER-LENGTH) (When (Integerp (Setf Addr-Byte (%NuBus-Read-8B-Careful Slot (+ CROMO-CONFIG-REGISTER-OFFSET-LOCATION (Ash Index 2))))) (Setf CFR-Addr (Dpb Addr-Byte (Byte 8 (Ash Index 3)) CFR-Addr)))) (When (Integerp (Setf CFR (%NuBus-Read-8B-Careful Slot CFR-Addr))) CFR))) (DEFUN board-type (Slot) ; Changed 10 APR 87 MMG "Returns the 3-character ID code from the NuBus Config Rom in SLOT." (Let ((Type (Make-String CROMO-BOARD-TYPE-NAME-LENGTH :Initial-Element #\Space)) char) (Dotimes (Index CROMO-BOARD-TYPE-NAME-LENGTH) (When (Integerp (Setf Char (%NuBus-Read-8B-Careful Slot (+ CROMO-BOARD-TYPE-OFFSET-NAME (Ash Index 2))))) (Setf (Aref Type Index) Char))) Type)) (DEFUN initialize-nubus-slots (&Aux Initfun Cfr) ; Changed 10 APR 87 MMG "For each slot F0-FF; checks the board type, ID byte, fault bit, and slots-owned field before calling the initialization function for that board type and slot as recorded in *NUBUS-BOARD-ALIST*" (Do ((Slot #xF0 (+ 1 Slot))) ((> Slot #xFF)) (When (And (Slot-Owned-P Slot) ; Do we own this slot? (Valid-Crom-P Slot) ; Does it have a valid config ROM? (Setf Cfr (Cfg-Register Slot)) ; Can we get to the Config Register? (Not (Logbitp #x02 Cfr)) ; If so, is the Fault Bit off? (Setf Initfun ; Is there an init function for this board? (Cdr (Assoc (Board-Type Slot) *Nubus-Board-Alist* :Test #'EQUAL))) (Funcall Initfun Slot))))) (DEFUN define-nubus-board-type (key function) ; changed 10/23/86, -ab "Enters (KEY . FUNCTION) on the list of NuBus Board types. Whenever Cold-Boot sees a board whose type code is KEY, it calls FUNCTION with one arg, the slot." (LET ((item (ASSOC key *Nubus-Board-Alist* :test #'EQUALP))) (IF (NULL item) (push (cons key function) *Nubus-Board-Alist*) (RPLACD item function)))) ;;; ;;; Hardware Boot Inits ;;; (DEFUN CLEAR-SCREEN-BUFFER (BUFFER-ADDRESS) (%P-DPB 0 %%Q-LOW-HALF BUFFER-ADDRESS) (%P-DPB 0 %%Q-HIGH-HALF BUFFER-ADDRESS) (%BLT BUFFER-ADDRESS (1+ BUFFER-ADDRESS) #o77777 1)) ;;AB 6/25/87. Added color support for GRH. ;;AB 7/20/87. Unblank screen on both cold & warm boots just in case it has been blanked. [SPR 6000] ;;JJP 9/2/87 " " on monochrome monitor on color system. ;;ab 1/12/87 Changes for MX. ;;ab 2/8/88 Enable event-timer interrupt on warm-boot also. ;;JLM 2/27/89 Added MP support; (Defun Hardware-Boot-Initializations (Cold-Boot) (DECLARE (SPECIAL tv:sib-is-csib tv:csib-expans-no-transp-va *bw-tv-io-space-virtual-address* %%csib-tv-mono-blank-mask)) (Setup-Physical-Resources) (COND ((AND (Boundp 'Cold-Hardware-Initializations) *sib-present*) (Mapc #'*EVAL Cold-Hardware-Initializations) ;<<======= first use of interpreter ;; The following spin is deisgned for an MP system. When more than one processor is booting, ;; the processors not in lowest slot MUST wait for the Lowest slot proc to get moving ;; currently, we use slot 6 as lowest (this needs to be changed to scan for lowest booting processor (when (and (mp-system-p) ; jlm 4/25/89 (not (si:cool-boot-p))) ;; marky 12-19-88 (let ((powerfail-addr (if tv:sib-is-csib %csib-powerfail-event-address-1 %sib-powerfail-event-address-1))) (do ((val (logand #xffffffff (si:%nubus-read tv:tv-slot-number powerfail-addr)) (logand #xffffffff (si:%nubus-read tv:tv-slot-number powerfail-addr)))) ((= val (logior #xf6000000 %slot-power-fail-event))) (do ((x 100. (1- x))) ((< x 0))) )))) ((NOT *sib-present*) (MAKUNBOUND 'tv:sib-slot-number) ;so we will trap if we try to use it (which cannot work)! (MAKUNBOUND 'tv:tv-slot-number))) ;;**AB** Event generator used for sequence breaking. (COND ((AND cold-boot (OR (mx-p) (exp2-p))) (and (fboundp 'setup-event-generator) (setup-event-generator)) (and (fboundp 'setup-processor-slot) (setup-processor-slot))) ((OR (mx-p) (exp2-p)) ;warm boot (and (fboundp 'enable-event-timer-interrupt) (enable-event-timer-interrupt)))) (When Cold-Boot (UNLESS (mx-p) (INITIALIZE-NuBUS-SLOTS)) ;; Hack notes: ;; %BOOT-VIRTUAL-MEMORY must come before CLEAR-SCREEN-BUFFER ;; so that the screen buffer virtual memory is set up before ;; we touch it. ;; Consequences: ;; o %BOOT-VIRTUAL-MEMORY can't rely on anything on the ;; crash list (not yet run) ;; o After these h/w inits, you will have use of your ;; full physical memory. (%boot-virtual-memory) (WHEN *sib-present* (%initialize-tv-screen-memory) (unless (cool-boot-p) (CLEAR-SCREEN-BUFFER (if tv:sib-is-csib TV:CSIB-EXPANS-NO-TRANSP-VA ;these are currently the same value *BW-TV-IO-SPACE-VIRTUAL-ADDRESS*))))) (WHEN (and *sib-present* (not (cool-boot-p))) ;; Unblank the screen on both COLD and WARM boots. (IF tv:sib-is-csib ;; CSIB is already reverse-video (and is at a different address) (%NuBus-write TV:TV-Slot-Number %CSIB-TV-Video-Attribute (dpb 1 %%csib-tv-mono-blank-mask (DPB 1 %%CSIB-TV-Video-Blank-Mask 0))) (%NuBus-write TV:TV-Slot-Number %SIB-TV-Video-Attribute (DPB 0 %%SIB-TV-Video-Not-Blanked (DPB 0 %%SIB-TV-Video-Black-on-White 0))))) ;; set up pointer to processor run light (COND (*sib-present* (SETQ REALLY-RUN-LIGHT (- %DISK-RUN-LIGHT 4))) (t (MAKUNBOUND 'really-run-light))) ;so we'll trap if we try to write to it! ) (DEFUN UNCLOSUREBIND (SYMBOLS) "If any of SYMBOLS has a closure binding evcp pointer in its value cell, remove it. Does not change the value of the symbol, but unshares it with the closure. This does not need to be done on A-memory variables." (DOLIST (SYMBOL SYMBOLS) (LET ((LOC (FOLLOW-CELL-FORWARDING (VALUE-CELL-LOCATION SYMBOL) NIL))) (IF (= (%P-DATA-TYPE LOC) DTP-EXTERNAL-VALUE-CELL-POINTER) (%BLT-TYPED (FOLLOW-CELL-FORWARDING LOC T) LOC 1 1))))) (Defun Init-Random-Variables () (SETQ TRACE-LEVEL 0) (SETQ INSIDE-TRACE NIL) (SETQ + NIL * NIL - NIL ;In case of error during first read/eval/print cycle / NIL ++ NIL +++ NIL ;or if their values were unprintable or obscene ** NIL *** NIL) ;and to get global values in case of break in a non-lisp-listener (SETQ // NIL /// NIL) (SETQ LISP-TOP-LEVEL-INSIDE-EVAL NIL) (SETQ %INHIBIT-READ-ONLY NIL) (OR (BOUNDP 'PRIN1) (SETQ PRIN1 NIL)) (SETQ *EVALHOOK* NIL *APPLYHOOK* NIL) (SETQ XR-CORRESPONDENCE-FLAG NIL ;Prevent the reader from doing random things XR-CORRESPONDENCE NIL) ; (SETQ *RSET T) ;In case any MACLISP programs look at it (SETQ FDEFINE-FILE-PATHNAME NIL) (SETQ INHIBIT-FDEFINE-WARNINGS NIL) ;Don't get screwed by warm boot (SETQ SELF-FLAVOR-DECLARATION NIL) (SETQ SELF NIL SELF-MAPPING-TABLE NIL) (SETQ SI:PRINT-READABLY NIL) (SETQ CHAOS:CHAOS-SERVERS-ENABLED NIL) ;Don't allow botherage from networks (SETQ FS:THIS-IS-A-PATCH-FILE nil) ) ;This is a temporary function, which turns on the "extra-pdl" feature (DEFUN NUMBER-GC-ON (&OPTIONAL (ON-P T)) (SETQ NUMBER-CONS-AREA (COND (ON-P EXTRA-PDL-AREA) (T WORKING-STORAGE-AREA)))) (DEFUN LISP-TOP-LEVEL1 (*TERMINAL-IO* &OPTIONAL (TOP-LEVEL-P T) &AUX OLD-PACKAGE W-PKG) "Read-eval-print loop used by Kernel. *TERMINAL-IO* is the stream to read and print with." (COND ((VARIABLE-BOUNDP *PACKAGE*) (BIND (LOCF *PACKAGE*) *PACKAGE*))) (COND ((FBOUNDP 'FORMAT) (FORMAT T "~2&;Reading~@[ at top level~]" TOP-LEVEL-P) (IF (SEND *TERMINAL-IO* :OPERATION-HANDLED-P :NAME) (FORMAT T " in ~A." (SEND *TERMINAL-IO* :NAME)) (FORMAT T ".")))) (PUSH NIL *VALUES*) (DO (THROW-FLAG) ;Gets non-NIL if throw to COMMAND-LEVEL (e.g. quitting from an error) (NIL) ;Do forever ;; If *PACKAGE* has changed, set OLD-PACKAGE and tell our window. ;; Conversely, if the window's package has changed, change ours. ;; The first iteration, we always copy from the window. (COND ((NOT (VARIABLE-BOUNDP *PACKAGE*))) ((EQ *TERMINAL-IO* COLD-LOAD-STREAM)) ;; User set the package during previous iteration of DO ;; => tell the window about it. ((AND OLD-PACKAGE (NEQ *PACKAGE* OLD-PACKAGE)) (FUNCALL *TERMINAL-IO* :SEND-IF-HANDLES :SET-PACKAGE *PACKAGE*) (SETQ OLD-PACKAGE *PACKAGE*)) ;; Window's package has been changed, or first iteration through DO, ;; => set our package to the window's -- if the window has one. ((SETQ W-PKG (FUNCALL *TERMINAL-IO* :SEND-IF-HANDLES :PACKAGE)) (AND (NEQ W-PKG *PACKAGE*) (SETQ *PACKAGE* W-PKG)) (SETQ OLD-PACKAGE *PACKAGE*)) ;; First time ever for this window => set window's package ;; to the global value of *PACKAGE*. ((NULL OLD-PACKAGE) (SETQ OLD-PACKAGE *PACKAGE*) (FUNCALL *TERMINAL-IO* :SEND-IF-HANDLES :SET-PACKAGE *PACKAGE*))) (SETQ THROW-FLAG T) (CATCH-ERROR-RESTART ((SYS:ABORT ERROR) "Return to top level in ~A." (OR (SEND *TERMINAL-IO* :SEND-IF-HANDLES :NAME) "current process")) (TERPRI) (SETQ +++ ++ ++ + + -) ;Save last three input forms (SETQ - (READ-FOR-TOP-LEVEL)) (LET ((LISP-TOP-LEVEL-INSIDE-EVAL T) VALUES) (UNWIND-PROTECT (SETQ VALUES (MULTIPLE-VALUE-LIST (LET (*INTERPRETER-ENVIRONMENT* *INTERPRETER-FUNCTION-ENVIRONMENT*) (EVAL-ABORT-TRIVIAL-ERRORS -)))) ;; Always push SOMETHING -- NIL if evaluation is aborted. (PUSH VALUES *VALUES*)) (SETQ /// // // / / VALUES) (SETQ *** ** ;Save first value, propagate old saved values ** * * (CAR /))) (DOLIST (VALUE /) (TERPRI) (FUNCALL (OR PRIN1 #'PRIN1) VALUE)) (SETQ THROW-FLAG NIL)) (WHEN THROW-FLAG ;; Inform user of return to top level. (FORMAT T "~&;Back to top level") (IF (SEND *TERMINAL-IO* :OPERATION-HANDLED-P :NAME) (FORMAT T " in ~A." (SEND *TERMINAL-IO* :NAME)) (WRITE-CHAR #\.))))) (defvar *handle-trivial-errors* t "T means to catch trivial evaluation errors before entering the debugger.") (DEFVAR *keep-locals-for-eval* nil) ;!Set to t this will keep local environments for eval ;;PHD 3/3/87 Replaced let by let-if for break. (DEFUN EVAL-ABORT-TRIVIAL-ERRORS (TOP-LEVEL-FORM) "Evaluate TOP-LEVEL-FORM, returning the value, but aborting on trivial errors. A trivial error is one involving a symbol present in the form itself. Aborting is done by signaling SYS:ABORT, like the Abort key. The user gets to choose whether to do that or to enter the debugger as usual." (DECLARE (SPECIAL TOP-LEVEL-FORM)) (CONDITION-BIND-IF *handle-trivial-errors* (((SYS:TOO-FEW-ARGUMENTS SYS:TOO-MANY-ARGUMENTS SYS:CELL-CONTENTS-ERROR SYS:WRONG-TYPE-ARGUMENT SYS:INVALID-FUNCTION-SPEC SYS:UNCLAIMED-MESSAGE) 'EVAL-ABORT-TRIVIAL-ERRORS-HANDLER)) (LET-IF (NOT *keep-locals-for-eval*) ;!Set this to t in the application, such as break, ((*interpreter-environment* nil) ;!and it will keep the lexical environment available. (*interpreter-function-environment* nil)) ;! (*EVAL TOP-LEVEL-FORM)))) (DEFUN EVAL-ABORT-TRIVIAL-ERRORS-HANDLER (CONDITION) (DECLARE (SPECIAL TOP-LEVEL-FORM)) (WHEN (COND ((CONDITION-TYPEP CONDITION 'SYS:CELL-CONTENTS-ERROR) (AND (SYMBOLP (SEND CONDITION :CONTAINING-STRUCTURE)) (MEM*Q-FWD (SEND CONDITION :CONTAINING-STRUCTURE) TOP-LEVEL-FORM))) ((CONDITION-TYPEP CONDITION 'SYS:INVALID-FUNCTION-SPEC) (MEM*Q (SEND CONDITION :FUNCTION-SPEC) TOP-LEVEL-FORM)) ((CONDITION-TYPEP CONDITION 'SYS:UNCLAIMED-MESSAGE) (MEM*Q (SEND CONDITION :MESSAGE) TOP-LEVEL-FORM)) (T (MEM*Q (FUNCTION-NAME (SEND CONDITION :FUNCTION)) TOP-LEVEL-FORM))) (SEND *QUERY-IO* :FRESH-LINE) (SEND CONDITION :PRINT-ERROR-MESSAGE CURRENT-STACK-GROUP T *QUERY-IO*) (SEND *QUERY-IO* :CLEAR-INPUT) (LET (*EVALHOOK* *APPLYHOOK*) (UNLESS (FQUERY `(:CHOICES ,(MAPCAR #'(LAMBDA (CHOICE) (IF (EQ (CAAR CHOICE) NIL) (APPEND CHOICE '(#\C-Z)) CHOICE)) FORMAT:Y-OR-N-P-CHOICES)) "Enter the debugger (No means abort instead)? ") (SIGNAL-CONDITION EH:ABORT-OBJECT)))) (VALUES)) (DEFUN MEM*Q-FWD (ELT TREE) "T if ELT is TREE or an element of TREE or an element of an element, etc. Does not compare the CDRs (the links of the lists of TREE), just the elements. Regards two symbols as equal if their value cells are forwarded together." ;; Cannot use MEMQ since it gets an error if a list ends in a non-NIL atom. (OR (EQ ELT TREE) (AND (SYMBOLP TREE) (SYMBOLP ELT) (EQ (FOLLOW-CELL-FORWARDING (VALUE-CELL-LOCATION ELT) T) (FOLLOW-CELL-FORWARDING (VALUE-CELL-LOCATION TREE) T))) (DO ((TAIL TREE (CDR TAIL))) ((ATOM TAIL) NIL) (IF (OR (EQ (CAR TAIL) ELT) (MEM*Q-FWD ELT (CAR TAIL))) (RETURN T))))) (DEFUN MEM*Q (ELT TREE) "T if ELT is TREE or an element of TREE or an element of an element, etc. Does not compare the CDRs (the links of the lists of TREE), just the elements." ;; Cannot use MEMQ since it gets an error if a list ends in a non-NIL atom. (OR (EQ ELT TREE) (DO ((TAIL TREE (CDR TAIL))) ((ATOM TAIL) NIL) (IF (OR (EQ (CAR TAIL) ELT) (MEM*Q ELT (CAR TAIL))) (RETURN T))))) ;;PHD 3/3/87 Added *Keep-locals-for-eval* binding (DEFVAR *BREAK-BINDINGS* '((*keep-locals-for-eval* t) ;!Allows access to local variables (RUBOUT-HANDLER NIL) ;Start new level of rubout catch (READ-PRESERVE-DELIMITERS NIL) ;For normal Lisp syntax (READ-CHECK-INDENTATION NIL) (DEFAULT-CONS-AREA BACKGROUND-CONS-AREA) ;as opposed to compiler temp area (OLD-STANDARD-INPUT STANDARD-INPUT) ;So user can find old stream. BREAK, too! (OLD-QUERY-IO QUERY-IO) ;.. (*STANDARD-INPUT* SYN-TERMINAL-IO) ;Rebind streams to terminal (*STANDARD-OUTPUT* SYN-TERMINAL-IO) (*QUERY-IO* SYN-TERMINAL-IO) (EH:ERRSET-STATUS NIL) ;"Condition Wall" for errsets (EH:CONDITION-HANDLERS NIL) ; and for conditions (EH:CONDITION-DEFAULT-HANDLERS NIL) (LOCAL-DECLARATIONS NIL) (SELF-FLAVOR-DECLARATION NIL)) "Bindings to be made by the function BREAK. Each element is a list (VARNAME VALUE-FORM) describing one binding. Bindings are made sequentially.") (DEFVAR OLD-STANDARD-INPUT) (DEFVAR OLD-QUERY-IO) ;Simple version of FERROR to be used in the cold load environment. (DEFUN FERROR-COLD-LOAD (&REST ARGS) (PRINT ARGS) (BREAK "FERROR.")) ;Simple version of CERROR to be used in the cold load environment. (DEFUN CERROR-COLD-LOAD (&REST ARGS) (PRINT ARGS) (BREAK "CERROR.")) (ADD-INITIALIZATION "Reset cold boot history" '(PUSH-NIL-ON-COLD-BOOT-HISTORY) '(:COLD)) ;;; This is a function, since PUSH isn't loaded early enough (DEFUN PUSH-NIL-ON-COLD-BOOT-HISTORY () (PUSH 'NIL COLD-BOOT-HISTORY)) ;;; Stuff which has to go somewhere, to be around in the cold-load, ;;; and doesn't have any logical place where it belongs (this used to ;;; be in LMIO;KBD) (DEFVAR USER-ID "" "String for the name you are logged in as, or an empty string if not logged in.") ;; This is here rather than with the scheduler because it has to be ;; in the cold-load. It checks for the non-existence of a scheduler ;; and does it itself in that case. ;; Takes a predicate and arguments to it. The process becomes blocked ;; until the application of the predicate to those arguments returns T. ;; Note that the function is run in the SCHEDULER stack group, not the ;; process's stack group! This means that bindings in effect at the ;; time PROCESS-WAIT is called will not be in effect; don't refer to ;; variables "freely" if you are binding them. ;; Kludge: if the scheduler seems broken, or we ARE the scheduler ;; (i.e. a clock function tries to block), then loop-wait (no blinkers...) ;; In case of a process-level interrupt while waiting, this function can get ;; restarted from its beginning. Therefore, it must not modify its arguments, ;; and the way it does its WITHOUT-INTERRUPTS must not be changed. ;; See (:METHOD SI:PROCESS :INTERRUPT) ;;PHD 4/8/87 moved set-process-wait into the scheduler to avoid consing. (DEFUN PROCESS-WAIT (WHOSTATE FUNCTION &REST ARGUMENTS) "Wait until FUNCTION applied to ARGUMENTS returns T. WHOSTATE is a string to appear in Peek and the who-line until then. Note that FUNCTION will be called in the scheduler stack group, so your special variable bindings will not be available. Pass whatever data or pointers you need in the ARGUMENTS." (COND ((APPLY FUNCTION ARGUMENTS) ;Test condition before doing slow stack-group switch NIL) ;Hmm, no need to wait after all ((AND SCHEDULER-EXISTS (EQ SCHEDULER-STACK-GROUP %CURRENT-STACK-GROUP) CURRENT-PROCESS) ;; Called PROCESS-WAIT from a process's wait-function! ;; Rather than hang the system, just say the process is not runnable now. (THROW 'PROCESS-WAIT-IN-SCHEDULER NIL)) ((OR (NOT SCHEDULER-EXISTS) (EQ SCHEDULER-STACK-GROUP %CURRENT-STACK-GROUP) (NULL CURRENT-PROCESS) (LET ((STATE (SG-CURRENT-STATE SCHEDULER-STACK-GROUP))) (NOT (OR (= STATE SG-STATE-AWAITING-INITIAL-CALL) (= STATE SG-STATE-AWAITING-CALL) (= STATE SG-STATE-AWAITING-RETURN))))) (DO () (NIL) (AND (APPLY FUNCTION ARGUMENTS) (RETURN NIL)))) (T (WITHOUT-INTERRUPTS ;A sequence break would reset my state to "running" (SETF (PROCESS-WHOSTATE CURRENT-PROCESS) WHOSTATE) (TV:WHO-LINE-PROCESS-CHANGE CURRENT-PROCESS) ; (SET-PROCESS-WAIT CURRENT-PROCESS FUNCTION ARGUMENTS) ;; DON'T change this FUNCALL to a STACK-GROUP-RESUME! The scheduler ;; needs to know what the process's current stack group is. (with-stack-list (l 'process-wait CURRENT-PROCESS FUNCTION ARGUMENTS) (FUNCALL SCHEDULER-STACK-GROUP l))) (TV:WHO-LINE-PROCESS-CHANGE CURRENT-PROCESS)))) ;;; various MP things (DEFUN get-cpu-type (Slot) "Returns the cpu type code from the NuBus Config Rom in SLOT." (%NuBus-Read-8B-Careful slot CROMO-CPU-TYPE-OFFSET)) (defun find-explorer-II-procs () (do ((slot #xf0 (incf slot)) slot-list) ((> slot #xff) slot-list) (if (and (string-equal (board-type slot) "CPU") (eql (get-cpu-type slot) %CPU-TI-EXPLORER-II)) (push-end (logand #xf slot) slot-list)))) (defun mp-initialize-ok () "Checks if an MP whether or not to do the initalization" (or (not (mp-system-p)) (and (not (cool-boot-p)) (eql (get-processor-slot) (min (values-list (find-explorer-II-procs))))))) (export '(sys:lisp-top-level ;function ; DAB 04-24-89 sys:lisp-reinitialize ;function sys:lisp-top-level1 ;function sys:*break-bindings ;variable ) 'sys)