;;; -*- Mode:LISP; Package:LAMBDA; Base:8; Readtable:ZL -*-
;	** (c) Copyright 1980 and 1983 Massachusetts Institute of Technology **
;       ** (c) Enhancements Copyright 1984,1985,1986 - Lisp Machine, Inc.
;;; Reading and writing disk labels over the debugging interface.
;;; There used to also be a label editor, but (SI:EDIT-DISK-LABEL "LAM") is better.

;;; Magic constants and global variables.

;;; Known pack types.  The first on this list is the default.
;;; Each element is a 4-list of
;;;   Pack brand name (32 or fewer chars) (as a symbol).
;;;   Number of cylinders.
;;;   Number of heads.
;;;   Number of blocks per track.
(DECLARE (SPECIAL PACK-TYPES))
(SETQ PACK-TYPES
      '((|Fujitsu Eagle| 842. 20. 23.)
	))

;;; Global variables defining the label.
(DECLARE
 (SPECIAL
  LABEL-CHECK-WORD	   ; ASCII \LABL\
  LABEL-VERSION-NUMBER	   ; 1
  N-CYLINDERS		   ; The next four are parameters of the type of pack.
  N-HEADS
  N-BLOCKS-PER-TRACK
  INITIAL-MCR-NAME
  INITIAL-LOD-NAME
  PACK-BRAND-NAME	   ; 32 chars ascii
  PACK-NAME		   ; 32 chars ascii
  PACK-COMMENT		   ; 96 chars ascii
  N-PARTITIONS		   ; Number of partitions
  N-WORDS-PER-PARTITION-DESCRIPTOR
  PARTITION-NAMES	   ; The next four are arrays, indexed by partition number.
  PARTITION-START
  PARTITION-SIZE
  PARTITION-COMMENTS))

;;; Utility functions.

