;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for MEDIUM-RESOLUTION-COLOR version 3.2 ;;; Reason: ;;; select-processor mods for :EXPLORER ;;; Written 10-Apr-86 14:00:15 by GJC (George Carrette) at site LMI Cambridge ;;; while running on Laurie Anderson from band 2 ;;; with Experimental System 110.121, Experimental Lambda-Diag 7.0, Experimental Local-File 68.1, Experimental FILE-Server 18.2, Experimental Unix-Interface 9.0, Experimental ZMail 65.7, Experimental Object Lisp 3.0, Experimental Tape 6.0, Experimental Site Data Editor 3.1, Experimental Tiger 24.0, Experimental KERMIT 31.2, Experimental Window-Maker 1.0, Experimental Gateway 4.0, Experimental TCP-Kernel 39.5, Experimental TCP-User 62.5, Experimental TCP-Server 45.5, Experimental MEDIUM-RESOLUTION-COLOR 3.0, Experimental MICRO-COMPILATION-TOOLS 3.0, microcode 1408, SDU ROM 102, Alpha III Cambridge. ;; *** Note: *** ;; You may lose because the buffer has no readtable attribute. ;; ************* ; From file DJ: L.VIDEO-DEVICE.GREY; GREY-INIT.LISP#25 at 10-Apr-86 14:00:16 #8R GREY#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GREY"))) (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; GREY-INIT  " (DEFUN STANDARD-GREY-INITIALIZATION-PROCEDURE () "Set up screens,etc. provided board is present and screens not set up. Try to read and write ctl bit 7." (select-processor (:explorer (or (medium-color-slot-on-explorer) (cerror "probably lose big" "this machine has no LMI color board"))) ((:lambda :cadr))) (select-processor (:cadr (USE-LAM)) ((:lambda :explorer) (use-lam-direct) (grey-exists-and-if-so-downloaded-p) (screen-initialize))) ;;setup some variables for ease of use (setq grey-screen-array (get-grey-screen-array)) (setq grey-screen-plane-array0 (get-grey-screen-plane-array0)) (setq grey-screen-plane-array1 (get-grey-screen-plane-array1)) (setq grey-screen-plane-array2 (get-grey-screen-plane-array2)) (setq grey-screen-plane-array3 (get-grey-screen-plane-array3)) (setq grey-screen-plane-array4 (get-grey-screen-plane-array4)) (setq grey-screen-plane-array5 (get-grey-screen-plane-array5)) (setq grey-screen-plane-array6 (get-grey-screen-plane-array6)) (setq grey-screen-plane-array7 (get-grey-screen-plane-array7)) (select-processor (:cadr) ((:lambda :explorer) ;; this just to show that this procedure has worked. (straight-map) (draw-frame)))) )) ; From modified file DJ: L.VIDEO-DEVICE.GREY; GREY-INIT.LISP#25 at 10-Apr-86 14:02:06 #8R GREY#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GREY"))) (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; GREY-INIT  " (defvar *medium-color-slot-on-explorer* nil) )) ; From modified file DJ: L.VIDEO-DEVICE.GREY; GREY-INIT.LISP#25 at 10-Apr-86 14:02:09 #8R GREY#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GREY"))) (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; GREY-INIT  " (add-initialization "reset color board slot" '(setq *medium-color-slot-on-explorer* nil) '(:before-cold)) )) ; From modified file DJ: L.VIDEO-DEVICE.GREY; GREY-INIT.LISP#25 at 10-Apr-86 14:02:11 #8R GREY#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GREY"))) (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; GREY-INIT  " (defun grey-exists-and-if-so-downloaded-p (&optional screen) screen (select-processor (:lambda (send (SEND (fs:parse-pathname "MEDIUM-RESOLUTION-COLOR:") :host) ;;this gets the shared-device host to ;;allocate the color board if it isn't ;;already allocated. That object calls ;;the download-grey-board. It setq's ;;grey-prom-plist nil, which is also done ;;by the download. -dexter 2/17/85 :allocate-if-easy)) (:explorer ;; with no shared-device stuff on explorer we find out directly from lisp ;; using nubus-read on the various slots available. (cond ((eq *medium-color-slot-on-explorer* :none) ()) (*medium-color-slot-on-explorer*) ((setq *medium-color-slot-on-explorer* (medium-color-slot-on-explorer)) (download-grey-board) t) ('else (setq *medium-color-slot-on-explorer* :none) ()))) (:cadr (cerror "lose" "lose")))) )) ; From modified file DJ: L.VIDEO-DEVICE.GREY; GREY-INIT.LISP#25 at 10-Apr-86 14:02:16 #8R GREY#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GREY"))) (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; GREY-INIT  " (defun read-nubus-prom-word (slot j) "Read the highest 512 words" (SI:%NUBUS-READ-SAFE (DPB #o17 #o0404 SLOT) (LSH (+ #o17777000 J) 2))) )) ; From modified file DJ: L.VIDEO-DEVICE.GREY; GREY-INIT.LISP#25 at 10-Apr-86 14:02:21 #8R GREY#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GREY"))) (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; GREY-INIT  " (defun read-nubus-prom-string (slot) (WITH-OUTPUT-TO-STRING (S) (DO ((J 0 (+ J 1)) (C)) ((= J 512.)) (SETQ C (read-nubus-prom-word slot j)) (if (null c) (return nil)) (SETQ C (LOGAND #O177 C)) (IF (NOT (MEMQ C '(0 #O177))) (SEND S ':TYO C))))) )) ; From modified file DJ: L.VIDEO-DEVICE.GREY; GREY-INIT.LISP#25 at 10-Apr-86 14:02:26 #8R GREY#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GREY"))) (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; GREY-INIT  " (defun medium-color-slot-on-explorer (&optional force-slot) "Look on NuBus for GREY board Return NIL if no board found" (do ((slot (or force-slot 0) (1+ slot))) ((or force-slot (= slot 5))) (let ((string (read-nubus-prom-string slot))) (when (and (string-search "LMI" string) (string-search "COLOR" string) (string-search "MEDIUM" string)) (let ((a-loc (- (lam:lam-lookup-name 'lam:a-grey-quad-slot) lam:raamo))) (si:%write-internal-processor-memories 4 ;; 4 means A/M-memory a-loc 0 (DPB #o17 #o0404 SLOT))) (return slot))))) )) ; From modified file DJ: L.VIDEO-DEVICE.GREY; GREY-WINDOW.LISP#20 at 10-Apr-86 14:03:50 #8R GREY#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GREY"))) (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; GREY-WINDOW  " (DEFUN screen-initialize nil (cond ((not (boundp 'grey-screen)) (select-processor (:cadr (use-direct)) ((:lambda :explorer) (use-lam-direct))) (add-initialization "grey make screen" '(setq grey-screen (make-grey-screen)) '(once))) )) )) ; From modified file DJ: L.VIDEO-DEVICE.GREY; GREY-WINDOW.LISP#20 at 10-Apr-86 14:05:01 #8R GREY#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GREY"))) (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; GREY-WINDOW  " (DEFUN create-useful-grey-fonts () (format t "Creating various special grey fonts") (dolist (a-font-name 'fonts:(hl12i medfnt mouse search cptfont 5x5)) ;; list determined by calling (find-grey-fonts-created) ;; after making and running windows (make-instance x ':superior grey-screen) ;; for x = tv:lisp-listener and zwei:zmacs-frame and putting the mouse and ;; a system menu on the grey screen. (or (get a-font-name 'fonts:grey-font) (make-grey-font (symeval a-font-name))))) )) ; From modified file DJ: L.VIDEO-DEVICE.GREY; GREY-WINDOW.LISP#20 at 10-Apr-86 14:05:14 #8R GREY#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GREY"))) (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; GREY-WINDOW  " (select-processor (:cadr) ((:lambda :explorer) (create-useful-grey-fonts))) )) ; From modified file DJ: L.VIDEO-DEVICE.GREY; GREY-TESTINIT.LISP#13 at 10-Apr-86 14:07:27 #8R GREY#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GREY"))) (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; GREY-TESTINIT  " (DEFUN WRITE-PLANE (ADR DATA &OPTIONAL (PLANE 0)) (select-processor (:cadr (FUNCALL WRITE-FUNCTION (+ ADR VIDEO-BUFFER-BASE-ADDRESS 1000000 (* PLANE 20000)) DATA)) ((:lambda :explorer) (FUNCALL WRITE-FUNCTION (+ ADR VIDEO-BUFFER-BASE-ADDRESS 200000 (* PLANE 20000)) DATA))) NIL) )) ; From modified file DJ: L.VIDEO-DEVICE.GREY; GREY-TESTINIT.LISP#13 at 10-Apr-86 14:07:31 #8R GREY#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GREY"))) (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; GREY-TESTINIT  " (DEFUN READ-PLANE (ADR DATA &OPTIONAL (PLANE 0)) (select-processor (:cadr (FUNCALL READ-FUNCTION (+ ADR VIDEO-BUFFER-BASE-ADDRESS 1000000 (* PLANE 20000)) DATA)) ((:lambda :explorer) (FUNCALL READ-FUNCTION (+ ADR VIDEO-BUFFER-BASE-ADDRESS 200000 (* PLANE 20000)) DATA))) NIL) )) ; From modified file DJ: L.VIDEO-DEVICE.GREY; GREY-TESTINIT.LISP#13 at 10-Apr-86 14:07:35 #8R GREY#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GREY"))) (COMPILER::PATCH-SOURCE-FILE "SYS: VIDEO-DEVICE; GREY; GREY-TESTINIT  " (DEFUN WRITE-COLOR-MAP (LOC R G B &OPTIONAL (SYNCHRONIZE NIL) (SCREEN GREY-SCREEN) &AUX (TV-ADR (TV:SCREEN-CONTROL-ADDRESS SCREEN)) (HARDWARE-COLOR-MAP (GET (LOCF (TV:SCREEN-PROPERTY-LIST SCREEN)) ':HARDWARE-COLOR-MAP))) (select-processor (:cadr (SETQ LOC (LOGAND LOC 377) R (- 377 (LOGAND (FIX R) 377)) G (- 377 (LOGAND (FIX G) 377)) B (- 377 (LOGAND (FIX B) 377))) (cond (SYNCHRONIZE (PROG NIL (%XBUS-WRITE MODE (LOGIOR 4000 MODE-REG)) (%XBUS-WRITE MODE MODE-REG) A (COND ((GREATERP (LOGAND 1 (%XBUS-READ TV-ADR)) 0) (RETURN NIL))) (GO A)))) (COMPILER:%XBUS-WRITE-SYNC COLOR (DPB R 1412 LOC) 0 TV-ADR 2 2) (COMPILER:%XBUS-WRITE-SYNC COLOR (DPB G 1412 (DPB 1 2602 LOC)) 0 TV-ADR 2 2) (COMPILER:%XBUS-WRITE-SYNC COLOR (DPB B 1412 (DPB 2 2602 LOC)) 0 TV-ADR 2 2) (AS-2-REVERSE (- 377 R) HARDWARE-COLOR-MAP LOC 0) (AS-2-REVERSE (- 377 G) HARDWARE-COLOR-MAP LOC 1) (AS-2-REVERSE (- 377 B) HARDWARE-COLOR-MAP LOC 2)) ((:lambda :explorer) (SETQ LOC (LOGAND LOC 377) R (LOGAND (FIX R) 377) G (LOGAND (FIX G) 377) B (LOGAND (FIX B) 377)) (%IO-SPACE-WRITE (+ COLOR (LOGAND 377 LOC)) (DPB B 2010 (DPB G 1010 R))) (AS-2-REVERSE R HARDWARE-COLOR-MAP LOC 0) (AS-2-REVERSE G HARDWARE-COLOR-MAP LOC 1) (AS-2-REVERSE B HARDWARE-COLOR-MAP LOC 2)))) ))