;;; -*- Mode:LISP; Package:GREY; Base:8; Readtable:ZL -*- ;; Copyright LISP Machine, Inc. 1984,1985,1986 ;; See filename "Copyright" for ;; licensing and release information. ;;;;START-UP FUNCTIONS ;; this function is run only once after the software has been loaded, for the entire ;; life of the band. From then on the initialization of the board is done ;; by a WRAPPER on the :EXPOSE method of the grey screen. So it is usually ;; a window system initialization. (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)))) (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)) (defvar *medium-color-slot-on-explorer* nil) (add-initialization "reset color board slot" '(setq *medium-color-slot-on-explorer* nil) '(:before-cold)) (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")))) (defun read-nubus-prom-word (slot j) "Read the highest 512 words" (SI:%NUBUS-READ-SAFE (DPB #o17 #o0404 SLOT) (LSH (+ #o17777000 J) 2))) (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))))) (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))) ((= slot 5)) (let ((string (read-nubus-prom-string slot))) (when (or force-slot (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))) (format t "A-loc = ~o" a-loc) (si:%write-internal-processor-memories 4 ;; 4 means A/M-memory a-loc 0 (DPB #o17 #o0404 SLOT))) (return slot))))) ;; invoke the initialization. (IF (OR (NOT (BOUNDP 'STANDARD-GREY-INITIALIZATION-PROCEDURE)) (EQ STANDARD-GREY-INITIALIZATION-PROCEDURE ':DOIT)) ;; For debugging purposes. (STANDARD-GREY-INITIALIZATION-PROCEDURE))