LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031381. :SYSTEM-TYPE :LOGICAL :VERSION 11. :TYPE "LISP" :NAME "COLD-LOAD-STREAM" :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 2758638808. :AUTHOR "REL3" :LENGTH-IN-BYTES 21575. :LENGTH-IN-BLOCKS 22. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    ;;; -*- Mode:Common-Lisp; Package:SI; Cold-load:T; Base:10 -*-;;;                           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;** (c) Copyright 1980 Massachusetts Institute of Technology **; Copyright (c) 1983,1987 Texas Instruments Incorporated  All Rights Reserved  ;;; This file contains those portions of the window system that need;;; to be in the cold-load, including the basic keyboard software and;;; the cold load stream.;;; Note that this file has to be in the SYSTEM-INTERNALS (SI) package;;; rather than TV because it is part of the cold-load.;compare these with SI:PROCESSOR-TYPE-CODE to conditionalize code for a specific machine.(DEFCONSTANT CADR-TYPE-CODE 1  "The value which SI:PROCESSOR-TYPE-CODE has when you run on a CADR.")(DEFCONSTANT LAMBDA-TYPE-CODE 2  "The value which SI:PROCESSOR-TYPE-CODE has when you run on a LAMBDA.")(DEFCONSTANT CHAPARRAL-TYPE-CODE 3  "The value which SI:PROCESSOR-TYPE-CODE has when you run on a CHAPARRAL.")(DEFCONSTANT EXPLORER-TYPE-CODE 3  "The value which SI:PROCESSOR-TYPE-CODE has when you run on a EXPLORER.")(DEFVAR TV:COLD-LOAD-STREAM-OWNS-KEYBOARD NIL  "Non-NIL means something reading from cold load stream, so turn off KBD-PROCESS.")(DEFVAR TV:MORE-PROCESSING-GLOBAL-ENABLE t)(DEFVAR TV:DEFAULT-BACKGROUND-STREAM 'TV:BACKGROUND-STREAM)(DEFVAR TV:KBD-LAST-ACTIVITY-TIME 0  "Time user last typed a key or clicked mouse.");;; The following constants are used to specify how pixels being drawn are;;; to be combined with existing pixels on the screen (or in an array if one;;; is using BITBLT).  The word ALU is an abbreviation for the words;;; Arithmetic Logic Unit.  The number is a 4 bit binary number which is the;;; result of applying the two input bits to a truth table.  For example,;;; TV:ALU-ANDCA is 2 which is 0010 in binary.  Converting this to a truth;;; table one gets:;;; ;;;               New pixel values;;; ;;; ANDCA | 0   1;;; ------+-------;;;    Screen   0  | 0   0 ;;;    Contents      |;;;    1  | 1   0;;; ;;; Note that the truth table is constructed from the binary number, filling;;; the first row with the 2 leading binary digits and the second row with;;; the 2 low order binary digits.  A total of 16 ALU constants are possible;;; but only the following six seem reasonable.(DEFCONSTANT TV:ALU-SETA  5 "Alu function for copying bits to the destination.")(DEFCONSTANT TV:ALU-XOR   6 "Alu function for flipping bits in destination.")(DEFCONSTANT TV:ALU-ANDCA 2 "Alu function for clearing bits in destination.")(DEFCONSTANT TV:ALU-IOR   7 "Alu function for setting bits in destination.")(DEFCONSTANT TV:ALU-SETZ  0 "Alu function for setting bits in the destination to zero.")(DEFCONSTANT TV:ALU-AND   1 "Alu function to AND source and destination bits together.");;; Call this when the state of a process may have changed.;;; In the cold-load because called by process stuff, loaded before window stuff.(DEFUN TV:WHO-LINE-PROCESS-CHANGE (PROC)  (AND (FBOUNDP 'TV:WHO-LINE-RUN-STATE-UPDATE)       (EQ PROC TV:LAST-WHO-LINE-PROCESS)       (TV:WHO-LINE-RUN-STATE-UPDATE)));;; Now including some flavor support in the kernel -sdk  3/19/86;;;;;; Copy from SYS2;FLAVOR, needed for setting up the sync program;;;(DEFSUBST SYMEVAL-IN-INSTANCE (INSTANCE PTR);;;  "Return the value of instance variable PTR in INSTANCE.;;;PTR can be a pointer to a value cell instead of a symbol.;;;Error if PTR does not work out to be a symbol which is an;;;instance variable in INSTANCE.";;;  (CONTENTS (LOCATE-IN-INSTANCE INSTANCE PTR)))(Defflavor COLD-LOAD-STREAM  (ARRAY;The array into which bits go      *** ucode knows index 1   LOCATIONS-PER-LINE;Number of words in a screen line  *** ucode knows index 2   HEIGHT;Height of screen   CURSOR-X;Current x position   CURSOR-Y;Current y position   FONT;The one and only font   CHAR-WIDTH;Width of a character   LINE-HEIGHT;Height of line, including vsp   BUFFER;The hardward buffer location   CONTROL-ADDRESS;Hardware controller address   UNRCHF;For :UNTYI   RUBOUT-HANDLER-BUFFER;For :RUBOUT-HANDLER   xxxx;this ivar not used but needed as placeholder because below   WIDTH;Width of screen                   *** ucode knows index 14.   )  () :ordered-instance-variables)(DEFMETHOD (COLD-LOAD-STREAM :PRINT-SELF) (STREAM &REST IGNORE)  (FORMAT STREAM "#<~A ~O>" (TYPE-OF SELF) (%POINTER SELF))) (DEFMETHOD (COLD-LOAD-STREAM :INIT) (PLIST)  (OR (BOUNDP 'KBD-TRANSLATE-TABLE)      (KBD-INITIALIZE))  (OR (BOUNDP 'TV:DEFAULT-SCREEN)      (SETQ TV:DEFAULT-SCREEN SELF))  (SETQ CURSOR-X 0 CURSOR-Y 0FONT (OR (GET PLIST :FONT) FONTS:CPTFONT)UNRCHF NILWIDTH (GET PLIST :WIDTH)HEIGHT (GET PLIST :HEIGHT)BUFFER (GET PLIST :BUFFER)CONTROL-ADDRESS (GET PLIST :CONTROL-ADDRESS)ARRAY (MAKE-ARRAY (LIST HEIGHT WIDTH) :TYPE ART-1B :DISPLACED-TO BUFFER)LOCATIONS-PER-LINE (TRUNCATE WIDTH 32.)CHAR-WIDTH (TV:FONT-CHAR-WIDTH FONT)LINE-HEIGHT (+ 2 (TV:FONT-CHAR-HEIGHT FONT))RUBOUT-HANDLER-BUFFER (MAKE-ARRAY 512. :TYPE ART-STRING :LEADER-LIST '(0 0))))(defmethod (sys:cold-load-stream :line-in) (ignore)  (let ((buf (make-array 64. :element-type 'string-char :fill-pointer 0)))    (setf (fill-pointer buf) 0)    (values  buf    (do ((tem (send self :tyi ()) (send self :tyi ())))((or (null tem) (= tem #\NEWLINE) (= tem #\END)) (adjust-array buf (array-active-length buf)) (null tem))      (vector-push-extend tem buf)))))(DEFMETHOD (COLD-LOAD-STREAM :CLEAR-EOL) ()  (LET ((CURRENTLY-PREPARED-SHEET SELF))    (%DRAW-RECTANGLE (- WIDTH CURSOR-X) LINE-HEIGHT CURSOR-X CURSOR-Y TV:ALU-ANDCA SELF)))(DEFMETHOD (COLD-LOAD-STREAM :READ-CURSORPOS) (&OPTIONAL (UNITS :PIXEL))   (let ((X CURSOR-X) (Y CURSOR-Y))     (when (EQ UNITS :CHARACTER)       (SETQ X (TRUNCATE X CHAR-WIDTH)     Y (TRUNCATE Y LINE-HEIGHT)))     (VALUES X Y)))(DEFMETHOD (COLD-LOAD-STREAM :SET-CURSORPOS) (X Y &OPTIONAL (UNITS :PIXEL))  (AND (NUMBERP UNITS);***CROCK***, flush when format fixed       (PSETQ UNITS X X Y Y UNITS))  (AND (EQ UNITS :CHARACTER)       (SETQ X (* X CHAR-WIDTH)     Y (* Y LINE-HEIGHT)))  (SETQ CURSOR-X (MAX 0 (MIN WIDTH X))CURSOR-Y (MAX 0 (MIN (- HEIGHT LINE-HEIGHT) Y))))(DEFMETHOD (COLD-LOAD-STREAM :HOME-CURSOR) ()  (SETQ CURSOR-X 0 CURSOR-Y 0))(DEFMETHOD (COLD-LOAD-STREAM :HANDLE-EXCEPTIONS) ())(DEFMETHOD (COLD-LOAD-STREAM :TYO) (CH)  (LET ((CURRENTLY-PREPARED-SHEET SELF)(ch-code (char-code ch)))    (COND ((< CH-code #o200)   (LET ((CHAR-WIDTHS (TV:FONT-CHAR-WIDTH-TABLE FONT)) (FIT-ENTRY (TV:FONT-INDEXING-TABLE FONT)) (DELTA-X))     (SETQ DELTA-X (IF CHAR-WIDTHS (AREF CHAR-WIDTHS CH-CODE) (TV:FONT-CHAR-WIDTH FONT)))     (AND (> (+ CURSOR-X DELTA-X) WIDTH);End of line exception  (FUNCALL SELF :TYO #\CR))     (IF (NULL FIT-ENTRY);; (%DRAW-CHAR FONT CH-CODE CURSOR-X CURSOR-Y TV:ALU-IOR SELF) (%DRAW-CHARACTER FONT CH-CODE DELTA-X CURSOR-X CURSOR-Y TV:ALU-IOR SELF) ;;  This is a character wider than 32 bits, so it's broken into smaller chunks ;;  so %draw-char(acter) can handle it.  We're using font-raster-width for the ;;  width because it will be wide enough for all cases, though maybe too wide ;;  for some.  - pf, Nov 4, 1986 (DO ((CH (AREF FIT-ENTRY CH-CODE) (1+ CH))      (LIM (AREF FIT-ENTRY (1+ CH-CODE)))      (XPOS CURSOR-X (+ XPOS (TV:FONT-RASTER-WIDTH FONT))))     ((= CH LIM));;   (%DRAW-CHAR FONT CH-CODE XPOS CURSOR-Y TV:ALU-IOR SELF)   (%DRAW-CHARACTER FONT CH-CODE (TV:FONT-RASTER-WIDTH FONT) XPOS CURSOR-Y TV:ALU-IOR SELF)))     (SETQ CURSOR-X (+ CURSOR-X DELTA-X))))  ((= CH #\CR)   (SETQ CURSOR-X 0 CURSOR-Y (+ CURSOR-Y LINE-HEIGHT))   (COND ((>= CURSOR-Y HEIGHT);End-of-page exception  (SETQ CURSOR-Y 0)) ((>= CURSOR-Y (- HEIGHT (* 2 LINE-HEIGHT)));MORE exception  (FUNCALL SELF :CLEAR-EOL);In case wholine is there  (WHEN TV:MORE-PROCESSING-GLOBAL-ENABLE    (FUNCALL SELF :STRING-OUT "**MORE**")    (FUNCALL SELF :TYI))  (SETQ CURSOR-X 0)  (FUNCALL SELF :CLEAR-EOL)  (SETQ CURSOR-Y 0)))   (FUNCALL SELF :CLEAR-EOL))  ((= CH #\TAB)   (DOTIMES (I (- 8 (zlc:remainder (TRUNCATE CURSOR-X CHAR-WIDTH) 8)))     (FUNCALL SELF :TYO #\SP)))  ((AND (< CH-CODE #o240) (BOUNDP 'FONTS:5X5))   ;; This won't work in the initial cold-load environment, hopefully no one   ;; will touch those keys then, but if they do we just type nothing.   ;; This code is like SHEET-DISPLAY-LOSENGED-STRING   (LET* ((CHNAME (symbol-name (CAR (RASSOC CH-CODE XR-SPECIAL-CHARACTER-NAMES))))  (CHWIDTH (+ (* (ARRAY-ACTIVE-LENGTH CHNAME) 6) 10.)))     (AND (> (+ CURSOR-X CHWIDTH) WIDTH);Won't fit on line  (FUNCALL SELF :TYO #\CR))     ;; Put the string then the box around it     (LET ((X0 CURSOR-X)   (Y0 (1+ CURSOR-Y))   (X1 (+ CURSOR-X (1- CHWIDTH)))   (Y1 (+ CURSOR-Y 9)))       (DO ((X (+ X0 5) (+ X 6))    (I 0 (1+ I))    (N (ARRAY-ACTIVE-LENGTH CHNAME)))   ((>= I N));; (%DRAW-CHAR FONTS:5X5 (aref chname i) X (+ Y0 2) TV:ALU-IOR SELF) ;;  Since 5x5 is probably going to stay fixed-width, use the font-char-width.  - pf, Nov 4, 1986 (%DRAW-CHARACTER FONTS:5X5 (AREF CHNAME I) (TV:FONT-CHAR-WIDTH FONTS:5X5) X (+ Y0 2) TV:ALU-IOR SELF))       (%DRAW-RECTANGLE (- CHWIDTH 8) 1 (+ X0 4) Y0 TV:ALU-IOR SELF)       (%DRAW-RECTANGLE (- CHWIDTH 8) 1 (+ X0 4) Y1 TV:ALU-IOR SELF)       (compiler2:%DRAW-SHADED-TRIANGLE  X0 (+ Y0 4) (+ X0 3) (1+ Y0)(+ X0 3) (1+ Y0) TV:ALU-IOR t t T nil SELF)       (compiler2:%DRAW-SHADED-TRIANGLE  (1+ X0) (+ Y0 5) (+ X0 3) (1- Y1)(+ X0 3) (1- Y1) TV:ALU-IOR t t T nil SELF)       (compiler2:%DRAW-SHADED-TRIANGLE  X1 (+ Y0 4) (- X1 3) (1+ Y0)(- X1 3) (1+ Y0) TV:ALU-IOR t t T nil SELF)       (compiler2:%DRAW-SHADED-TRIANGLE  (1- X1) (+ Y0 5) (- X1 3) (1- Y1)(- X1 3) (1- Y1) TV:ALU-IOR t t T nil SELF)       (SETQ CURSOR-X (1+ X1))))))    CH))(DEFMETHOD (COLD-LOAD-STREAM :CLEAR-SCREEN) ()  (SETQ CURSOR-X 0 CURSOR-Y 0)  (LET ((CURRENTLY-PREPARED-SHEET SELF))    (%DRAW-RECTANGLE WIDTH HEIGHT 0 0 TV:ALU-ANDCA SELF)))(DEFMETHOD (COLD-LOAD-STREAM :FRESH-LINE) ()  (IF (ZEROP CURSOR-X) (FUNCALL SELF :CLEAR-EOL)      (FUNCALL SELF :TYO #\CR)))(DEFMETHOD (COLD-LOAD-STREAM :STRING-OUT) (STRING &OPTIONAL (START 0) END)  (DO ((I START (1+ I))       (END (OR END (ARRAY-ACTIVE-LENGTH STRING))))      ((>= I END))    (FUNCALL SELF :TYO (AREF STRING I)))) (DEFMETHOD (COLD-LOAD-STREAM :LINE-OUT) (STRING &OPTIONAL (START 0) END)  (FUNCALL SELF :STRING-OUT STRING START END)  (FUNCALL SELF :TYO #\CR))(DEFMETHOD (COLD-LOAD-STREAM :UNTYI) (CH)  (IF RUBOUT-HANDLER      (DECF (ARRAY-LEADER RUBOUT-HANDLER-BUFFER 1))    (SETQ UNRCHF CH)))(DEFMETHOD (COLD-LOAD-STREAM :LISTEN) ()  (OR UNRCHF      (DO () ((NOT (KBD-HARDWARE-CHAR-AVAILABLE)) NIL)(AND (SETQ UNRCHF (KBD-CONVERT-TO-SOFTWARE-CHAR (KBD-GET-HARDWARE-CHAR)))     (RETURN T)))))(DEFMETHOD (COLD-LOAD-STREAM :ANY-TYI) (&OPTIONAL IGNORE)  (FUNCALL COLD-LOAD-STREAM :TYI))(DEFMETHOD (COLD-LOAD-STREAM :ANY-TYI-NO-HANG) ()  (FUNCALL COLD-LOAD-STREAM :TYI-NO-HANG))(DEFMETHOD (COLD-LOAD-STREAM :TYI) (&OPTIONAL IGNORE &AUX IDX)  (declare (special eh:*reading-command* eh:*abort-object*))  (without-interrupts    (COND ((NOT RUBOUT-HANDLER)   (IF UNRCHF       (PROG1 UNRCHF (SETQ UNRCHF NIL))       (DO-FOREVER (COLD-LOAD-STREAM-WAIT-FOR-CHAR) (LET ((CHAR (KBD-CONVERT-TO-SOFTWARE-CHAR (KBD-GET-HARDWARE-CHAR))))   (CASE CHAR (NIL);Unreal character (#\BREAK (BREAK "BREAK")) ;; Horrible kludge to make the debugger usable in ;; the cold-load stream.  How could this reasonably be done? (#\ABORT (IF EH:*READING-COMMAND* (RETURN CHAR)      (SIGNAL EH:*ABORT-OBJECT*))) (OTHERWISE (RETURN CHAR)))))))  ((> (ARRAY-LEADER RUBOUT-HANDLER-BUFFER 0)      (SETQ IDX (ARRAY-LEADER RUBOUT-HANDLER-BUFFER 1)))   (STORE-ARRAY-LEADER (1+ IDX) RUBOUT-HANDLER-BUFFER 1)   (AREF RUBOUT-HANDLER-BUFFER IDX))  (T    (COLD-LOAD-STREAM-RUBOUT-HANDLER)))))(DEFMETHOD (COLD-LOAD-STREAM :TYI-NO-HANG) ()  (AND (FUNCALL SELF :LISTEN)       (FUNCALL SELF :TYI)))(DEFVAR COLD-LOAD-STREAM-BLINKER-TIME 15.)(DEFVAR COLD-LOAD-STREAM-WAIT-TIME 1000.)(DEFUN COLD-LOAD-STREAM-WAIT-FOR-CHAR ()  (declare (:self-flavor cold-load-stream))  (DO ((PHASE NIL)       (BLINKER-COUNT 0)       (CURRENTLY-PREPARED-SHEET SELF))      ((KBD-HARDWARE-CHAR-AVAILABLE)       (AND PHASE    (%DRAW-RECTANGLE (TV:FONT-BLINKER-WIDTH FONT) (TV:FONT-BLINKER-HEIGHT FONT) CURSOR-X     CURSOR-Y TV:ALU-XOR SELF)))    (COND ((MINUSP (SETQ BLINKER-COUNT (1- BLINKER-COUNT)))   (%DRAW-RECTANGLE (TV:FONT-BLINKER-WIDTH FONT) (TV:FONT-BLINKER-HEIGHT FONT) CURSOR-X     CURSOR-Y TV:ALU-XOR SELF)   (SETQ PHASE (NOT PHASE) BLINKER-COUNT COLD-LOAD-STREAM-BLINKER-TIME)))    (DOTIMES (I COLD-LOAD-STREAM-WAIT-TIME))))(DEFVAR RUBOUT-HANDLER-OPTIONS NIL  "Within rubout handler, the options supplied as first arg to:RUBOUT-HANDLER operation.")(DEFVAR COLD-LOAD-STREAM-ACTIVATION-CHARACTER);;; Give a single character, or do rubout processing, throws to RUBOUT-HANDLER on editing.(DEFUN COLD-LOAD-STREAM-RUBOUT-HANDLER ()  (declare (:self-flavor cold-load-stream))  (WHEN (= (ARRAY-LEADER RUBOUT-HANDLER-BUFFER 1) #o7777777)    (SETF (ARRAY-LEADER RUBOUT-HANDLER-BUFFER 1) 0)    (THROW 'RUBOUT-HANDLER T))  (IF COLD-LOAD-STREAM-ACTIVATION-CHARACTER      (RETURN-FROM COLD-LOAD-STREAM-RUBOUT-HANDLER(PROG1 COLD-LOAD-STREAM-ACTIVATION-CHARACTER       (SETQ COLD-LOAD-STREAM-ACTIVATION-CHARACTER NIL))))  (DO ((CH)       (RUBBED-OUT-SOME)       (LEN)       (RUBOUT-HANDLER NIL)       (PASS-THROUGH (CDR (ASSOC :PASS-THROUGH (THE LIST RUBOUT-HANDLER-OPTIONS) :TEST #'EQ)))       (EDITING-COMMAND (CDR (ASSOC :EDITING-COMMAND (THE LIST RUBOUT-HANDLER-OPTIONS) :TEST #'EQ)))       (DO-NOT-ECHO (CDR (ASSOC :DO-NOT-ECHO (THE LIST RUBOUT-HANDLER-OPTIONS) :TEST #'EQ)))       (COMMAND-HANDLER (ASSOC :COMMAND (THE LIST RUBOUT-HANDLER-OPTIONS) :TEST #'EQ))       (ACTIVATION-HANDLER (ASSOC :ACTIVATION (THE LIST RUBOUT-HANDLER-OPTIONS) :TEST #'EQ))       (INITIAL-INPUT (CADR (ASSOC :INITIAL-INPUT (THE LIST RUBOUT-HANDLER-OPTIONS) :TEST #'EQ))))      (NIL)    (when initial-input      (let ((length (length initial-input)))(funcall self :string-out initial-input)(if (< (array-length rubout-handler-buffer) length)    (setq rubout-handler-buffer (adjust-array rubout-handler-buffer (+ length length))))(copy-array-portion initial-input 0 length rubout-handler-buffer 0 length)(setf (fill-pointer rubout-handler-buffer ) length)(setq initial-input nil);;gross kludge.(setq rubout-handler-options (remove-if-not #'(lambda (x) (eq (car x) :initial-input)) rubout-handler-options))(setq rubbed-out-some t)))    (SETQ CH (FUNCALL SELF :TYI))    (COND ((AND COMMAND-HANDLER(APPLY (CADR COMMAND-HANDLER) CH (CDDR COMMAND-HANDLER)))     (SETF (ARRAY-LEADER RUBOUT-HANDLER-BUFFER 1) 0)     (THROW 'TV:RETURN-FROM-RUBOUT-HANDLER     (VALUES       `(:COMMAND ,CH 1)       :COMMAND)))  ;; Don't touch this character, just return it to caller.  ((OR (MEMBER CH EDITING-COMMAND :TEST #'char=)       (ASSoc-CAREFUL CH EDITING-COMMAND))   ;; Cause rubout handler rescan next time the user does :TYI.   (IF RUBBED-OUT-SOME       (SETF (ARRAY-LEADER RUBOUT-HANDLER-BUFFER 1) #o7777777))   (RETURN CH))  ((AND (NOT (OR (MEMBER CH DO-NOT-ECHO :TEST #'char=) (MEMBER CH PASS-THROUGH :TEST #'char=) (AND ACTIVATION-HANDLER      (APPLY (CADR ACTIVATION-HANDLER) CH (CDDR ACTIVATION-HANDLER)))))(OR (LDB-TEST %%KBD-CONTROL-META CH)    (MEMBER CH '(#\RUBOUT #\CLEAR-INPUT #\CLEAR-SCREEN #\DELETE) :TEST #'char=)))   (COND     ((= CH #\CLEAR-INPUT);CLEAR flushes all buffered input      (STORE-ARRAY-LEADER 0 RUBOUT-HANDLER-BUFFER 0)      (SETQ RUBBED-OUT-SOME T);Will need to throw out      (FUNCALL SELF :TYO CH);Echo and advance to new line      (FUNCALL SELF :TYO #\CR))     ((OR (= CH #\FORM) (= CH #\VT));Retype buffered input      (FUNCALL SELF :TYO CH);Echo it      (IF (= CH #\FORM) (FUNCALL SELF :CLEAR-SCREEN) (FUNCALL SELF :TYO #\CR))      (LET ((PROMPT (CADR (OR (ASSOC :REPROMPT (THE LIST RUBOUT-HANDLER-OPTIONS) :TEST #'EQ)      (ASSOC :PROMPT (THE LIST RUBOUT-HANDLER-OPTIONS) :TEST #'EQ)))))(AND PROMPT     (IF (STRINGP PROMPT) (PRINC PROMPT SELF)       (FUNCALL PROMPT SELF CH))))      (FUNCALL SELF :STRING-OUT RUBOUT-HANDLER-BUFFER))     ((= CH #\RUBOUT)      (COND ((NOT (ZEROP (SETQ LEN (ARRAY-LEADER RUBOUT-HANDLER-BUFFER 0))))     (SETQ CURSOR-X (MAX 0 (- CURSOR-X CHAR-WIDTH)))     (FUNCALL SELF :CLEAR-EOL)     (STORE-ARRAY-LEADER (SETQ LEN (1- LEN)) RUBOUT-HANDLER-BUFFER 0)     (SETQ RUBBED-OUT-SOME T)     (COND ((ZEROP LEN)    (STORE-ARRAY-LEADER 0 RUBOUT-HANDLER-BUFFER 1)    (THROW 'RUBOUT-HANDLER T))))))     ((LDB-TEST %%KBD-CONTROL-META CH)      (KBD-CONVERT-BEEP)))   (COND ((AND (ZEROP (FILL-POINTER RUBOUT-HANDLER-BUFFER))       (ASSOC :FULL-RUBOUT (THE LIST RUBOUT-HANDLER-OPTIONS) :TEST #'EQ))  (SETF (ARRAY-LEADER RUBOUT-HANDLER-BUFFER 1) 0)  (THROW 'RUBOUT-HANDLER T))))  (T;It's a self-inserting character   (COND ((MEMBER CH DO-NOT-ECHO :TEST #'char=)  (SETQ COLD-LOAD-STREAM-ACTIVATION-CHARACTER CH)) ((AND ACTIVATION-HANDLER       (APPLY (CADR ACTIVATION-HANDLER) CH (CDDR ACTIVATION-HANDLER)))  (SETQ CH `(:ACTIVATION ,CH 1))  (SETQ COLD-LOAD-STREAM-ACTIVATION-CHARACTER CH)) (T  (IF (LDB-TEST %%KBD-CONTROL-META CH);in :pass-through, but had bucky bits      (KBD-CONVERT-BEEP)    (FUNCALL SELF :TYO CH)    (VECTOR-PUSH-EXTEND CH RUBOUT-HANDLER-BUFFER))))   (COND ((AND (ATOM CH)       (LDB-TEST %%KBD-CONTROL-META CH)));do nothing (RUBBED-OUT-SOME  (STORE-ARRAY-LEADER 0 RUBOUT-HANDLER-BUFFER 1)  (THROW 'RUBOUT-HANDLER T)) (T  (STORE-ARRAY-LEADER (ARRAY-LEADER RUBOUT-HANDLER-BUFFER 0)      RUBOUT-HANDLER-BUFFER 1)  (SETQ COLD-LOAD-STREAM-ACTIVATION-CHARACTER NIL)  (RETURN CH)))))))(DEFMETHOD (COLD-LOAD-STREAM :RUBOUT-HANDLER)     (RUBOUT-HANDLER-OPTIONS FUNCTION &REST ARGS)  (STORE-ARRAY-LEADER 0 RUBOUT-HANDLER-BUFFER 0)  (STORE-ARRAY-LEADER 0 RUBOUT-HANDLER-BUFFER 1)  (MULTIPLE-VALUE-BIND (PROMPT-STARTING-X PROMPT-STARTING-Y)      (FUNCALL COLD-LOAD-STREAM :READ-CURSORPOS)    (LET ((PROMPT (CADR (ASSOC :PROMPT (THE LIST RUBOUT-HANDLER-OPTIONS) :TEST #'EQ))))      (AND PROMPT;Prompt if desired   (IF (STRINGP PROMPT)       (PRINC PROMPT SELF)     (FUNCALL PROMPT SELF NIL))))    (CATCH 'TV:RETURN-FROM-RUBOUT-HANDLER      (DO ((RUBOUT-HANDLER T);Establish rubout handler   (INHIBIT-SCHEDULING-FLAG T);Make sure all chars come here   (COLD-LOAD-STREAM-ACTIVATION-CHARACTER NIL))  (NIL)(CATCH 'RUBOUT-HANDLER;Throw here when rubbing out  (CONDITION-CASE (ERROR)      (RETURN (APPLY FUNCTION ARGS));Call read type function    (PARSE-ERROR     (TERPRI SELF)     (PRINC ">>ERROR: " SELF)     (SEND ERROR :REPORT SELF)     (TERPRI SELF)     (FUNCALL SELF :STRING-OUT RUBOUT-HANDLER-BUFFER);On error, retype buffered     (DO () (NIL) (FUNCALL SELF :TYI)))));and force user to edit it;;Maybe return when user rubs all the way back(AND (ZEROP (ARRAY-LEADER RUBOUT-HANDLER-BUFFER 0))     (LET ((FULL-RUBOUT-OPTION (ASSOC :FULL-RUBOUT (THE LIST RUBOUT-HANDLER-OPTIONS) :TEST #'EQ)))       (WHEN FULL-RUBOUT-OPTION ;; Get rid of the prompt, if any. (FUNCALL COLD-LOAD-STREAM :SET-CURSORPOS PROMPT-STARTING-X PROMPT-STARTING-Y) (FUNCALL COLD-LOAD-STREAM :CLEAR-EOL) (RETURN (VALUES NIL (CADR FULL-RUBOUT-OPTION))))))))))(DEFMETHOD (COLD-LOAD-STREAM :CLEAR-INPUT) ()  (SETQ UNRCHF NIL)  (STORE-ARRAY-LEADER 0 RUBOUT-HANDLER-BUFFER 0)  (STORE-ARRAY-LEADER 0 RUBOUT-HANDLER-BUFFER 1)  (DO () ((NOT (KBD-HARDWARE-CHAR-AVAILABLE)))    ;;Call the convert routine for up-shifts too    (KBD-CONVERT-TO-SOFTWARE-CHAR (KBD-GET-HARDWARE-CHAR))))(defmethod (cold-load-stream :Beep) (&rest ignore)  (si:%Nubus-Write    tv:tv-slot-number    SI:%Sib-Tv-Video-Attribute    (Logxor (Dpb -1 SI:%%Sib-Tv-Video-Black-On-White 0)    (si:%Nubus-Read Tv:tv-slot-number  SI:%Sib-Tv-Video-Attribute)))  (dotimes (i 320.) nil)  (si:%Nubus-Write    tv:tv-slot-number    SI:%Sib-Tv-Video-Attribute    (Logxor (Dpb -1 SI:%%Sib-Tv-Video-Black-On-White 0)    (si:%Nubus-Read Tv:tv-slot-number  SI:%Sib-Tv-Video-Attribute))))(compile-flavor-methods cold-load-stream)(DEFPARAMETER COLD-LOAD-STREAM-INIT-PLIST  `(nil     :WIDTH 1024.     :HEIGHT 808.     :BUFFER ,IO-SPACE-VIRTUAL-ADDRESS     )) (Defvar COLD-LOAD-STREAM nil)(PROGN (SETQ COLD-LOAD-STREAM (%MAKE-INSTANCE 'COLD-LOAD-STREAM))       (FUNCALL COLD-LOAD-STREAM :INIT COLD-LOAD-STREAM-INIT-PLIST));Avoid lossage when processes are in use but window system is not loaded yet.(OR (FBOUNDP 'TV:BACKGROUND-STREAM)    (FSET 'TV:BACKGROUND-STREAM COLD-LOAD-STREAM))     ;; FOR THE CODE BELOW     (%P-DPB        DTP-FIX %%Q-DATA-TYPE FREED-ARRAY-LOCN)))  (COND ((<= (SETQ freed-array-length   (1- (- current-data-length new-data-length)))     %array-max-simple-index-length) (%P-STORE-TAG-AND-POINTER freed-array-locn dtp-array-header    (+ ;; not on simple array-dim-mult     art-32b     freed-array-length)) (%P-DPB 1 %%array-simple-bit freed-array-locn))(t (%P-STORE-TAG-AND-POINTER freed-array-locn dtp-array-header      (+ array-dim-mult art-32barray-long-length-flag))   (%P-STORE-CONTENTS-OFFSET (1- freed-array-length)     freed-array-locn     1)))))   (IF (ZEROP long-array-bit)       (IF (ZEROP (%P-LDB %%array-simple-bit array))   (%P-DPB new-index-length %%array-index-length-if-short array)   (%P-DPB new-index-length %%array-index-length-if-simple array))       (%P-STORE-CONTENTS-OFFSET new-index-leng