(DEFUN PACKED-READ-STRING (NCHARS *ADDR)
   (DO ((WORDS (// (+ NCHARS 3) 4) (1- WORDS))
	(ADDR *ADDR (1+ ADDR))
	(L NIL))
       ((ZEROP WORDS)
	(PKG-BIND 'lambda
	  (inhibit-style-warnings (IMPLODE (NREVERSE L)))))
     (DECLARE (FIXNUM WORDS ADDR))
     (DO ((WORD (LABEL-READ-WORD ADDR) (ASH WORD -10))
	  (CH)
	  (I (COND ((= WORDS 1) (1+ (\ (1- NCHARS) 4))) (T 4)) (1- I)))
	 ((ZEROP I))
       (DECLARE (FIXNUM WORD I CH))
       (SETQ CH (LOGAND 377 WORD))
       (OR (= CH 200) (= CH 0)
	   (SETQ L (CONS CH L))))))

(DEFUN PACKED-WRITE-STRING (NCHARS *ADDR STRING)
   (DO ((ADDR *ADDR (1+ ADDR))
	(PNAME (if (stringp string)
		   (string-upcase string)
		 (get-pname string)))
	(N 0))
       ((NOT (< N (SETQ NCHARS (STRING-LENGTH PNAME)))))
     (DO ((WORD 0)
	  (SHIFT 0 (+ SHIFT 10)))
	 ((= SHIFT 40)
	  (LABEL-WRITE-WORD ADDR WORD))
       (LET ((CHAR (COND ((< N NCHARS)
			  (AREF PNAME N))
			 (T 0)))) 
	 (SETQ WORD (+ WORD (ASH CHAR SHIFT)))
	 (SETQ N (1+ N))))))

(DEFUN GET-FIXNUM (PROMPT)
   (DO () (NIL)
     (AND PROMPT (PRINC PROMPT))
     (TYO 40)
     (LET ((X (READ)))
        (COND ((FIXP X)
	       (RETURN X))
	      (T (PRINC '| (Please type a fixnum.) |))))))

;;; Manipulating the label of the pack.

;This creates an in-core label that happens to be close to what we currently want.
(DEFUN INITIALIZE-LABEL (PACK-TYPE)
   (SETQ LABEL-CHECK-WORD "LABL"
	 LABEL-VERSION-NUMBER 1
	 N-CYLINDERS (CADR PACK-TYPE)
	 N-HEADS (CADDR PACK-TYPE)
	 N-BLOCKS-PER-TRACK (CADDDR PACK-TYPE)
	 INITIAL-MCR-NAME "MCR1"
	 INITIAL-LOD-NAME "LOD1"
	 PACK-BRAND-NAME (CAR PACK-TYPE)
	 PACK-NAME ""
	 PACK-COMMENT "(Initial dummy setup)"
	 N-PARTITIONS 10.
	 N-WORDS-PER-PARTITION-DESCRIPTOR 7
	 PARTITION-NAMES (make-array 100)
	 PARTITION-START (make-array 100)
	 PARTITION-SIZE (make-array 100)
	 PARTITION-COMMENTS (make-array 100))
   (FILLARRAY PARTITION-NAMES '(MCR1 MCR2 PAGE LOD1 LOD2 LOD3 LOD4 LOD5 LOD6 LOD7 NIL))
   (FILLARRAY PARTITION-START '(21 245 524 21210 41674 62360 103044 123530 144214 164700 0))
   (FILLARRAY PARTITION-SIZE '(224 224 20464 20464 20464 20464 20464 20464 20464 20464 0))
   (FILLARRAY PARTITION-COMMENTS '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)))

(INITIALIZE-LABEL (CAR PACK-TYPES)) ;Make sure reasonable crud exists when first loaded

(DEFUN READ-LABEL ()
  (IF SI:LAM-DISK-USE-NUBUS-MEMORY-MODE
      (READ-LABEL-VIA-NUBUS)
    (READ-LABEL-VIA-MULTIBUS)))

(DEFUN READ-LABEL-VIA-MULTIBUS ()
  (LAM-DISK-READ-VIA-MULTIBUS 0 2000 1)
  (READ-LABEL-1)
  T)

(DEFUN READ-LABEL-VIA-NUBUS ()
  "Load up our data structures to have what we read through the debugging cables."
  (LAM-DISK-WRITE-VIA-NUBUS 1 LAM-DISK-LOWCORE 1) ;Save on block 1
  (LAM-DISK-READ-VIA-NUBUS 0 LAM-DISK-LOWCORE 1)
  (READ-LABEL-1)
  (LAM-DISK-READ-VIA-NUBUS 1 LAM-DISK-LOWCORE 1) ;Restore saved core
  T)

(DEFUN LABEL-READ-WORD (RELATIVE-ADR)
  (if SI:LAM-DISK-USE-NUBUS-MEMORY-MODE (PHYS-MEM-READ (+ (* LAM-DISK-LOWCORE 400) RELATIVE-ADR))
    (multibus-read-32 (+ (multibus-real-address 2000) (* relative-adr 4)))))

(DEFUN LABEL-WRITE-WORD (RELATIVE-ADR DATA)
  (if SI:LAM-DISK-USE-NUBUS-MEMORY-MODE (PHYS-MEM-WRITE (+ (* LAM-DISK-LOWCORE 400) RELATIVE-ADR) DATA)
    (multibus-write-32 (+ (multibus-real-address 2000) (* relative-adr 4)) data)))

;sets free variables: n-heads n-cylinders n-blocks-per-track n-b-p-t
(DEFUN READ-LABEL-1 ()
  "Initialize the label parameters from block LAM-DISK-LOWCORE in debugged machine's mem.
This is used when reading or writing that machine's label."
  (let ((b 0)		;double word adr
	(n-h nil) (n-b-p-t nil))
    (SETQ LABEL-CHECK-WORD (PACKED-READ-STRING 4 B)
	  LABEL-VERSION-NUMBER (LABEL-READ-WORD (1+ B))
	  N-CYLINDERS (LABEL-READ-WORD (+ B 2))
	  N-H (LABEL-READ-WORD (+ B 3))
	  N-B-P-T (LABEL-READ-WORD (+ B 4))
	  INITIAL-MCR-NAME (PACKED-READ-STRING 4 (+ B 6))
	  INITIAL-LOD-NAME (PACKED-READ-STRING 4 (+ B 7))
	  PACK-BRAND-NAME (PACKED-READ-STRING 32. (+ B 10))
	  PACK-NAME (PACKED-READ-STRING 32. (+ B 20))
	  PACK-COMMENT (PACKED-READ-STRING 96. (+ B 30))
	  N-PARTITIONS (LABEL-READ-WORD (+ B 200))
	  N-WORDS-PER-PARTITION-DESCRIPTOR (LABEL-READ-WORD (+ B 201)))
    (cond ((or (zerop n-h)
	       (zerop n-b-p-t))
	   (ferror nil "n-heads=~s, n-blocks-per-track=~s, you would lose badly"
		   n-h
		   n-b-p-t))
	  ((not (= n-words-per-partition-descriptor 7))
	   (ferror nil "n-words-per-partiton-descriptor is ~s, not 7"
		   n-words-per-partition-descriptor)))
    (setq n-heads n-h
	  n-blocks-per-track n-b-p-t)
    (PRINT-LABEL-WARNINGS)
    (DO ((I 0 (1+ I))
	 (ADDR (+ B 202) (+ ADDR N-WORDS-PER-PARTITION-DESCRIPTOR)))
	((= I N-PARTITIONS))
      (DECLARE (FIXNUM I ADDR))
      (AND (> N-WORDS-PER-PARTITION-DESCRIPTOR 0)
	   (STORE (ARRAYCALL T PARTITION-NAMES I) (PACKED-READ-STRING 4 ADDR)))
      (AND (> N-WORDS-PER-PARTITION-DESCRIPTOR 1)
	   (STORE (ARRAYCALL FIXNUM PARTITION-START I) (LABEL-READ-WORD (1+ ADDR))))
      (AND (> N-WORDS-PER-PARTITION-DESCRIPTOR 2)
	   (STORE (ARRAYCALL FIXNUM PARTITION-SIZE I) (LABEL-READ-WORD (+ 2 ADDR))))
      (AND (> N-WORDS-PER-PARTITION-DESCRIPTOR 3)
	   (STORE (ARRAYCALL T PARTITION-COMMENTS I) (PACKED-READ-STRING 16. (+ 3 ADDR)))))
  (SORT-PARTITIONS)))

(DEFUN PRINT-LABEL-WARNINGS ()
   (LET ((ERROR-P NIL))
     (COND ((NOT (STRING-EQUAL LABEL-CHECK-WORD "LABL"))
	    (FORMAT T "Warning: Label check word is /"~A/", not /"LABL/".~%"
		      LABEL-CHECK-WORD)
	    (SETQ ERROR-P T)))
     (COND ((NOT (= LABEL-VERSION-NUMBER 1))
	    (FORMAT T "Warning: Label version number is ~D., not 1.~%"
		      LABEL-VERSION-NUMBER)
	    (SETQ ERROR-P T)))
     (COND ((NOT (= N-WORDS-PER-PARTITION-DESCRIPTOR 7))
	    (FORMAT T "Warning: Number of words per partition descriptor is ~D., not 7.~%"
		      N-WORDS-PER-PARTITION-DESCRIPTOR)
	    (SETQ ERROR-P T)))
     ERROR-P))

(DEFUN WRITE-LABEL ()
 (ferror nil "can't work")
 (comment
    (COND ((NOT (Y-OR-N-P "Do you really want to write the label? "))
	   (FERROR NIL "I guess you don't.")))
    (COND ((NOT (EQ LABEL-CHECK-WORD '|LABL|))
	   (OR (Y-OR-N-P "Current label was clobbered, go ahead anyway? ")
	       (FERROR NIL "No, don't go ahead."))
	   (SETQ LABEL-CHECK-WORD '|LABL|)
	   ))
    (COND ((NOT (= LABEL-VERSION-NUMBER 1))
	   (FORMAT T "Current version number is ~D, not 1; " LABEL-VERSION-NUMBER)
	   (SETQ LABEL-VERSION-NUMBER (GET-FIXNUM "write what version number? "))))
    (COND ((NOT (= N-WORDS-PER-PARTITION-DESCRIPTOR 7))
	   (FORMAT T "Current n-words-per-partition-descriptor is ~D., not 7; "
		   N-WORDS-PER-PARTITION-DESCRIPTOR)
	   (SETQ N-WORDS-PER-PARTITION-DESCRIPTOR
		 (GET-FIXNUM "use what number: "))))
    (COND (SI:LAM-DISK-USE-NUBUS-MEMORY-MODE
	   (LAM-DISK-WRITE 1 LAM-DISK-LOWCORE 1)))
    (LET ((B 0))
      (PACKED-WRITE-STRING 4 B LABEL-CHECK-WORD)
      (LABEL-WRITE-WORD (1+ B) LABEL-VERSION-NUMBER)
      (LABEL-WRITE-WORD (+ 2 B) N-CYLINDERS)
      (LABEL-WRITE-WORD (+ 3 B) N-HEADS)
      (LABEL-WRITE-WORD (+ 4 B) N-BLOCKS-PER-TRACK)
      (LABEL-WRITE-WORD (+ 5 B) (* N-BLOCKS-PER-TRACK N-HEADS))
      (PACKED-WRITE-STRING 4 (+ 6 B) INITIAL-MCR-NAME)
      (PACKED-WRITE-STRING 4 (+ 7 B) INITIAL-LOD-NAME)
      (PACKED-WRITE-STRING 32. (+ 10 B) PACK-BRAND-NAME)
      (PACKED-WRITE-STRING 32. (+ 20 B) PACK-NAME)
      (PACKED-WRITE-STRING 96. (+ 30 B) PACK-COMMENT)
      (LABEL-WRITE-WORD (+ 200 B) N-PARTITIONS)
      (LABEL-WRITE-WORD (+ 201 B) N-WORDS-PER-PARTITION-DESCRIPTOR)
      (DO ((I 0 (1+ I))
	   (ADDR (+ B 202) (+ ADDR N-WORDS-PER-PARTITION-DESCRIPTOR)))
	  ((= I N-PARTITIONS))
	(AND (> N-WORDS-PER-PARTITION-DESCRIPTOR 0)
	     (PACKED-WRITE-STRING 4 ADDR (ARRAYCALL T PARTITION-NAMES I)))
	(AND (> N-WORDS-PER-PARTITION-DESCRIPTOR 1)
	     (LABEL-WRITE-WORD (1+ ADDR) (ARRAYCALL FIXNUM PARTITION-START I)))
	(AND (> N-WORDS-PER-PARTITION-DESCRIPTOR 2)
	     (LABEL-WRITE-WORD (+ 2 ADDR) (ARRAYCALL FIXNUM PARTITION-SIZE I)))
	(AND (> N-WORDS-PER-PARTITION-DESCRIPTOR 3)
	     (PACKED-WRITE-STRING 16. (+ 3 ADDR) (ARRAYCALL T PARTITION-COMMENTS I)))
	(DO ((J 7 (1+ J)))
	    ((NOT (< J N-WORDS-PER-PARTITION-DESCRIPTOR)))
	  (LABEL-WRITE-WORD (+ J ADDR) 0))))
    (COND (SI:LAM-DISK-USE-NUBUS-MEMORY-MODE
	   (LAM-DISK-WRITE-VIA-NUBUS 0 LAM-DISK-LOWCORE 1)
	   (LAM-DISK-READ-VIA-NUBUS 1 LAM-DISK-LOWCORE 1))
	  (T
	   (LAM-DISK-WRITE-VIA-MULTIBUS 0 2000 1)))
    NIL) )

(DEFUN SORT-PARTITIONS ()
    (DO I 0 (1+ I) (>= I N-PARTITIONS)
      (DO J (1+ I) (1+ J) (>= J N-PARTITIONS)
	(COND ((> (ARRAYCALL FIXNUM PARTITION-START I)
		  (ARRAYCALL FIXNUM PARTITION-START J))
	       (LET ((X (ARRAYCALL FIXNUM PARTITION-START I)))
		 (DECLARE (FIXNUM X))
		 (STORE (ARRAYCALL FIXNUM PARTITION-START I)
			(ARRAYCALL FIXNUM PARTITION-START J))
		 (STORE (ARRAYCALL FIXNUM PARTITION-START J) X))
	       (LET ((X (ARRAYCALL FIXNUM PARTITION-SIZE I)))
		 (DECLARE (FIXNUM X))
		 (STORE (ARRAYCALL FIXNUM PARTITION-SIZE I)
			(ARRAYCALL FIXNUM PARTITION-SIZE J))
		 (STORE (ARRAYCALL FIXNUM PARTITION-SIZE J) X))
	       (LET ((X (ARRAYCALL T PARTITION-NAMES I)))
		 (STORE (ARRAYCALL T PARTITION-NAMES I)
			(ARRAYCALL T PARTITION-NAMES J))
		 (STORE (ARRAYCALL T PARTITION-NAMES J) X))
	       (LET ((X (ARRAYCALL T PARTITION-COMMENTS I)))
		 (STORE (ARRAYCALL T PARTITION-COMMENTS I)
			(ARRAYCALL T PARTITION-COMMENTS J))
		 (STORE (ARRAYCALL T PARTITION-COMMENTS J) X)))))))

(DEFUN LAM-SET-CURRENT-MICROLOAD (PART)
  (COND ((NUMBERP PART) (SETQ PART (INTERN (STRING-APPEND "LMC" (+ PART #/0)) 'lambda))))
  (OR (STRING-EQUAL PART "LMC" :start1 0 :start2 0 :end1 3)
      (FERROR NIL "|Partition name should be LMCn, is ~s" PART))
  (READ-LABEL)
  (SETQ INITIAL-MCR-NAME PART)
  (WRITE-LABEL))

(DEFUN LAM-SET-CURRENT-BAND (PART)
  (COND ((NUMBERP PART) (SETQ PART (INTERN (STRING-APPEND "LOD" (+ PART #/0)) 'lambda))))
  (OR (STRING-EQUAL PART "LOD" :start1 0 :start2 0 :end1 3)
      (ERROR '|Partition name should be among LOD1...LOD7| PART))
  (READ-LABEL)
  (SETQ INITIAL-LOD-NAME PART)
  (WRITE-LABEL))

;;; Only works on the real machine.
(DEFUN LAM-PRINT-DISK-LABEL ()  ;This is what I always think it is named. -- DLW
  (PRINT-DISK-LABEL "LAM"))