;;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10; Fonts:(CPTFONT CPTFONTB CPTFONTI MEDFNB) -*-
;1;;                           RESTRICTED RIGHTS LEGEND*
;1;;Use, duplication, or disclosure by the Government is subject to*
;1;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in*
;1;;Technical Data and Computer Software clause at 52.227-7013.*
;1;;*
;1;;                     TEXAS INSTRUMENTS INCORPORATED.*
;1;;                              P.O. BOX 2909*
;1;;                           AUSTIN, TEXAS 78769*
;1;;                                 MS 2151*
;1;;*
;1;; Copyright (C) 1980, Massachusetts Institute of Technology*
;1;; Copyright (C) 1984-1989 Texas Instruments Incorporated. All rights reserved.*

;1;;*
;1;; Edit History*
;1;;*
;1;;   Date    Author  Description*
;1;;------------------------------------------------------------------------------*
;;;   04-13-89  DAB    Moved MEASURED-SIZE-OF-PARTITION to disk-partition.
;;;   04-13-89  DAB    Changed  4NEW-PACK-TYPES* to support the new size requirements for GDOS and DIAG.
;1;;  04/10/89 MAY     Changed 4EDIT-DISK-LABEL** 1to use guts of tv:with-font-map to correctly*
;1;; *			1 restore the original font map. Also moved ferror up to prevent*
;1;;*			1 permanently losing original font map.*
;;;   12-16-88 DAB     Fixed print-available-bands to except '(x y) and '("x" "y") for machines.
;;;   12-15-88 DAB     Added the cpu-type as third arg to get-partition-list-of-unit in 4my-find-microcode-partition*. 
;;;   **************** Rel 5.0 OS DAB
;;;   10/5/88.  ab     d-l 5-1    Changed :COND (resource-present-p :disk) PRINT-DISK-LABEL to Explorer-named version 
;;;                               which is called by main PRINT-DISK-LABEL routine (now in DISK-PARTITION).  Done to
;;;                               support printing of remote Exp labels from microExplorers.
;;;                                 Also fixed SET-PARTITION-PROPERTY & friends to work on remote Explorer units.
;;;   7-13-88 DAB   - 4CHECK-FOR-END-OF-DISK* was not calculating  the end-of-disk properly.
;;;   4-06-88 DAB   - Modified find-default-load to not force in a cpu-type if not suppied.
;;;   2/26/88 ab    - Moved the mX verson of PRINT-DISK-LABEL [(not (resource-present-p :disk))] to 
;;;                   DISK-PARTITION file.
;;;  01.25.88 MBC     Integrate my mods with DAB's 12-02-87 thru 01-20-88 modfications.
;;;  01.21.88 MBC     Convert to MAC conditionalizations, ala DEFINE-WHEN & RESOURCE-PRESENT-P.
;;;  12-02-87 DAB   - Fixed Print-available-bands to work properly.Changes to FINGER-ALL-LISPM was also required
;;;                   to make this work.
;;;  09-25-87 DAB   - Fixed the problem in print-disk-label and edit-disk-lable erroring off when NVRAM unit is offline.
;;;  09-21-87 JJP   - Added Color underscore support
;;;  09-08-87 DAB   - Changed 4LE-Com-Control-W* to wait for remote IO to complete if unit is a closure.
;1;; 01-07-86 MBC*		1Remove duplicate definition of Partition-Comment.*
;1;; 12/4/86  HW   - Make calls to STRING-EQUAL use keyword arguments *
;1;; 10-09-86 MBC  - Change SUBSTRING to SUBSEQ.  Leave READLINE w/ option = :NO-INPUT-SAVE in.*
;1;; 12-12-85 MBC  -  Lots of changes (from system patch 2-70)::*
;1;; *	1Add band types, Empty & System Log to disk label support.  Also*
;1;; *	1fixed a bug that prevented expanding the partition table length past a*
;1;; *	1page boundary.  Added optional band attribute matching to Find-Disk-Partition.*
;1;; Fix Get-Partition-List to ignore disk without proper labels. 2/20/85 coats*
;1;; Revised to restore closure test inside four functions.  Supports magtape. 2/13/85 coats*
;1;; Disk label editor for the version 2 (NUPI) disk label.*
;1;;*
;1;;  Problems fixed in 2.1 Patch Release: 3-31-86 DAB.  [SEE BELOW]*
;1;; Move PAD-NAME-FIELD and *PARTITION-NAME-CASE-SENSITIVE* to Disk-Label-Intermediates file, so*
;1;;   they'll be defined for Find-Disk-Partiiton. 8-4-86 MBC*
;1;;*
;1;; *
;1;;3-31-86 DAB.*
;1;;*
;1;;*
;1;;*	1All references to (send *standard-output* ...) have been changed to*
;1;;*	1    (send user:*terminal-io* ..) This problem caused the comment field to wrap.*
;1;;*	1    When this happen you could not edit the comment field.*
;1;;*
;1;;*	1Whenever the SYS:ABORT key was pressed the EDIT-DISK-LABEL was aborted. If the key*
;1;;*	1    was pressed by mistake the user lost all previous changes. With this release*
;1;;*	1    the EDIT-DISK-LABEL is only aborted by SYS:ABORT in the main menu (i.e. when*
;1;;*	1    "Label Edit Command:" is displayed). A verification message will be printed.*
;1;;*	1    The user will still have an opportunity to return to the EDIT-DISK-LABEL.*
;1;;*	1    Pressing the SYS:ABORT key in other functions will return the user to the main*
;1;;*	1    menu.*
;1;;*	
;1;;*	1This release has added the capability of adding and modifying CPU types for each*
;1;;*	1    partition. The user can select from a table of currently supported CPUs or*
;1;;*	1    enter his/her own. The new command CTRL-C is used to edit this field.*
;1;;*
;1;;*	1The list of partition types (CTRL-A) has been expanded to include System Log Bands,*
;1;;*	1    Empty Bands and User Defined Bands. The user defined partition type is any*
;1;;*	1    number between #x0C and #xFE ,inclusive.*
;1;;*
;1;;*	1All partition name are four ASCII characters. Blanks are padded on the right when*
;1;;*	1    less than four characters are entered.*
;1;;*
;1;;*	1The format of the display during PRINT-DISK-LABEL and EDIT-DISPLAY-LABEL has been*
;1;;*	1    changed.*
;1;;*	1    Most noteably:*
;1;;*	1    1) The headings above the list of partitions. The "at block" and "blocks long"*
;1;;*	1       have been removed from each partition line.*
;1;;*
;1;;*	1    2) Informative messages such as " xx blocks overlap" and " xx blocks free at*
;1;;*	1       yy" are written on a new line.*
;1;;*
;1;;*	1    3) A new column was added call "CPU/OS Type".*
;1;;*
;1;;*	1    4) Partition type "Explorer Microcode" now show "Microcode".*
;1;;*
;1;;         5) Columns "Starting Block" and "Length" has been moved to the right next to "Name". *
;1;;*
;1;;*	1The default values for disk types used during CTRL-I (Initialize disk) have been*
;1;;*	1       changed to include "LABL", "PTBL", "SAVE" and "EXPT" partitions with*
;1;;*	1       lenghts of 2,3,3 and 148 respectively.*
;1;;*
;1;;*	1The default list of partition types used during CTRL-A has been changed to include*
;1;;*	1       System Log Band, Empty Band and User Defined Bands. If "User Defined Bands"*
;1;;*	1       is selected the user is prompted for a numeric number. The number can be in*
;1;;*	1       any base but perferable hex.*
;1;;*
;1;;*	1The default list of CPU Types used during CTRL-C includes Explorer, Numachine,*
;1;;*	1       S1500,TI Lisp, System 5, Generic and User Defined CPU type. If "User*
;1;;*	1       Defined CPU Types" is selected the user is prompted for a numeric number.*
;1;;*	1       The number can be in any base but perferable hex. The number must be in*
;1;;*	1       the range of #xC and #xFE, inclusive.*
;1;;*
;1;;*	1The Check-For-End-Disk functions has been fixed. The previous version did not*
;1;;*	1       subtract out the number of reserved sectors used for defect mapping.*
;1;;*	1       Now it does.*
;1;;*
;1;;*	1The function SET-Partition-attribute has been modified to include the new*
;1;;*	1       partition types.*
;1;;*
;1;;*	1A new function called SET-Partition-CPU-type provides the same functionality*
;1;;*	1       as SET-Partition-attribute but modifies CPU Types.*
;1;;*
;1;;*	1The function GET-Partition-list has been changed to include an optional parameter*
;1;;*	1       "Processor-Type".If included only partitions having this value in the*
;1;;*	1       partition type field is returned.*
;1;;*	
;1;;     If the length of the partition table is greater than 1 block and the number of*
;1;;*	1       partition exceded 31 entries all entries below the thirty first is lost.*
;1;;*	1       A temporary array was created to small. This release has expanded the*
;1;;*	1       temporary arrary to handle partition table length of 3 blocks. *
;1;;*
;1;;*	1Additional warning messages have been added to CTRL-W for "END OF DISK",*
;1;;*	1       "OVERLAYING PARTITIONS","The length of Partition Table Does Not Equal*
;1;;*	1       Length of the Save Area", "Default Load Band  does not exist or is*
;1;;*	1       not of type (Load Band)" and "Default Microload Band does not exist or*
;1;;*	1       is not of type (Microload)" occurences.*
;1;;*
;1;;*	1The EDIT-DISK-LABEL functions use the READ and READLINE functions as the primary*
;1;;*	1      input method. This causes all input parameters to be added to the command*
;1;;*	1      line history string. In another words when you exit EDIT-DISK-LABEL and*
;1;;*	1      press CTRL-C you get "junk" or data that was entered during the edit*
;1;;*	1      process. You would expect "(EDIT-DISK-LABEL". This problem is now fixed.*
;1;;*
;1;;*	1The EDIT-DISK-LABEL supports lowercase partition names. The global variable*
;1;;*	1      *partition-name-case-sensitive* must be set in order to enter or copy*
;1;;*	1      lowercase partition names. The lowercase option is intended to *
;1;;*	1      support UNIX partition types and should not be used in strictly Explorer*
;1;;*	1      environment. This variable can be set explictly using SETF or the command*
;1;;*	1      CRTL-T in EDIT-DISK-LABEL.*
;1;;*	1      The low level function FIND-DISK-PARTITION will now support lowercase*
;1;;*	1      partition names when SI:*Partition-name-case-sensitive* is set. This*
;1;;*	1      function is called by many of the partition utilities functions such as*
;1;;*	1      TRANSMIT-BAND, RECEIVE-BAND, COPY-DISK-PARTITION and*
;1;;           COMPARE-DISK-PARTITION. The TO-BAND and FROM-BAND entries in these*
;1;;           function must be strings if using lowercase partition names, a numeric*
;1;;           value will still be mapped to uppercase "LOD".*
;1;;*
;1;;      The EDIT-DISK-LABEL will check the current window characterists. If the window*
;1;;           is not a full screen window and current font is not of type CPTFONT a new*
;1;;           window will be created. The new window object is save in*
;1;;           *WORKING-DLEDIT-WINDOW* and will be used on all future EDIT-DISK-LABEL*
;1;;           calls.*
;1;;*
;1;;      Overwrite warning are displaye dwhen the user attempts to use disk blocks 0 or 1*
;1;;           and disk blocks allocated to the default partition table and save area.*
;1;;        *
;1;;*
;1;;        An optional keyword specifying CPU (processor) type has been added to the*
;1;;*	1      following functions:*
;1;;*	1      GET-PARTITION-LIST*
;1;;*	1      SET-DEFAULT-MICROCODE*
;1;;*	1      FIND-DEFAULT-MICROCODE*
;1;;*	1      FIND-DEFAULT-LOAD*
;1;;*	1      SET-DEFAULT-LOAD-BAND*
;1;;*
;1;;*
;1;;*	
;1;; Known Problems not fixed with this release.*
;1;;*
;1;;*	1Edit-Disk-label can not expand a full window length. This will occur if the*
;1;;*	1       window width is to small to allow one per partition, adding enough*
;1;;*	1       partitions to fill the entire window or using to large of a font.*
;1;;*	1       Therefore, use EDIT-DISK-LABEL from a full screen window, limit the     *
;1;;*	1       number of partitions to 30 and use medium font size.*
;1;;*
;1;;*	1The current version of EDIT-DISK-LABEL does not automatically expand the*
;1;;*	1       partition table. In the CTRL-O function the user is prompted when the*
;1;;*	1       current partition table is full if he/she wishes to expand the partition*
;1;;*	1       table. Currently this can only be done manually using the following*
;1;;*	1       steps:*
;1;;*	1       1) Execute (EDIT-Disk-Label)*
;1;;            2) Create a new partition (CTRL-O) with name "PTBX", length 3 blocks,*
;1;;*	1          attribute Partition-Table.*
;1;;            3) Write the new disk label to disk (CTRL-W).*
;1;;*	1       4) Reboot.*
;1;;*	1       5) Execute (SI:Copy-DISK-Partition 0 'PTBL 0 'PTBX).*
;1;;*	1       6) Execute (EDIT-Disk-Label)*
;1;;*	1       7) Modify "Partition Table" to PTBX.*
;1;;*	1       8) Modify partition's "length" to 3.*
;1;;*	1       9) Modify partition's "starting block" to the starting block of PTBX.*
;1;;*	1      10) Write the new disk label to disk (CTRL-W).*
;1;;*	1      11) Reboot.*
;1;;*
;1;;         The STBM specification for the DISK LABEL states:*
;1;;*	1      Each entry in the partition table has a set of partition "key"*
;1;;*	1      characteristics. These include: Name of the partition, partition type,*
;1;;*	1      partition user type and partition attribute bits. Any combination of the*
;1;;*	1      characteristics may be used to uniquely identify a partiion.*
;1;;*
;1;;*	1      EDIT-DISK-LABEL supports this requirement, but the DLEDIT interface*
;1;;*	1      functions, such as "Change Partition Property","Set Current Band" and*
;1;;*	1      "Find Disk Partition for READ",do not. Others such as "Find Disk*
;1;;*	1      Partition" do provide limited search on partition type and CPU type.*

