;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for CDI version 1.5
;;; Reason:
;;;  Change select-processors for the default unit to a function call.
;;; Written 15-May-86 09:37:16 by Gibson at site LMI Cambridge
;;; while running on Larry from band 3
;;; with System 110.232, Lambda-Diag 7.17, Experimental Local-File 68.7, FILE-Server 18.4, Unix-Interface 9.1, ZMail 65.14, Object Lisp 3.4, Tape 6.39, Site Data Editor 3.3, Tiger 24.0, KERMIT 31.3, Window-Maker 1.1, Gateway 4.8, TCP-Kernel 39.7, TCP-User 62.7, TCP-Server 45.5, MEDIUM-RESOLUTION-COLOR 3.4, MICRO-COMPILATION-TOOLS 3.2, System Revision Level 3.18, Experimental CDI 1.4, microcode 1512, SDU ROM 103.



; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:29
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "


(DEFUN FIND-DISK-PARTITION (NAME &OPTIONAL RQB UNIT (ALREADY-READ-P NIL) CONFIRM-WRITE)
  "Search the label of disk unit UNIT for a partition named NAME.
Returns three values describing what was found, or NIL if none found.
The values are the first block number of the partition,
the length in disk blocks of the partition,
and the location in the label (in words) of the data for this partition."
  (DECLARE (VALUES FIRST-BLOCK N-BLOCKS LABEL-LOC NAME))
  (setq unit (default-disk-unit unit))
  (IF (AND (CLOSUREP UNIT)
	   (FUNCALL UNIT :HANDLES-LABEL))
      (FUNCALL UNIT :FIND-DISK-PARTITION NAME)
    (WITH-DISK-RQB (RQB (OR RQB DISK-LABEL-RQB-PAGES))
      (OR ALREADY-READ-P (READ-DISK-LABEL RQB UNIT))
      (DO ((N-PARTITIONS (GET-DISK-FIXNUM RQB
					  (ecase (get-disk-fixnum rqb 1)
					    (1 #o200)
					    (2 (+ 256. 2)))))
	   (WORDS-PER-PART (GET-DISK-FIXNUM RQB
					    (ecase (get-disk-fixnum rqb 1)
					      (1 #o201)
					      (2 (+ 256. 3)))))
	   (I 0 (1+ I))
	   (LOC (ecase (get-disk-fixnum rqb 1)
		  (1 #o202)
		  (2 (+ 256. 16.)))
		(+ LOC WORDS-PER-PART))
	   (words-before-comment
	     (ecase (get-disk-fixnum rqb 1)
	       (1 3)
	       (2 4)))
	   )
	  ((= I N-PARTITIONS) NIL)
	(WHEN (STRING-EQUAL (GET-DISK-STRING RQB LOC 4) NAME)
	  (AND CONFIRM-WRITE
	       (NOT (FQUERY FORMAT:YES-OR-NO-QUIETLY-P-OPTIONS
			    "Do you really want to clobber partition ~A ~
				 ~:[~*~;on unit ~D ~](~A)? "
			    NAME (NUMBERP UNIT) UNIT
			    (GET-DISK-STRING RQB
					     (+ LOC words-before-comment)
					     (* 4 (- words-per-part words-before-comment)))))
	       (RETURN-FROM FIND-DISK-PARTITION (VALUES NIL T)))
	  (RETURN-FROM FIND-DISK-PARTITION (VALUES (GET-DISK-FIXNUM RQB (+ LOC 1))
						   (GET-DISK-FIXNUM RQB (+ LOC 2))
						   LOC
						   NAME)))))))


))

; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:31
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "


(DEFUN FIND-DISK-PARTITION-FOR-READ (NAME &OPTIONAL RQB UNIT (ALREADY-READ-P NIL)
				     		        (NUMBER-PREFIX "LOD"))
  "Like FIND-DISK-PARTITION except there is error checking and coercion.
If NAME is a number, its printed representation is appended to NUMBER-PREFIX
to get the partition name to use."
  (DECLARE (VALUES FIRST-BLOCK N-BLOCKS LABEL-LOC NAME))
  (setq unit (default-disk-unit unit))
  (TYPECASE NAME
    (NUMBER
     (SETQ NAME (FORMAT NIL "~A~D" NUMBER-PREFIX NAME)))
    (SYMBOL
     (SETQ NAME (SYMBOL-NAME NAME)))
    (STRING)
    (T
     (FERROR "~S is not a valid partition name" NAME)))
  (MULTIPLE-VALUE-BIND (FIRST-BLOCK N-BLOCKS LABEL-LOC)
      (FIND-DISK-PARTITION NAME RQB UNIT ALREADY-READ-P)
    (IF (NOT (NULL FIRST-BLOCK))
	(VALUES FIRST-BLOCK N-BLOCKS LABEL-LOC NAME)
      (FERROR "No partition named /"~A/" exists on disk unit ~D." NAME UNIT))))

))

; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:32
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "


