LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031458. :SYSTEM-TYPE :LOGICAL :VERSION 11. :TYPE "LISP" :NAME "LISP-REINITIALIZE" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758641519. :AUTHOR "REL3" :LENGTH-IN-BYTES 33478. :LENGTH-IN-BLOCKS 33. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                   ;;; -*- 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 (b)(3)(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,1987 Texas Instruments Incorporated  All Rights Reserved;;; 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.")(ADD-INITIALIZATION "Next boot is a cold boot" '(SETQ COLD-BOOTING T) '(:BEFORE-COLD));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*)));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.(DEFUN LISP-REINITIALIZE (&OPTIONAL (CALLED-BY-USER T)  &AUX (crash-list lisp-crash-list) (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 NILFILE-LOCAL-DECLARATIONS NILUNDO-DECLARATIONS-FLAG NILCOMPILER:QC-FILE-IN-PROGRESS NIL)  (Unless CALLED-BY-USER;;;    (If (FBOUNDP 'COMPILER:MA-RESET);Unload microcompiled defs, because they are gone!;;;(COMPILER:MA-RESET)); Hopefully manage to do this before any gets called.    (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.  (UNCLOSUREBIND '(READ-AREA))  (SETQ READ-AREA NIL)  (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* nileh:*condition-default-handlers* nileh:*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.  (SETQRUBOUT-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);  (MAPC (FUNCTION *EVAL) CRASH-LIST);  (SETQ LISP-CRASH-LIST NIL)  (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*)) (SETQ *TERMINAL-IO*     COLD-LOAD-STREAM       *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) (FUNCALL *TERMINAL-IO* :HOME-CURSOR)))  (SETQ TV:MOUSE-WINDOW NIL);This gets looked at before the mouse process is turned on  ;Switch to Common Lisp on Cold Boot once crash list is processed.;    (SETQ IBASE 10. BASE 10. *NOPOINT T);    (TURN-COMMON-LISP-ON)  ;; Find page partitions  (WHEN (AND COLD-BOOT (NOT CALLED-BY-USER))    ;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))    ;; 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*) (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 (EQ *terminal-io* cold-load-stream)    (send *terminal-io* :clear-screen)    (Initial-Screen-Heading))  (INITIALIZATIONS 'WARM-INITIALIZATION-LIST T)  (SETQ COLD-BOOTING NIL)  ;;  ;; 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 ((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)  (Initializations 'user-application-initialization-list));;; 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](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   ;;  Let's try starting out in Common Lisp mode.;  (SETQ *LISP-MODE* :ZETALISP;*READTABLE* STANDARD-READTABLE;*READER-SYMBOL-SUBSTITUTIONS* NIL;ZWEI:*DEFAULT-MAJOR-MODE* :ZETALISP   ;; remove this and you will die in TURN-ZETALISP-ON;)  (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 NILFILE-LOCAL-DECLARATIONS NILUNDO-DECLARATIONS-FLAG NILCOMPILER: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.  (SETQ READ-AREA NIL)  (NUMBER-GC-ON t)  (PKG-INITIALIZE)  (SETQ QLD-MINI-DONE nil)  (SETQ SCHEDULER-EXISTS NILCURRENT-PROCESS NILTV:WHO-LINE-PROCESS NILTV:LAST-WHO-LINE-PROCESS NIL)  ;Get the right readtable.  (OR (VARIABLE-BOUNDP INITIAL-READTABLE)      (SETQ INITIAL-READTABLE STANDARD-READTABLE;    STANDARD-READTABLE (COPY-READTABLE STANDARD-READTABLE);    *READTABLE* STANDARD-READTABLE    ))  (WHEN (VARIABLE-BOUNDP COMMON-LISP-READTABLE)    (UNLESS (VARIABLE-BOUNDP INITIAL-COMMON-LISP-READTABLE)      (SETQ INITIAL-COMMON-LISP-READTABLE COMMON-LISP-READTABLE;    COMMON-LISP-READTABLE (COPY-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* nileh:*condition-default-handlers* nileh:*condition-resume-handlers* nil);;;  ;And all kinds of randomness...  (init-random-variables);  ;Turn Zetalisp on for cold-band cold boot until after crash list processed;  (SETQ IBASE 8. BASE 8. *NOPOINT NIL);  (TURN-ZETALISP-ON)  ;; ************************** 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    ;;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)  (FUNCALL *TERMINAL-IO* :HOME-CURSOR)  (SETQ TV:MOUSE-WINDOW NIL);This gets looked at before the mouse process is turned on;  ;Switch to Common Lisp once crash list is processed.;  (SETQ IBASE 10. BASE 10. *NOPOINT T);  (TURN-COMMON-LISP-ON)  ;; Find page partitions  (setq *default-unit-from-mem* nil)  (initialize-disk-system)  (CONFIGURE-PAGE-BANDS)    ;; 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))    (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)))(Defun Hardware-Boot-Initializations (Cold-Boot)  ;; These 2 not needed.  Done in Cold-Hardware-Inits.  Changed 10/23/86, -ab ;;  (SETQ TV:TV-SLOT-NUMBER #x+F5);;  (FORWARD-VALUE-CELL 'TV:SIB-SLOT-NUMBER 'TV:TV-SLOT-NUMBER)  (If (Boundp 'Cold-Hardware-Initializations)      (Mapc #'*EVAL Cold-Hardware-Initializations));<<======= first use of interpreter  (When Cold-Boot    (INITIALIZE-NuBUS-SLOTS)                        ;; for ethernet, changed 10/23/86, -ab    ;; 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.    (WHEN (FBOUNDP '%boot-virtual-memory) (%boot-virtual-memory));; Changed 10/23/86, -ab    (WHEN (FBOUNDP '%initialize-tv-screen-memory)                ;; Changed 10/23/86, -ab      (%initialize-tv-screen-memory))    (CLEAR-SCREEN-BUFFER IO-SPACE-VIRTUAL-ADDRESS)    (%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  (SETQ REALLY-RUN-LIGHT (- %DISK-RUN-LIGHT 4))  )(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 thingsXR-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)  );;------------------------------------------------------------------------------;; 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 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 whosetype 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))))(DEFUN initialize-nubus-slots (); changed 10/23/86, -ab  "Reads NuBus slots F0-FF and dispatches on the board type."  (DO ((slot #xF0 (1+ slot)))      ((> slot #xFF))    (LET ((func (CDR (ASSOC (board-type slot) *Nubus-Board-Alist* :test #'EQUALP))))      (WHEN func       (funcall func slot)))))(Defun BOARD-TYPE (slot);RAF 3/5/85  ;; Returns the 3 char ID code from NuBus Config ROM in SLOT  (Let ((Type (make-string 3 :initial-element #\space))        (board-there? (integerp (%NuBus-Read-8B-Careful slot #xFFFF84))))    (when board-there?      (Dotimes (i 3)(let ((char (%NuBus-Read-8B-Careful slot (+ #xFFFF84 (ash i 2)))))  (setf (aref type i) (If (integerp char)  char  #\space)))))    type))(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 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));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-ARGUMENTSSYS:CELL-CONTENTS-ERROR SYS:WRONG-TYPE-ARGUMENTSYS: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)))) hash-table))  (floor    (*      (if (floatp (hash-table-rehash-threshold hash-table))  (hash-table-rehash-threshold hash-table) 0.7s0)      (- modulus 2))));; First, undo any WITHOUT-INTERRUPTS we did so that we don't cause the rehash;; to lock out everything else.  But do lock the hash tab