;1;;*
;1;; Edit History*
;1;;*
;1;;                   Patch*
;1;;   Date    Author  Number   Description*
;1;;------------------------------------------------------------------------------*
;1;; 10-15-86   ab      --      - Changes for 2K page-size. *
;1;;*
;1;; 2-2-87     DAB     added (when (find-symbol "MENU-CHOOSE" 'W) in select-current-band and select-current-microload*
;1;; 2-2-87     HW      Removed cold-load attribute from this file; change a few fonts.*	1 *
;1;; 2-3-87     MRR     Changed the Set-Current-Band family of functions (i.e. SET-CURRENT-BAND,*
;1;;                    SET-CURRENT-MICROLOAD) to use the configuration partition. *
;1;;                    Added SET-CURRENT-BAND-IN-PTBL, SET-DEFAULT-BAND-IN-PTBL to act like old set-current-band.*
;1;;                    Added an optional arg to GENERATE-PARTITION-MENU-LIST for cpu-type.*
;1;;                    Moved CURRENT-MICROLOAD to Disk-Label-Intermediates file, to be with CURRENT-BAND.*
;1;;*
;1;; 02-06-87   DAB     Added new cpu types for downloadable controllers. Requires microload 177.*
;1;; 2-9-87     MRR     Added warnings to DISK-INTEGRITY-CHECK for PRIM-related issues.  *
;1;;                    Added warnings to LE-COM-CONTROL-E when one edits the current-microload and current-load fields*
;1;;                    or the LOD and MCR names.*
;1;; 2-13-87    MRR     Changed names of assure-versions-1 & -2 to assure-mcr-version & assure-lod-version.*
;1;;                    Also, fixed these to deal with wilds, "*", properly. *
;1;;                    Fixed SET-CURRENT-BAND-IN-PTBL to check partition attributes, etc.*
;1;;                    Removed warnings about LABL and SAVE area length from DISK-INTEGRITY-CHECK.*
;1;;                    Added variables *LE-remote-edit* and *LE-prim-style-edit* to keep track of these situations.*
;1;; 02-16-87   DAB     Corrected measured-size-of-partition to work on rel2 load bands.*
;1;; 02-17-87   DAB     Change to base 10.*
;1;; 03.02-87   DAB     Changed edit-disk-label to handle fonts properly.*
;1;;  3-03-87   MRR     Fixed MY-FIND-MICROCODE-PARTITION to just look for the version number in the microcode comment*
;1;;                    field rather than the string "CONTROL" and the version number. Somebody may need to fix *
;1;;                    FIND-MICROCODE-PARTITION also.*
;1;; 03.17.87   DAB     Added a new partition called ANCHOR.*
;1;; 03.17.87   MRR     Added new vars for managing config band info. Added LE-GET-CFG-DATA. Changed these functions to*
;1;;                    support config-style editing: LE-COM-CONTROL-E, LE-COM-CONTROL-W, LE-COM-CONTROL-R, LE-COM-CONTROL-M,*
;1;;                    PRINT-DISK-LABEL, PRINT-DISK-LABEL-FROM-RQB, EDIT-DISK-LABEL-1.*
;1;;                    These changes are also in patch IO-1-4 (pre-release 3).*
;1;;                    Changed name to |Disk Label Default| in partition-properties variable.*
;1;; 03.18.87   MRR     Added comment field to display list created in GENERATE-PARTITION-MENU-LIST. *
;1;; 03.23.87   DAB     Added partition-name-string support.*
;1;; 03.27.87    HW     Change use of :draw-rectangle to sys:%draw-rectangle to get around window problem in LE-UNDERSCORE.*
;1;; 03.30.87   DAB     Removed cpu-type default from partition-list-from-rqb.*
;1;; 04.06.87   DAB     Fixed Set-default-load and set-default-microcode. If a cpu-type was not entered it was errorring*
;1;;                    when doing (= nil ..)*
;1;; 04.07.87   DAB     Fixed get-ucode-version-from-band to handle different offset for Explorer II.*
;1;; 04.21.87   DAB     Fixed le-get-cfg-data to ignore bad CFG partitions.*
;1;; 05.15.87    HW     Allow edit-disk-label to work with suggestions on. If listener is too small just output error message.*

;;;
;;; Edit History
;;; 12.02.87 	MBC	new seperate file to isolate 90% of edit label not needed for ADDIN.
;;;

;;; Addin conditional...
(eval-when (eval compile)
  (defprop when t si:may-surround-defun)
  (defprop unless t si:may-surround-defun))

(define-when :DISK
(DEFVAR 4*END-OF-DISK-ERROR** ()) 		;1 new 2.1 release end-of-disk check*

(DEFVAR 4*OVERLAP-ERROR** ()) 			;1 new 2.1 rel. warning on overlays*

(DEFVAR 4*WORKING-DISK-SIZE** ()) 		;1working disk capacity: total - defect sectors*

(DEFVAR 4*WORKING-DLEDIT-WINDOW** ())              ;1create a window with full screen and CPTfont*

(defvar 4*LE-remote-edit** :unbound)
(defvar 4*LE-prim-style-edit** :unbound)

(defvar 4*LE-mcr-or-lod-changed** :unbound) ;1mrr 3.17.87*
(defvar 4*le-lod-name** nil)  
(defvar 4*le-lod-unit** nil)
(defvar 4*le-mcr-name** nil)
(defvar 4*le-mcr-unit** nil)
(defvar 4*le-cfg-unit** nil)
(defvar 4*le-cfg-name** nil)

;1new mrr 3.17.87*
(defun 4le-get-cfg-data* ()
  (ignore-errors  ;104.21.87 DAB Ignore bad CFG partitions.*
    (multiple-value-setq (*le-mcr-name* *le-mcr-unit*)
      (get-cfg-boot-data *le-cfg-name* *le-cfg-unit* ))
    (multiple-value-setq (*le-lod-name* *le-lod-unit*)
      (get-cfg-load-data *le-cfg-name* *le-cfg-unit*))))

;1;; LE-STRUCTURE is a list of items, each item looks like:*
;1;;   (name value start-x start-y width)*

(DEFVAR 4LE-STRUCTURE* ()) 

;1;; This is a subroutine for PRINT-DISK-LABEL-FROM-RQB which implements this.*
;1;; Note that if not consing up a structure, this must work on a non-display *
;1;; stream*
;1;;2.1 changes: terminal-io *

(DEFUN 4LE-OUT* (NAME VALUE STREAM CONS-UP-LE-STRUCTURE-P &OPTIONAL SPECIAL-FORMAT)
  (LET ((X)
	(Y)
	(WIDTH))
    (IF CONS-UP-LE-STRUCTURE-P
      (MULTIPLE-VALUE-SETQ (X Y)
	(SEND USER:*TERMINAL-IO* :READ-CURSORPOS)));12.1 fix. terminal-io*
    (FORMAT STREAM (OR SPECIAL-FORMAT (IF (NUMBERP VALUE)
					"~D"
					"~A"));1new Special-format 12-12-85*
	    VALUE)
    (WHEN CONS-UP-LE-STRUCTURE-P
      (SETQ WIDTH (- (SEND USER:*TERMINAL-IO* :READ-CURSORPOS) X));12.1 fix terminal-io*
      (IF (MINUSP WIDTH)
	(SETQ WIDTH (- (W:SHEET-INSIDE-RIGHT USER:*TERMINAL-IO*) X)));12.1 fix terminal-io*
      (IF (ZEROP WIDTH)
	(SETQ WIDTH 4))
      (PUSH (LIST NAME VALUE X Y WIDTH) LE-STRUCTURE)))
  ()) 

        
;1;;check the new label for disk integrity, ie. default partition attributes must match what the partition*
;1;; was created.*

(DEFUN 4DISK-INTEGRITY-CHECK* (RQB &AUX PART-NAME LEN)
  (IF *END-OF-DISK-ERROR*
    (PROGN
      (FORMAT USER:*TERMINAL-IO* "~%*** Warning: Partition(s) extend past end of disk at block(s) ~d! "
	      *END-OF-DISK-ERROR*)
      (FORMAT USER:*TERMINAL-IO* "~%***          Maximum capacity of this disk is ~d blocks. "
	      *WORKING-DISK-SIZE*)))
  (IF *OVERLAP-ERROR*
    (FORMAT USER:*TERMINAL-IO*
	    "~%*** Warning: There are overlaying partitions in this label at block(s) ~d! "
	    *OVERLAP-ERROR*))
  (SETF PART-NAME (GET-DISK-STRING RQB %DL-PARTITION-TABLE-NAME 4));1default partition name*
  (MULTIPLE-VALUE-BIND (PART-BASE PART-LENGTH IGNORE IGNORE PARTITION-ATTRIBUTES)
    (FIND-DISK-PARTITION PART-NAME RQB () T)
    (AND PART-BASE
       (PROGN
	 (WHEN (NOT (= (LDB %%BAND-TYPE-CODE PARTITION-ATTRIBUTES) %BT-PARTITION-TABLE))
	   (FORMAT USER:*TERMINAL-IO*
		   "~%*** Warning: The default Partition Table ~a is not of type (Partition Table)!"
		   PART-NAME))
	 (IF (= PART-BASE (GET-DISK-FIXNUM RQB %DL-PARTITION-TABLE-START))
	   ()
	   (FORMAT USER:*TERMINAL-IO*
		   "~%*** Warning: The start block of the Partition Table ~a does not match what has been created below!"
		   PART-NAME))
	 (IF (= PART-LENGTH (GET-DISK-FIXNUM RQB %DL-PARTITION-TABLE-LENGTH))
	   ()
	   (FORMAT USER:*TERMINAL-IO*
		   "~%*** Warning: The length of the Partition Table ~a does not match what has been created below!"
		   PART-NAME))))
    (SETF LEN (GET-DISK-FIXNUM RQB %DL-PARTITION-TABLE-LENGTH)))

  ;1; obsolete for 2.1 and later.*
  ;1;(SETF PART-NAME (GET-DISK-STRING RQB %DL-SAVE-AREA-NAME 4))*
  ;1;(MULTIPLE-VALUE-BIND (PART-BASE PART-LENGTH IGNORE IGNORE PARTITION-ATTRIBUTES)*
  ;1;  (FIND-DISK-PARTITION PART-NAME RQB () T)*
  ;1;  (AND PART-BASE*
  ;1;     (PROGN*
  ;1;*	1 (WHEN (NOT (= (LDB %%BAND-TYPE-CODE PARTITION-ATTRIBUTES) %BT-SAVE-AREA))*
  ;1;*	1   (FORMAT USER:*TERMINAL-IO**
  ;1;*		1   "~%*** Warning: The default Save Area ~a is not of type (Save Area)!"*
  ;1;*		1   PART-NAME))*
  ;1;*	1 (IF (= PART-BASE (GET-DISK-FIXNUM RQB %DL-SAVE-AREA-START))*
  ;1;*	1   ()*
  ;1;*	1   (FORMAT USER:*TERMINAL-IO**
  ;1;*		1   "~%*** Warning: The start block of the Save Area ~a does not match what has been created below!"*
  ;1; *		1   PART-NAME))*
  ;1;*	1 (IF (= PART-LENGTH (GET-DISK-FIXNUM RQB %DL-SAVE-AREA-LENGTH))*
  ;1;*	1   ()*
  ;1;*	1   (FORMAT USER:*TERMINAL-IO**
  ;1;*		1   "~%*** Warning: The length of the Save Area ~a does not match what has been created below!"*
  ;1;*		1   PART-NAME))))*
  ;1;*
  ;1; (AND (NOT (= LEN (GET-DISK-FIXNUM RQB %DL-SAVE-AREA-LENGTH)))*	
  ;1;    (FORMAT USER:*TERMINAL-IO**
  ;1;*	1       "~%*** Warning: The length of Partition Table ~a does not equal the length of Save area ~a."*
  ;1;*	1       (GET-DISK-STRING RQB %DL-PARTITION-TABLE-NAME 4)*
  ;1;*	1       (GET-DISK-STRING RQB %DL-SAVE-AREA-NAME 4)))*
  ;1;  )*
  
  ;1;--------new stuff-----------*
  (setf part-name "PRIM")
  (MULTIPLE-VALUE-BIND (PART-BASE IGNORE IGNORE IGNORE PARTITION-ATTRIBUTES)
    (FIND-DISK-PARTITION PART-NAME RQB () T)

  ;1; If PRIM is present on this disk...    *
    (When PART-BASE
      ;1;first check for the presence of a valid config band*
      (let ((part-list (partition-list-from-rqb RQB %BT-Configuration-Band %Cpu-Generic-Band))
	    default-found)
	(if (null part-list)
	    (format user:*terminal-io*
		    "~%*** Warning: This label contains a PRIM partition but not a valid, generic configuration partition.")	
	    (progn
	      (setq default-found nil)
	      (dolist (part part-list default-found)
		(when (LDB-TEST %%DEFAULT-INDICATOR (sixth part)) ;103.25.87 DAB*
		  (return (setq default-found t))))   ;103.23.87 DAB*
	      (unless default-found
		(format user:*terminal-io*
		    "~%*** Warning: This label contains a PRIM partition but not a default configuration partition."))
	      ))
      ;1;then check whether PRIM is default*
	(if (not (LDB-TEST %%DEFAULT-INDICATOR PARTITION-ATTRIBUTES))
	    (format user:*terminal-io*
		    "~%*** Warning: The default flag must be turned on for the PRIM partition.")
      ;1;then check whether PRIM is the first default microcode.*
	    (progn
	      (setq part-list (partition-list-from-rqb RQB %BT-microload %Cpu-explorer)) ;103.23.87 DAB*
	      (setq default-found nil)
	      (dolist (part part-list default-found)
		(when (LDB-TEST %%DEFAULT-INDICATOR (sixth part))
		  (if (string-equal part-name (first part))	;1if another default mcr is found, set flag.*
		      (return)
		      (setq default-found t)
		      (return))))
	      (when default-found
		(format user:*terminal-io*
			"~%*** Warning: ~a must be the first microcode partition with the default flag turned on.
Turn off other microcode partitions before ~a so that it can control the boot process." part-name part-name)
		)))))
  ;1; If PRIM is default or this is an Explorer II...*
    (when *LE-prim-style-edit*
      ;1;then check for a generic PTBL -- This is serious!!!*
      (let ((part-list (partition-list-from-rqb RQB %BT-partition-table %Cpu-Generic-Band)) ;103.25.87 DAB*
	    default-found)
	(if (null part-list)
	    (progn
	      (format user:*terminal-io*
		      "~%*** Warning: This label does not contain a valid, generic PTBL partition entry. 
-----  You will not be able to boot from this disk!!!  -----")
	      (beep)
	      (return-from disk-integrity-check nil))
	    (progn
	      (setq default-found nil)
	      (dolist (part part-list default-found)
		(when (LDB-TEST %%DEFAULT-INDICATOR (sixth part))
		  (setq default-found t)))
	      (unless default-found
		(format user:*terminal-io*
			"~%*** Warning: The default flag must be turned on for the Partition Table partition.
-----  You will not be able to boot from this disk!!!  -----")
		(beep)
		(return-from disk-integrity-check nil))
	      ))
	)
      )
    )
  T)  ;1disk-integrity-check *
 


;1;;2.1 changes: Modified the format of the listing of partitions. Added CPU column.*
;1;;             Informative messages now print on new line. *
(DEFUN 4PRINT-DISK-LABEL-FROM-RQB* (STREAM RQB CONS-UP-LE-STRUCTURE-P &AUX CURRENT-MICROLOAD CURRENT-BAND)
  (TERPRI STREAM)
  (LE-OUT 'VOLUME-NAME (GET-DISK-STRING RQB %DL-VOLUME-NAME 16.) STREAM CONS-UP-LE-STRUCTURE-P)
  (PRINC ", " STREAM)
  (LE-OUT 'DRIVE-NAME (GET-DISK-STRING RQB %DL-DEVICE-NAME 12.) STREAM CONS-UP-LE-STRUCTURE-P)
  (PRINC ", " STREAM)
  (LE-OUT 'COMMENT (GET-DISK-STRING RQB %DL-COMMENT 96.) STREAM CONS-UP-LE-STRUCTURE-P)
  (FORMAT STREAM "~%~a version ~d, ";1 You can't edit these*
	  (GET-DISK-STRING RQB %DL-BASE 4) (GET-DISK-FIXNUM RQB %DL-VERSION))
  (LET ((TYPE-WORD (GET-DISK-FIXNUM RQB %DL-STORAGE-TYPE)))
    (SELECT (LDB %%DL-TYPE-CODE TYPE-WORD)
       (%TC-DISK (LE-OUT 'DEVICE-TYPE "DISK" STREAM CONS-UP-LE-STRUCTURE-P)
	(LET ((TEMP (GET-DISK-FIXNUM RQB %BYTES-PER)))
	  (TERPRI STREAM)
	  (LE-OUT 'N-BYTES-PER-BLOCK (LDB %%BYTES-PER-BLOCK TEMP) STREAM CONS-UP-LE-STRUCTURE-P)
	  (PRINC " bytes per block, " STREAM)
	  (LE-OUT 'N-BYTES-PER-SECTOR (LDB %%BYTES-PER-SECTOR TEMP) STREAM
		  CONS-UP-LE-STRUCTURE-P)
	  (PRINC " bytes per sector, " STREAM)
	  (TERPRI STREAM)
	  (SETQ TEMP (GET-DISK-FIXNUM RQB %SECTOR-HEADS))
	  (LE-OUT 'N-SECTORS-PER-TRACK (LDB %%SECTORS-PER-TRACK TEMP) STREAM
		  CONS-UP-LE-STRUCTURE-P)
	  (PRINC " sectors per track, " STREAM)
	  (LE-OUT 'N-HEADS (LDB %%NUMBER-OF-HEADS TEMP) STREAM CONS-UP-LE-STRUCTURE-P)
	  (PRINC " heads, " STREAM)
	  (TERPRI STREAM)
	  (SETQ TEMP (GET-DISK-FIXNUM RQB %CYLINDERS))
	  (LE-OUT 'N-CYLINDERS (LDB %%NUMBER-OF-CYLINDERS TEMP) STREAM CONS-UP-LE-STRUCTURE-P)
	  (PRINC " cylinders, " STREAM)
	  (LE-OUT 'N-SECTORS-FOR-DEFECTS (LDB %%NUMBER-OF-SECTORS-FOR-DEFECTS TEMP) STREAM
		  CONS-UP-LE-STRUCTURE-P)
	  (PRINC " sectors for defects, " STREAM)))
       (%TC-TAPE (LE-OUT 'DEVICE-TYPE "TAPE" STREAM CONS-UP-LE-STRUCTURE-P))
       (OTHERWISE
	(LE-OUT 'DEVICE-TYPE (FORMAT () "UNKNOWN (~d)" (LDB %%DL-TYPE-CODE TYPE-WORD)) STREAM
		CONS-UP-LE-STRUCTURE-P))))
  (TERPRI STREAM)
  ;1mrr 3.14.87*
  (cond (*LE-prim-style-edit* 
	 (format stream "System Load Defaults from ~a on unit ~a:" (parse-partition-name *le-cfg-name*) *le-cfg-unit*)
	 (princ " Microcode = " stream)                                ;103.25.87 DAB*
	 (le-out 'system-microload (parse-partition-name *le-mcr-name*) stream cons-up-le-structure-p) ;103.27.87 DAB*
	 (princ " on unit " stream)
	 (le-out 'system-microload-unit *le-mcr-unit* stream cons-up-le-structure-p)
	 (princ ", Load = " stream)
	 (le-out 'system-band (parse-partition-name *le-lod-name*) stream cons-up-le-structure-p);103.27.87 DAB*
	 (princ " on unit " stream)
	 (le-out 'system-band-unit *le-lod-unit* stream cons-up-le-structure-p)
	 (terpri stream))
	(*le-remote-edit*			;1we might do something here*
	 ))
  (PRINC "Disk Label defaults:  Microcode = " STREAM)	;1mrr 3.13.87*
  (LE-OUT 'CURRENT-MICROLOAD (SETQ CURRENT-MICROLOAD (FIND-DEFAULT-MICROLOAD RQB)) STREAM
	  CONS-UP-LE-STRUCTURE-P)
  ;1(PUT-DISK-STRING RQB (STRING CURRENT-MICROLOAD) %DL-CURRENT-MICROLOAD 4)   ;rel3 *
  (PRINC "  Load = " STREAM)			;1mrr 3.13.87*
  (LE-OUT 'CURRENT-BAND (SETQ CURRENT-BAND (FIND-DEFAULT-LOAD RQB)) STREAM
	  CONS-UP-LE-STRUCTURE-P)
  ;1(PUT-DISK-STRING RQB (STRING CURRENT-BAND) %DL-CURRENT-BAND 4)             ;rel3*
  (TERPRI STREAM)
  (PRINC "Partition table " STREAM)
  (LE-OUT 'PARTITION-TABLE-NAME (GET-DISK-STRING RQB %DL-PARTITION-TABLE-NAME 4) STREAM
	  CONS-UP-LE-STRUCTURE-P)
  (PRINC ", starting block " STREAM)
  (LE-OUT 'PARTITION-TABLE-START (GET-DISK-FIXNUM RQB %DL-PARTITION-TABLE-START) STREAM
	  CONS-UP-LE-STRUCTURE-P)
  (PRINC ", length " STREAM)
  (LE-OUT 'PARTITION-TABLE-LENGTH (GET-DISK-FIXNUM RQB %DL-PARTITION-TABLE-LENGTH) STREAM
	  CONS-UP-LE-STRUCTURE-P)
  (TERPRI STREAM)
  (PRINC "Save area " STREAM)
  (LE-OUT 'SAVE-AREA-NAME (GET-DISK-STRING RQB %DL-SAVE-AREA-NAME 4) STREAM
	  CONS-UP-LE-STRUCTURE-P)
  (PRINC ", starting block " STREAM)
  (LE-OUT 'SAVE-AREA-START (GET-DISK-FIXNUM RQB %DL-SAVE-AREA-START) STREAM
	  CONS-UP-LE-STRUCTURE-P)
  (PRINC ", length " STREAM)
  (LE-OUT 'SAVE-AREA-LENGTH (GET-DISK-FIXNUM RQB %DL-SAVE-AREA-LENGTH) STREAM
	  CONS-UP-LE-STRUCTURE-P)
  (TERPRI STREAM)
  ;1; The partition table resides in the disk label buffer starting at block 1.*
  (LET ((PT-START %PT-BASE)
	N-PARTITIONS
	WORDS-PER-PART)
    (FORMAT STREAM "~d partitions, "
	    (SETQ N-PARTITIONS (GET-DISK-FIXNUM RQB (+ PT-START %PT-NUMBER-OF-PARTITIONS))))
    (FORMAT STREAM " ~d-word descriptors:"
	    (SETQ WORDS-PER-PART
		  (GET-DISK-FIXNUM RQB (+ PT-START %PT-SIZE-OF-PARTITION-ENTRIES))))
    ;1; print out partition descriptors*
    (SETF *END-OF-DISK-ERROR* ())
    (SETF *OVERLAP-ERROR* ())
    (FORMAT STREAM "~2%                            Starting")
    (FORMAT STREAM "~%  Name  Partition type        Block  Length  CPU/OS Type  Comments ")
    (DO ((I 0 (1+ I))
	 (LOC (+ PT-START %PT-PARTITION-DESCRIPTORS) (+ LOC WORDS-PER-PART)))
	((= I N-PARTITIONS))
      (LET ((PARTITION-NAME (GET-DISK-STRING RQB LOC 4)))
	(IF (LDB-TEST %%DEFAULT-INDICATOR (GET-DISK-FIXNUM RQB (+ LOC %PD-ATTRIBUTES)))
	  (FORMAT STREAM "~%* ")
	  (FORMAT STREAM "~%  "))
	(LE-OUT 'PARTITION-NAME PARTITION-NAME STREAM CONS-UP-LE-STRUCTURE-P "~4a"));112-12-85*
      (PRINC " " STREAM)
      (FORMAT STREAM "~20a"
	      (LE-GET-PARTITION-TYPE
	       (LDB %%BAND-TYPE-CODE (GET-DISK-FIXNUM RQB (+ LOC %PD-ATTRIBUTES)))))
      (PRINC " " STREAM)
      (LE-OUT 'PARTITION-START (GET-DISK-FIXNUM RQB (+ LOC %PD-START)) STREAM
	      CONS-UP-LE-STRUCTURE-P "~7D");112-12-85*
      (PRINC "  " STREAM)
      (LE-OUT 'PARTITION-SIZE (GET-DISK-FIXNUM RQB (+ LOC %PD-LENGTH)) STREAM
	      CONS-UP-LE-STRUCTURE-P "~6d");112-12-85*	
      (PRINC " " STREAM)
      (FORMAT STREAM "~13a"
	      (LE-GET-PARTITION-CPU-TYPE
	       (LDB %%CPU-TYPE-CODE (GET-DISK-FIXNUM RQB (+ LOC %PD-ATTRIBUTES)))))
      (PRINC " " STREAM)
      (WHEN (> WORDS-PER-PART %PD-COMMENT);1 Partition comment*
	(LE-OUT 'PARTITION-COMMENT
		(GET-DISK-STRING RQB (+ LOC %PD-COMMENT) (* 4 (- WORDS-PER-PART %PD-COMMENT)))
		STREAM CONS-UP-LE-STRUCTURE-P))
      (LET ((THIS-END
	     (+ (GET-DISK-FIXNUM RQB (+ LOC %PD-START)) (GET-DISK-FIXNUM RQB (+ LOC %PD-LENGTH))))
	    (NEXT-BASE
	     (IF (= (1+ I) N-PARTITIONS);1 last partition*
	      ;1; +++ figure this out, should be total number of blocks +++*
	      ;1; +++ cheat for now +++*
	       (+ (GET-DISK-FIXNUM RQB (+ LOC %PD-START))
		  (GET-DISK-FIXNUM RQB (+ LOC %PD-LENGTH)))
	       ;1; Starting block number of next partition*
	       (GET-DISK-FIXNUM RQB (+ LOC %PD-START WORDS-PER-PART)))))
	(COND
	  ((> (- NEXT-BASE THIS-END) 0)
	   (FORMAT STREAM "~%~21,@t *Note: ~D blocks free at ~D" (- NEXT-BASE THIS-END) THIS-END))
	  ((< (- NEXT-BASE THIS-END) 0)
	   (FORMAT STREAM "~%~21,@t *Warning: ~D blocks overlap" (- THIS-END NEXT-BASE))
	   (SETF *OVERLAP-ERROR* (APPEND *OVERLAP-ERROR* (LIST NEXT-BASE)))));1 compute size of disk from label parameters.*
	(WHEN (CHECK-FOR-END-OF-DISK RQB LOC)
	  (FORMAT T "~%~21,@t *Warning: Partition crosses end of disk. Disk Capacity: ~d"
		  *WORKING-DISK-SIZE*)
	  (SETF *END-OF-DISK-ERROR*
		(APPEND *END-OF-DISK-ERROR* (LIST (GET-DISK-FIXNUM RQB (+ LOC %PD-START))))))))))
 
;1;;2.1 changes: Subtracted Number of defects sectors from total disk capacity to determined end of disk.*

(DEFUN 4CHECK-FOR-END-OF-DISK* (RQB LOC)
  "2Checks to see if the partition starting at loc goes past the end of the disk.
   The end of disk is calculated to be the total disk capacity minus the number of sectors used for
   defect mapping.*"
  (LET* ((TEMP (GET-DISK-FIXNUM RQB %BYTES-PER))
	 (DISK-SIZE
	  (-
	   (* (LDB %%NUMBER-OF-HEADS (GET-DISK-FIXNUM RQB %SECTOR-HEADS))
	      (LDB %%SECTORS-PER-TRACK (GET-DISK-FIXNUM RQB %SECTOR-HEADS))
	      (LDB %%NUMBER-OF-CYLINDERS (GET-DISK-FIXNUM RQB %CYLINDERS))
	      (LDB %%BYTES-PER-SECTOR TEMP));1total bytes capacity of disk*
	   (* (LDB %%NUMBER-OF-SECTORS-FOR-DEFECTS (GET-DISK-FIXNUM RQB %CYLINDERS))
	      (LDB %%BYTES-PER-SECTOR TEMP))));1bytes for defects*
	 (BLOCK-SIZE (LDB %%BYTES-PER-BLOCK TEMP)))
    (WHEN (AND (NEQ 0 DISK-SIZE) (NEQ 0 BLOCK-SIZE))
      (SETF *WORKING-DISK-SIZE* (1- (FLOOR DISK-SIZE BLOCK-SIZE)))  
      (IF (> (+ (GET-DISK-FIXNUM RQB (+ LOC %PD-START)) (GET-DISK-FIXNUM RQB (+ LOC %PD-LENGTH)));07-13-88 changed >= to > DB
	   (FLOOR DISK-SIZE BLOCK-SIZE))
	T)))) 

;1;; Label editor*

(DEFVAR 4LE-ITEM-NUMBER* :UNBOUND) 

(DEFVAR 4LE-UNIT* :UNBOUND) 

(DEFVAR 4LE-DISK-LABEL* :UNBOUND)

(DEFVAR 3LE-LINE-PHASE *:UNBOUND)
;1;; Change n-words-per-partition of a label sitting in an RQB*

(DEFUN 4CHANGE-PARTITION-MAP* (RQB NEW-N-WORDS)
  (LET ((OLD-N-WORDS (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES)))
	(N-PARTITIONS (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-NUMBER-OF-PARTITIONS)))
	(PARTITION-START (+ %PT-BASE %PT-PARTITION-DESCRIPTORS)))
    (LET ((SAVE (MAKE-ARRAY (LIST N-PARTITIONS (MAX OLD-N-WORDS NEW-N-WORDS)))))
	  ;1; Fill with zeros*
      (DOTIMES (I N-PARTITIONS)
	(DOTIMES (J (MAX OLD-N-WORDS NEW-N-WORDS))
	  (SETF (AREF SAVE I J) 0)))
      ;1; Copy out*
      (DOTIMES (I N-PARTITIONS)
	(DOTIMES (J OLD-N-WORDS)
	   (SETF (AREF SAVE I J) (GET-DISK-FIXNUM RQB (+ PARTITION-START (* I OLD-N-WORDS) J)))))
      ;1; Copy back in*
      (PUT-DISK-FIXNUM RQB NEW-N-WORDS (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES))
      (DOTIMES (I N-PARTITIONS)
	(DOTIMES (J NEW-N-WORDS)
	  (PUT-DISK-FIXNUM RQB (AREF SAVE I J) (+ PARTITION-START (* I NEW-N-WORDS) J))))))) 

;1;; Known pack types.  The first on this list is the default.*
;1;; Each element is a 4-list of*
;1;;   Pack brand name (32 or fewer chars) (as a symbol).*
;1;;   Addressing list:*
;1;;       Number of cylinders.*
;1;;       Number of heads.*
;1;;       Number of blocks per track.*
;1;;       Number of sectors per block.*
;1;;       Number of bytes per sector.*
;1;;       Number of reserved sectors for defects.*
;1;;   Partition list: name, size (- blocks, + cylinders at cyl bndry)*
;1;;   First partition starts at block 17. (first track reserved)*

;1;;2.1 changes: Added LABL,PTBL and SAVE as partitions. UNIX requirement.*

(DEFVAR 4NEW-PACK-TYPES*
   `((|Single Primary Disk| (917. 15. 8. 4 256. 0 0)
      ((LABL -2 ,%BT-VOLUME-LABEL ,%CPU-Generic-Band (%%DELETE-PROTECTED %%DEFAULT-INDICATOR))
       (PTBL -3 ,%BT-PARTITION-TABLE ,%CPU-Generic-Band (%%DELETE-PROTECTED %%DEFAULT-INDICATOR))
       (SAVE -3 ,%BT-SAVE-AREA ,%cpu-explorer)
       (FMT -9 ,%BT-FORMAT-PARAMETER ,%CPU-Generic-Band (%%COPY-PROTECTED))
       (TZON -122 ,%BT-TEST-ZONE ,%CPU-Generic-Band)
       (BOOT -64 ,%BT-MICROLOAD ,%cpu-explorer)
       (PRIM -64 ,%BT-MICROLOAD ,%cpu-explorer)
       (GDOS -400 ,%BT-MICROLOAD ,%cpu-explorer (%%DIAGNOSTIC-INDICATOR))  ; DAB 04-13-89 GDOS 2.0 and >
       (DIAG -2048 ,%BT-FILE-BAND ,%cpu-explorer (%%DIAGNOSTIC-INDICATOR))   ; DAB 04-13-89 GDOS 2.0 and >
       (MCR1 -156 ,%BT-MICROLOAD ,%cpu-explorer (%%DEFAULT-INDICATOR))
       (MCR2 -156 ,%BT-MICROLOAD ,%cpu-explorer)
       (LOD1 -40000 ,%BT-LOAD-BAND ,%cpu-explorer (%%DEFAULT-INDICATOR))
       (FILE -30000 ,%BT-FILE-BAND ,%cpu-explorer)
       (EXPT -148 ,%BT-MICROLOAD ,%cpu-explorer (%%DIAGNOSTIC-INDICATOR))
       (CFG1 -17 ,%bt-configuration-band ,%CPU-Generic-Band)
       (CFG2 -17 ,%bt-configuration-band ,%CPU-Generic-Band)
       (DLND -156 ,%BT-LOAD-BAND ,%cpu-TI-Nubus-Peripheral-Interface-68010 ) 
       (PAGE -36435 ,%BT-PAGE-BAND ,%cpu-explorer)  ; DAB 04-13-89
       (END 0 ,%BT-TEST-ZONE ,%CPU-Generic-Band)))
     (|Double Primary Disk - Unit 0| (917. 15. 8. 4 256. 0 0)
      ((LABL -2 ,%BT-VOLUME-LABEL ,%CPU-Generic-Band (%%DELETE-PROTECTED  %%DEFAULT-INDICATOR))
       (PTBL -3 ,%BT-PARTITION-TABLE ,%CPU-Generic-Band (%%DELETE-PROTECTED  %%DEFAULT-INDICATOR))
       (SAVE -3 ,%BT-SAVE-AREA ,%cpu-explorer)
       (FMT -9 ,%BT-FORMAT-PARAMETER ,%CPU-Generic-Band (%%COPY-PROTECTED))
       (TZON -122 ,%BT-TEST-ZONE ,%CPU-Generic-Band)
       (BOOT -64 ,%BT-MICROLOAD ,%cpu-explorer)
       (PRIM -64 ,%BT-MICROLOAD ,%cpu-explorer)
       (GDOS -400 ,%BT-MICROLOAD ,%cpu-explorer (%%DIAGNOSTIC-INDICATOR))  ; DAB 04-13-89 GDOS 2.0 and >
       (DIAG -2048 ,%BT-FILE-BAND ,%cpu-explorer (%%DIAGNOSTIC-INDICATOR))  ; DAB 04-13-89 GDOS 2.0 and >
       (MCR1 -148 ,%BT-MICROLOAD ,%cpu-explorer (%%DEFAULT-INDICATOR))
       (MCR2 -148 ,%BT-MICROLOAD ,%cpu-explorer)
       (LOD1 -45000 ,%BT-LOAD-BAND ,%cpu-explorer (%%DEFAULT-INDICATOR))
       (LOD2 -45000 ,%BT-LOAD-BAND ,%cpu-explorer)
       (EXPT -148 ,%BT-MICROLOAD ,%cpu-explorer (%%DIAGNOSTIC-INDICATOR))
       (CFG1 -17 ,%bt-configuration-band ,%CPU-Generic-Band)
       (CFG2 -17 ,%bt-configuration-band ,%CPU-Generic-Band)
       (DLND -156 ,%BT-LOAD-BAND ,%cpu-TI-Nubus-Peripheral-Interface-68010) 
       (PAGE -16451 ,%BT-PAGE-BAND ,%cpu-explorer)  ; DAB 04-13-89
       (END 0 ,%BT-TEST-ZONE ,%CPU-Generic-Band)))
     (|Double Primary Disk - Unit 1| (917. 15. 8. 4 256. 0 0)
      ((LABL -2 ,%BT-VOLUME-LABEL ,%CPU-Generic-Band (%%DELETE-PROTECTED %%DEFAULT-INDICATOR))
       (PTBL -3 ,%BT-PARTITION-TABLE ,%CPU-Generic-Band (%%DELETE-PROTECTED %%DEFAULT-INDICATOR))
       (SAVE -3 ,%BT-SAVE-AREA ,%cpu-explorer)
       (FMT -9 ,%BT-FORMAT-PARAMETER ,%CPU-Generic-Band (%%COPY-PROTECTED))
       (TZON -122 ,%BT-TEST-ZONE ,%CPU-Generic-Band)
       (BOOT -64 ,%BT-MICROLOAD ,%cpu-explorer (%%DEFAULT-INDICATOR))
       (PRIM -64 ,%BT-MICROLOAD ,%cpu-explorer)
       (GDOS -400 ,%BT-MICROLOAD ,%cpu-explorer (%%DIAGNOSTIC-INDICATOR))  ; DAB 04-13-89 GDOS 2.0 and >
       (DIAG -2048 ,%BT-FILE-BAND ,%cpu-explorer (%%DIAGNOSTIC-INDICATOR))  ; DAB 04-13-89 GDOS 2.0 and >
       (FILE -30000 ,%BT-FILE-BAND ,%cpu-explorer)
       (EXPT -148 ,%BT-MICROLOAD ,%cpu-explorer (%%DIAGNOSTIC-INDICATOR))
       (PAGE -76937 ,%BT-PAGE-BAND ,%cpu-explorer) ; DAB 04-13-89
       (END 0 ,%BT-TEST-ZONE ,%CPU-Generic-Band)))
     (|Secondary Disk| (917. 15. 8. 4 256. 0 0)
      ((LABL -2 ,%BT-VOLUME-LABEL ,%CPU-Generic-Band (%%DELETE-PROTECTED %%DEFAULT-INDICATOR))
       (PTBL -3 ,%BT-PARTITION-TABLE ,%CPU-Generic-Band (%%DELETE-PROTECTED %%DEFAULT-INDICATOR))
       (SAVE -3 ,%BT-SAVE-AREA ,%cpu-explorer)
       (FMT -9 ,%BT-FORMAT-PARAMETER ,%CPU-Generic-Band (%%COPY-PROTECTED))
       (TZON -122 ,%BT-TEST-ZONE ,%CPU-Generic-Band)
       (BOOT -64 ,%BT-MICROLOAD ,%cpu-explorer (%%DEFAULT-INDICATOR))
       (PRIM -64 ,%BT-MICROLOAD ,%cpu-explorer)))
     (|SMD Primary Disk| (711. 24. 25. 2 512. 8532. 1)
      ((LABL -2 ,%BT-VOLUME-LABEL ,%CPU-Generic-Band (%%DELETE-PROTECTED %%DEFAULT-INDICATOR))
       (PTBL -3 ,%BT-PARTITION-TABLE ,%CPU-Generic-Band (%%DELETE-PROTECTED %%DEFAULT-INDICATOR))
       (SAVE -3 ,%BT-SAVE-AREA ,%cpu-explorer)
       (FMT -9 ,%BT-FORMAT-PARAMETER ,%CPU-Generic-Band (%%COPY-PROTECTED))
       (TZON -122 ,%BT-TEST-ZONE ,%CPU-Generic-Band)
       (BOOT -64 ,%BT-MICROLOAD ,%cpu-explorer)
       (PRIM -64 ,%BT-MICROLOAD ,%cpu-explorer)
       (GDOS -400 ,%BT-MICROLOAD ,%cpu-explorer (%%DIAGNOSTIC-INDICATOR))  ; DAB 04-13-89 GDOS 2.0 and >
       (DIAG -2048 ,%BT-FILE-BAND ,%cpu-explorer (%%DIAGNOSTIC-INDICATOR))  ; DAB 04-13-89 GDOS 2.0 and >
       (MCR1 -156 ,%BT-MICROLOAD ,%cpu-explorer (%%DEFAULT-INDICATOR))
       (MCR2 -156 ,%BT-MICROLOAD ,%cpu-explorer)
       (LOD1 -40000 ,%BT-LOAD-BAND ,%cpu-explorer (%%DEFAULT-INDICATOR))
       (FILE -30000 ,%BT-FILE-BAND ,%cpu-explorer)
       (EXPT -148 ,%BT-MICROLOAD ,%cpu-explorer (%%DIAGNOSTIC-INDICATOR))
       (CFG1 -17 ,%bt-configuration-band ,%CPU-Generic-Band)
       (CFG2 -17 ,%bt-configuration-band ,%CPU-Generic-Band)
       (DLND -156 ,%BT-LOAD-BAND ,%cpu-TI-Nubus-Peripheral-Interface-68010)
       (PAGE -88876 ,%BT-PAGE-BAND ,%cpu-explorer)  ; DAB 04-13-89 GDOS 2.0 and >
       (EMPT -268624 ,%bt-empty-band ,%CPU-Generic-Band)
       (END 0 ,%BT-TEST-ZONE ,%CPU-Generic-Band)))
     )) 
				 
;1;; Possible attributes of partitions.*


(DEFVAR 4PARTITION-TYPES*
   '((|Load Band| %BT-LOAD-BAND) (|Microload Band| %BT-MICROLOAD) (|Page Band| %BT-PAGE-BAND)
     (|File Band| %BT-FILE-BAND) (|Meter Band| %BT-METER-BAND) (|Test Zone| %BT-TEST-ZONE)
     (|Format Parameter| %BT-FORMAT-PARAMETER) (|Volume Label| %BT-VOLUME-LABEL)
     (|Save Area| %BT-SAVE-AREA) (|Partition Table| %BT-PARTITION-TABLE)
     (|Configuration Band| %BT-CONFIGURATION-BAND) (|System Log Band| %BT-LOG-BAND)
     (|Anchor Band| %bt-anchor-band)   ;103.17.87 DAB*
     (|Empty Band| %BT-EMPTY-BAND))) 
;1;; User CPU or Operating System types*
;1;;2.1 Changes. Added to allow editing of CPU types.*

(DEFVAR 4CPU-TYPES*
   '((|Explorer| %CPU-EXPLORER) (|Numachine| %CPU-NUMACHINE) (|S1500| %CPU-S1500)
     (|Terminal Concentrator| %cpu-TI-Terminal-concentrator-68010)
     (|Explorer IB| %cpu-TI-Explorer-I-B)
     (|Explorer II| %cpu-TI-Explorer-II )
     (|CLM| %cpu-TI-CLM )
     (|Nubus Peripheral Interface| %cpu-TI-Nubus-Peripheral-Interface-68010 )
     (|Mass Storage Controller| %cpu-TI-Mass-storage-controller-68010 )
     (|Comm. Carrier| %cpu-TI-Comm-Carrier-68010 )
     (|TI Lisp| %CPU-TI-LISP) (|GDOS| %CPU-GDOS) (|System 5| %CPU-SYSTEM5)
     (|Generic| %CPU-GENERIC-BAND)))  

;1;; Property bits of partitions. Format of dpb specification*


(DEFVAR 4PARTITION-PROPERTIES*
   `((|Expandable| ,%%EXPANDABLE) (|Contractable| ,%%CONTRACTABLE)
     (|Delete protected| ,%%DELETE-PROTECTED) (|Logical partition| ,%%LOGICAL-PARTITION)
     (|Copy protected| ,%%COPY-PROTECTED) (|Disk Label Default| ,%%DEFAULT-INDICATOR)	;1mrr 3.17.87 changed default name.*
     (|Diagnostic| ,%%DIAGNOSTIC-INDICATOR))) 

;1;;2.1 changes. changed initialization of BLOCK to be zero. Allow LABL partition to begin with block 0.*

(DEFUN 4LE-INITIALIZE-LABEL* (RQB PACK-TYPE)
  (FILL (RQB-BUFFER RQB) 0)			;1 Zero out unused areas of label.*
  (PUT-DISK-STRING RQB "LABL" %DL-BASE 4)	;1 Checkword*
  (PUT-DISK-FIXNUM RQB LABEL-VERSION %DL-VERSION)	;1 Version number*
  (PUT-DISK-FIXNUM RQB
		   (DPB %ADDRESS-LOGICAL %%DL-ADDRESS
			(DPB %MEDIA-FIXED %%DL-MEDIA (DPB %TC-DISK %%DL-TYPE-CODE 0)))
		   %DL-STORAGE-TYPE)		;1 Storage type, disk, fixed.*
  (LET ((SECOND-VAR (SECOND PACK-TYPE)))
    (PUT-DISK-FIXNUM RQB
		     (DPB (FIFTH SECOND-VAR) %%BYTES-PER-SECTOR
			  (* (FOURTH SECOND-VAR) (FIFTH SECOND-VAR)))
		     %BYTES-PER)
    (PUT-DISK-FIXNUM RQB
		     (DPB (+ (* (THIRD SECOND-VAR) (FOURTH SECOND-VAR)) (seventh  SECOND-VAR)) %%SECTORS-PER-TRACK
			  (DPB (SECOND SECOND-VAR) %%NUMBER-OF-HEADS 0))
		     %SECTOR-HEADS)
    (PUT-DISK-FIXNUM RQB
		     (DPB (SIXTH SECOND-VAR) %%NUMBER-OF-SECTORS-FOR-DEFECTS (FIRST SECOND-VAR))
		     %CYLINDERS))
  ;1(PUT-DISK-STRING RQB "MCR1" %DL-CURRENT-MICROLOAD 4)*	1;this is compatible with the old label format*
  ;1(PUT-DISK-STRING RQB "LOD1" %DL-CURRENT-BAND 4)      ;rel3*
  ;1; Brand name of drive*
  (PUT-DISK-STRING RQB (STRING (CAR PACK-TYPE)) %DL-DEVICE-NAME 12.)
  (PUT-DISK-STRING RQB "(name)" %DL-VOLUME-NAME 16.)	;1Name of pack*
  (PUT-DISK-STRING RQB "(comment)" %DL-COMMENT 96.)	;1Comment*
  ;1; Setup partition table descriptor.*
  (PUT-DISK-STRING RQB "PTBL" %DL-PARTITION-TABLE-NAME 4)
  (PUT-DISK-FIXNUM RQB 2 %DL-PARTITION-TABLE-START)
  (PUT-DISK-FIXNUM RQB 3 %DL-PARTITION-TABLE-LENGTH)
  ;1; Setup save area descriptor.*
  (PUT-DISK-STRING RQB "SAVE" %DL-SAVE-AREA-NAME 4)
  (PUT-DISK-FIXNUM RQB 5 %DL-SAVE-AREA-START)
  (PUT-DISK-FIXNUM RQB 3 %DL-SAVE-AREA-LENGTH)
  ;1; Build partition table.  The partition table resides in block 1 of the*
  ;1; the disk label buffer (rqb).*
  (LET ((PT-START %PT-BASE)
	(SECOND-VAR (SECOND PACK-TYPE))
	(WORDS-PER-DESCRIPTOR 12.))		;1This should give us 32. bytes for comments.*
    (PUT-DISK-STRING RQB "PRTN" PT-START 4)
    (PUT-DISK-FIXNUM RQB 1 (+ PT-START %PT-VERSION))
    (PUT-DISK-FIXNUM RQB (LENGTH (THIRD PACK-TYPE)) (+ PT-START %PT-NUMBER-OF-PARTITIONS))
    (PUT-DISK-FIXNUM RQB WORDS-PER-DESCRIPTOR (+ PT-START %PT-SIZE-OF-PARTITION-ENTRIES))
    (PUT-DISK-FIXNUM RQB %PD-COMMENT (+ PT-START %PT-COMMENT-UNKNOWN))
;1;; name  size partition-type cpu-type attributes sector-odd   *
    (DO ((LOC (+ PT-START %PT-PARTITION-DESCRIPTORS) (+ LOC WORDS-PER-DESCRIPTOR))
	 (BLOCK 0
	   (+ BLOCK SZ))
	 (SZ)
	 (BPC   (* (SECOND SECOND-VAr) (THIRD SECOND-VAR) ))
	 (PARTS (THIRD PACK-TYPE) (CDR PARTS)))
	((NULL PARTS))
      (SETQ SZ
	    (IF (or (MINUSP (CADAR PARTS)) (zerop (CADAR PARTS)))
		(- (CADAR PARTS))
		(PROGN
		  (SETQ BLOCK (* BPC (CEILING BLOCK BPC)))
		  (* (CADAR PARTS) BPC))))
      (PUT-DISK-STRING RQB (STRING (CAAR PARTS)) (+ LOC %PD-NAME) 4)
      (PUT-DISK-FIXNUM RQB BLOCK (+ LOC %PD-START))
      (PUT-DISK-FIXNUM RQB SZ (+ LOC %PD-LENGTH))
      
      (LET ((PARTITION-PROPERTIES (CADDAR PARTS)))
	(DOLIST (PARTITION-PROP (CAR (cdr (CDDDAR PARTS))))
	  (SETQ PARTITION-PROPERTIES
		(DPB 1
		     (EVAL PARTITION-PROP)
		     PARTITION-PROPERTIES)))
	(PUT-DISK-FIXNUM RQB (DPB (car (CDDDAR PARTS)) %%CPU-TYPE-CODE PARTITION-PROPERTIES)
			 (+ LOC %PD-ATTRIBUTES)))
      (PUT-DISK-STRING RQB "" (+ LOC %PD-COMMENT) 32.))))
 



;1;; Display the label which is sitting in an RQB *
;1;; 2.1 changes: terminal-io*

(DEFUN 4LE-DISPLAY-LABEL* (RQB UNIT &OPTIONAL NO-PROMPT)
  (SEND USER:*TERMINAL-IO* :CLEAR-SCREEN)
  (COND
    ((NUMBERP UNIT) (FORMAT USER:*TERMINAL-IO* "Editing label for unit ~D~%" UNIT));12.1 fix terminal-io*
    (T
     (FORMAT USER:*TERMINAL-IO* "Editing label for unit ~D on ~A~%";12.1 fix terminal-io*
	     (FUNCALL UNIT :UNIT-NUMBER) (FUNCALL UNIT :MACHINE-NAME))))
  (SETQ LE-STRUCTURE ())
  (PRINT-DISK-LABEL-FROM-RQB USER:*TERMINAL-IO* RQB T);12.1 fix terminal-io*
  (SETQ LE-STRUCTURE (NREVERSE LE-STRUCTURE))
  (UNLESS NO-PROMPT
    (FORMAT USER:*TERMINAL-IO* "~&Label Edit Command: "));12.1 fix terminal-io*
  (SETQ LE-ITEM-NUMBER (MIN LE-ITEM-NUMBER (LENGTH LE-STRUCTURE)))
  (SETF LE-LINE-PHASE t)
  (LE-UNDERSCORE)) 


;1;; Underscore the selected item*
;1;; 2.1 changes: terminal-io*

(DEFUN 4LE-UNDERSCORE* ()
  (LET ((ITEM (NTH LE-ITEM-NUMBER LE-STRUCTURE)))
    (w:prepare-sheet (user:*terminal-io*)
      (IF ITEM
	  (sys:%draw-rectangle 
	    (FIFTH ITEM)
	    2
	    (+ (w:sheet-inside-left user:*terminal-io*) (THIRD ITEM))
	    (+ (w:sheet-inside-top user:*terminal-io*) (FOURTH ITEM)
	       (- (W:SHEET-LINE-HEIGHT USER:*TERMINAL-IO*) 2))
	    (IF (and (boundp 'tv:*color-system*) tv:*color-system*)
		(IF le-line-phase tv:alu-sub tv:alu-add)
		W:ALU-XOR)
	    user:*terminal-io*)
	  ;1; Pointing at the line after the last existing partition.*
	  (sys:%draw-rectangle 
	    1
	    (SEND USER:*TERMINAL-IO* :LINE-HEIGHT);12.1 fix terminal-io*
	    (+ (w:sheet-inside-left user:*terminal-io*) 0)
	    (+ (w:sheet-inside-top user:*terminal-io*) (FOURTH (CAR (LAST LE-STRUCTURE)))
	       (W:SHEET-LINE-HEIGHT USER:*TERMINAL-IO*))
	    (IF (and (boundp 'tv:*color-system*) tv:*color-system*)
		(IF le-line-phase tv:alu-sub tv:alu-add)
		W:ALU-XOR)
	    user:*terminal-io*)
	  )))
  (SETF le-line-phase (not le-line-phase)))



(DEFVAR 4LE-SOMETHING-CHANGED* () "2Used to figure out if we've made any editing changes.*") 

(DEFPARAMETER 4*EDIT-DISK-LABEL-COMMAND-ALIST**
   '((#\SPACE . LE-COM-CONTROL-L) (#\c-L . LE-COM-CONTROL-L) (#\? . LE-COM-?)
     (#\HELP . LE-COM-?) (#\ . LE-COM-CONTROL-P) (#\c-P . LE-COM-CONTROL-P)
     (#\c-R . LE-COM-CONTROL-R) (#\c-S . LE-COM-CONTROL-S) (#\c-W . LE-COM-CONTROL-W)
     (#\END . LE-COM-END) (#\ABORT . LE-COM-ABORT) (#\c-A . LE-COM-CONTROL-A)
     (#\ . LE-COM-CONTROL-B) (#\c-B . LE-COM-CONTROL-B) (#\c-D . LE-COM-CONTROL-D)
     (#\PAGE . LE-COM-FORM) (#\c-E . LE-COM-CONTROL-E) (#\ . LE-COM-CONTROL-F)
     (#\c-F . LE-COM-CONTROL-F) (#\c-I . LE-COM-CONTROL-I) (#\c-K . LE-COM-CONTROL-K)
     (#\c-L . LE-COM-CONTROL-L) (#\c-M . LE-COM-CONTROL-M) (#\
 . LE-COM-CONTROL-N)
     (#\c-N . LE-COM-CONTROL-N) (#\m-~ . LE-COM-META-~) (#\c-O . LE-COM-CONTROL-O)
     (#\c-c . le-com-control-c) (#\c-t . le-com-control-t) (#\newline . le-com-control-l)))



(DEFUN 4EDIT-DISK-LABEL* (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*) &AUX (LAST-TERMINAL-IO NIL))
  "2Allows modification of the disk label. Unit may be a local unit id or
a string containing the name of a remote machine, or a string containing
a remote machine name, colon, remote unit id.*"
  (IF 						     	;1IF WINDOW IS BIG ENOUGH*
    (AND (FBOUNDP 'W:SHEET-WIDTH)	             	;1dledit should be done in a full*
						     	;1size window with CPT type font*	
	 (>= (SEND *TERMINAL-IO* :HEIGHT) 680.) 	;1May run into full screen problems.. 2.19.87 MBC*
	 (>= (SEND *TERMINAL-IO* :WIDTH) 780.)) 	;1leave room for suggestions  5/15/87  HW*
    (PROGN 
      ;1; may 04/01/89 Changed to correctly restore font-map. Also*
      ;1; rearranged so that ferror would not leave font-map permanently*
      ;1; hosed. *      
      (UNLESS (IGNORE-ERRORS (AND (W:SHEET-WIDTH *TERMINAL-IO*) T))
	(FERROR () "Attempt to edit without terminal-io being a window."))
      ;1; Lowercase below is from tv:with-font-map which is not available in cold-load band*
      ;1; nor is it available in development band.*
      (let* ((old-font-map (send *terminal-io* :font-map))		;1; may 04/10/89 *
	     (old-current-font (send *terminal-io* :current-font)))	;1; may 04/10/89 *
	(unwind-protect							;1; may 04/10/89 *
	    (progn							;1; may 04/10/89 *
	      (send *terminal-io* :set-font-map (list fonts:cptfont))	;1; may 04/10/89 *

	      (MULTIPLE-VALUE-BIND (UNIT DECODEDP)
		  (DECODE-UNIT-ARGUMENT UNIT "editing label")
		(UNWIND-PROTECT (EDIT-DISK-LABEL-1 UNIT)
		  (UNLESS DECODEDP
		    (DISPOSE-OF-UNIT UNIT)))))

	  (send *terminal-io* :set-font-map old-font-map)		;1; may 04/10/89 *
	  (send *terminal-io* :set-current-font old-current-font t)))	;1; may 04/10/89 *

      (when LAST-TERMINAL-IO
	(SEND *TERMINAL-IO* :DESELECT)
	(SEND (SETF *TERMINAL-IO* LAST-TERMINAL-IO) :SELECT)))
    ;1; else*
    (FORMAT t "~% SYS:EDIT-DISK-LABEL must be executed from a full size Lisp Listener.")))  ;15/15/87  HW*
  
;1;; When this is called LE-Unit should already be decoded, i.e., an*
;1;; instance of a disk handler.  TERMINAL-IO should be bound to the *
;1;; stream used for operator interaction.*
;1;; 2.1 changes: Wrapped a condition-case around read command options. The user was hitting abort*
;1;;              by mistake to often. This gives him another chance to recover.*
(Defun 4edit-disk-label-1* (LE-unit)
  (Let ((LE-Disk-Label  (read-disk-label LE-Unit))
	(LE-Item-Number 0)
	(LE-Something-Changed Nil)
	(LE-line-phase nil)
	(*le-mcr-or-lod-changed* nil)		;1mrr 3.17.87*
	(*LE-remote-edit* nil)
	(*LE-prim-style-edit* nil)
	(*le-cfg-name* nil)
	(*le-cfg-unit* nil)
	(*le-mcr-name* nil)
	(*le-mcr-unit* nil)
	(*le-lod-name* nil)
	(*le-lod-unit* nil))			;1mrr 3.17.87*
 
    (If (And (Not (String-Equal (Get-disk-String LE-Disk-Label 0 4) "LABL"))
	     (y-or-n-p "Disk label not valid, initialize? "))
	(LE-Com-Control-I)			;1 initializer command.*
	;1else -- This is the usual branch.*
	;1new for Rel3 --MRR*
	;1If this is a remote edit, then we can't tell if it is a prim-style edit, so act as if it is not.*
	(if (setq *LE-remote-edit* (closurep LE-unit))
	    (setq *LE-prim-style-edit* nil)		  
	    ;1else, if this is a prim-style edit, then find out the system defaults from cfg.*
	    (if (setq *LE-prim-style-edit* (or (ignore-errors (prim-default-p))
					       (= (cpu-type) %cpu-ti-explorer-II) ;1Explorer II environment*
					       (= 2 si:microcode-type-code) ;1LX environment - mrr 3.20.87 *
					       ))
		(if (ignore-errors   ;09-25-87 DAB  If nvram is offline.
		      (and (setq *le-cfg-name* (default-cfg-in-ptbl (nvram-default-unit)))
			   (setq *le-cfg-unit* (nvram-default-unit))
			   ))
		    (le-get-cfg-data)
		    ;1else no correct default cfg found, so set everything to nil.*
		    (setq *le-mcr-name* nil *le-mcr-unit* nil *le-lod-name* nil *le-lod-unit* nil))
		))
	
	(LE-Display-Label LE-Disk-Label LE-Unit t))
    
    (Format user:*terminal-io* "~&Use CTRL-R to read and edit existing label; press ~
                  HELP for help.~%")
    (Format user:*terminal-io* "~&Label Edit Command: ")
    (Catch 'LE-EXIT
      (Do ((ch) (com))
	  (NIL)
	(condition-case ()
	    (SETQ CH (READ-CHAR)
		  COM (CDR (ASSOC CH *EDIT-DISK-LABEL-COMMAND-ALIST* :TEST #'CHAR=))) ;1mrr 3.18.87 char-equal *
	  (sys:abort (If (y-or-n-p "Are you sure you want to exit EDIT-DISK-LABEL")
			 (return)
			 (setf com 'LE-COM-CONTROL-L)))
	  )
	(Cond ((Or (Null com) ;1;nothing typed*
		   (Not (Fboundp com))) ;1;command not defined*
	       (Beep)
	       (Format user:*terminal-io* "~%~:C is not a known edit-disk-label ~
                               command. Press HELP for help, or END to ~
                               exit." CH)
	       (Format user:*terminal-io* "~&Label Edit Command: "))
	      (T (Multiple-Value-Bind (ignore abort)
		     (Catch-Error-Restart ((error Sys:Abort)
					   "Return to EDIT-DISK-LABEL.")
		       (Funcall com))
		   (If abort
		       (LE-DISPLAY-LABEL LE-DISK-LABEL LE-Unit)))))))
    (RETURN-DISK-RQB LE-DISK-LABEL))
  )


;1;; REDISPLAY.*
(Defun 4LE-Com-Form* ()
  (LE-Display-Label LE-DISK-LABEL LE-Unit))

(Defun 4LE-Com-Abort* ()
  (Format user:*terminal-io* "~%Type ~:C to exit, or ~:C for help." #\END #\HELP))

;1;; Exit.*
(Defun 4LE-Com-End* ()
  (When (Or (Null LE-Something-Changed)
	    (Fquery NIL "~&It appears that you have not written out your ~
                  changes.~%You must type ~:C to write out your changes ~
                  before typing ~:C.~%Do you still want to exit? "
		    #\Control-W #\End))
    (Format user:*terminal-io* "~%Exiting the disk label editor.")
    (Throw 'LE-Exit nil))
  )

(Defun 4LE-Com-Meta-~* ()
  (Format user:*terminal-io* "~%No longer modified.")
  (Setq LE-Something-Changed Nil))

;1;; 2.1 changes: Added Condition-case to handled ABORT key. Now returns to main menu.*
;1;;              Added User defined Partition types. Now always forces LE-display-label.*
;1;;              wrapped rubout parameter in reads to eliminate text being placed on command history *
(defun 4LE-Com-Control-A* ()
  (Format *terminal-io* "~%Partition types are:~%")
  (condition-case ()				;1add condition call. SYS:ABort will now only abort this command.*
      (progn
       (Do ((l partition-types (Cdr l))
	    (n 0 (1+ n)))
	   ((Null l))
	 (Format *terminal-io* " ~d  ~a~%" n (Caar l)))
       (format *terminal-io* " ~d  User Defined Partition Types~%" (length partition-types))
       (Format *terminal-io* "Enter desired number: ")
       
       (Let* ((*read-base* 10.)			;1read in decimal  12-12-85 MBC*
	      (tem (Nth (with-input-editing (*terminal-io* '((:no-input-save t)))
			  (Read *terminal-io*)) partition-types)))
	 (if (null tem)
	     (if (do-forever
		   (format *terminal-io* "~%User defined Partition Type. Enter a value from 12 - 254 or ABORT to exit:")
		   (setf tem (with-input-editing (*terminal-io* '((:no-input-save t)))
			       (read user:*terminal-io*)))
		   (cond ((null tem) (return tem))
			 ((and (numberp tem) (>= tem 12.) (<= tem 254.)) (return tem))
			 (t (Format user:*terminal-io* " ** Invalid Range. Please Reenter.")))
		   )				;1do-forever*
		 (setf tem (append '(|User defined|) (list tem))))
	     ) 
	 (If (Not (Null tem))
	     (Cond ((= LE-Item-Number (Length LE-Structure))
		    (Format *terminal-io* "~&There is no currently selected partition.")
		    (Beep))
		   (t (Let* ((ploc (LE-Current-Partition))
			     (temp (dpb (eval (cadr tem))	;1modifyied to add CPU command below*
					%%band-type-code
					(get-disk-fixnum le-disk-label 
							 (+ ploc %pd-attributes)))))
			(Put-disk-Fixnum le-disk-label temp (+ ploc %PD-Attributes))
			(Setq LE-Something-Changed t)
			)))
	     )
	 (LE-Display-Label LE-Disk-Label LE-Unit)))
    (sys:abort (values nil t)))			;1error condition handler*
  )

;1;; 2.1 Changes: Added this new command to allow editing of cpu types.*
;1;;              wrapped rubout parameter in reads to eliminate text being placed on command history *
(defun 4LE-Com-Control-C* ()			;1new command to modifiy CPU/OS Types*
  (Format user:*terminal-io* "~%CPU/OS types are:~%")
  (Do ((l CPU-types (Cdr l))
       (n 0 (1+ n)))
      ((Null l))
    (Format user:*terminal-io* " ~d  ~a~%" n (Caar l)))
  (format user:*terminal-io* " ~d  User Define CPU Type" (length cpu-types))
  (Format user:*terminal-io* "~%Enter desired number: ")
  (condition-case ()				;1add condition call. SYS:ABort will now only abort this command.*
      (Let* ((*read-base* 10.)			;1read in decimal  12-12-85 MBC*
	     (tem (Nth (with-input-editing (user:*terminal-io* '((:no-input-save t)))
			 (Read user:*terminal-io*))  CPU-types)))
	(if (null tem)
	    (if (do-forever
		  (format user:*terminal-io*"~%User defined CPU Type. Enter a value from 0 - 65535 or ABORT to exit:")
		  (setf tem (with-input-editing (user:*terminal-io* '((:no-input-save t)))
			      (read user:*terminal-io*)))
		  (cond ((null tem) (return tem))
			((and (numberp tem) (>= tem 0) (<= tem 65535.)) (return tem))
			(t (Format user:*terminal-io*" ** Invalid Range. Please Reenter.")))
		  )
		(setf tem (append '(|User defined|) (list tem))))
	    )
	
	(If (Not (Null tem))
	    (Cond ((= LE-Item-Number (Length LE-Structure))
		   (Format user:*terminal-io* "~&There is no currently selected partition.")
		   (Beep))
		  (t (Let* ((ploc (LE-Current-Partition))
			    (temp (dpb (eval (cadr tem))
				       %%CPU-type-code
				       (get-disk-fixnum le-disk-label 
							(+ ploc %pd-attributes)))))
		       (Put-disk-Fixnum le-disk-label temp (+ ploc %PD-Attributes))
		       (Setq LE-Something-Changed t)
		       )))
	    )
	(LE-Display-Label LE-Disk-Label LE-Unit))
    (sys:abort (values nil t)))			;1error condition handler*
  )

;1;; Move to previous item.*
(Defun 4LE-Com-Control-B* ()
  (LE-Underscore)
  (Setq LE-Item-Number (Max 0 (1- LE-Item-Number)))
  (LE-Underscore))

(Defun 4LE-Com-Control-D* ()
  (Let ((ploc (LE-Current-Partition)))
    (If (= LE-Item-Number (Length LE-Structure))
	(Beep)
	(SI:Describe-Partition
	  (string-append 
	    (Get-disk-String LE-DISK-LABEL ploc 4) "."
	    (format nil "~d"			;103.20.87 DAB*
		    (LDB %%CPU-TYPE-CODE (GET-DISK-FIXNUM LE-DISK-LABEL  (+ pLOC %PD-ATTRIBUTES)))))
	  LE-UNIT LE-DISK-LABEL
	  )))
  )



;1;; Move to next item.*
(Defun 4LE-Com-Control-F* ()
  (LE-Underscore)
  (Setq LE-Item-Number (Min (Length LE-Structure) (1+ LE-Item-Number)))
  (LE-Underscore))


;1;;2.1 changes: Added Condition-case to handle Abort, now returns to main menu.*
;1;;             Always forces LE-display-label.*
;1;;              wrapped rubout handler parameter in reads to eliminate text being placed on command history*
(defun 4LE-Com-Control-M* ()
  (let ((part-properties partition-properties))
    (when  *le-prim-style-edit*			;1mrr 3.17.87*
      (setq part-properties (copy-list partition-properties))	;1make a copy because we don't what to change the original.*
      (push '(|System Load Default| 0)  (nthcdr 5 part-properties)))
  (Format user:*terminal-io* "~&Partition Properties are:~%")	;112-12-85*
  (Do ((l part-properties (Cdr l))
       (n 0 (1+ n)))
      ((Null l))
    (Format user:*terminal-io* " ~d  ~a~%" n (Caar l)))
  (Setq LE-Something-Changed t)
  (Format user:*terminal-io* "Enter desired number: ")
  (condition-case ()				;1add condition call. SYS:ABort will now only abort this command.*
      (Let ((tem (Nth (with-input-editing (user:*terminal-io* '((:no-input-save t)))
			(Read user:*terminal-io*)) 
		      part-properties)))
	(If (Not (Null tem))
	    (Let* ((ploc (LE-Current-Partition))
		   (temp (get-disk-fixnum le-disk-label (+ ploc %PD-Attributes))))
	      (Cond ((= LE-Item-Number (Length LE-Structure))
		     (Format user:*terminal-io* "~&There is no currently selected partition.")
		     (Beep))
		    
		    ;1mrr 3.17.87*
		    ;1if the user chooses System Load Default on a MCR or LOD, set the config vars.*
		    ((and *le-prim-style-edit*
		          (= (cpu-type) (ldb %%cpu-type-code temp))
			  (or (= %bt-microload (ldb %%band-type-code temp))
			      (= %bt-load-band (ldb %%band-type-code temp)))
			  (= (cadr tem) 0))
		     (let* ((item (nth le-item-number le-structure))
			    (value (second item)))
		       (cond ((= %bt-microload (ldb %%band-type-code temp))
			      (setq *le-mcr-name* value *le-mcr-unit* le-unit)
			      (setq *le-mcr-or-lod-changed* t))
			     ((= %bt-load-band (ldb %%band-type-code temp))
			      (setq *le-lod-name* value *le-lod-unit* le-unit)
			      (setq *le-mcr-or-lod-changed* t)))))
		    ((zerop (cadr tem))			    
		     (format *terminal-io*
			     "~&Can't select this partition as a System Load Default. (Press space to continue)")
		     (read-char))
		    (t (if (not (ldb-test (cadr tem) temp))
			   (setq temp (dpb 1 (cadr tem) temp))
			   (setq temp (dpb 0 (cadr tem) temp)))
		       (Put-disk-Fixnum le-disk-label temp (+ ploc %PD-Attributes))
		       ))
	      ))
	(LE-Display-Label LE-Disk-Label LE-Unit))
    (sys:abort (values nil t)))			;1error condition handler*
  ))


;1;; Move to the first item on the next line.*
(Defun 4LE-Com-Control-N* ()
  (LE-Underscore)
  (Do ((l (Nthcdr LE-Item-Number LE-Structure) (Cdr l))
       (n LE-Item-Number (1+ n))
       (y0 (Or (Fourth (Nth LE-Item-Number LE-Structure)) 0)))
      ((Or (Null l) (> (Fourth (Car l)) y0))
       (Setq LE-Item-Number (Min (Length LE-Structure) n))
       (LE-Underscore)))
  )

;1;; Move to the first item on the previous line.*
(Defun 4LE-Com-Control-P* ()
  (LE-Underscore)
  (Do ((y0 (Or (Fourth (Nth LE-Item-Number LE-Structure)) 0))
       (l LE-Structure (Cdr l))
       (n 0 (1+ n))
       (y)
       (cand-y -1)
       (cand-n 0))
      (())
    (Setq y (Fourth (Car l)))
    (Cond ((Or (Null l) (= y y0))
	   (Setq LE-Item-Number cand-n)
	   (LE-Underscore)
	   (Return Nil))
	  ((= y cand-y) )			;1Next thing on same line*
	  (T (Setq cand-y y
		   cand-n n))))			;1First thing on a line*
  )

;1;; Read in the label from the unit.*

(Defun 4LE-Com-Control-R* ()
						;1 Read the disk label, fetching the RQB.*
  (Setq LE-Disk-Label (read-disk-label le-unit))
  (when *LE-prim-style-edit*			;1mrr 3.16.87 Read the CFG, too.*
    (if (and (setq *le-cfg-name* (default-cfg-in-ptbl (nvram-default-unit)))
	     (setq *le-cfg-unit* (nvram-default-unit)))
	(le-get-cfg-data)
	;1else no correct default cfg found, so set everything to nil.*
	(setq *le-mcr-name* nil *le-mcr-unit* nil *le-lod-name* nil *le-lod-unit* nil)))				
  (LE-Display-Label LE-Disk-Label LE-Unit))

;1;; Write the label out to the unit.*
;1;; 2.1 changes: added warning on end of disk. Added Condition case to handle abort.*
;1;;              Check for mismatch between partition table and save area created in the upper half*
;1;;              with its lower half.*

(Defun 4LE-Com-Control-W* ()
  (when
    (disk-integrity-check le-disk-label)    
    (condition-case ()
	(progn
	 (Cond ((yes-or-no-p "Do you want to write out this label? ")
		(write-disk-label le-disk-label LE-Unit)
		(when (closurep le-unit)   ;09-08-87 DAB
		  ;;If this is a remote disk, you must wait until the operation completes. Otherwise,
		  ;;Dispose-of-unit may close the connection before the label is rewritten.
		  (Format user:*terminal-io* "Waiting Remote Disk Transfer to Complete.")
		  (funcall le-unit :wait)) 
		(Setq LE-Something-Changed Nil)
       		 (Format user:*terminal-io* "~&Disk label written.~%"))
	       (T
		(Format user:*terminal-io* "~&Disk label not written.~%")))
	 ;1mrr 3.14.87*
	 (when *le-mcr-or-lod-changed*
	   (format user:*terminal-io*
		   "~&The System Load Defaults in the configuration band may have changed during the edit.")
	   (if (yes-or-no-p
		 "~&Do you want to update the configuration band ~a on unit ~a with the values displayed above? "
		 (parse-partition-name *le-cfg-name*) *le-cfg-unit*)
	       (progn 
		 (set-cfg-boot-data *le-cfg-name* *le-cfg-unit* :boot-unit *le-mcr-unit* :boot-name *le-mcr-name*)
		 (set-cfg-load-data *le-cfg-name* *le-cfg-unit* :load-unit *le-lod-unit* :load-name *le-lod-name*)
		 (setq *le-mcr-or-lod-changed* nil)
		 (Format user:*terminal-io* "~&Configuration band written.~%")
		 (le-get-cfg-data)
		 )
	       (Format user:*terminal-io* "~&Configuration band not written.~%"))))      
      (sys:abort (values nil t))))
  (Format user:*terminal-io* "~&Label Edit Command: ")
  )



;1;; Initialize the label.*
;1;; 2.1 changes: Added Condition-case to handle ABORT. NOw returns to main menu.*
;1;;              wrapped rubout parameter in reads to eliminate text being placed on command history *
(Defun 4LE-Com-Control-I* ()
  (Format user:*terminal-io* "Pack types are:~%")
  (Do ((l new-pack-types (Cdr l))
       (n 0 (1+ n)))
      ((Null l))
    (Format user:*terminal-io* " ~s  ~a~%" n (Caar l)))
  (Setq LE-Something-Changed t)
  (Format user:*terminal-io* "Enter desired number: ")
  (condition-case ()				;1add condition call. SYS:ABort will now only abort this command.*
      (Let ((tem (Nth (with-input-editing (user:*terminal-io* '((:no-input-save t)))
			(Read user:*terminal-io*))
		      new-pack-types)))
	(If (Not (Null tem))
	    (LE-Initialize-Label LE-Disk-Label tem))
	(LE-Display-Label LE-Disk-Label LE-Unit))
    (sys:abort (values nil t)))
  )

;1;; Delete current partition.*
(Defun 4LE-Com-Control-K* ()
  (Let ((ploc (LE-Current-Partition)))
    (condition-case ()				;1add condition call. SYS:ABort will now only abort this command.*
	(Cond ((= LE-Item-Number (Length LE-Structure))
	       (Format user:*terminal-io* "~&There is no currently selected partition.")
	       (Beep))
	      ((Fquery nil "Delete partition ~s? "
		       (Get-disk-String LE-Disk-Label ploc 4))
	       (Setq LE-Something-Changed t)
	       (Let ((nparts (Get-disk-Fixnum LE-Disk-Label
					      (+ %pt-base %PT-Number-of-Partitions)))
		     (nwords (Get-disk-Fixnum LE-Disk-Label
					      (+ %pt-base %PT-Size-of-Partition-Entries)))
		     (buf (RQB-Buffer LE-Disk-Label)))
		 (Put-disk-Fixnum LE-Disk-Label (Max (1- nparts) 0)
				  (+ %pt-base %PT-Number-of-Partitions))
		 (Copy-Array-Portion buf (* (+ ploc nwords) 2) (Array-total-size buf)
				     buf (* ploc 2) (Array-total-size buf)))
	       ))
      (sys:abort (values nil t))))
  (LE-Display-Label LE-Disk-Label LE-Unit)
  )

;1;; Redisplay label.*
(Defun 4LE-Com-Control-L* ()
  (LE-Display-Label LE-Disk-Label LE-Unit))

;1;; toggle partiton name case sensitivity flag*
(defun 4le-com-control-t* ()
  (format user:*terminal-io*
	  "~%Warning: Partition name case sensitivity is not fully supported in all partition utility functions.")
  (format user:*terminal-io* "~%Partition name case sensitivity is now ~a~%"
	  (if *partition-name-case-sensitive* 'on 'off))
  (condition-case ()				;1add condition call. SYS:ABort will now only abort this command.*
      (if (y-or-n-p "Do you what to change partition-name case sensitivity")
	  (if *partition-name-case-sensitive*
	      (setf *partition-name-case-sensitive* nil)
	      (setf *partition-name-case-sensitive* t)))
    (LE-Display-Label LE-Disk-Label LE-Unit)
    (sys:abort (values nil t)))
  (LE-Display-Label LE-Disk-Label LE-Unit))

;1;; Add a partition.*
;1;; 2.1 changes Expand make array foo. It was to small for partition table greater than length 1.*
(Defun 4LE-Com-Control-O* ()
  (Setq LE-Something-Changed t)
  (Let ((ploc (LE-Current-Partition))
	(nparts
	  (1+ (Get-disk-Fixnum LE-Disk-Label
			       (+ %pt-base %PT-Number-of-Partitions))))
	(nwords (Get-disk-Fixnum LE-Disk-Label
				 (+ %pt-base %PT-Size-of-Partition-Entries)))
	(buf (RQB-Buffer LE-Disk-Label)))
    (When (> (+ (* nparts nwords) %PT-Partition-Descriptors)
	     (* (Get-disk-Fixnum LE-Disk-Label %DL-Partition-Table-Length) disk-block-word-size))
      (When (y-or-n-p "Partition table full. Expand it?")
	(Format user:*terminal-io* "~&Sorry, unable to expand partition table.")
	))
    ;1; Check if partition table is now large enough.*
    (When (<= (+ (* nparts nwords) %PT-Partition-Descriptors)
	      (* (Get-disk-Fixnum LE-Disk-Label %DL-Partition-Table-Length) disk-block-word-size))
      (Put-disk-Fixnum LE-Disk-Label nparts
		       (+ %pt-base %PT-Number-of-Partitions))
      (Let ((foo (Make-Array #o12000 ':Type 'Art-16b)))	;1used to be 400 for 1 block partition table*
        (Copy-Array-Portion buf (* ploc 2) (Array-total-size buf)	;1with 3 blocks lengths 12000 seems to to work*
                            foo (* nwords 2) #o12000)
        (Copy-Array-Portion foo 0 #o12000
                            buf (* ploc 2) (Array-total-size buf))
        ;1; Initialize new partition.*
        (Put-disk-String LE-Disk-Label "????" (+ ploc %PD-Name) 4)
        (Put-disk-Fixnum LE-Disk-Label 0 (+ ploc %PD-Length))
        (Put-disk-Fixnum LE-Disk-Label (dpb %cpu-explorer %%cpu-type-code 0) (+ ploc %PD-Attributes))
        (Put-disk-Fixnum LE-Disk-Label
			 (If (= LE-Item-Number (Length LE-Structure))
			     (+ (Get-disk-Fixnum LE-Disk-Label
						 (+ %PD-Length (- ploc nwords)))
				(Get-disk-Fixnum LE-Disk-Label
						 (+ %PD-Start (- ploc nwords))))
			     (Get-disk-Fixnum LE-Disk-Label
					      (+ ploc nwords %PD-Start)))
			 (+ ploc %PD-Start))
        (Return-Array foo))
      (LE-Display-Label LE-Disk-Label LE-Unit)))
  )

;1;; Sort partitions by address (2nd word) and redisplay.*


(DEFUN 4LE-COM-CONTROL-S* ()
  (SETQ LE-SOMETHING-CHANGED T)
  ;1;something probably changed*
  (DO ((NPARTS (GET-DISK-FIXNUM LE-DISK-LABEL (+ %PT-BASE %PT-NUMBER-OF-PARTITIONS)) (1- NPARTS))
       (NWORDS (GET-DISK-FIXNUM LE-DISK-LABEL (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES)))
       (FROB NIL NIL)
       (PART-LIST NIL (CONS (CONS (GET-DISK-FIXNUM LE-DISK-LABEL (1+ LOC)) FROB) PART-LIST))
       (LOC (+ %PT-BASE %PT-PARTITION-DESCRIPTORS) (+ LOC NWORDS))
       (BUF (RQB-BUFFER LE-DISK-LABEL)))
      ((ZEROP NPARTS)
       (SETQ PART-LIST (SORTCAR PART-LIST #'<))
       (DO ((L PART-LIST (CDR L))
	    (LOC (+ %PT-BASE %PT-PARTITION-DESCRIPTORS) (+ LOC NWORDS)))
	   ((NULL L))
	 (DO ((K (CDAR L) (CDR K))
	      (I (1- (* 2 NWORDS)) (1- I)))
	     ((MINUSP I))
	   (SETF (AREF BUF (+ LOC LOC I)) (CAR K)))))
    (DOTIMES (I (* 2 NWORDS))
      (PUSH (AREF BUF (+ LOC LOC I)) FROB)))
  (LE-DISPLAY-LABEL LE-DISK-LABEL LE-UNIT)) 

;1;; 2.1 changes: Added to new function to handle partition name shorter than 4 characters. PAd left with spaces.*
;1;;PAD all name fields with trailing ASCII Spaces. NuBus Arthitecture Spec. requirements*


;1;; Edit the selected item.*
;1;; 2.1 changes: Added Condition-case to handle ABORT, now returns to main menu.*
;1;;              Pads partition name with spaces. Added Condition-case to handle ABORT, now returns*
;1;;              to main menu. Added editing of CPU types. Always forces LE-display-label.*
;1;;              wrapped rubout parameter in reads to eliminate text being placed on command history *

(DEFUN 4LE-COM-CONTROL-E* ()
  (SETQ LE-SOMETHING-CHANGED T)
  ;1; something probably will...*
  (CONDITION-CASE ()				;1add condition call. SYS:ABort will now only abort this command.*
      (IF (< LE-ITEM-NUMBER (LENGTH LE-STRUCTURE))
	  (LET ((ITEM (NTH LE-ITEM-NUMBER LE-STRUCTURE)))
	    (LET ((NAME (FIRST ITEM))
		  (VALUE (SECOND ITEM)))
	      
	      (LET ((*print-base* 10.))
		(FORMAT USER:*TERMINAL-IO* "Change ~a from ~s to: " NAME VALUE))
	      (SETQ VALUE
		    (IF (NUMBERP VALUE)
			(LET ((*read-base* 10.))
			  (EVAL
			    (WITH-INPUT-EDITING (USER:*TERMINAL-IO* '((:NO-INPUT-SAVE T)))
			      (READ USER:*TERMINAL-IO*))))
			(zlc:READLINE USER:*TERMINAL-IO* () '((:NO-INPUT-SAVE T)))))
	      ;1; Avoid lossage in lowercase partition names.*
	      (IF (MEMBER NAME '(PARTITION-NAME CURRENT-BAND CURRENT-MICROLOAD system-band system-microload) :TEST #'EQ)
		  (SETQ VALUE
			(IF *PARTITION-NAME-CASE-SENSITIVE*
			    (STRING VALUE)
			    (STRING-UPCASE VALUE))))
	      (CASE NAME
		    (VOLUME-NAME (PUT-DISK-STRING LE-DISK-LABEL VALUE %DL-VOLUME-NAME 16.))
		    (DRIVE-NAME (PUT-DISK-STRING LE-DISK-LABEL VALUE %DL-DEVICE-NAME 12.))
		    (COMMENT
		     (PUT-DISK-STRING LE-DISK-LABEL VALUE %DL-COMMENT 96.))
		    (N-BYTES-PER-BLOCK
		     (PUT-DISK-FIXNUM LE-DISK-LABEL
				      (DPB VALUE %%BYTES-PER-BLOCK
					   (GET-DISK-FIXNUM LE-DISK-LABEL %BYTES-PER))
				      %BYTES-PER))
		    (N-BYTES-PER-SECTOR
		     (PUT-DISK-FIXNUM LE-DISK-LABEL
				      (DPB VALUE %%BYTES-PER-SECTOR
					   (GET-DISK-FIXNUM LE-DISK-LABEL %BYTES-PER))
				      %BYTES-PER))
		    (N-SECTORS-PER-TRACK
		     (PUT-DISK-FIXNUM LE-DISK-LABEL
				      (DPB VALUE %%SECTORS-PER-TRACK
					   (GET-DISK-FIXNUM LE-DISK-LABEL %SECTOR-HEADS))
				      %SECTOR-HEADS))
		    (N-HEADS
		     (PUT-DISK-FIXNUM LE-DISK-LABEL
				      (DPB VALUE %%NUMBER-OF-HEADS
					   (GET-DISK-FIXNUM LE-DISK-LABEL %SECTOR-HEADS))
				      %SECTOR-HEADS))
		    (N-CYLINDERS
		     (PUT-DISK-FIXNUM LE-DISK-LABEL
				      (DPB VALUE %%NUMBER-OF-CYLINDERS
					   (GET-DISK-FIXNUM LE-DISK-LABEL %CYLINDERS))
				      %CYLINDERS))
		    (N-SECTORS-FOR-DEFECTS
		     (PUT-DISK-FIXNUM LE-DISK-LABEL
				      (DPB VALUE %%NUMBER-OF-SECTORS-FOR-DEFECTS
					   (GET-DISK-FIXNUM LE-DISK-LABEL %CYLINDERS))
				      %CYLINDERS))
		    (CURRENT-MICROLOAD
		     (cond (*le-prim-style-edit*
			    (FORMAT USER:*TERMINAL-IO*
				    "Editing this field only changes the disk label, not the System Load defaults.")
			    (when (fquery '(:beep t :stream user:*terminal-io*)
					  "Change ~a to ~a anyway ? " name value)
			      (setq *le-mcr-or-lod-changed* t)
			      (SETF VALUE (PAD-NAME-FIELD VALUE 4))
			      (SET-DEFAULT-MICROLOAD LE-DISK-LABEL VALUE)))
			   (t
			    (SETF VALUE (PAD-NAME-FIELD VALUE 4))
			    ;1(PUT-DISK-STRING LE-DISK-LABEL VALUE %DL-CURRENT-MICROLOAD 4) ;rel3*
			    (SET-DEFAULT-MICROLOAD LE-DISK-LABEL VALUE))))
		    (CURRENT-BAND
		     (cond (*le-prim-style-edit*
			    (FORMAT USER:*TERMINAL-IO*
				    "Editing this field only changes the disk label, not the System Load defaults.")
			    (when (fquery '(:beep t :stream user:*terminal-io*)
					  "Change ~a to ~a anyway ? " name value)
			      (setq *le-mcr-or-lod-changed* t)
			      (SETF VALUE (PAD-NAME-FIELD VALUE 4))
			      (SET-DEFAULT-LOAD-BAND LE-DISK-LABEL VALUE)))
			   (t
			    (SETF VALUE (PAD-NAME-FIELD VALUE 4))
			    ;1(PUT-DISK-STRING LE-DISK-LABEL VALUE %DL-CURRENT-BAND 4) ;rel3*
			    (SET-DEFAULT-LOAD-BAND LE-DISK-LABEL VALUE))))

		    ;1mrr 3.14.87*
		    (system-microload (setq *le-mcr-or-lod-changed* t
					    *le-mcr-name* value))
		    (system-microload-unit (setq *le-mcr-or-lod-changed* t
						  *le-mcr-unit* value))
		    (system-band (setq *le-mcr-or-lod-changed* t
				       *le-lod-name* value))
		    (system-band-unit (setq *le-mcr-or-lod-changed* t
					    *le-lod-unit* value)) 
		     
		    (N-PARTITIONS
		     (PUT-DISK-FIXNUM LE-DISK-LABEL VALUE (+ %PT-BASE %PT-NUMBER-OF-PARTITIONS)))
		    (WORDS-PER-PART (CHANGE-PARTITION-MAP LE-DISK-LABEL VALUE))
		    (PARTITION-TABLE-NAME (SETF VALUE (PAD-NAME-FIELD VALUE 4))


		  (PUT-DISK-STRING LE-DISK-LABEL VALUE %DL-PARTITION-TABLE-NAME 4))
		    (PARTITION-TABLE-START
		     (PUT-DISK-FIXNUM LE-DISK-LABEL VALUE %DL-PARTITION-TABLE-START))
		    (PARTITION-TABLE-LENGTH
		     (IF (>= *MAX-PTBL-SIZE* VALUE)
			 (PUT-DISK-FIXNUM LE-DISK-LABEL VALUE %DL-PARTITION-TABLE-LENGTH)
			 (PROGN
			   (FORMAT USER:*TERMINAL-IO*
				   "Partition table length cannot exceed SI:*MAX-PTBL-SIZE*, ~d."
				   *MAX-PTBL-SIZE*)
			   (BEEP)
			   (zlc:READLINE USER:*TERMINAL-IO* () '((:NO-INPUT-SAVE T))))))
		    (SAVE-AREA-NAME (SETF VALUE (PAD-NAME-FIELD VALUE 4))
				    (PUT-DISK-STRING LE-DISK-LABEL VALUE %DL-SAVE-AREA-NAME 4))
		    (SAVE-AREA-START (PUT-DISK-FIXNUM LE-DISK-LABEL VALUE %DL-SAVE-AREA-START))
		    (SAVE-AREA-LENGTH (PUT-DISK-FIXNUM LE-DISK-LABEL VALUE %DL-SAVE-AREA-LENGTH))
		    ;1; These occur in multiple instances*
		    ((PARTITION-NAME PARTITION-START PARTITION-SIZE PARTITION-COMMENT PARTITION-TYPE)
		     (LET ((PLOC (LE-CURRENT-PARTITION)))
		       (CASE NAME
			     (PARTITION-NAME
			      ;1if prim-style and an explorer-type mcr or load name change, set flag. mrr 3.13.87*
			      (when  *le-prim-style-edit*
				(let* ((ploc (le-current-partition))
				       (att (get-disk-fixnum le-disk-label (+ ploc %pd-attributes))))
				  (and (= (cpu-type) (ldb %%cpu-type-code att))
				       (or (= %bt-microload (ldb %%band-type-code att))
					   (= %bt-load-band (ldb %%band-type-code att)))))
				(setq *le-mcr-or-lod-changed* t))	
			      (SETF VALUE (PAD-NAME-FIELD VALUE 4))
			      (PUT-DISK-STRING LE-DISK-LABEL VALUE (+ PLOC %PD-NAME) 4))
			     (PARTITION-TYPE (PUT-DISK-FIXNUM LE-DISK-LABEL VALUE (+ PLOC %PD-ATTRIBUTES)))
			     (PARTITION-START
			      (IF (RESERVED-BLOCKS-OVERWRITE-PROTECTION PLOC NAME VALUE)
				  (PUT-DISK-FIXNUM LE-DISK-LABEL VALUE (+ PLOC %PD-START))))
			     (PARTITION-SIZE
			      (IF (RESERVED-BLOCKS-OVERWRITE-PROTECTION PLOC NAME VALUE)
				  (PUT-DISK-FIXNUM LE-DISK-LABEL VALUE (+ PLOC %PD-LENGTH))))
			     (PARTITION-COMMENT
			      (PUT-DISK-STRING LE-DISK-LABEL VALUE (+ PLOC %PD-COMMENT)
					       (* 4
						  (-
						    (GET-DISK-FIXNUM LE-DISK-LABEL
								     (+ %PT-BASE
									%PT-SIZE-OF-PARTITION-ENTRIES))
						    %PD-COMMENT)))))))
		    (OTHERWISE (FERROR () "No editor for ~S" NAME)))))
	  (BEEP))
    (ABORT (VALUES () T)))
  (LE-DISPLAY-LABEL LE-DISK-LABEL LE-UNIT))
 
;1;; overwrite protection for disk label and partition table*
;1;; block 0 and 1 are reserved for disk label.*

(DEFUN 4RESERVED-BLOCKS-OVERWRITE-PROTECTION* (PLOC NAME VALUE &AUX START LENGTH
					     (PARTITION-TABLE-START (GET-DISK-FIXNUM LE-DISK-LABEL %DL-PARTITION-TABLE-START))
					     (PARTITION-TABLE-END
					       (+ PARTITION-TABLE-START (1- (GET-DISK-FIXNUM LE-DISK-LABEL %DL-PARTITION-TABLE-LENGTH))))
					     (SAVE-AREA-START (GET-DISK-FIXNUM LE-DISK-LABEL %DL-SAVE-AREA-START))
					     (SAVE-AREA-END
					       (+ SAVE-AREA-START
						  (IF (EQ 0 (GET-DISK-FIXNUM LE-DISK-LABEL %DL-SAVE-AREA-LENGTH))
						      0
						      (1- (GET-DISK-FIXNUM LE-DISK-LABEL %DL-SAVE-AREA-LENGTH)))))
					     (NAMED-PARTITION-END NIL))
  (CASE NAME
	(PARTITION-START (SETQ START VALUE)
			 (SETQ LENGTH (GET-DISK-FIXNUM LE-DISK-LABEL (+ PLOC %PD-LENGTH))))
	(PARTITION-SIZE (SETQ LENGTH VALUE)
			(SETQ START (GET-DISK-FIXNUM LE-DISK-LABEL (+ PLOC %PD-START)))))
  (SETQ NAMED-PARTITION-END (IF (EQ 0 LENGTH)
				0
				(1- (+ START LENGTH))))
  (BLOCK DONE
    (COND
      ((< START 2)				;1blocks 0 and 1 reserved for disk label*
       (YES-OR-NO-P
	 "~%***Warning. This partition will overlap the DISK LABEL (blocks 0 and 1)!~%            This may cause loss of data and/or an unbootable disk.~%            Are you sure you want to do this?"))
      ((WHEN (NOT
	       (OR (AND (< PARTITION-TABLE-START START) (< PARTITION-TABLE-END START))
		   (> PARTITION-TABLE-START NAMED-PARTITION-END)))
	 (RETURN-FROM DONE
	   (YES-OR-NO-P
	     "~%***Warning. This partition will overlap the default PARTITION TABLE!.~%            This may cause loss of data and/or an unbootable disk.~%            Are you sure you want to do this?"))))
      ;1;;check to see if attemting to overlap the save area. Save area is used during disk-save.*
      ;1;;If overlapping occurs you would loss any data in the overlapping blocks.*
      ;1;;If the partition is a save-area type do not allow the user to proceed.*
      ((WHEN (NOT				;1is attribute of type save-area?*
	       (OR				;1does save-area lie in partition range*
		 (EQ (GET-DISK-FIXNUM LE-DISK-LABEL (+ PLOC %PD-ATTRIBUTES)) %BT-SAVE-AREA)
		 (AND (< SAVE-AREA-START START) (< SAVE-AREA-END START))
		 (> SAVE-AREA-END NAMED-PARTITION-END)))
	 (RETURN-FROM DONE
	   (YES-OR-NO-P				;1yes,overtlapping has occur, ask to proceed.*
	     "~%***Warning. This partition will overlap the default SAVE AREA!.~%            This may cause loss of data during DISK-SAVE and/or an unbootable disk.~%            Are you sure you want to do this?"))))
      (T T)))) 




;1;; Return the word number of the start of the descriptor for the partition*
;1;; containing the current item.*

(DEFUN 4LE-CURRENT-PARTITION* ()
  (DO ((WORDS-PER-PARTITION
	 (GET-DISK-FIXNUM LE-DISK-LABEL (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES)))
       (PNO 0)
       (L LE-STRUCTURE (CDR L))
       (N LE-ITEM-NUMBER (1- N)))
      ((ZEROP N)
       (+ %PT-BASE %PT-PARTITION-DESCRIPTORS (* PNO WORDS-PER-PARTITION)))
    (IF (EQ (CAAR L) 'PARTITION-COMMENT)
	(SETQ PNO (1+ PNO))))) 


(DEFF 4LE-COM-HELP* 'LE-COM-?) 

(DEFF 4LE-COM-SPACE* 'LE-COM-CONTROL-L) 

(DEFF 4LE-COM-
* 'LE-COM-CONTROL-N) 

(DEFF 4LE-COM-* 'LE-COM-CONTROL-F) 

(DEFF 4LE-COM-* 'LE-COM-CONTROL-P) 

(DEFF 4LE-COM-* 'LE-COM-CONTROL-B) 

(DEFF 4LE-COM-RETURN* 'LE-COM-CONTROL-L)		;12.1 added deff to help return out of help. Redisplay label*
;1;; Print a help message.*
;1;; 2.1 changes: Added CTRL-C command*

(DEFUN 4LE-COM-?* ()				;12.1 fix changed listing to be alphabetic by control*
  (SEND USER:*TERMINAL-IO* :CLEAR-SCREEN)		;1    letter. Seperated cursor control commands.*
						;1 Uppercased key words for readability.*
  (FORMAT USER:*TERMINAL-IO*
	  "~&Commands are as follows:   
CTRL-A set partition ATTRIBUTES (Load Band, File Band, etc.).
CTRL-C set partition CPU or Operating System type (Explorer,TI Lisp, etc.).
CTRL-D DESCRIBE the current partition.
CTRL-E EDIT selected item.
CTRL-I INITIALIZE the label from defaults.
CTRL-K DELETE partition.
CTRL-L, SPACE, RETURN clear the screen and redisplay the label.
CTRL-M set/remove partition PROPERTIES (Diagnostic, Default, etc.).
CTRL-O ADD partition.
CTRL-R READ label from disk.
CTRL-S SORT partitions by starting block address.
CRTL-T toggles case sensitivity.
CTRL-W WRITE label to disk.
META-~~ mark buffer unmodified.

CURSOR CONTROLS:
  CTRL-B back
  CTRL-F forward
  CTRL-N down 
  CTRL-P up.
 Or use arrow keys.

~:c-exit~%"
	  #\END)
  (FORMAT USER:*TERMINAL-IO* "~&Label Edit Command: ")) 

;;; end of define-when :disk
)




;;; these next four need :addin conditionalization... 12.1.87 MBC

;1;; 2.1 Changes: Modified to handled used defined CPU values. Added S1500,GDOS and SYSTEM5 types*
(define-when :DISK
(DEFUN 4SET-PARTITION-CPU-TYPE* (PART-NAME UNIT NEW-USER-TYPE
			       &optional (confirm-read t) &key &allow-other-keys) ;103.13.87 DAB*
  "2Set the new cpu type indicated by the NEW-USER-TYPE argument on partition PART-NAME on UNIT.
 PART-NAME can be a number, a partition name or a partition-name-string, such as \"NAME.Explorer\".

 Valid keywords for argument NEW-USER-TYPE are:
 :explorer, :NuMachine, :TI-Lisp, :Generic-Band, :S1500, :SYSTEM5, :GDOS, :Terminal-Concentrator,
 :Explorer-II, :CLM, :Nubus-Peripheral-Interface, :Mass-Storage-Controller, :Comm-Carrier
  or any number from 0 - #xFFFF.
 When duplicate partitions of PART-NAME exist and CONFIRM-READ is non-nil a selection menu will be display,
 otherwise a fatal error occurs.

 The optional keyword :USER-TYPE has been removed. Use the following syntax for PART-NAME to select specific user/cpu
 partitions: \"PART-NAME.USER/CPU\".
 Use PRINT-PARTITION-USER-TYPES to view valid user/cpu extensions.*" ;103.23.87 DAB*

  (WITH-RQB (RQB (READ-DISK-LABEL UNIT))
    
    (MULTIPLE-VALUE-BIND (PART-BASE IGNORE LABEL-LOC IGNORE ATTRIBUTES)
	(FIND-DISK-PARTITION PART-NAME RQB UNIT T () confirm-read) ;103.23.87 DAB*
      (IF (AND PART-BASE
	       (setq new-user-type (select-user-type new-user-type)))
	  (PROGN
	    (PUT-DISK-FIXNUM RQB (DPB NEW-USER-TYPE %%CPU-TYPE-CODE ATTRIBUTES)
			     (+ LABEL-LOC %PD-ATTRIBUTES))
	    (WRITE-DISK-LABEL RQB UNIT)
	    NEW-USER-TYPE)
	  ()))))



(DEFUN 4RESET-PARTITION-PROPERTY* (PART-NAME UNIT PROPERTY &optional (confirm-read t)) ;103.23.87 DAB*
  "2Turns off the partition property indicated by the PROPERTY argument on partition PART-NAME on UNIT.
 Valid keywords for the PROPERTY argument are:
 :Expandable, :Contractable, :Delete-protected, :Logical-partition, :Copy-protected,
 :Default, :Diagnostic.
  If duplicate partitions exist a selection menu will appear if COMFIRM-READ is non-nil, otherwise a fatal error occurs.*"

  (CHANGE-PARTITION-PROPERTY PART-NAME UNIT PROPERTY 0 confirm-read))  ;103.23.87 DAB*




(DEFUN 4CHANGE-PARTITION-PROPERTY* (PART-NAME UNIT PROPERTY VALUE &optional (confirm-read t)) ;103.23.87 DAB*
  "2Set the partition property indicated by the PROPERTY argument on partition PART-NAME on UNIT.
 PART-NAME can be a number, a partition name or a partition-name-string, such as \"NAME.Explorer\".
 Valid keywords for the PROPERTY argument are:
 :Expandable, :Contractable, :Delete-protected, :Logical-partition, :Copy-protected,
 :Default, :Diagnostic.

 When duplicate partitions of PART-NAME exist and CONFIRM-READ is non-nil a selection menu will be display,
  otherwise a fatal error occurs.
 Use PRINT-PARTITION-USER-TYPES to view valid user/cpu extensions.*"	;103.23.87 DAB*

  (WITH-RQB (RQB (READ-DISK-LABEL UNIT))
    (MULTIPLE-VALUE-BIND (PART-BASE PROPERTY-OFFSET LABEL-LOC IGNORE ATTRIBUTES)
	(FIND-DISK-PARTITION PART-NAME RQB UNIT T () confirm-read) ;103.23.87 Dab*
      (IF (AND PART-BASE (SETQ PROPERTY-OFFSET (TRANSLATE-PARTITION-PROPERTY PROPERTY)))
	  (PROGN
	    (PUT-DISK-FIXNUM RQB (DPB VALUE PROPERTY-OFFSET ATTRIBUTES)
			     (+ LABEL-LOC %PD-ATTRIBUTES))
	    (WRITE-DISK-LABEL RQB UNIT)
	    PROPERTY)
	  ())))) 


 
;1;*
;1; These routines use pop-up menus to present the user with a selection of possible*
;1; partitions to choose from.*
;1;*


;1;; Return a list of all the partitions of type TYPE on all*
;1;; online units in the system.  This list has the form:*
;1;;   ((unit name type start size comment) ... )*
;1;;2.1 changes: Added processor type optional parameter.*
;1;;             *


;1;; This must be special to allow the lambda expression to see it.*

(PROCLAIM '(SPECIAL MENU-PARTITION-TYPE DOC-STRING)) 

;1 3.0 added optional arg for cpu-type. *
(DEFUN 4generate-partition-menu-list*
       ( &Optional menu-partition-type (doc-string "Select partition \"~a\"") cpu-type)
  (let ((band-list (si:get-partition-list menu-partition-type cpu-type))
	(menu-list nil)
	name cpu-type partition-namestring
	)
    (dolist (part-list band-list menu-list)	   ;1Show more partition info on the menu, 3/19/87 mp*
      (setq cpu-type (si:keyword-user-type (ldb si:%%cpu-type-code (third part-list))))
      (setq name (second part-list))
      (setq partition-namestring (string-append name "." cpu-type))
      
      (push (list
	      (format nil "~1,1t ~a ~5,1t ~a ~12,1t ~a ~22,1t ~a ~42,1t ~a ~65,1t ~a"
		      (first part-list)	   ;1unit*
		      name                 ;1name*
		      (fifth part-list)    ;1length*
		      (si:le-get-partition-type (ldb si:%%band-type-code (third part-list)))  ;1part-type *
		       cpu-type             ;1cpu-type*
		       (sixth part-list))   ;1comment*
	      (append (list (car part-list) partition-namestring) (cddr part-list)))
	    menu-list))
    (setq menu-list
	  (append
	    (list (format nil
			  "~1,1tUnit~5,1tName~12,1t Length ~22,1tPartition Type ~42,1t User/Cpu-Type ~65,1t Comment"))
	    (list '("" :no-select nil ))   ;103.24.87 DAB*
	    (reverse menu-list) ;103.25.87 DAB*
	     ))
    ))

;1(Defun Generate-Partition-Menu-List*
;1       ( &Optional menu-partition-type (doc-string "Select partition \"~a\"") cpu-type)*
;1  ;;;partition-descriptor: UNIT NAME ATTRIBUTE START LENGHT COMMENTS*
;1  (Mapcar #'(Lambda (partition-descriptor)*
;	1      (If (And (Not (Null menu-partition-type))*
;		1       (Not (= (ldb (byte 10. 0) (Third partition-descriptor)) menu-partition-type)))*
;		1  *
;		1  ;; Item not selectable.*
;		1  `(,(Format nil "Unit: ~d, Partition: ~a"*
;			1     (First partition-descriptor)*
;			1     (Second partition-descriptor))*
;		1    :No-Select nil)*
;		1  `(,(Format nil "Unit: ~d, Partition: ~a  ~a"*
;			1     (First partition-descriptor)*
;			1     (Second partition-descriptor)*
;			1     (Sixth partition-descriptor)) ;mrr 3.18.87*
;		1    :Value ,partition-descriptor*
;		1    :Font Fonts:MEDFNB*
;		1    :Documentation ,(Format nil doc-string (Sixth partition-descriptor)))))*
;	1  ;; Fetch a list of all partitions on all units.*
;	1  (if cpu-type*
;	1      (Get-Partition-List menu-partition-type cpu-type)*
;	1      (Get-Partition-List menu-partition-type)))*
;1  )*

 

;1;; New support for CFG band.  The old default mcr & load were determined*	
;1;; simply by the default bit in the partition table.  Now, if a PRIM (boot) band is *
;1;; present and the is marked as the default in the PTBL (on the default unit & slot),*
;1;; then look in the default config band, CFGx, to determine the default Lisp MCR*
;1;; Code and Lisp Load Band to boot.*

(DEFUN 4SET-CURRENT-BAND* (BAND &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*) MICRO-P
			 &key CFG-UNIT CFG-BAND)
  "2Specify 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 
advised to select that microcode as well.  Usually, do so.

If MICRO-P then act on the microcode MCR band, instead of the LOD band.

Do PRINT-DISK-LABEL to see what bands are available and what they contain.

If using PRIM-style boot, changes are made in the default configuration band
or CFG-BAND.  If using the old boot without a configuration band, the band's
default bit is set in the partition table of UNIT.

UNIT can be a disk drive number on the local machine, or for access to remote 
machines, the UNIT argument can be a string containing the name of a machine 
and the unit number (e.g. \"P1:0\").  However, remote access just changes the 
disk label, not the CFG band.

If partition name case sensitivity was used during EDIT-DISK-LABEL the global 
variable *partition-name-case-sensitive* must be set to T, otherwise get-partition 
will return the first occurrence of band.  If band is numeric then band will 
always be mapped to uppercase.

Returns T if the band was set as specified, NIL if not (probably because user 
said no to a query).*"
  
  (let (dispose) ;1 code is in place for when decode-unit-argument gets fixed. Rel3K ?*
    (unwind-protect
	(progn
	  (if (or
		(closurep
		  (multiple-value-setq (unit dispose)
		    (decode-unit-argument unit (format () "(SET-CURRENT-~:[BAND~;MICROLOAD~] ~D)" micro-p band))))
		
						;1don't depend on PRIM for LX and ExpII. mrr 3.24.87*
		(not (or (= (cpu-type) %cpu-ti-explorer-II)   ;1Explorer II environment*
			 (= 2 si:microcode-type-code)         ;1LX environment   *
			 (ignore-errors (prim-default-p))
			 )))1    *
	      
	      ;1;THEN must be remote, or old boot method.*
	      (SET-CURRENT-BAND-IN-PTBL band UNIT micro-p)
	      ;1;otherwise, must be local*
	      (when (setf band (assure-band-name band micro-p))	;1check for MCR or LOD or if integer, convert it.*
		(multiple-value-setq (cfg-unit cfg-band)	;1find them!*
		  (find-units-and-cfg-band unit cfg-unit cfg-band))
		(unless cfg-unit
		  (ferror nil "The disk is configured with a PRIM band, but not a CFG band."))
		(when  (if micro-p
			   (assure-mcr-version band unit cfg-band cfg-unit)
			   (assure-lod-version band unit cfg-band cfg-unit))
		  (let ((slot (GET-DEVICE-SLOT-NUMBER unit)))
		    (unless slot
		      (ferror nil "Unit ~a is not defined in disk-type-table" unit))
		    (if micro-p
			(set-Cfg-Boot-Data cfg-band cfg-unit :boot-unit unit :boot-slot slot :boot-name band)
			(set-cfg-load-data cfg-band cfg-unit :load-unit unit :load-slot slot :load-name band)))
		  ))))
	  (when dispose (dispose-of-unit unit)))) 
  )
;;; end of second define-when :disk
)

(DEFUN 4SET-CURRENT-MICROLOAD* (BAND &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*)
			      &key CFG-UNIT CFG-BAND)
  "2Specify the microload band to be used for loading Explorer microcode at boot time.
If using PRIM-style boot, changes are made in CFG-BAND or the default configuration 
band.  If using the old boot without a configuration band, the band's default 
bit is set in the partition table of UNIT.

Returns T if the microcode band was set as specified, NIL if not.*"
  (set-current-band band unit T :cfg-unit cfg-unit :cfg-band cfg-band))

 
;1;; 2.1 changes: Added optional parameter CPU-type.*

(define-when :disk
(DEFUN 4SET-DEFAULT-BAND-IN-PTBL* (BAND &optional (UNIT *DEFAULT-DISK-UNIT*) (CONFIRM-READ t)) ;103.20.87 DAB*
  "2Sets the default bit on a partition. This function will search the partition table
for the specified band and if found, set the default bit. It will then go and clear 
the default bit on all other bands of the same User-Type as BAND.  Returns the band 
name if successful, NIL if not.
If duplicate band exist and CONFIRM-READ is non-nil a selection menu will be display.
The optional argument CPU-TYPE has been removed. Use the following syntax for BAND to select specific user/cpu
partitions: \"BAND.USER/CPU\".*" ;103.20.87 DAB*

  (LET (DECODEDP result)
    (unless (closurep unit)
      (MULTIPLE-VALUE-SETQ (UNIT DECODEDP)
			   (DECODE-UNIT-ARGUMENT UNIT "hacking label")))
    (WITH-RQB (RQB (READ-DISK-LABEL UNIT))
      (MULTIPLE-VALUE-BIND (PART-BASE ignore LABEL-LOC IGNORE ATTRIBUTES)
			   (FIND-DISK-PARTITION BAND RQB UNIT T () Confirm-read);103.20.87 DAB*
	(when  PART-BASE                                                        ;103.20.87 DAB*
	  (let ((function-type (LDB %%BAND-TYPE-CODE attributes))
		(cpu-type (LDB %%CPU-TYPE-CODE attributes))) ;103.20.87 DAB*
	    (PUT-DISK-FIXNUM RQB (DPB 1 %%DEFAULT-INDICATOR attributes) (+ LABEL-LOC %PD-ATTRIBUTES))
	    
	    ;1; Now, go through the rest of the partitions looking for microload bands that are of this*
	    ;1; processor type and reset their (possibly) turned on default bit.*
	    ;1;*
	    (LOOP FOR INDEX FROM (+ %PT-BASE %PT-PARTITION-DESCRIPTORS) TO
		  (+ %PT-BASE %PT-PARTITION-DESCRIPTORS
		     (* (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-NUMBER-OF-PARTITIONS))
			(GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES))))
		  BY (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES)) DO
		  (IF (AND (NOT (= INDEX LABEL-LOC))
			   (= (LDB %%BAND-TYPE-CODE (GET-DISK-FIXNUM RQB (+ INDEX %PD-ATTRIBUTES))) FUNCTION-TYPE)
			   (= (LDB %%CPU-TYPE-CODE (GET-DISK-FIXNUM RQB (+ INDEX %PD-ATTRIBUTES))) CPU-TYPE))
		      (PUT-DISK-FIXNUM
			RQB
			(DPB 0 %%DEFAULT-INDICATOR (GET-DISK-FIXNUM RQB (+ INDEX %PD-ATTRIBUTES)))
			(+ INDEX %PD-ATTRIBUTES)))))
	  (setf result band)
	  (WRITE-DISK-LABEL RQB UNIT))))
    (UNLESS DECODEDP
      (DISPOSE-OF-UNIT UNIT))
    result))



;1;;*
;1;;  All of the checking should be pulled out into a common function so we can*
;1;;   use it even if we're talking abou the new boot*
;1;;*
(DEFUN 4SET-CURRENT-BAND-IN-PTBL* (BAND &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*) MICRO-P (CONFIRM-READ t))  
  (let ((ucode-name "MCR")
	(lod-name "LOD") current-ucode-version dont-dispose
	label-index attributes ucode-version-of-band partition-name-string)
    (multiple-value-setq (unit dont-dispose)
      (decode-unit-argument unit (format () "(SET-CURRENT-~:[BAND~;MICROLOAD~] ~D)" micro-p band)))
    (unwind-protect 
	(with-rqb (rqb (read-disk-label unit))
	  (setq band
		(cond ((stringp band)
		       (if *partition-name-case-sensitive*
			    band   ;103.20.87 DAB*
			   (string-upcase  band)))  ;103.20.87 DAB*
 		      (t (format () "~A~D" (if micro-p ucode-name lod-name) band))))
	  
	  (multiple-value-setq (nil nil label-index band attributes partition-name-string) ;103.19.87 DAB*
	    (find-disk-partition band rqb unit t () confirm-read)) ;103.20.87 DAB*
	  
	  ;1check validity of attributes*
	  (selector band (lambda (name1 name2) (string-equal name1 name2 :end1 2 :end2 2))
	    (ucode-name
	     (unless (= (ldb %%band-type-code (get-disk-fixnum rqb (+ label-index %pd-attributes)))
			%bt-microload)
	       (format *standard-output* "~%The band ~a is not a valid ~A band."
		        partition-name-string ucode-name) ;103.20.87 DAB*
	       (return-from set-current-band-in-ptbl nil)))
	    (lod-name
	     (unless (= (ldb %%band-type-code (get-disk-fixnum rqb (+ label-index %pd-attributes)))
			%bt-load-band)
	       (format *standard-output* "~%The band ~a is not a valid ~A band."
		        partition-name-string lod-name) ;103.20.87 DAB*
	       (return-from set-current-band-in-ptbl nil)))
	    (otherwise
	     (format *standard-output* "~%The specified band, ~a is not a ~A band."
		      partition-name-string (if micro-p ucode-name lod-name)) ;103.20.87 DAB*
	     (return-from set-current-band-in-ptbl nil)))
	  
	  (if  micro-p
	       (set-default-microload rqb band)
	       (set-default-load-band rqb band)
	       (multiple-value-setq (nil nil ucode-version-of-band)
		 (measured-size-of-partition  partition-name-string unit)) ;103.19.87 DAB*
	      
	       (setq current-ucode-version
		     (catch-error (get-ucode-version (current-microload unit) unit)))
		
	       (if ucode-version-of-band
		   (if (eq current-ucode-version ucode-version-of-band)
		       (format *standard-output*
			       "~%The new current band ~A should work properly
with the ucode version that is already current."
			        partition-name-string) ;103.20.87 DAB*
		       (let ((band-ucode-partition
			       (find-microcode-partition rqb ucode-version-of-band)))
			 (if band-ucode-partition                                  
			     (if (fquery ()
					 "~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)
				 (set-default-microload rqb band-ucode-partition)
				 (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-from set-current-band-in-ptbl nil)))
			     ;1; Band's desired microcode doesn't seem present.*
			     (format *standard-output*
				     "~%~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-from set-current-band-in-ptbl nil)))))))
	  (write-disk-label rqb unit)
	  t)
      (unless dont-dispose
	(dispose-of-unit unit))))
  )
;;; end of 3rd define-when :disk
)

(define-when :disk
;1;;*
;1;;  Make sure that the first three characters follow the "LOD" "MCR" convention.*
;1;;*
(defun 4assure-band-name* (name &optional micro-p)
  (let* ((prefix (if micro-p "MCR" "LOD"))
	 (BAND
	   (COND
	     ((STRINGP name)                          
	      (IF *PARTITION-NAME-CASE-SENSITIVE*
		  (STRING name)                       
		  (STRING-UPCASE name)))    
	     ((numberp name)			;103.24.87 DAB*
	      (FORMAT () "~A~D" prefix name))
	     (t (string name)))))		;103.24.87 DAB                *
    (if
      (OR (STRING-EQUAL (SUBSEQ BAND 0 3) prefix)
	  (FQUERY () "The specified band is not a ~A band.  Select it anyway? " prefix)
	  ())
      BAND)))


(defun 4assure-mcr-version* (mcr-band mcr-unit cfg-band cfg-unit)
  "2Checks whether the specified microcode band goes with the load band that is 
specified in the CFG band. Sends messages to standard-output and returns T 
or Nil depending on whether the user overrides the findings. T means go ahead.*"
  (let ((new-ucode-version (get-ucode-version mcr-band mcr-unit)))
    (multiple-value-bind (lod lod-unit)
	(get-cfg-load-data cfg-band cfg-unit)
      (when (or (string-equal lod "*")
		(string-equal lod-unit "*"))
	(if (null (current-load-in-ptbl mcr-unit))
	    (return-from assure-mcr-version
	      (fquery format:yes-or-no-p-options
		    "~%No load band is currently selected to compare with ~a on ~a.
Should I really select ~a on unit ~a ? "
		    mcr-band mcr-unit mcr-band mcr-unit))
	    (setq lod (current-load-in-ptbl mcr-unit) ;1Check: Can Load-name be * and Load-unit be a number?*
		  lod-unit mcr-unit)))
      (setq lod (parse-partition-name lod))  ;104.08.87 DAB Load band is not hardware dependent.*
      (multiple-value-bind (ignore ignore ucode-version-of-band)
	  (measured-size-of-partition lod lod-unit)

	(if (eq new-ucode-version ucode-version-of-band) 
	    (progn
	      (format *standard-output* "~%The new band ~a on unit ~a should work properly with the
Load band ~a on unit ~a that is currently selected as the default." mcr-band mcr-unit lod lod-unit)
	      t)
	    (fquery format:yes-or-no-p-options
		    "~%~a on unit ~a doesn't seem to go with band ~a on unit ~a,
which is currently selected.  
Should I really select ~a on unit ~a ? "
		    mcr-band mcr-unit lod lod-unit mcr-band mcr-unit)))
  )))



(defun 4assure-lod-version* (load-band load-unit cfg-band cfg-unit)
  "2Checks whether the specified load band goes with the microcode that is 
specified in the CFG band. Sends messages to standard-output and returns T 
or Nil depending on whether the user overrides the findings. T means go ahead.*"
  (let (mcr mcr-unit current-ucode-version)
    (multiple-value-setq (mcr mcr-unit) (get-cfg-boot-data cfg-band cfg-unit))
    (when (string-equal mcr-unit "*")
      (setq mcr-unit cfg-unit))
    (when (string-equal mcr "*")
      (return-from assure-lod-version
	(fquery format:yes-or-no-p-options
		    "~%No MCR band is currently selected to compare with ~a on ~a.
Should I really select ~a on unit ~a ?" 
      		    load-band load-unit load-band load-unit)))
    (unless 
      (setq current-ucode-version (catch-error (get-ucode-version mcr mcr-unit)))
      (return-from assure-lod-version
	(fquery format:yes-or-no-p-options
		    "~%No MCR band is currently selected to compare with ~a on ~a.
Should I really select ~a on unit ~a ?" 
      		    load-band load-unit load-band load-unit)))
    (multiple-value-bind (ignore ignore ucode-version-of-band)
	(measured-size-of-partition load-band load-unit)
      (when ucode-version-of-band
	(if (eq current-ucode-version ucode-version-of-band)
	    (progn
	      (format *standard-output* "~%The new current band ~A on unit ~a should work properly
with the ucode version of ~a on unit ~a that is already currently
selected in the configuration partition ~a." load-band load-unit mcr mcr-unit cfg-band)
	      t)
	    (let ((band-ucode-partition   ;1Go look for mcr on load-unit*
		    (my-find-microcode-partition load-unit ucode-version-of-band)))
		(if band-ucode-partition
		     (if (equal band-ucode-partition
				(get-cfg-boot-data cfg-band cfg-unit))
			 (progn
			   (format *standard-output* "~%The new current band ~A on unit ~a should work properly
with the ucode version of ~a on unit ~a that is already currently
selected in the configuration partition ~a." load-band load-unit mcr mcr-unit cfg-band)
			   t)
			 (fquery  format:yes-or-no-p-options
				 "~%~A on unit ~a goes with ucode ~d, which is not selected.
Partition ~A on unit ~a claims to contain ucode ~D.  
You should probably select it soon. ~%Should I really select ~A? "
				 load-band load-unit ucode-version-of-band band-ucode-partition
				 load-unit ucode-version-of-band load-band))
			  
		     (progn
		       ;1; Band's desired microcode doesn't seem present.*
		       (format *standard-output*
			       "~%~A claims to go with ucode ~D,
which does not appear to be present on unit ~a.
It may or may not run with other ucode versions.
Currently ucode ~D is selected."
			      load-band ucode-version-of-band load-unit current-ucode-version)
		       (fquery format:yes-or-no-p-options
			       "~%Should I really select ~A? " LOAD-BAND)))))))))

(defun 4my-find-microcode-partition* (unit ucode-version)
  "2Look for the specified ucode version in the comment fields of 
   the microcode partitions on the specifed unit. Returns the ucode name or nil.*"
  (let ((ubands (get-partition-list-of-unit unit %bt-microload (cpu-type)))  ;12-14-88 DAB Added third argument.
	(desired-comment (format nil "~D" ucode-version))
	partition-name comment)
    (dolist (part ubands nil)
      (setq partition-name (seventh part)) ;103.20.87 DAB*
      (setq comment (sixth part))
      (and (string-equal partition-name "MCR" :start1 0 :start2 0 :end1 3 :end2 3)
	   (search desired-comment comment :test #'string-equal)
	   (return partition-name)))))

;;; end of 4th define-when :disk
)


(define-when :disk
;;1; Select-current-band and select-current-microload* may just go away.
;;; Or selection may be done by the user editing the addin's startup file.
;;; OR to properly support all this automatically we'd need:
;;;  1. Find out which volume the current valid startup file is on -
;;;     by asking the MAC via a Misc ACB command.
;;;  2. Programmatically read "startup", modify it, and write it back out.
;;;
(DEFUN 4SELECT-CURRENT-BAND* ()
  (LET ((LOAD-BAND
	  (when (find-symbol "MENU-CHOOSE" 'W)
	    (FUNCALL (SYMBOL-FUNCTION (FIND-SYMBOL "MENU-CHOOSE" 'W))
		     (GENERATE-PARTITION-MENU-LIST %BT-LOAD-BAND "Select LOAD band \"~a\"")
		     :label '(:STRING "Select the LOAD band:" :FONT FONTS:MEDFNB
				      ))
	    )))
    (WHEN (NOT (NULL LOAD-BAND))
      (FORMAT T "~&[Load band \"~a\" on unit ~d., \"~a\"]" (SECOND LOAD-BAND) (FIRST LOAD-BAND)
	      (SIXTH LOAD-BAND))
      ;1; go set it.*
      (SET-CURRENT-BAND (SECOND LOAD-BAND) (FIRST LOAD-BAND))))) 


(DEFUN 4SELECT-CURRENT-MICROLOAD* ()
  (LET ((MICROLOAD
	  (when (find-symbol "MENU-CHOOSE" 'W)
	    (FUNCALL (SYMBOL-FUNCTION (FIND-SYMBOL "MENU-CHOOSE" 'W))
		     (GENERATE-PARTITION-MENU-LIST %BT-MICROLOAD "Select MICROCODE band \"~a\"")
		     :label '(:STRING "Select MICROCODE band:" :FONT FONTS:MEDFNB))))
	)
    (WHEN (NOT (NULL MICROLOAD))
      (FORMAT T "~&[Microcode band \"~a\" on unit ~d., \"~a\"]" (SECOND MICROLOAD)
	      (FIRST MICROLOAD) (SIXTH MICROLOAD))
      ;1; Go set it.*
      (SET-CURRENT-BAND (SECOND MICROLOAD) (FIRST MICROLOAD) T))))


(defun partition-list (&OPTIONAL RQB (UNIT *DEFAULT-DISK-UNIT*) ALREADY-READ-P &AUX (RETURN-RQB NIL))
"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> <attributes> <partition-name-string>).
RQB is an rqb to use, or NIL meaning allocate one temporarily."
  (UNWIND-PROTECT (PROGN
		    (COND
		      ((NULL RQB)
		       (WITHOUT-INTERRUPTS
			 (SETQ RETURN-RQB T
			       RQB (OR ALREADY-READ-P (READ-DISK-LABEL UNIT))))))
		    (PARTITION-LIST-FROM-RQB RQB))
    (AND RETURN-RQB (RETURN-DISK-RQB RQB))))


(DEFUN 4PARTITION-LIST-from-RQB* (RQB &OPTIONAL FUNCTION-TYPE USER-TYPE) ;103.25.87 DAB  ;03.30.87 DAB*
  "2Returns all of the partitions of type, FUNCTION-TYPE, and processor type, USER-TYPE,
from a rqb.  You have to pass the FUNCTION-TYPE as one of the %PT-type-mumble types as
defined in QDEV or if its NIL return everything.  USER-TYPE should a cpu type or if NIL
partitions will be returned regardless of their user (cpu) type.
Returns a list of lists (<name> <base> <size> <comment> <desc-loc> <attributes>).*"
;1;%BT-Microload  %BT-Load-Band      --- Functions-Types*
;1;%Cpu-Generic-Band %CPU-EXPLORER   --- User-Types*
  (LET (PARTITIONS)    
        ;1; For all partitions in this label.*
    (DO ((N-PARTITIONS (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-NUMBER-OF-PARTITIONS)))
	     (WORDS-PER-PART
	       (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES)))
	     (I 0 (1+ I))
	     (LOC (+ %PT-BASE %PT-PARTITION-TABLE-OVERHEAD-SIZE) (+ LOC WORDS-PER-PART)))
	    ((= I N-PARTITIONS))
	  ;1; If this partition qualifies.*
	  (WHEN (and (if (NULL FUNCTION-TYPE) t    ;103.26.87 DAB*
			 (= FUNCTION-TYPE
			    (LDB %%BAND-TYPE-CODE (GET-DISK-FIXNUM RQB (+ LOC %PD-ATTRIBUTES)))))
		     (IF (NULL USER-TYPE) t
			 (= USER-TYPE
			    (LDB %%CPU-TYPE-CODE	
				 (GET-DISK-FIXNUM RQB (+ LOC %PD-ATTRIBUTES)))))	
		     )
	    ;1; Add this partition to list.*
	    (SETQ PARTITIONS
		  (NCONC PARTITIONS
			 (LIST
			   (LIST (GET-DISK-STRING RQB (+ LOC %PD-NAME) 4)
			         (GET-DISK-FIXNUM RQB (+ LOC %PD-START))
				 (GET-DISK-FIXNUM RQB (+ LOC %PD-LENGTH))
				 (GET-DISK-STRING RQB (+ LOC %PD-COMMENT)
						  ;1; get the partition comment length from the label*
						  (* 4
						     (-
						       (GET-DISK-FIXNUM RQB
									(+ %PT-BASE
									   %PT-SIZE-OF-PARTITION-ENTRIES))
						       (GET-DISK-FIXNUM RQB
									(+ %PT-BASE
									   %PT-COMMENT-UNKNOWN)))))
				 loc
				 (GET-DISK-FIXNUM RQB (+ LOC %PD-ATTRIBUTES))
				 (string-append  (GET-DISK-STRING rqb (+ LOC %PD-NAME) 4)
						 "."	;103.23.87 DAB*
						 (si:keyword-user-type
						   (ldb si:%%cpu-type-code (GET-DISK-FIXNUM rqb (+ LOC %PD-ATTRIBUTES)))))
                                 ))))))
    PARTITIONS))



 


(DEFUN 4COPY-DISK-LABEL* (&OPTIONAL (FROM-UNIT *DEFAULT-DISK-UNIT*) (TO-UNIT NIL))
  "2Copy the disk label from one unit to another.
A unit can be a disk drive number, the name of a machine (the chaosnet is used)
or machine name, colon, and unit number on the machine.*"
  (AND
    (FQUERY FORMAT:YES-OR-NO-P-OPTIONS
	    "May I smash the label on unit ~D with a copy of the label from unit ~D?" TO-UNIT
	    FROM-UNIT)
    (LET (RQB)
      (UNWIND-PROTECT (PROGN
			(SETQ FROM-UNIT (DECODE-UNIT-ARGUMENT FROM-UNIT "reading label" T ())
			      TO-UNIT (DECODE-UNIT-ARGUMENT TO-UNIT "writing label" T T))
			(SETQ RQB (READ-DISK-LABEL FROM-UNIT))
			(WRITE-DISK-LABEL RQB TO-UNIT))
	(DISPOSE-OF-UNIT FROM-UNIT)
	(DISPOSE-OF-UNIT TO-UNIT)
	(RETURN-DISK-RQB RQB)))))

;;; end of 5th define-when :disk
) 
 
;;ab 2/26/88.  Moved the mX verson [(not (resource-present-p :disk))] to DISK-PARTITION 
;;ab 10/5/88.  Changed :COND (resource-present-p :disk) PRINT-DISK-LABEL to Explorer-named version 
;;             which is called by main PRINT-DISK-LABEL routine (now in DISK-PARTITION).  Done to
;;             support printing of remote Exp labels from microExplorers.
(DEFUN print-disk-label-explorer (unit stream decodedp &aux rqb)
  (UNWIND-PROTECT
      (PROGN
	(SETQ RQB (READ-DISK-LABEL UNIT))
						;New for Rel3 mrr 3.16.87
	(let ((*LE-remote-edit* nil)	
	      (*LE-prim-style-edit* nil)
	      (*le-cfg-name* nil)
	      (*le-cfg-unit* nil)
	      (*le-mcr-name* nil)
	      (*le-mcr-unit* nil)
	      (*le-lod-name* nil)
	      (*le-lod-unit* nil))	
						;If this is a remote edit, then we can't tell if it is a prim-style edit, so act as if it is not.
	  (if (setq *LE-remote-edit* (closurep unit))
	      (setq *LE-prim-style-edit* nil)		  
						;else, if this is a prim-style edit, then find out the system defaults from cfg.
	      (if (setq *LE-prim-style-edit* (or (ignore-errors (prim-default-p))
						 (= (cpu-type) %cpu-ti-explorer-II)))
		  (if (ignore-errors		;09-25-87 DAB If nvram unit is offline.
			(and (setq *le-cfg-name*  (default-cfg-in-ptbl (nvram-default-unit)))
			     (setq *le-cfg-unit* (nvram-default-unit))))
		      (le-get-cfg-data)
						;else no correct default cfg found, so set everything to nil.
		      (setq *le-mcr-name* nil *le-mcr-unit* nil *le-lod-name* nil *le-lod-unit* nil))
		  ))
	  (PRINT-DISK-LABEL-FROM-RQB STREAM RQB ())))
    (RETURN-DISK-RQB RQB)
    (UNLESS DECODEDP
      (DISPOSE-OF-UNIT UNIT)))
  )


 
(define-when :DISK
(DEFUN 4GET-UCODE-VERSION-FROM-COMMENT* (PART UNIT)
  "2Return the microcode version stored in partition PART on unit UNIT.
This works by parsing the comment in the disk label.
UNIT can be a disk unit number, the name of a machine on the chaos net,
or machine name, colon, and unit number on the machine.*"
  (PROGN
    (LET ((COMMENT
	    (PARTITION-COMMENT PART UNIT))
	  )
      (AND COMMENT
	   (LET ((*read-BASE* 10.))
	     (MULTIPLE-VALUE-BIND (VAL IGNORE)
		 (READ-FROM-STRING
		   (SUBSEQ COMMENT
			      (1+
				(SEARCH (THE STRING (STRING " ")) (THE STRING (STRING COMMENT)) :TEST
					#'CHAR-EQUAL)))
		   T)
	       VAL))))))
)

;;; MEASURED-SIZE-OF-PARTITION was moved to disk-partition.  ; DAB 04-13-89
 

(define-when :DISK				;arbitrary, but saves space MBC 1.21.88

(DEFUN 4PRINT-LOADED-BAND* (&OPTIONAL (STREAM T))	;1Can be NIL to return a string*
  (PROG2					;1If STREAM is NIL, want to return a string with no carriage returns in it*
    (FORMAT STREAM "~&")
    (FORMAT STREAM "This is band ~A of ~A, with ~A" *LOADED-BAND* DISK-PACK-NAME
	    (IF (FBOUNDP 'SYSTEM-VERSION-INFO)	;1For the cold load*
		(SYSTEM-VERSION-INFO)
		"[fresh cold load]"))
    (FORMAT STREAM "~%"))) 


(DEFUN 4PRINT-AVAILABLE-BANDS* (&OPTIONAL (WHICH "LOD")
				    (MACHINES '("LM"))	; THIS is a NO-NO !!! ;;;(CHAOS:FINGER-ALL-LMS 'IGNORE () () T))
				    &AUX
				    (WL (AND (STRINGP WHICH) (MIN (ARRAY-ACTIVE-LENGTH WHICH) 4))) DONT-DISPOSE UNIT TEM
				    PARTITION-LIST PARTITION-LIST-ALIST)
  "2Print a summary of the contents of partitions existing on MACHINES.
MACHINES defaults to all free Lisp machines.
Only partitions whose names start with WHICH are mentioned.
WHICH defaults to \"LOD\".*"
  (CHECK-ARG WHICH (OR (STRINGP WHICH) (EQ WHICH T)) "a string or T")
  (PROGN
    (DOLIST (M MACHINES)
      (UNWIND-PROTECT (SETF
			(VALUES UNIT DONT-DISPOSE)
			(DECODE-UNIT-ARGUMENT (string M) "Examining Label")) ;12-16-88 DAB added (string M)
	(SETQ PARTITION-LIST (PARTITION-LIST () UNIT))
	(UNLESS DONT-DISPOSE
	  (DISPOSE-OF-UNIT UNIT)))
      (DOLIST (PARTITION PARTITION-LIST)
	(AND (OR (EQ WHICH T) (STRING-EQUAL (CAR PARTITION) WHICH :end1 WL :end2 WL))
	     (PLUSP (LENGTH (FOURTH PARTITION)))
	     (IF (SETQ TEM (ASSOC (FOURTH PARTITION) PARTITION-LIST-ALIST :TEST #'EQUAL))
		 (RPLACD (LAST TEM) (CONS (LIST M (FIRST PARTITION)) ()))
		 (PUSH (LIST* (FOURTH PARTITION) (LIST M (FIRST PARTITION)) ()) PARTITION-LIST-ALIST))))))
  (SETQ PARTITION-LIST-ALIST (SORTCAR PARTITION-LIST-ALIST #'STRING-LESSP))
  (DOLIST (P PARTITION-LIST-ALIST)
    (FORMAT T "~%~A:~20T~:{~<~%~20T~2:;~A ~A~>~:^, ~}" (CAR P) (CDR P))))

)


(define-when :DISK
;1;; Simple routines for manipulating the label*
;1;; These are to be called by the user*
;1;; 2.1 changes: Added optional parameter CPU-type.*

(DEFUN 4FIND-DEFAULT-MICROLOAD* (RQB &OPTIONAL CPU-TYPE)
  "2This function will search the partition table looking for a microload band of this processor type
  with the default bit set. It will return a string of the partition name of the first partition 
  which it finds.*"
  (unless cpu-type (setf cpu-type (cpu-type)))	;103.25.87*
  (setq cpu-type (select-user-type cpu-type)) ;103.23.87 DAB*
  (LOOP FOR INDEX FROM (+ %PT-BASE %PT-PARTITION-DESCRIPTORS) TO
	(+ %PT-BASE %PT-PARTITION-DESCRIPTORS
	   (* (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-NUMBER-OF-PARTITIONS))
	      (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES))))
	BY (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES)) DO
	(IF (AND
	      (= (LDB %%BAND-TYPE-CODE (GET-DISK-FIXNUM RQB (+ INDEX %PD-ATTRIBUTES))) %BT-MICROLOAD)
	      (= (LDB %%CPU-TYPE-CODE (GET-DISK-FIXNUM RQB (+ INDEX %PD-ATTRIBUTES))) CPU-TYPE)
	      (LDB-TEST %%DEFAULT-INDICATOR (GET-DISK-FIXNUM RQB (+ INDEX %PD-ATTRIBUTES))))
	    (RETURN (GET-DISK-STRING RQB (+ INDEX %PD-NAME) 4)))
	FINALLY (RETURN ()))) 
;1;; 2.1 changes: Added optional parameter CPU-type.*

(DEFUN 4SET-DEFAULT-MICROLOAD* (RQB BAND &rest &aux cpu-type)	;103.23.87 DAB*
  "2Sets the default microload partition. This function will search the partition table
  for the specified band and if it finds it, will set the default bit. It will then go
  and reset the default bit in other microcode bands that may be set.
  The optional argument CPU-TYPE has been removed. Use the following syntax for BAND to select specific user/cpu
  partitions: \"BAND.USER/CPU\".*" ;1too much work!*
  (setf (values band cpu-type)
	(parse-partition-name band))		;103.23.87 DAB*
  (PUT-DISK-STRING RQB BAND %DL-CURRENT-MICROLOAD 4)
  (multiple-value-bind (ignore ignore label-loc ignore)
      (find-disk-partition band rqb nil t)
    (if label-loc
	(when (and (= (ldb %%band-type-code (get-disk-fixnum rqb (+ label-loc %PD-Attributes)))
		      %BT-Microload)
		   (if cpu-type (= (ldb %%CPU-type-code (get-disk-fixnum rqb (+ label-loc %PD-Attributes))) ;104.06.87 DAB*
				   cpu-type)
		       t))
	  (Put-disk-Fixnum rqb (dpb 1. %%default-indicator
				    (get-disk-fixnum rqb (+ label-loc %PD-Attributes)))
			   (+ label-loc %PD-Attributes))
;1;*
;1; Now, go through the rest of the partitions looking for microload bands that are of this*
;1; processor type and reset their (possibly) turned on default bit.*
;1;*
	  (loop for index from (+ %pt-base  %pt-partition-descriptors)
		to   (+ %pt-base %pt-partition-descriptors
			(* (get-disk-fixnum rqb (+ %pt-base %pt-number-of-partitions))
			   (get-disk-fixnum rqb (+ %pt-base %pt-size-of-partition-entries))))
		by   (get-disk-fixnum rqb (+ %pt-base %pt-size-of-partition-entries))
		do (if (and (not (= index label-loc))
			    (= (ldb %%Band-type-code
				    (get-disk-fixnum rqb (+ index %PD-attributes)))
			       %BT-microload)
			    (if cpu-type (= (ldb %%CPU-type-code ;104.06.87 DAB*
						 (get-disk-fixnum rqb (+ index %PD-attributes)))
					    cpu-type)
				t))
		       (put-disk-fixnum rqb
					(dpb 0.
					     %%Default-indicator
					     (get-disk-fixnum rqb (+ index %PD-attributes)))
					(+ index %PD-attributes))))
	  (values band))
	(values nil))
    ))

;1;; 2.1 changes: Added CPU Type.*

(DEFUN 4FIND-DEFAULT-LOAD* (RQB &OPTIONAL CPU-TYPE)
  "2This function will search the partition table looking for a load band of this processor type
  with the default bit. It will return a string of the partition name of the first partition 
  which it finds.*"
  ;(unless cpu-type (setf cpu-type (cpu-type)))	;103.25.87*
  (when cpu-type (setq cpu-type (select-user-type cpu-type))) ;103.23.87 DAB*
  (LOOP FOR INDEX FROM (+ %PT-BASE %PT-PARTITION-DESCRIPTORS) TO
	(+ %PT-BASE %PT-PARTITION-DESCRIPTORS
	   (* (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-NUMBER-OF-PARTITIONS))
	      (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES))))
	BY (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES)) DO
	(IF (AND
	      (= (LDB %%BAND-TYPE-CODE (GET-DISK-FIXNUM RQB (+ INDEX %PD-ATTRIBUTES))) %BT-LOAD-BAND)
	      (or (not cpu-type)  ;04-06-88 DAB
		  (= (LDB %%CPU-TYPE-CODE (GET-DISK-FIXNUM RQB (+ INDEX %PD-ATTRIBUTES))) CPU-TYPE))
	      (LDB-TEST %%DEFAULT-INDICATOR (GET-DISK-FIXNUM RQB (+ INDEX %PD-ATTRIBUTES))))
	    (RETURN (GET-DISK-STRING RQB (+ INDEX %PD-NAME) 4)))
	FINALLY (RETURN ()))) 

;1;; 2.1 changes: Added optional parameter CPU-type.*

(DEFUN 4SET-DEFAULT-LOAD-BAND* (RQB BAND &rest &aux CPU-Type)
  "2Sets the default loadband. This function will search the partition table
  for the specified band and if it finds it, will set the default bit. It will then go
  and reset the default bit in other load bands that may be set.
  The optional argument CPU-TYPE has been removed. Use the following syntax for BAND to select specific user/cpu
  partitions: \"BAND.USER/CPU\".*" 
  (setf (values band cpu-type) (parse-partition-name band))	;103.19.87 DAB  *
  (PUT-DISK-STRING RQB BAND %DL-CURRENT-BAND 4)
  (multiple-value-bind (ignore ignore label-loc ignore)
      (find-disk-partition band rqb nil t)
    (if label-loc
	(when (and (= (ldb %%band-type-code (get-disk-fixnum rqb (+ label-loc %PD-Attributes)))
		      %BT-load-band)
		   (if cpu-type (= (ldb %%CPU-type-code (get-disk-fixnum rqb (+ label-loc %PD-Attributes))) ;104.06.87 DAB*
				   CPU-Type)
		       t))
	  (Put-disk-Fixnum rqb (dpb 1. %%default-indicator
				    (get-disk-fixnum rqb (+ label-loc %PD-Attributes)))
			   (+ label-loc %PD-Attributes))
;1;*
;1; Now, go through the rest of the partitions looking for load bands that are of this*
;1; processor type and reset their (possibly) turned on default bit.*
;1;*
	  (loop for index from (+ %pt-base %pt-partition-descriptors)
		to   (+ %pt-base %pt-partition-descriptors
			(* (get-disk-fixnum rqb (+ %pt-base %pt-number-of-partitions))
			   (get-disk-fixnum rqb (+ %pt-base %pt-size-of-partition-entries))))
		by   (get-disk-fixnum rqb (+ %pt-base %pt-size-of-partition-entries))
		do (if (and (not (= index label-loc))
			    (= (ldb %%Band-type-code
				    (get-disk-fixnum rqb (+ index %PD-attributes)))
			       %BT-load-band)
			    (if cpu-type (= (ldb %%CPU-type-code ;104.06.87 DAB*
						 (get-disk-fixnum rqb (+ index %PD-attributes)))
					    CPU-Type)
				t))
		       (put-disk-fixnum rqb
					(dpb 0.
					     %%Default-indicator
					     (get-disk-fixnum rqb (+ index %PD-attributes)))
					(+ index %PD-attributes))))
	  (values band))			;1return name as successful completion.*
	(values nil))				;1return nil if couldnt find band.*
    ))

)


(DEFUN 4GET-UCODE-VERSION-FROM-BAND* (PART &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*)
				    &AUX PART-BASE PART-SIZE RQB DONT-DISPOSE)
  "2Return the microcode version stored in partition PART on unit UNIT.
This works by reading the version number stored in the fourth word of the band.
UNIT can be a disk unit number or the name of a machine on the chaos net.*"
  (SETF (VALUES UNIT DONT-DISPOSE)
	(DECODE-UNIT-ARGUMENT UNIT (FORMAT () "Finding microcode version in ~A partition" PART)))
  (UNWIND-PROTECT (PROGN
		    (MULTIPLE-VALUE-SETQ (PART-BASE PART-SIZE)
					 (FIND-DISK-PARTITION-FOR-READ PART () UNIT))
		    (SETQ RQB (GET-DISK-RQB))
		    (DISK-READ RQB UNIT PART-BASE)
		   (LET ((BUF (RQB-BUFFER RQB)))
		     (if (= (DPB (AREF BUF 3.) (BYTE 16. 16.) (DPB (AREF BUF 2.) (BYTE 16. 0) 0))
			    5) ;1Explorer II?*
			 (DPB (AREF BUF 5.) (BYTE 16. 16.) (DPB (AREF BUF 4.) (BYTE 16. 0) 0)) ;1Explorer II 04.07.87 DAB*
		         (DPB (AREF BUF 7.) (BYTE 16. 16.) (DPB (AREF BUF 6.) (BYTE 16. 0) 0)) ;1Explorer *
			 ))
		    )
    (UNLESS DONT-DISPOSE
      (DISPOSE-OF-UNIT UNIT))
    (RETURN-DISK-RQB RQB))) 


(DEFUN 4GET-UCODE-VERSION* (PART &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*))
  "2The proper, system-pseudo-independent, function for finding the microcode
version of a band.*"
  (GET-UCODE-VERSION-FROM-BAND PART UNIT)) 


(define-when :DISK
  (DEFUN 4FIND-MICROCODE-PARTITION* (RQB MICROCODE-VERSION
					 &AUX N-PARTITIONS WORDS-PER-PART DESIRED-COMMENT)
    (SETQ DESIRED-COMMENT (FORMAT NIL "CONTROL ~D" MICROCODE-VERSION))
    (SETQ N-PARTITIONS (GET-DISK-FIXNUM RQB (+ %pt-base %pt-number-of-partitions)))
    (SETQ WORDS-PER-PART (GET-DISK-FIXNUM RQB (+ %pt-base %pt-size-of-partition-entries)))
    (IF (<= WORDS-PER-PART 3)			;1Partition comment*
	NIL
	(DO ((I 0 (1+ I))
	     (PARTITION-NAME)
	     (COMMENT)
	     (LEN (LENGTH DESIRED-COMMENT))
	     (LOC  (+ %pt-base %pt-partition-table-overhead-size) (+ LOC WORDS-PER-PART)))
	    ((= I N-PARTITIONS))
	  (SETQ PARTITION-NAME (GET-DISK-STRING RQB (+ loc %pd-name) 4))
	  (SETQ COMMENT (GET-DISK-STRING RQB (+ LOC %pd-comment) 16.))
	  (AND (STRING-EQUAL PARTITION-NAME "MCR" :end1 3 :end2 3)
	       (STRING-EQUAL COMMENT DESIRED-COMMENT :end1 LEN :end2 LEN)
	       (RETURN PARTITION-NAME)))))
  )

;;10/5/88 ab.  Fixed GET-PARTITION-COMMENT-LENGTH on remote Explorer units from microExplorer.
(DEFUN get-partition-comment-length (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*))
  (COND ((OR (CLOSUREP unit)
	     (resource-present-p :disk))
	 (get-partition-comment-length-explorer unit))
	(t (get-partition-comment-length-microExplorer unit))))

;;10/5/88 ab.  Fixed GET-PARTITION-COMMENT-LENGTH on remote Explorer units from microExplorer.
(DEFUN GET-PARTITION-COMMENT-LENGTH-microExplorer (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*))
  (declare (ignore unit))
  32.)

;;10/5/88 ab.  Fixed GET-PARTITION-COMMENT-LENGTH on remote Explorer units from microExplorer.
(DEFUN GET-PARTITION-COMMENT-LENGTH-Explorer (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*))
  "Returns the length of the comment field in the disk partition table."
  (WITH-RQB (RQB (READ-DISK-LABEL UNIT))
    (* 4 (- (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES)) %PD-COMMENT))))



;;10/5/88 ab.  Fixed SET-PARTITION-ATTRIBUTE on remote Explorer units from microExplorer.
(DEFUN set-partition-attribute (PART-NAME UNIT ATTRIBUTE &optional (CONFIRM-READ t))
  (COND ((OR (CLOSUREP unit)
	     (resource-present-p :disk))
	 (set-partition-attribute-Explorer part-name unit attribute confirm-read))
	(t (set-partition-attribute-microExplorer part-name unit attribute confirm-read))))

;;10/5/88 ab.  Fixed SET-PARTITION-ATTRIBUTE on remote Explorer units from microExplorer.
(DEFUN SET-PARTITION-ATTRIBUTE-microExplorer (PART-NAME UNIT ATTRIBUTE &optional (CONFIRM-READ t))
  (DECLARE (IGNORE part-name unit attribute confirm-read))
  nil)

;;10/5/88 ab.  Fixed SET-PARTITION-ATTRIBUTE on remote Explorer units from microExplorer.
(DEFUN SET-PARTITION-ATTRIBUTE-explorer (PART-NAME UNIT ATTRIBUTE &optional (CONFIRM-READ t))
  "Set the attribute indicated by the ATTRIBUTE argument on partition PART-NAME on UNIT.
 PART-NAME can be a number, a partition name or a partition-name-string, such as \"NAME.Explorer\".
 Valid keywords for argument ATTRIBUTE are:
 :Load-band, :Microcode-band, :Page-band, :File-band, :Meter-band, :Test-zone,
 :Format-Parameter, :Volume-label, :Save-area, :Partition-Table, :Configuration-band,
 :Log-band, :Anchor-band ,:empty-band
 or a number from #x0C - #xFE. (user defined attributes).
 When duplicate partitions of PART-NAME exist and CONFIRM-READ is non-nil a selection menu will be display,
 otherwise a fatal error occurs.

 The optional keyword :USER-TYPE has been removed.
 Use the following syntax for PART-NAME to select a specific user/cpu partition: \"PART-NAME.USER/CPU\".
 Use PRINT-PARTITION-USER-TYPES to view valid user/cpu extensions."
  (WITH-RQB (RQB (READ-DISK-LABEL UNIT))
    (MULTIPLE-VALUE-BIND (PART-BASE ATTRIBUTE-VALUE LABEL-LOC IGNORE ATTRIBUTES)
	(FIND-DISK-PARTITION PART-NAME RQB UNIT T () confirm-read)	;03.13.87 DAB
      (IF (AND PART-BASE
	       (IF (NUMBERP ATTRIBUTE)		;add to allow user define values
		   (IF (AND (>= ATTRIBUTE 0) (<= ATTRIBUTE #xFF))
		       (SETQ ATTRIBUTE-VALUE ATTRIBUTE))	;user range 
		   (SETQ ATTRIBUTE-VALUE
			 (SELECT ATTRIBUTE (:LOAD-BAND %BT-LOAD-BAND) (:MICROCODE-BAND %BT-MICROLOAD)
				 (:PAGE-BAND %BT-PAGE-BAND) (:FILE-BAND %BT-FILE-BAND)
				 (:METER-BAND %BT-METER-BAND) (:TEST-ZONE %BT-TEST-ZONE)
				 (:FORMAT-PARAMETER %BT-FORMAT-PARAMETER) (:VOLUME-LABEL %BT-VOLUME-LABEL)
				 (:SAVE-AREA %BT-SAVE-AREA) (:PARTITION-TABLE %BT-PARTITION-TABLE)
				 (:CONFIGURATION-BAND %BT-CONFIGURATION-BAND) (:LOG-BAND %BT-LOG-BAND)
				 (:anchor-band %bt-anchor-band) (:EMPTY-BAND %BT-EMPTY-BAND)))))	;03.17.87 DAB
	  (PROGN
	    (PUT-DISK-FIXNUM RQB (DPB ATTRIBUTE-VALUE %%BAND-TYPE-CODE ATTRIBUTES)
			     (+ LABEL-LOC %PD-ATTRIBUTES))
	    (WRITE-DISK-LABEL RQB UNIT)
	    ATTRIBUTE)
	  ()))))


;;10/5/88 ab.  Fixed SET-PARTITION-PROPERTY on remote Explorer units from microExplorer.
(DEFUN set-partition-property (PART-NAME UNIT PROPERTY &optional (CONFIRM-READ t))
  (COND ((OR (CLOSUREP unit)
	     (resource-present-p :disk))
	 (set-partition-property-Explorer part-name unit property confirm-read))
	(t (set-partition-property-microExplorer part-name unit property confirm-read))))

;;10/5/88 ab.  Fixed SET-PARTITION-PROPERTY on remote Explorer units from microExplorer.
(DEFUN SET-PARTITION-PROPERTY-microExplorer (PART-NAME UNIT PROPERTY &optional (CONFIRM-READ t))
  (DECLARE (IGNORE part-name unit property confirm-read))
  nil)

;;10/5/88 ab.  Fixed SET-PARTITION-PROPERTY on remote Explorer units from microExplorer.
(DEFUN SET-PARTITION-PROPERTY-explorer (PART-NAME UNIT PROPERTY &optional (confirm-read t))	;03.23.87 DAB
  "Set the partition property indicated by the PROPERTY argument on partition PART-NAME on UNIT.
 PART-NAME can be a number, a partition name or a partition-name-string, such as \"NAME.Explorer\".
 Valid keywords for the PROPERTY argument are:
 :Expandable, :Contractable, :Delete-protected, :Logical-partition, :Copy-protected,
 :Default, :Diagnostic.
 When duplicate partitions of PART-NAME exist and CONFIRM-READ is non-nil a selection menu will be display,
 otherwise a fatal error occurs.
 Use PRINT-PARTITION-USER-TYPES to view valid user/cpu extensions."
  (CHANGE-PARTITION-PROPERTY PART-NAME UNIT PROPERTY 1 confirm-read ))