(DEFUN FIND-DISK-PARTITION-FOR-WRITE (NAME &OPTIONAL RQB UNIT (ALREADY-READ-P NIL)
						    (NUMBER-PREFIX "LOD"))
  "Like FIND-DISK-PARTITION except there is error checking, coercion, and confirmation.
If NAME is a number, its printed representation is appended to NUMBER-PREFIX
to get the partition name to use.
Returns NIL if the partition specified is valid but the user refuses to confirm."
  (DECLARE (VALUES FIRST-BLOCK N-BLOCKS LABEL-LOC NAME))
  (setq unit (default-disk-unit unit))
  (COND ((and (closurep unit) (eq (closure-function unit) 'fs:band-magtape-handler))
	 (return-from find-disk-partition-for-write (values 0 9999999 nil name)))
	((NUMBERP NAME) (SETQ NAME (FORMAT NIL "~A~D" NUMBER-PREFIX NAME)))
	((SYMBOLP NAME) (SETQ NAME (GET-PNAME NAME)))
	((NOT (STRINGP NAME)) (FERROR "~S is not a valid partition name" NAME)))
  (LET* ((CURRENT-BAND (CURRENT-BAND unit))
	 (CURRENT-BAND-BASE-BAND (INC-BAND-BASE-BAND CURRENT-BAND unit))
	 (CURRENT-RUNNING-BAND (STRING-APPEND "LOD"
					      (LDB #o2010 CURRENT-LOADED-BAND))))
    (COND ((NOT (EQ UNIT 0)))
	  ((STRING-EQUAL NAME CURRENT-BAND)
	   (FORMAT T "~&It is dangerous to write into the current band.
If there is a disk error saving,
the machine's current band will be invalid
and cold-booting will not work."))
	  ((AND CURRENT-BAND-BASE-BAND
		(STRING-EQUAL NAME CURRENT-BAND-BASE-BAND))
	   (FORMAT T "~&It is dangerous to write into the current band's base band.
The current band ~A is an incremental band
and requires ~A, its base band, in order to cold-boot.
Overwriting that band makes the current band invalid
and the machine will be unbootable until a valid band is selected."
		   CURRENT-BAND CURRENT-BAND-BASE-BAND))
	  ((STRING-EQUAL NAME CURRENT-RUNNING-BAND)
	   (FORMAT T "~&It may be unwise to overwrite the currently running band.
Do it only if you are sure the current band for booting (~A)
will work properly."
		   CURRENT-BAND))))
  (MULTIPLE-VALUE-BIND (FIRST-BLOCK N-BLOCKS LABEL-LOC)
      (FIND-DISK-PARTITION NAME RQB UNIT ALREADY-READ-P T)
    (IF (NOT (NULL FIRST-BLOCK))
	(VALUES FIRST-BLOCK N-BLOCKS LABEL-LOC NAME)
      (IF (NULL N-BLOCKS)
	  (FERROR "No partition named /"~A/" exists on disk unit ~D." NAME UNIT)
	NIL))))

))

; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:34
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "


(DEFUN PARTITION-LIST (&OPTIONAL RQB UNIT ALREADY-READ-P)
  "Returns the data of the disk label on unit UNIT.
The value is a list with one element per partition,
with the format (<name> <base> <size> <comment> <desc-loc>).
RQB is an rqb to use, or NIL meaning allocate one temporarily."
  (setq unit (default-disk-unit unit))
  (WITH-DISK-RQB (RQB (OR RQB DISK-LABEL-RQB-PAGES))
    (UNLESS ALREADY-READ-P
      (READ-DISK-LABEL RQB UNIT))
    (LET ((RESULT (MAKE-LIST (GET-DISK-FIXNUM RQB (ecase (get-disk-fixnum rqb 1)
						    (1 #o200)
						    (2 (+ 256. 2))))))
	  (WORDS-PER-PART (GET-DISK-FIXNUM RQB (ecase (get-disk-fixnum rqb 1)
						 (1 #o201)
						 (2 (+ 256. 3)))))
	  (words-before-comment (ecase (get-disk-fixnum rqb 1)
				  (1 3)
				  (2 4)))
	  )
      (DO ((LOC (ecase (get-disk-fixnum rqb 1)
		  (1 #o202)
		  (2 (+ 256. 16.)))
		(+ LOC WORDS-PER-PART))
	   (R RESULT (CDR R)))
	  ((NULL R) RESULT)
	(SETF (CAR R)
	      (LIST (GET-DISK-STRING RQB LOC 4)
		    (GET-DISK-FIXNUM RQB (+ LOC 1))
		    (GET-DISK-FIXNUM RQB (+ LOC 2))
		    (GET-DISK-STRING RQB (+ LOC words-before-comment)
				     (* 4 (- words-per-part words-before-comment)))
		    LOC))))))

;;; This is a hack to allow one to easily find if a partition he wants is available.

))

; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:35
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "


(DEFUN DESCRIBE-PARTITION (PART &OPTIONAL UNIT
			   &AUX PART-BASE PART-SIZE
			   COMPRESSED-FORMAT-P INCREMENTAL-BAND-P
			   VALID-SIZE HIGHEST-VIRTUAL-ADDRESS
			   DESIRED-UCODE-VERSION)
  "Print information about partition PART on unit UNIT.
UNIT can be a disk unit number, the name of a machine on the chaos net,
or /"CC/" which refers to the machine being debugged by this one."
  (setq unit (default-disk-unit unit))
  (WITH-DECODED-DISK-UNIT (UNIT UNIT (FORMAT NIL "describing ~A partition" PART))
    (MULTIPLE-VALUE (PART-BASE PART-SIZE)
      (FIND-DISK-PARTITION-FOR-READ PART NIL UNIT))
    (WITH-DISK-RQB (RQB)
      (SETQ VALID-SIZE
	    (COND ((OR (NUMBERP PART) (STRING-EQUAL PART "LOD" :END1 3))
		   (DISK-READ RQB UNIT (1+ PART-BASE))
		   (LET ((BUF (RQB-BUFFER RQB)))
		     (SETQ COMPRESSED-FORMAT-P
			   (= #o1000 (AREF BUF (* 2 %SYS-COM-BAND-FORMAT))))
		     (SETQ INCREMENTAL-BAND-P
			   (= #o1001 (AREF BUF (* 2 %SYS-COM-BAND-FORMAT))))
		     (SETQ VALID-SIZE (SYS-COM-PAGE-NUMBER BUF %SYS-COM-VALID-SIZE))
		     (SETQ VALID-SIZE (IF (AND (> VALID-SIZE #o10)
					       ( VALID-SIZE PART-SIZE))
					  VALID-SIZE
					PART-SIZE))
		     (SETQ HIGHEST-VIRTUAL-ADDRESS
			   (SYS-COM-PAGE-NUMBER BUF %SYS-COM-HIGHEST-VIRTUAL-ADDRESS))
		     (SETQ DESIRED-UCODE-VERSION
			   (AREF BUF (* 2 %SYS-COM-DESIRED-MICROCODE-VERSION)))
		     VALID-SIZE))
		  (T PART-SIZE)))
      (FORMAT T "~%Partition ~A starts at ~D and is ~D pages long."
	      (STRING-UPCASE PART) PART-BASE PART-SIZE)
      (IF (OR COMPRESSED-FORMAT-P INCREMENTAL-BAND-P)
	  (PROGN
	    (IF COMPRESSED-FORMAT-P
		(FORMAT T "~%It is a compressed world-load.")
	      (FORMAT T "~%It is an incremental band with base band ~A."
		      (INC-BAND-BASE-BAND PART UNIT)))
	    (FORMAT T "~%Data length is ~D pages, highest virtual page number is ~D."
		    VALID-SIZE HIGHEST-VIRTUAL-ADDRESS))
	(FORMAT T "~%It is in non-compressed format, data length ~D pages." VALID-SIZE))
      (IF DESIRED-UCODE-VERSION
	  (FORMAT T "~%Goes with microcode version ~D." DESIRED-UCODE-VERSION)))))


))

; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:38
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "


(DEFUN DESCRIBE-PARTITIONS (&OPTIONAL UNIT)
  "Describes all of the partitions of UNIT, or the standard disk if unit is not supplied."
  (setq unit (default-disk-unit unit))
  (WITH-DECODED-DISK-UNIT (UNIT UNIT "describing partitions")
    (LOOP FOR (BAND . REST) IN (PARTITION-LIST NIL UNIT)
	  DOING
	  (FORMAT T "~%")
	  (DESCRIBE-PARTITION BAND UNIT))))


))

; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:42
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "


(DEFUN GET-UCODE-VERSION-OF-BAND (PART &OPTIONAL UNIT)
  "Return the microcode version number that partition PART on unit UNIT should be run with.
This is only meaningful when used on a LOD partition.
UNIT can be a disk unit number, the name of a machine on the chaos net,
or /"CC/" which refers to the machine being debugged by this one."
  (setq unit (default-disk-unit unit))
  (WITH-DECODED-DISK-UNIT (UNIT UNIT (FORMAT NIL "Finding microcode for ~A partition" PART))
    (WITH-DISK-RQB (RQB)
      (MULTIPLE-VALUE-BIND (PART-BASE PART-SIZE)
	  (FIND-DISK-PARTITION-FOR-READ PART NIL UNIT)
	(COND ((ZEROP PART-SIZE)
	       (FERROR NIL "PARTITION SIZE IS ZERO"))
	      ((OR (NUMBERP PART) (STRING-EQUAL PART "LOD" :END1 3))
	       (DISK-READ RQB UNIT (1+ PART-BASE))
	       (LET ((BUF (RQB-BUFFER RQB)))
		 (AREF BUF (* 2 %SYS-COM-DESIRED-MICROCODE-VERSION)))))))))


))

; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:44
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "


(DEFUN MEASURED-SIZE-OF-PARTITION (PART &OPTIONAL UNIT)
  "Return the number of blocks of partition PART on unit UNIT actually containing data. 
Except for LOD partitions, this is the total size. 
The second value, for LOD partitions, is the required PAGE partition size. 
The third value, for LOD partitions, is the desired microcode version. 
UNIT can be a disk unit number, the name of a machine on the chaos net,
or /"CC/" which refers to the machine being debugged by this one."
  (setq unit (default-disk-unit unit))
  (DECLARE (VALUES PARTITION-DATA-SIZE VIRTUAL-MEMORY-SIZE MICROCODE-VERSION))
  (WITH-DECODED-DISK-UNIT (UNIT UNIT (FORMAT NIL "sizing ~A partition" PART))
    (MULTIPLE-VALUE-BIND (PART-BASE PART-SIZE NIL PART-NAME)
	(FIND-DISK-PARTITION-FOR-READ PART NIL UNIT)
      (LET ((L (MULTIPLE-VALUE-LIST
		 (MEASURED-FROM-PART-SIZE UNIT PART-NAME PART-BASE PART-SIZE))))
	(IF (CAR L)
	    (VALUES-LIST L)
	  PART-SIZE)))))




))

; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:46
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "

(DEFUN LOAD-MCR-FILE (FILENAME PART &OPTIONAL UNIT)
  "Load microcode from file FILENAME into partition PART on unit UNIT.
UNIT can be a disk unit number, the name of a machine on the chaosnet,
or /"CC/" which refers to the machine being debugged by this one."
  (setq unit (default-disk-unit unit))
  (LET ((DEFAULT (PATHNAME (SELECT-PROCESSOR
			     (:CADR "SYS: UBIN; UCADR MCR >")
			     (:LAMBDA "SYS: UBIN; ULAMBDA MCR >")
			     (:EXPLORER "SYS: UBIN; ULAMBDA MCR >")
			     ))))
    (SETQ FILENAME (COND ((EQ FILENAME 'T)
			  DEFAULT)
			 ((NUMBERP FILENAME)
			  (SEND DEFAULT :NEW-VERSION FILENAME))
			 (T
			  (MERGE-PATHNAMES FILENAME DEFAULT)))))
  (UNLESS (STRING-EQUAL (SEND FILENAME :CANONICAL-TYPE) :MCR)
    (FERROR "~A is not a MCR file." FILENAME))
  (WITH-DECODED-DISK-UNIT (UNIT UNIT (FORMAT NIL "Loading ~A into ~A partition" FILENAME PART)
				NIL T)
    (WITH-DISK-RQB (RQB)
      (MULTIPLE-VALUE-BIND (PART-BASE PART-SIZE NIL PART)
	  (FIND-DISK-PARTITION-FOR-WRITE PART NIL UNIT NIL "MCR")
	(WITH-OPEN-FILE (FILE FILENAME :DIRECTION :INPUT :CHARACTERS NIL :BYTE-SIZE 16.)
	  (BLOCK DONE
	    (DO ((BUF16 (rqb-buffer rqb))
		 (BLOCK PART-BASE (1+ BLOCK))
		 (N PART-SIZE (1- N)))
		((ZEROP N) (FERROR "Failed to fit in partition"))
	      (DO ((LH) (RH)
		   (I 0 (+ I 2)))
		  ((= I #o1000)
		   (DISK-WRITE RQB UNIT BLOCK))
		(SETQ LH (SEND FILE :TYI)
		      RH (SEND FILE :TYI))
		(WHEN (OR (NULL LH) (NULL RH))
		  (UPDATE-PARTITION-COMMENT
		    PART
		    (LET ((PATHNAME (SEND FILE :TRUENAME)))
		      (FORMAT NIL "~A ~D" (SEND PATHNAME :NAME) (SEND PATHNAME :VERSION)))
		    UNIT)
		  (RETURN-FROM DONE NIL))
		(SETF (AREF BUF16 I) RH)
		(SETF (AREF BUF16 (1+ I)) LH)))))))))


))

; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:48
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "


(DEFUN LOAD-EMC-FILE (FILENAME PART &OPTIONAL UNIT)
  "Load microcode from file FILENAME into partition PART on unit UNIT.
UNIT can be a disk unit number, the name of a machine on the chaosnet
or /"CC/" which refers to the machine being debugged by this one."
  (setq unit (default-disk-unit unit))
  (SETQ FILENAME (COND ((NUMBERP FILENAME)
			(SEND (PATHNAME "SYS:UBIN;ULAMBDA EMC >") :NEW-VERSION
			      FILENAME))
		       ((EQ FILENAME T)
			(PATHNAME "SYS:UBIN;ULAMBDA EMC >"))
		       (T
			(MERGE-PATHNAMES FILENAME "SYS: UBIN; ULAMBDA EMC >"))))
  ;;  Do string-equal, not equal, on the canonical-type, not the type
  (if (not (or (STRING-EQUAL (SEND FILENAME :CANONICAL-TYPE) :MCR)
	       (STRING-EQUAL (SEND FILENAME :CANONICAL-TYPE) :EMC)))
      (FERROR "~A is not a MCR file." FILENAME))
  (WITH-DECODED-DISK-UNIT (UNIT UNIT
				(FORMAT NIL "Loading ~A into ~A partiton"
					FILENAME PART)
				NIL
				T)
    (WITH-DISK-RQB (RQB)
      (MULTIPLE-VALUE-BIND (PART-BASE PART-SIZE NIL PART)
	  (FIND-DISK-PARTITION-FOR-WRITE PART NIL UNIT NIL "MCR")
	(WITH-OPEN-FILE (FILE FILENAME :DIRECTION :INPUT :CHARACTERS NIL :BYTE-SIZE 16.)
	  (BLOCK DONE
	    (DO ((BUF16 (ARRAY-LEADER RQB %DISK-RQ-LEADER-BUFFER))
		 (BLOCK PART-BASE (1+ BLOCK))
		 (N PART-SIZE (1- N)))
		((ZEROP N) (FERROR "Failed to fit in partition"))
	      (DO ((LH) (RH)
		   (I 0 (+ I 2)))
		  ((= I #o1000)
		   (DISK-WRITE RQB UNIT BLOCK))
		(SETQ LH (SEND FILE :TYI)
		      RH (SEND FILE :TYI))
		(COND ((OR (NULL LH) (NULL RH))
		       (UPDATE-PARTITION-COMMENT
			 PART
			 (format nil "~A ~D"
				 (send (truename file) :name)
				 (send (truename file) :version))
			 UNIT)
		       (RETURN-FROM DONE NIL)))
		(ASET RH BUF16 I)
		(ASET LH BUF16 (1+ I))))))))))


;;; Put a microcode file onto my own disk, LAMBDA style.
;;; Note that the halfwords are IN order in a LMC file (as opposed to a MCR file).

))

; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:50
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "

(DEFUN LOAD-LMC-FILE (FILENAME PART &OPTIONAL UNIT)
  "Load microcode from file FILENAME into partition PART on unit UNIT.
UNIT can be a disk unit number, the name of a machine on the chaosnet,
or /"CC/" or /"LAM/" which refers to the machine being debugged by this one."
  (setq unit (default-disk-unit unit))
  (SETQ FILENAME (COND ((EQ FILENAME T)
			(PATHNAME "SYS: UBIN; ULAMBDA LMC >"))
		       ((NUMBERP FILENAME)
			(SEND (PATHNAME "SYS: UBIN; ULAMBDA LMC >")
			      :NEW-VERSION FILENAME))
		       (T
			(MERGE-PATHNAMES FILENAME (PATHNAME "SYS: UBIN; ULAMBDA LMC >")))))
  (UNLESS (STRING-EQUAL (SEND FILENAME :TYPE) :LMC)
    (FERROR "~A is not a LMC file." FILENAME))
  (WITH-DECODED-DISK-UNIT (UNIT UNIT
				(FORMAT NIL "Loading ~A into ~A partition" FILENAME PART)
				NIL
				T)
    (WITH-DISK-RQB (RQB)
      (WITH-DISK-RQB (RQB-FOR-LABEL 3)
	(MULTIPLE-VALUE-BIND (PART-BASE PART-SIZE NIL PART)
	    (FIND-DISK-PARTITION-FOR-WRITE PART RQB-FOR-LABEL UNIT NIL "LMC")
	  (WITH-OPEN-FILE (FILE FILENAME :DIRECTION :INPUT :CHARACTERS NIL :BYTE-SIZE 16.)
	    (BLOCK DONE
	      (DO ((BUF16 (rqb-buffer rqb))
		   (BLOCK PART-BASE (1+ BLOCK))
		   (N PART-SIZE (1- N)))
		  ((ZEROP N) (FERROR "Failed to fit in partition"))
		(DO ((LH) (RH)
		     (I 0 (+ I 2)))
		    ((= I #o1000)
		     (DISK-WRITE RQB UNIT BLOCK))
		  (SETQ RH (SEND FILE :TYI)	;note halfwords in "right" order in LMC file
			LH (SEND FILE :TYI))
		  (WHEN (OR (NULL LH) (NULL RH))
		    (UPDATE-PARTITION-COMMENT
		      PART
		      (LET ((PATHNAME (SEND FILE ':TRUENAME)))
			(FORMAT NIL "~A ~D" (SEND PATHNAME ':NAME) (SEND PATHNAME :VERSION)))
		      UNIT)
		    (RETURN-FROM DONE NIL))
		  (SETF (AREF BUF16 I) RH)
		  (SETF (AREF BUF16 (1+ I)) LH))))))))))


))

; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:51
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "

(DEFUN COMPARE-LMC-FILE (FILENAME PART &OPTIONAL UNIT)
  "Compare microcode from file FILENAME with partition PART on unit UNIT.
UNIT can be a disk unit number, the name of a machine on the chaosnet,
or /"CC/" or /"LAM/" which refers to the machine being debugged by this one."
  (setq unit (default-disk-unit unit))
  (SETQ FILENAME (IF (NUMBERP FILENAME)
		     (SEND (PATHNAME "SYS: UBIN; ULAMBDA LMC >")
			   :NEW-VERSION FILENAME)
		   (FS:MERGE-PATHNAME-DEFAULTS FILENAME)))
  (UNLESS (STRING-EQUAL (SEND FILENAME :TYPE) "LMC")
    (FERROR "~A is not a LMC file." FILENAME))
  (WITH-DECODED-DISK-UNIT (UNIT UNIT
				(FORMAT NIL "Comparing ~A with ~A partition" FILENAME PART)
				NIL
				NIL)
    (WITH-DISK-RQB (RQB)
      (WITH-DISK-RQB (RQB-FOR-LABEL 3)
	(MULTIPLE-VALUE-BIND (PART-BASE PART-SIZE)
	    (FIND-DISK-PARTITION-FOR-READ PART RQB-FOR-LABEL UNIT NIL "LMC")
	  (WITH-OPEN-FILE (FILE FILENAME :DIRECTION :INPUT :CHARACTERS NIL :BYTE-SIZE 16.)
	    (BLOCK DONE
	      (DO ((BUF16 (rqb-buffer rqb))
		   (BLOCK PART-BASE (1+ BLOCK))
		   (N PART-SIZE (1- N)))
		  ((ZEROP N) (FORMAT T "~&File is longer than partition"))
		(DISK-READ RQB UNIT BLOCK)
		(DO ((LH) (RH)
		     (I 0 (+ I 2)))
		    ((= I #o1000))
		  (SETQ RH (SEND FILE ':TYI)	;note halfwords in "right" order in LMC file
			LH (SEND FILE ':TYI))
		  (COND ((OR (NULL LH) (NULL RH))
			 (RETURN-FROM DONE NIL)))
		  (COND ((OR (NOT (= RH (AREF BUF16 I)))
			     (NOT (= LH (AREF BUF16 (1+ I)))))
			 (FORMAT T "~&Compare error:  adr ~O; file ~O-~O; partition ~O-~O"
				 I LH RH (AREF BUF16 (1+ I)) (AREF BUF16 I)))))))))))))


))

; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:53
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "


(defun get-pack-name (&optional unit &aux pack-names)
  (setq unit (default-disk-unit unit))
  (WITH-DECODED-DISK-UNIT (unit unit "reading label")
    (WITH-DISK-RQB (RQB DISK-LABEL-RQB-PAGES)
      (read-disk-label rqb unit)
      (let ((whole-pack-name (ecase (get-disk-fixnum rqb 1)
			       ;;the fourth arg, t, here means not to stop at the first 0 byte
			       (1 (get-disk-string rqb #o20 32. t))
			       (2 (get-disk-string rqb 12. 16.)))))
	(do  ((i 0 (1+ i))
	      (tok-begin nil))
	     ((= i (string-length whole-pack-name))
	      (when tok-begin
		(push (substring whole-pack-name tok-begin) pack-names)))
	  (let ((c (logand 177 (aref whole-pack-name i))))
	    (cond ((and (> c (char-int #\space) )
			(< c 177)
			(not (char-equal c #/:)))
		    (if (null tok-begin)
			(setq tok-begin i)))
		   ((null tok-begin))
		   (t
		    (push (substring whole-pack-name tok-begin i) pack-names)
		    (setq tok-begin nil))))))))
  (values-list (reverse pack-names)))

))

; From modified file DJ: L.IO; DISK.LISP#400 at 15-May-86 09:37:55
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DISK  "


(defun set-pack-name (pack-name &optional unit)
  (setq unit (default-disk-unit unit))
  (WITH-DECODED-DISK-UNIT (unit unit "writing label")
    (WITH-DISK-RQB (RQB DISK-LABEL-RQB-PAGES)
      (read-disk-label rqb unit)
      (ecase (get-disk-fixnum rqb 1)
	(1 (put-disk-string rqb pack-name #o20 32.))
	(2 (put-disk-string rqb pack-name 12. 16.)))
      (write-disk-label rqb unit)))
  pack-name)

;This is a test function.

))

; From modified file DJ: L.IO; DLEDIT.LISP#91 at 15-May-86 09:39:06
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DLEDIT  "


(DEFUN SET-CURRENT-MICROLOAD (BAND &OPTIONAL UNIT)
  "Specify the MCR band to be used for loading microload at boot time.
Do PRINT-DISK-LABEL to see what bands are available and what they contain.
UNIT can be a string containing a machine's name, or /"CC/";
then the specified or debugged machine's current microload is set.
The last works even if the debugged machine is down.
UNIT can also be a disk drive number; however, it is the disk on
drive zero which is used for booting."
  (setq unit (default-disk-unit unit))
  (SET-CURRENT-BAND BAND UNIT T))

))

; From modified file DJ: L.IO; DLEDIT.LISP#91 at 15-May-86 09:39:09
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DLEDIT  "


(DEFUN SET-CURRENT-BAND (BAND &OPTIONAL UNIT MICRO-P &AUX LABEL-INDEX)
  "Specify the LOD band to be used for loading the Lisp system at boot time.
If the LOD band you specify goes with a different microcode,
you will be given the option of selecting that microcode as well.  Usually, do so.

Do PRINT-DISK-LABEL to see what bands are available and what they contain.
UNIT can be a string containing a machine's name, or /"CC/";
then the specified or debugged machine's current band is set.
The last works even if the debugged machine is down.
UNIT can also be a disk drive number; however, it is the disk on
drive zero which is used for booting.

Returns T if the band was set as specified, NIL if not
 (probably because user said no to a query)."
  (setq unit (default-disk-unit unit))
  (with-decoded-disk-unit (unit unit
				(FORMAT NIL "(SET-CURRENT-~:[BAND~;MICROLOAD~] ~D)"
					MICRO-P BAND))
    (with-disk-rqb (rqb disk-label-rqb-pages)
      (PROG ((UCODE-NAME (SELECT-PROCESSOR
			   (:CADR "MCR")
			   (:LAMBDA "LMC")
			   (:explorer "MCR")
			   )))
	    (SETQ BAND (COND ((OR (SYMBOLP BAND) (STRINGP BAND))
			      (STRING-UPCASE (STRING BAND)))
			     (T (FORMAT NIL "~A~D"
					(COND (MICRO-P UCODE-NAME)
					      (T "LOD"))
					BAND))))
	    (OR (STRING-EQUAL (SUBSTRING BAND 0 3)
			      (IF MICRO-P UCODE-NAME "LOD"))
		(FQUERY NIL "The specified band is not a ~A band.  Select it anyway? "
			(IF MICRO-P UCODE-NAME "LOD"))
		(RETURN NIL))
	    
	    (MULTIPLE-VALUE (NIL NIL LABEL-INDEX)
	      (FIND-DISK-PARTITION-FOR-READ BAND RQB UNIT))	;Does a READ-DISK-LABEL
	    
	    (ecase (get-disk-fixnum rqb 1)
	      (1 (PUT-DISK-STRING RQB BAND (COND (MICRO-P 6) (T 7)) 4))
	      (2 (if (numberp unit)
		     (if micro-p
			 (set-default-microload-V2 rqb band)
		       (set-default-load-band-V2 rqb band))
		   (ferror "can't set the default band remotely for V2 labels")))
	      )
	    
	    (IF (NOT MICRO-P)
		(MULTIPLE-VALUE-BIND (NIL MEMORY-SIZE-OF-BAND UCODE-VERSION-OF-BAND)
		    (MEASURED-SIZE-OF-PARTITION BAND UNIT)
		  (LET ((CURRENT-UCODE-VERSION (current-microload-version unit))
			(MACHINE-MEMORY-SIZE (cond ((and (numberp unit)
							 (= (get-disk-fixnum rqb 1) 2))
						    (page-partition-size-for-local-machine))
						   (t
						    (MEASURED-SIZE-OF-PARTITION "PAGE" UNIT)))))
		    (AND (> MEMORY-SIZE-OF-BAND MACHINE-MEMORY-SIZE)
			 (NOT (FQUERY NIL "~A requires a ~D block PAGE partition, but there is only ~D.  Select ~A anyway? "
				      BAND MEMORY-SIZE-OF-BAND MACHINE-MEMORY-SIZE BAND))
			 (RETURN NIL))
		    (MULTIPLE-VALUE-BIND (BASE-BAND-NAME BASE-BAND-VALID)
			(INC-BAND-BASE-BAND BAND UNIT)
		      (WHEN BASE-BAND-NAME
			(FORMAT T "~%Band ~A is an incremental save with base band ~A."
				BAND BASE-BAND-NAME)
			(UNLESS BASE-BAND-VALID
			  (FORMAT T "~2%It appears that ~A's contents have been changed
 since ~A was dumped.  Therefore, booting ~A may fail to work!"
				  BASE-BAND-NAME BAND BAND)
			  (UNLESS (FQUERY FORMAT:YES-OR-NO-P-OPTIONS "~%Select ~A anyway? "
					  BAND)
			    (RETURN NIL)))))
		    (IF UCODE-VERSION-OF-BAND
			(IF (EQ CURRENT-UCODE-VERSION UCODE-VERSION-OF-BAND)
			    (FORMAT T "~%The new current band ~A should work properly
with the ucode version that is already current." BAND)
			  (LET ((BAND-UCODE-PARTITION
				  (FIND-MICROCODE-PARTITION RQB UCODE-VERSION-OF-BAND)))
			    (IF BAND-UCODE-PARTITION
				(IF (FQUERY NIL "~A goes with ucode ~D, which is not selected.
Partition ~A claims to contain ucode ~D.  Select it? "
					    BAND UCODE-VERSION-OF-BAND
					    BAND-UCODE-PARTITION UCODE-VERSION-OF-BAND)
				    (ecase (get-disk-fixnum rqb 1)
				      (1 (PUT-DISK-STRING RQB BAND-UCODE-PARTITION 6 4))
				      (2 (cond ((numberp unit)
						(set-default-microload-V2 rqb band-ucode-partition))
					       (t
						(ferror "can't set remote V2 labels")))))
				  (UNLESS (FQUERY FORMAT:YES-OR-NO-P-OPTIONS
						  "~2%The machine may fail to boot if ~A is selected
 with the wrong microcode version.  It wants ucode ~D.
Currently ucode version ~D is selected.
Do you know that ~A will run with this ucode? "
						  BAND UCODE-VERSION-OF-BAND
						  CURRENT-UCODE-VERSION BAND)
				    (RETURN NIL)))
			      ;; Band's desired microcode doesn't seem present.
			      (FORMAT T "~%~A claims to go with ucode ~D,
which does not appear to be present on this machine.
It may or may not run with other ucode versions.
Currently ucode ~D is selected."
				      BAND UCODE-VERSION-OF-BAND CURRENT-UCODE-VERSION)
			      (UNLESS (FQUERY FORMAT:YES-OR-NO-P-OPTIONS
					      "~%Should I really select ~A? " BAND)
				(RETURN NIL))))))))
	      ;; Here to validate a MCR partition.
	      (WHEN (and (= (get-disk-fixnum rqb 1) 1)
			 (> LABEL-INDEX (- #o400 3)))
		(FORMAT T "~%Band ~A may not be selected since it is past the first page of the label.
The bootstrap prom only looks at the first page.  Sorry.")
		(RETURN NIL)))
	    (WRITE-DISK-LABEL RQB UNIT)
	    (RETURN T)))))


))

; From modified file DJ: L.IO; DLEDIT.LISP#91 at 15-May-86 09:39:12
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DLEDIT  "


(DEFUN CURRENT-MICROLOAD (&OPTIONAL UNIT)
  "Return the name of the current microload band.
UNIT can be a name of a machine, a number of a disk drive,
or a string containing CC."
  (setq unit (default-disk-unit unit))
  (CURRENT-BAND UNIT T))

))

; From modified file DJ: L.IO; DLEDIT.LISP#91 at 15-May-86 09:39:15
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DLEDIT  "


(DEFUN CURRENT-BAND (&OPTIONAL UNIT MICRO-P)
  "Return the name of the current Lisp system (LOD) band.
UNIT can be a name of a machine, a number of a disk drive,
or a string containing CC."
  (setq unit (default-disk-unit unit))
  (with-decoded-disk-unit (unit unit "Reading Label")
    (with-disk-rqb (rqb disk-label-rqb-pages)
      (READ-DISK-LABEL RQB UNIT)
      (ecase (get-disk-fixnum rqb 1)
	(1
	 (GET-DISK-STRING RQB (IF MICRO-P 6 7) 4))
	(2
	 (cond ((numberp unit)
		(current-band-for-local-machine micro-p))
	       (t
		(find-v2-band rqb (if micro-p 1 0) nil))))))))

))

; From modified file DJ: L.IO; DLEDIT.LISP#91 at 15-May-86 09:39:17
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DLEDIT  "


(Defun default-disk-unit (unit)
  (when (null unit)
    (select-processor
      ((:cadr :lambda) 0)
      (:explorer (explorer-lod-band-logical-unit))))
  )

))

; From modified file DJ: L.IO; DLEDIT.LISP#91 at 15-May-86 09:39:20
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DLEDIT  "


(DEFUN PRINT-DISK-LABEL (&OPTIONAL UNIT (STREAM STANDARD-OUTPUT))
  "Print the contents of a disk label.
A unit can be a disk drive number, the name of a machine (the chaosnet is used)
or /"CC/" meaning the machine being debugged by this one.
The last can be used even if that machine is down."
  (setq unit (default-disk-unit unit))
  (WITH-DECODED-DISK-UNIT (DECODED-UNIT UNIT "reading label")
    (using-resource (rqb si:rqb disk-label-rqb-pages 4)
      (read-disk-label rqb decoded-unit)
      (print-disk-label-from-rqb stream decoded-unit rqb nil))))

))

; From modified file DJ: L.IO; DLEDIT.LISP#91 at 15-May-86 09:39:24
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; DLEDIT  "


(DEFUN EDIT-DISK-LABEL (&OPTIONAL LE-UNIT (INIT-P NIL)
						;If t, dont try to save page 1 since current
						; label is garbage.  It can bomb setting
						; blocks-per-track to 0, etc.
			&AUX LE-STRUCTURE (LE-ITEM-NUMBER 0) CH COM ABORT)
  "Edit the label of a disk pack.
LE-UNIT is the disk drive number, or a name of a machine (the chaosnet is used),
or /"CC/" which refers to the machine being debugged by this one."
  (setq le-unit (default-disk-unit le-unit))
  (SETQ LE-SOMETHING-CHANGED NIL)		;restart
  (WITH-DECODED-DISK-UNIT (LE-UNIT LE-UNIT "editing label" INIT-P)
    (WITH-DISK-RQB (LE-RQB DISK-LABEL-RQB-PAGES)
      (LE-INITIALIZE-LABEL LE-RQB (CAR PACK-TYPES))
      (if (null init-p)
	  (READ-DISK-LABEL LE-RQB LE-UNIT))
      (LE-DISPLAY-LABEL LE-RQB LE-UNIT T)
      (FORMAT T "Use Control-R to read and edit existing label; hit HELP for help.~%")
      (PRINC "Label Edit Command: ")
      (*CATCH 'LE-EXIT
	(DO-FOREVER
	  (SETQ CH (SEND *TERMINAL-IO* ':TYI))
	  (SETQ COM (INTERN-SOFT (STRING-UPCASE (FORMAT NIL "LE-COM-~:C" CH))
				 "SI"))
	  (COND ((OR (NULL COM)			;nothing typed
		     (NOT (FBOUNDP COM)))	;command not defined
		 (BEEP)
		 (FORMAT T "~%~:C is not a known edit-disk-label command.  ~
                                        Type ~:C for help, or ~:C to exit." CH #/HELP #/END))
		(T (MULTIPLE-VALUE (NIL ABORT)
		     (CATCH-ERROR-RESTART ((ERROR SYS:ABORT)
					   "Return to EDIT-DISK-LABEL.")
		       (FUNCALL COM)))
		   (AND ABORT (LE-DISPLAY-LABEL LE-RQB LE-UNIT)))))))))


;;; Redisplay

))