;;; -*- Mode:LISP; Package:SI; Base:8; Readtable:ZL -*-



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


;;; NOTE: THIS IS NO LONGER A PATCH FILE 28-Jan-86 19:51:51 -GJC.

(DEFCONST LAM-REMOTE-DISK-WRITE-CHECK NIL "T => LAM remote disk handler does read after write")
(DEFCONST LAM-DISK-USE-NUBUS-MEMORY-MODE T)


(DEFUN MAKE-LAM-DISK-UNIT (UNIT USE &OPTIONAL LAM-DISK-INIT-P WRITE-P &AUX TEM)
  (DECLARE (SPECIAL REMOTE-DISK-CONN REMOTE-DISK-STREAM REMOTE-DISK-UNIT)
	   (SPECIAL LAM-DISK-UNIT LAM-DISK-INIT-P LAMBDA:LAM-DISK-LOWCORE LAMBDA:LAM-DISK-TYPE))
  (COND ((STRING-EQUAL UNIT "LAM")
	 (SETQ TEM (STRING-SEARCH-CHAR #\SP UNIT))
	 (LET ((LAM-DISK-UNIT (IF (NULL TEM) 0 (READ-FROM-STRING UNIT NIL (1+ TEM)))))
	   (declare (special lam-disk-init-p lam-disk-unit))
	   (COND ((NOT (ZEROP LAM-DISK-UNIT))
		  (FERROR NIL "LAM can only talk to unit zero")))
	   (COND ((NULL LAM-DISK-INIT-P)
		  (LAMBDA:LAM-DISK-INIT)
		  (COND (LAM-DISK-USE-NUBUS-MEMORY-MODE
			;Block 2 is part of disk label!
			 (LAMBDA:LAM-DISK-WRITE-VIA-NUBUS 1 LAMBDA:LAM-DISK-LOWCORE 1)
   ;below code no longer uses (1+ lam-disk-lowcore)
   ;			 (LAMBDA:LAM-DISK-WRITE-VIA-NUBUS 3 (1+ LAMBDA:LAM-DISK-LOWCORE) 1)
			 )))
		 (T (SETQ lambda:LAM-DISK-TYPE T)))   ;Dont try to read garbage label, etc.
	   (CLOSURE '(LAM-DISK-UNIT LAM-DISK-INIT-P)
		    'LAM-DISK-HANDLER)))
	((string-equal unit "EXP")
	 (setq tem (string-search-char #\sp unit))
	 (let ((lam-disk-unit (if (null tem) 0 (read-from-string unit nil (1+ tem)))))
	   (declare (special lam-disk-init-p lam-disk-unit))
	   (cond ((null lam-disk-init-p)
		  (lam:exp-disk-init)
			;this used to save 2 blocks --rg 11/18/85
		  (lam:exp-disk-write 1 lam:lam-disk-lowcore 1))
		 (t
		  (setq lambda:lam-disk-type t)))
	   (closure '(lam-disk-unit lam-disk-init-p)
		    'exp-disk-handler)))
	('ELSE
	 (FERROR NIL "LAM debug disk unit only for LAM or EXP"))))


(DEFUN LAM-DISK-HANDLER (OP &REST ARGS)
  (DECLARE (SPECIAL LAM-DISK-UNIT LAM-DISK-INIT-P LAMBDA:LAM-DISK-TYPE))
  (SELECTQ OP
    (:READ
     (LET* ((RQB (CAR ARGS))
	    (BLOCK (CADR ARGS))
	    (N-BLOCKS (ARRAY-LEADER RQB %DISK-RQ-LEADER-N-PAGES)))
       (DO ((BLOCK BLOCK (1+ BLOCK))
	      (N-BLOCKS N-BLOCKS (1- N-BLOCKS))
	      (BUF (RQB-BUFFER RQB))
	      (BUF-IDX -1))
	     ((ZEROP N-BLOCKS))
	   (LAMBDA:LAM-DISK-READ-VIA-NUBUS BLOCK LAMBDA:LAM-DISK-LOWCORE 1)
	   (DO ((ADR (ASH LAMBDA:LAM-DISK-LOWCORE 8) (1+ ADR))
		(WORD)
		(W 0 (1+ W)))
	       (( W 400))
	     (SETQ WORD (LAMBDA:PHYS-MEM-READ ADR))
	     (AS-1 (LOGAND 177777 WORD) BUF (SETQ BUF-IDX (1+ BUF-IDX)))
	     (AS-1 (LDB 2020 WORD) BUF (SETQ BUF-IDX (1+ BUF-IDX)))))))
    (:WRITE
     (LET* ((RQB (CAR ARGS))
	    (BLOCK (CADR ARGS))
	    (N-BLOCKS (ARRAY-LEADER RQB %DISK-RQ-LEADER-N-PAGES)))
       (DO ((BLOCK BLOCK (1+ BLOCK))
	    (N-BLOCKS N-BLOCKS (1- N-BLOCKS))
	    (BUF (RQB-BUFFER RQB))
	    (BUF-IDX -1))
	   ((ZEROP N-BLOCKS))
	 (IF (ZEROP BLOCK)
	     (LAMBDA:READ-LABEL))		;do it first.
	 (DO ((ADR (ASH LAMBDA:LAM-DISK-LOWCORE 8) (1+ ADR))
	      (WORD)
	      (W 0 (1+ W)))
	     (( W 400))
	   (SETQ WORD (DPB (AR-1 BUF (SETQ BUF-IDX (+ 2 BUF-IDX)))
			   2020
			   (AR-1 BUF (1- BUF-IDX))))
	   (LAMBDA:PHYS-MEM-WRITE ADR WORD))
	 ;; If writing label, init some params such as LAMBDA:BLOCKS-PER-CYLINDER.
	 RETRY (LAMBDA:LAM-DISK-WRITE-VIA-NUBUS BLOCK LAMBDA:LAM-DISK-LOWCORE 1)
  ;below code clobbers core block +1, and is pretty useless.
;               (COND ((AND LAM-REMOTE-DISK-WRITE-CHECK 
;			   (NULL (LAMBDA:LAM-DISK-READ-VIA-NUBUS BLOCK
;								 (1+ LAMBDA:LAM-DISK-LOWCORE)
;								 1)))
;		      (GO RETRY)))	;read it back to let hardware check ECC, etc.
	       )))
    (:DISPOSE (COND ((NULL LAM-DISK-INIT-P)
		     (IF LAM-DISK-USE-NUBUS-MEMORY-MODE
			 (LAMBDA:LAM-DISK-READ-VIA-NUBUS 1 LAMBDA:LAM-DISK-LOWCORE 1))
				 ;Restore saved core
		     )
		    (T (SETQ LAMBDA:LAM-DISK-TYPE NIL)))) ;Otherwise read label now that it
							; maybe isnt garbage
    (:UNIT-NUMBER 0)
    (:MACHINE-NAME "via LAM")
    (:SAY (FORMAT T "LAM-SAY ~A~%" (CAR ARGS)))
    (:HANDLES-LABEL NIL)))