;;; -*- Mode:LISP; Package:GREY; Base:8 -*-

;; Copyright LISP Machine, Inc. 1984
;;    See filename "Copyright" for
;; licensing and release information.


;;;;START-UP FUNCTIONS

;; THIS IS PROBABLY THE WRONG COMBINATION OF THINGS, SINCE
;; THE BOARD MUST BE DOWNLOADED ON POWER-UP, (OR ALLOCATION
;; WHAT ABOUT UNIX USAGE?) EVEN THOUGH THE SCREENS MAY ALREADY
;; BE IN THE SAVED LISP ENVIRONMENT. -GJC

;; Furthermore, in a 2x2 environment, more than one lispm may want it.
;;
;; we've been having problems in the situation where you reboot and need to
;; re-aquire the color screen, but do not want to init the bus, since the other
;; half of the 2x2 is in operation. -dexter 2/17/85

(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 si:processor-type-code
    (si:cadr-type-code (USE-LAM))
    (si:lambda-type-code (use-lam-direct)))
  (cond ((= si:processor-type-code si:lambda-type-code)	;if youre a lambda, do this:

	 (grey-exists-and-if-so-downloaded-p)		;downloads after allocation

	 (SCREEN-INITIALIZE)				;makes a grey screen

	 (SETQ GREY-ARRAY (GET-GREY-SCREEN-ARRAY))	;setup some variables for ease
	 (SETQ GREY-ARRAY0 (GET-GREY-SCREEN-ARRAY0))	;of use
	 (SETQ GREY-ARRAY1 (GET-GREY-SCREEN-ARRAY1))
	 (SETQ GREY-ARRAY2 (GET-GREY-SCREEN-ARRAY2))
	 (SETQ GREY-ARRAY3 (GET-GREY-SCREEN-ARRAY3))
	 (SETQ GREY-ARRAY4 (GET-GREY-SCREEN-ARRAY4))
	 (SETQ GREY-ARRAY5 (GET-GREY-SCREEN-ARRAY5))
	 (SETQ GREY-ARRAY6 (GET-GREY-SCREEN-ARRAY6))
	 (SETQ GREY-ARRAY7 (GET-GREY-SCREEN-ARRAY7))))
  (cond ((or (= si:processor-type-code si:cadr-type-code)
	     (grey-exists-and-if-so-downloaded-p))	;do we get a gratuitous download here?
	 
	 (STRAIGHT-MAP)
	 (DRAW-FRAME))))

(defvar grey-board-downloaded? nil)

(defun make-sure-grey-board-is-downloaded ()
  (cond ((null grey-prom-plist)
	 ;; true when first loaded and after cold boot.
	 (SETUP-GREY-PROM-PLIST)
	 (setq grey-board-downloaded? nil)))
  (cond ((null grey-board-downloaded?)
	 (setq sram-object (assemble-sram-source sram-source))
	 (CLEAR-COLOR-MAP)
	 (INIT)
	 (START)
	 (LOAD-VMB 0)
	 (setq grey-board-downloaded? t))))


(DEFUN READ-GREY-PROM-STRING (&OPTIONAL (PROM-START-ADDRESS CON-PROM))
  (WITH-OUTPUT-TO-STRING (S)
    (DO ((J 0 (+ J 1))
	 (C))
	((= J 512.))
      (SETQ C (LOGAND #O177 (%IO-SPACE-READ (+ PROM-START-ADDRESS J))))
      (IF (NOT (MEMQ C '(0 #O177)))
	  (SEND S ':TYO C)))))


(DEFUN PARSE-PROM-STRING (STRING)
  "Prom string my be /"LMI FOO BAR BAZ/" or /"LMI FOO V3.3/" returns a property list
/((LMI FOO BAR) :VERSION 3.3 :MINOR-VERSION 3 :MAJOR-VERSION 3)"
  (DO ((TOKENS NIL (CONS TOKEN TOKENS))
       (TOKEN)
       (TEMP)
       (NEXT-INDEX 0))
      ((EQ STRING (MULTIPLE-VALUE (TOKEN NEXT-INDEX)
		    (LET ((READTABLE SI:INITIAL-READTABLE))
		      (READ-FROM-STRING STRING STRING NEXT-INDEX))))
       (SETQ TOKENS (NREVERSE TOKENS))
       (DO ((L TOKENS (CDR L))
	    (PLIST (LIST NIL)))
	   ((NULL L)
	    PLIST)
	 (SETQ TOKEN (CAR L))
	 (COND ((AND (SYMBOLP TOKEN)
		     (= #/V (AREF (SETQ TOKEN (STRING TOKEN)) 0))
		     (> (STRING-LENGTH TOKEN) 1)
		     (<= #/0 (AREF TOKEN 1) #/9))
		(PUTPROP PLIST (READ-FROM-STRING TOKEN NIL 1) ':VERSION)
		(COND ((SETQ TEMP (STRING-SEARCH-CHAR #/. TOKEN 1))
		       (PUTPROP PLIST (MULTIPLE-VALUE (TEMP NEXT-INDEX)
					(READ-FROM-STRING TOKEN NIL 1 TEMP))
				':MAJOR-VERSION)
		       (PUTPROP PLIST (READ-FROM-STRING TOKEN NIL NEXT-INDEX)
				':MINOR-VERSION))))
	       ('ELSE
		(SETF (CAR PLIST) (NCONC (CAR PLIST) (LIST TOKEN)))))))))

(DEFVAR GREY-PROM-PLIST NIL)
(DEFVAR GREY-PROM-STRING NIL)

(DEFUN SETUP-GREY-PROM-PLIST ()
  (SETQ GREY-PROM-STRING (READ-GREY-PROM-STRING))
  (SETQ GREY-PROM-PLIST (PARSE-PROM-STRING GREY-PROM-STRING))
  (or (and (>= (length (car grey-prom-plist))
	       3)
	   (string-equal (first (car grey-prom-plist)) "LMI")
	   (string-equal (second (car grey-prom-plist)) "MEDIUM")
	   (string-equal (third (car grey-prom-plist)) "COLOR"))
      ;; an important error check. Sometimes the LBOOT procedure
      ;; doesn't set up the a-grey-slot correctly, and this finds the error
      ;; before we lose big in a NXM, which the lambda doesn't handle
      ;; yet due to further SDU operating system lossage. 6/10/84 18:12:42 -gjc
      (ferror nil "You have lost. Not a medium color board or a-grey-slot wrong")))


;; more stuff

(defun download-grey-board ()
  (WRITE-METER 'SI:%LOWEST-DIRECT-VIRTUAL-ADDRESS
	       VIDEO-BUFFER-BASE-VIRTUAL-ADDRESS)
  (setq grey-prom-plist nil)
  (make-sure-grey-board-is-downloaded))

(defun grey-exists-and-if-so-downloaded-p (&optional screen &aux temp)
  screen					; ignored. mumblidge
  (send (SEND (fs:parse-pathname "MEDIUM-RESOLUTION-COLOR:") :host)
	:allocate-if-easy))			;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
	 
;; invoke the initialization.

(IF (OR (NOT (BOUNDP 'STANDARD-GREY-INITIALIZATION-PROCEDURE))
	(EQ STANDARD-GREY-INITIALIZATION-PROCEDURE ':DOIT))
    ;; For debugging purposes.
    (STANDARD-GREY-INITIALIZATION-PROCEDURE))