LMFL#!C(:PADDED T :HOST "SYS" :BACKUP-DATE 2773684095. :SYSTEM-TYPE :LOGICAL :VERSION 4. :TYPE "LISP" :NAME "EDIT-DISK-PARTITIONS" :DIRECTORY ("REL3-2" "ZMACS") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-2\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2770913753. :AUTHOR "REL3-2" :LENGTH-IN-BYTES 133729. :LENGTH-IN-BLOCKS 131. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                ;;;-*- Mode:Common-Lisp; Package:ZWEI; Fonts:(MEDFNT MEDFNB); Base:10 -*-;;;The data, information, methods, and concepts contained herein are;;;a valuable trade secret of Texas Instruments.   They are licensed;;;in  confidence  by  Texas  Instruments  and  may  only be used as;;;permitted  under the terms of the  definitive  license  agreement;;;under which such use is licensed.;;;;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;;;;; Copyright (C) 1986, Texas Instruments Incorporated. All rights reserved.;;---------;; This file contains the entire set of code used to define the Disk-Label-Editor.;; It is currently in a developmental phase.  All questions and problems should be;; forwarded to Carol Isom.;;---------;; Only one DLE-buffer can exist at a time (in the current implementation).;; If the buffer has been created, this variable points to it.(defparameter *disk-label-buffer* nil  "Zwei Disk Label Buffer");; The first font in this list is the main display font in the DLE.;; The second font is used to highlight characters in the display which;; correspond to keystroke commands.;;;(defparameter disk-label-fonts '(:cptfnt :medfnt));;; Create a local kill history to keep the disk label editing stuff off the real kill history(DEFMACRO font-char-width (ind)  `(OR (AND ft (AREF ft (CHAR-CODE (AREF line ,ind))))       (tv:font-char-width (AREF (w:sheet-font-map window)                                 (CHAR-FONT (AREF line ,ind))))))(defparameter disk-kill-history   (MAKE-HISTORY "kill history" :ELEMENT-STRING-FUNCTION 'SUMMARIZE-KILL-HISTORY-INTERVAL)   "History of intervals of killed text.");; The following definitions define the order and column alignment;; for each of the fields displayed by the DLE.  It may be desirable;; or even necessary in the future, to allow a re-ordering of the ;; columns (maybe even at runtime!).  Therefore, please continue;; to allow for this flexibility in generating the following formats.(defparameter disk-name-column 1)(defparameter disk-unit-column 20)(defparameter cfg-name-column 1)(defparameter default-mcr-column 27)(defparameter default-mcr-unit-column 54)(defparameter default-lod-column 62)(defparameter default-lod-unit-column 80)(defparameter disk-label-modified 63)(defparameter default-boot-column 35)(defparameter name-column 7)(defparameter attribute-column 15)(defparameter blocks-column 52)(defparameter origin-column 42)(defparameter cpu-type-column 60)(defparameter flags-column 72)(defparameter comment-column 88)(defparameter module-column 1)(defparameter offset-column 12)(defparameter length-column 21)(defparameter boot-timeout-column 30)(defparameter number-of-entries-column 44)(defparameter board-type-column 59)(defparameter valid-slots-column 86)(defparameter processor-type-column 71)(defparameter cfg-comment-column 10)(defparameter default-generation-column 28)(defparameter default-revision-column 45)(defparameter module-edit-item-column 40)(defparameter partition-tab-list '((comment-column) (flags-column 15) (cpu-type-column  11)   (blocks-column 7) (origin-column 7) (attribute-column 22)   (name-column 4)))(defparameter disk-tab-list '((24 0) (11 11)))(defparameter cfg-header-tab-list '((77 0)(default-lod-column  15) (53 0)(default-mcr-column 25) ))(defparameter cfg-info-tab-list '((default-revision-column 13) (default-generation-column 15)))(defparameter cfg-comment-tab-list '((cfg-comment-column)))(defparameter module-tab-list '((valid-slots-column) (processor-type-column 11) (board-type-column 11)(number-of-entries-column 3) (boot-timeout-column 4) (length-column 2)   (offset-column 2)))(defparameter cfg-item-tab-list '((module-edit-item-column)))(defparameter cfg-function-list '((default-revision-column com-change-cfg-revision) (default-generation-column com-change-cfg-generation) (cfg-comment-column com-change-cfg-comments) (valid-slots-column com-change-valid-slots) (processor-type-column com-change-bootable-processor) (board-type-column com-change-cfg-board-type) (number-of-entries-column com-change-number-of-entries) (boot-timeout-column com-change-boot-timeout) (length-column com-change-cfg-length) (offset-column com-change-cfg-offset) (module-edit-item-column  com-edit-config-item-menu)))(defparameter function-list '((0 com-mouse-mark-region)      ( name-column com-change-partition-name)      ( 11 com-change-disk-name)      ( attribute-column com-change-partition-attribute)      (default-mcr-column com-change-default-mcr-partition)      ( origin-column com-change-partition-origin)      (default-lod-column  com-change-default-load-partition)      ( blocks-column com-change-partition-blocks)      ( cpu-type-column com-change-partition-cpu-type)      ( flags-column com-change-partition-properties)      ( comment-column com-change-partition-comments)));; This format line is printed once for each on-line disk.(defparameter format-disk-line              (format nil "Disk Name:  ~~~dt~~s~~~dtDisk Unit:  ~~2d"      disk-name-column disk-unit-column))(defparameter format-cfg-data-line1              (format nil "~~~dtRam Base: ~~x" module-edit-item-column ))(defparameter format-cfg-data-line2              (format nil "~~~dtBoot Partition Name: ~~a" module-edit-item-column  ))(defparameter format-cfg-data-line3              (format nil "~~~dtBoot Partition Unit: ~~a" module-edit-item-column ))(defparameter format-cfg-data-line4              (format nil "~~~dtBoot Partition Slot: ~~a" module-edit-item-column  ))(defparameter format-cfg-data-line5              (format nil "~~~dtHardware Id: ~~a" module-edit-item-column  ))(defparameter format-cfg-data-line6              (format nil "~~~dtSoftware Id: ~~a"      module-edit-item-column ))(defparameter format-cfg-character-line      (format nil "~~~dt~~a" module-edit-item-column ))(defparameter format-cfg-line      (format nil "~~~dt Configuration Band:~~s~~~dtMicrocode:~~s~~~dtUnit:~~2d~~~dtLoadband:~~s~~~dtUnit:~~2d~~~dt~~a"      cfg-name-column default-mcr-column default-mcr-unit-column default-lod-column      default-lod-unit-column disk-label-modified ))(defparameter default-boot-message      (format nil "~~~dt~~a" default-boot-column))(defparameter format-cfg-line1      (format nil "~~~dt Configuration Band:~~s~~~dtGeneration:~~s~~~dtRevision:~~s"      cfg-name-column default-generation-column default-revision-column))(defparameter format-cfg-comment-line      (format nil "~~~dt Comments:~~s"      cfg-comment-column))(defparameter format-cfg-line-header      (format nil "~~~dtModule~~~dtOffset~~~dtLength~~~dtBoot Timeout~~~dt# of Entries~~~dtBoard Type~~~dtProcessor Type~~~dtValid Slots"      module-column offset-column length-column      boot-timeout-column number-of-entries-column Board-type-column      processor-type-column valid-slots-column ))(defparameter default-warning-message      (format nil "----WARNING--- This may not change the default boot selections"))(defparameter default-message      (format nil "(DEFAULT BOOT PARAMETERS)"))(defparameter not-default-message      (format nil "(---- NOT DEFAULT BOOT PARAMETERS ---)"))(defparameter remote-disk-message      (format nil "(CANNOT DETERMINE DEFAULT BOOT PARAMETERS ON REMOTE DISK)"))(defparameter format-invalid-partition      (format nil "----------------WARNING----- Partition contains INVALID DATA ----------------------"))(defparameter free-blocks-message      (format nil "----------------------~~d. Blocks Free -----------------------"))(defparameter overlapping-blocks-message      (format nil "----------------------~~d. Overlapping Blocks ----------------"))(defparameter end-of-disk-message      (format nil "----------------------Data Excedes Physical Disk Size----------"));; This format line places the column headings for the partition data.(defparameter format-partition-line-header              (format nil "~~~dtName~~~dtAttribute~~~dtOrigin~~~dtBlocks~~~dtCPU Type~~~dtProperties   ~~~dtComment"      name-column attribute-column origin-column      blocks-column cpu-type-column flags-column comment-column));; This format line is printed once for each partition.(defparameter format-partition-line              (format nil "~~~dt~~a~~~d,2t~~a~~~d,2t~~6d~~~d,2t~~6d~~~d,2t~~a~~~d,2t~~a~~~d,2t~~a"      name-column attribute-column origin-column      blocks-column cpu-type-column flags-column comment-column));; this format line is printed once for each cfg module(defparameter format-cfg-partition-line      (format nil "~~~dt~~d~~~dt~~d~~~dt~~d~~~dt~~d~~~dt~~d~~~dt~~a~~~dt~~a~~~dt~~a"      module-column offset-column length-column      boot-timeout-column number-of-entries-column Board-type-column      processor-type-column valid-slots-column ));; This string is printed as the disk modified flag on the DISK-LINE(defparameter disk-modified-flag "modified");; The following closures are selectable sorting algorithems used;; to sort the partition lines.(defparameter origin-sort #'(lambda (partition-data1 partition-data2) (< (send partition-data1 :origin)    (send partition-data2 :origin))))(defparameter block-sort #'(lambda (partition-data1 partition-data2) (< (send partition-data1 :size)    (send partition-data2 :size))))(defparameter attribute-sort #'(lambda (partition-data1 partition-data2) (< (send partition-data1 :type)    (send partition-data2 :type))))(defparameter name-sort #'(lambda (partition-data1 partition-data2)       (string-lessp (send partition-data1 :name)     (send partition-data2 :name))))(defparameter comment-sort #'(lambda (partition-data1 partition-data2)       (string-lessp (send partition-data1 :comment)     (send partition-data2 :comment))))(DEFVAR PARTITION-PROPERTIES   `((|Expandable| ,si:%%EXPANDABLE :expandable-property)     (|Contractable| ,si:%%CONTRACTABLE :contractable-property)     (|Delete protected| ,si:%%DELETE-PROTECTED :delete-protected-property)     (|Logical partition| ,si:%%LOGICAL-PARTITION :logical-property)     (|Copy protected| ,si:%%COPY-PROTECTED :copy-protected-property)     (|Disk Label Default| ,si:%%DEFAULT-INDICATOR :default-property);mrr 3.17.87 changed default name.     (|Diagnostic| ,si:%%DIAGNOSTIC-INDICATOR :diagnostic-property)));; The default algorithem is to sort by origin.(defparameter sorting-predicate origin-sort)(defprop sorting-predicates (origin-sort block-sort name-sort comment-sort attribute-sort) :types-of-sorts)(defvar item-menu'(("Change partition name" . com-change-partition-name)  ("Change partition attribute" . com-change-partition-attribute)  ("Change origin" . com-change-partition-origin)          ("Change number of blocks" . com-change-partition-blocks)          ("Change CPU/OS type" . com-change-partition-cpu-type)          ("Change properties" . com-change-partition-properties)          ("Change comments" . com-change-partition-comments)          ("Describe partition" . com-describe-partition)))(defvar cfg-item-menu'(("Change configuration module offset" . com-change-cfg-offset)  ("Change configuration module length" . com-change-cfg-length)  ("Change boot timeout value" . com-change-boot-timeout)          ("Change number of configuration Entries" . com-change-number-of-entries)          ("Change Board Type" . com-change-cfg-board-type)          ("Change Valid slots" . com-change-valid-slots)          ("Change processor type" . com-change-bootable-processor)  ("Add an optional entry" . com-add-character-item)  ("Delete last optional entry". com-delete-character-item)          ))(defvar cfg-item1-menu'(("Change configuration module offset" . com-change-cfg-offset)  ("Change configuration module length" . com-change-cfg-length)  ("Change boot timeout value" . com-change-boot-timeout)          ("Change number of configuration Entries" . com-change-number-of-entries)          ("Change Board Type" . com-change-cfg-board-type)          ("Change Valid slots" . com-change-valid-slots)          ("Change processor type" . com-change-bootable-processor)          ))(defvar cfg-overhead-menu'(("Change generation" . com-change-cfg-generation)  ("Change revision" . com-change-cfg-revision)  ("Change comments" . com-change-cfg-comments)          ))(defvar config-menu'(("Change partition name" . com-change-partition-name)  ("Change partition attribute" . com-change-partition-attribute)  ("Change starting block" . com-change-partition-origin)          ("Change number of blocks" . com-change-partition-blocks)          ("Change CPU/OS type" . com-change-partition-cpu-type)          ("Change properties" . com-change-partition-properties)          ("Change comments" . com-change-partition-comments)          ("Describe partition" . com-describe-partition)  ("Edit Configuration Parameters". com-edit-config-band)))(defvar disk-name-menu'(("Change Disk name" . com-change-disk-name)          ("Describe Disk" . com-describe-disk)))(defvar default-cfg-menu'(("Change default mcr partition" . com-change-default-mcr-partition)  ("Change default load partition" . com-change-default-load-partition)  ("Edit Configuration Parameters". com-edit-config-band)          ))(defvar maintenance-menu-alist'(("Change default load partition" . com-change-default-load-partition)  ("Change default mcr partition" . com-change-default-mcr-partition)  ("Change sort parameters" . com-change-sort-algorithem)  ("Compare disk partition" . com-compare-disk-partition)  ("Add a partition" . com-add-partition)  ("Delete a partition" . com-kill-partition)  ("Receive band into partition" . com-receive-band)  ("Transmit band from partition" . com-transmit-band)  ("" :no-select t)  ("Zmacs Commands" :no-select t :font tr12b)  ("List Buffers" . com-list-buffers)  ("Split Screen" . com-split-screen)))(defvar cfg-maintenance-menu-alist'(("Add a Module" . com-add-module)  ("Delete a Module" . com-kill-module)  ("Edit Data Items" . com-show-cfg-data);;;  ("Copy Data Items" . com-copy-data)  ("" :no-select t)  ("Zmacs Commands" :no-select t :font tr12b)  ("List Buffers" . com-list-buffers)  ("Split Screen" . com-split-screen)))(defvar *disk-unit-COMTAB* ) (setq *disk-unit-comtab* (SET-COMTAB 'disk-unit-comtab    '(#\END COM-disk-unit-COMPLETE      #\RETURN com-disk-unit-complete      )))(SET-COMTAB-INDIRECTION *disk-unit-comtab* *MINI-BUFFER-COMTAB*);; This macro defines the DLE editing mode.  (defmajor Com-Disk-Label-Mode disk-label-mode "Disk-Label-Editor"  "Setup for Editing Disk Label Information" ()    (set-comtab *mode-comtab* '(#\Sp com-down-real-line   #\rubout com-up-real-line   #\Help com-edit-disk-label-documentation   #\mouse-l-1 com-disk-label-editor-find-highlighted-string   #\Mouse-M-1 com-edit-item-menu   #\Mouse-R-1 com-edit-partition-menu                                   #\CTRL-K com-kill-partition                                   #\CTRL-k com-kill-partition                                   #\CTRL-O com-add-partition                                   #\CTRL-o com-add-partition   #\undo com-beep   #\Abort com-disk-label-abort   #\End com-disk-label-exit   )   '(("Boot File System" . com-boot-file-system)     ("Update Disk Labels" . com-update-disk-labels))   )    (set-mouse-documentation)  (set-mode-line-list (append (mode-line-list) '("      (END to exit)"))))(defmajor Com-Disk-config-Mode disk-config-mode "Disk-config-Editor"  "Setup for Editing Disk Configuration Information" ()        (set-comtab *mode-comtab* '( #\Help com-edit-config-documentation#\s com-show-cfg-data#\S com-show-cfg-data#\mouse-L-1  com-disk-config-editor-find-highlighted-string#\Mouse-M-1 com-edit-config-item-menu#\Mouse-R-1 com-edit-config-partition-menu#\Abort com-disk-config-abort#\End com-disk-config-exit)   )    (set-mouse-documentation)  (set-mode-line-list (append (mode-line-list) '("      (END to exit)"))))(defprop com-edit-item-menu "Band Maintenance Menu" :mouse-short-documentation)(defprop com-edit-config-item-menu "Config Module Maintenance Menu" :mouse-short-documentation)(defprop com-edit-config-partition-menu "Config Maintenance Menu" :mouse-short-documentation)(defprop com-edit-partition-menu "Disk Management Menu" :mouse-short-documentation)(defprop com-disk-label-menu "Disk Management Menu" :mouse-short-documentation)(defcom COM-edit-item-MENU"A menu of disk label commands to operate on the partition clicked on."()  (let ((*kill-history* disk-kill-history))  (com-mouse-mark-region)  (if (or (getf (line-plist (bp-line (point))) :partition)  (getf (line-plist (bp-line (point))) :disk))  (let ((disk-label-interval (getf (line-plist (bp-line (point))) :disk))(disk-cfg-overhead (getf (line-plist (bp-line (point))) :cfg-overhead))(bp (bp-line (point)))menu)    (if (not disk-label-interval)(progn  (if (equal 10 (send (getf (line-plist (bp-line (point))) :partition) :type));;; is this a cfg partition???      (setq menu config-menu)      (setq menu item-menu))  (edit-disk-item-menu menu (send (getf (line-plist bp) :partition) :name))))    (if (and disk-label-interval     (not disk-cfg-overhead))(let (command)   ;;; disk name line  (select-window)  (redisplay-all-windows t)  (using-resource (menu menu-command-menu disk-name-menu)    (send menu :set-label (format nil "Commands for Disk Name" ))    (send menu :set-geometry t t nil)    (setq command (funcall menu :choose)))  ;;Ensure that ZMACS window is selected correctly after the menu  (select-window)  (if command      (funcall command)      (values dis-none dis-none))))    (if disk-cfg-overhead(let (command)   ;;; cfg parameters line  (select-window)  (redisplay-all-windows t)  (using-resource (menu menu-command-menu default-cfg-menu)    (send menu :set-label (format nil "Commands for Configuration Line" ))    (send menu :set-geometry t t nil)    (setq command (funcall menu :choose)))  ;;Ensure that ZMACS window is selected correctly after the menu  (select-window)  (if command      (funcall command)      (values dis-none dis-none))))    dis-none)  (barf "Line does not describe a partition"))))(defcom COM-edit-config-item-MENU"A menu of configuration commands to operate on the module clicked on."()  (let ((*kill-history* disk-kill-history))  (com-mouse-mark-region)  (if (or (getf (line-plist (bp-line (point))) :partition)  (getf (line-plist (bp-line (point))) :disk))  (let ((disk-cfg-overhead (getf (line-plist (bp-line (point))) :cfg-overhead)))    (if (not disk-cfg-overhead)(if (getf (line-plist (bp-line (point))) :cfg-data)    (edit-config-character-item)    (if (and (array-leader (bp-line (point)) 1)     (getf (line-plist(array-leader (bp-line (point)) 1)) :cfg-data))(let (command)   ;;; disk name line  (select-window)  (redisplay-all-windows t)  (using-resource (menu menu-command-menu cfg-item-menu)    (send menu :set-label (format nil "Commands for Modules" ))    (send menu :set-geometry t t nil)    (setq command (funcall menu :choose)))  ;;Ensure that ZMACS window is selected correctly after the menu  (select-window)  (if command      (funcall command)      (values dis-none dis-none)))(let (command)   ;;; disk name line  (select-window)  (redisplay-all-windows t)  (using-resource (menu menu-command-menu cfg-item1-menu)    (send menu :set-label (format nil "Commands for Modules" ))    (send menu :set-geometry t t nil)    (setq command (funcall menu :choose)))  ;;Ensure that ZMACS window is selected correctly after the menu  (select-window)  (if command      (funcall command)      (values dis-none dis-none)))))(let (command)   ;;; disk name line  (select-window)  (redisplay-all-windows t)  (using-resource (menu menu-command-menu cfg-overhead-menu)    (send menu :set-label (format nil "Commands for Configuration Overhead" ))    (send menu :set-geometry t t nil)    (setq command (funcall menu :choose)))  ;;Ensure that ZMACS window is selected correctly after the menu  (select-window)  (if command      (funcall command)      (values dis-none dis-none))))    dis-none)  (barf "Line does not describe a partition")) dis-none))(defun edit-disk-item-MENU (menu-alist name)  (let ((*kill-history* disk-kill-history))  (com-mouse-mark-region)  (if (or (getf (line-plist (bp-line (point))) :partition)  (getf (line-plist (bp-line (point))) :disk))      (let (command)(select-window)(redisplay-all-windows t)(using-resource (menu menu-command-menu menu-alist)  (send menu :set-label (format nil "Commands for ~d" name))  (send menu :set-geometry t t nil)  (setq command (funcall menu :choose)));;Ensure that ZMACS window is selected correctly after the menu(select-window)(if command    (funcall command)    (values dis-none dis-none)))      (barf "Line does not describe a partition"))))(defcom com-edit-partition-menu" A menu of partition maintenance commands"()  (let ((*kill-history* disk-kill-history))  (com-mouse-mark-region)  (if (or (getf (line-plist (bp-line (point))) :partition)  (getf (line-plist (bp-line (point))) :disk))      (if (getf (line-plist (bp-line (point))) :disk)  (com-edit-item-menu)  (let (command)    (select-window)    (redisplay-all-windows t)    (using-resource (menu menu-command-menu maintenance-menu-alist)      (send menu :set-label (format nil "Partition Maintance Commands"))      (send menu :set-geometry t t nil)      (setq command (funcall menu :choose)))    ;;Ensure that ZMACS window is selected correctly after the menu    (select-window)    (if command(funcall command)(values dis-none dis-none))))      (barf "Line does not describe a partition"))  dis-none))(defcom com-edit-config-partition-menu" A menu of configuration maintenance commands"()  (let ((*kill-history* disk-kill-history))  (com-mouse-mark-region)  (if (getf (line-plist (bp-line (point))) :partition)      (if (getf (line-plist (bp-line (point))) :cfg-overhead)  (com-edit-config-item-menu)  (let (command)    (select-window)    (redisplay-all-windows t)    (using-resource (menu menu-command-menu cfg-maintenance-menu-alist)      (send menu :set-label (format nil "Configuration Maintance Commands"))      (send menu :set-geometry t t nil)      (setq command (funcall menu :choose)))    ;;Ensure that ZMACS window is selected correctly after the menu    (select-window)    (if command(funcall command)(values dis-none dis-none))))      (barf "line does not describe a module"))  dis-none))(defcom com-disk-unit-complete       "check The disk unit number enter"       (declare (special disk-unit) )       (let ((value (bp-line (point)))     ) (if (equal value "")     (setq value si:*default-disk-unit*)) (multiple-value-bind (disk-unit decoded-p)     (si:decode-unit-argument value "editing label")   (THROW 'RETURN-FROM-COMMAND-LOOP (list disk-unit decoded-p)))) );; This command is the main entry point for the DLE.;; It creates/initializes the DLE buffer if necessary and selects it.(defcom com-edit-disk-partition  "Edit Disk Partitions"()  (let (disk-listdisk-unitdisk-label-interval(disk-label-buffer (dolist (buffer *zmacs-buffer-list*)     (when (string-equal "Disk Label Buffer" (buffer-name buffer))       (return buffer)))))    (if (not disk-label-buffer)(progn (setq disk-list (zwei:edit-in-mini-buffer *disk-unit-comtab*  nil nil (list (format nil "Enter Disk Unit to edit HOST:UNIT  (Default is ~a) END to exit" si:*default-disk-unit*))))       (setq disk-unit (car disk-list))       (setf disk-label-buffer (make-instance 'zwei-disk-label-buffer :name "Disk Label Buffer"))       (setf (buffer-saved-major-mode  disk-label-buffer) 'disk-label-mode)         ;remote disk does not access nvram       (send  disk-label-buffer :activate)       (setq disk-label-interval (send  disk-label-buffer :revert-1 disk-unit(if (numberp disk-unit) nil t)))       (send  disk-label-buffer :select)       (check-partition-length disk-label-interval)       (with-read-only-suppressed (*interval*) (send  disk-label-interval :insert-partition-descriptions));;;       (redefine-fonts *window* (set-buffer-fonts disk-label-buffer disk-label-fonts))       (setf *disk-label-buffer* disk-label-buffer)       )(progn  (send  disk-label-buffer :activate)  (send  disk-label-buffer :select)))    )  dis-none);; This command defines the HELP key processing while in DLE mode.;; Its main purpose is to add an "M" option to the type of help available;; through the HELP key.(defcom com-edit-disk-label-documentation"Handel HELP Key"()    (let ((*com-documentation-alist*       (cons '(#\M com-edit-disk-label-help) *com-documentation-alist*))) (com-documentation))  dis-none);; This command is executed if the user selects the "M" option from the HELP menu.;; See the previous command edit-disk-label-documentation for more information.(defcom com-edit-disk-label-help"Supply documentation for Disk Partition Editor"()  (format t "~:|~%           EDIT DISK PARTITION HELP~%~             ~%  The Disk Partition Editor is a utility that allows you to modify the~             ~%  current status of the disk labels for each of your disks.  When~             ~%  the utility is initially entered the current status is listed in~             ~%  the edit buffer.  Using the available commands, described below,~             ~%  you modify the data in the buffer.  Changes to the actual disk labels~             ~%  are not made until you give the explicit command to update them.~%~             ~%  Commands specific to the boxed partition are located on middle click~%~             ~%  Commands of a more general nature are located on right click~%~             ~%     Keystroke       Command~%~             ~%        CTRL-O - Insert new partition after to the current partition.~             ~%        CTRL-K - Delete  the current partition.~             ~%        ABORT  - Exit the disk partition editor and lose changes (delete buffer).~             ~%        END    - Exit the disk partition editor but keep the buffer.~%~             ~%  The partition properties are  ~%~             ~%        E - Expandable~             ~%        c - Contractable~             ~%        P - delete Protected~             ~%        L - Logical partition~             ~%        C - Copy protected~             ~%        D - Default (disk label default)~             ~%        d - Diagnostic~%~             ~%  When changing the orgin and size fields you may type numeric LISP~             ~%  expressions in the minibuffer to help calculate the desired number.~%~             ~%  If the current partition is a METR band or a Syslog, Describe will~             ~%  will offer to display the relevant information.~%~             ~%  The command META-X Boot File System will dismount the current file~             ~%  and boot the file system on the indicated partition.  If the partition is~             ~%  not currently a file band you will be asked if you want to initialize it~             ~%  as a file band.  A numeric argument to this function will simply dismount~             ~%  the current file system.~%~             ~%  The command META-X Update Disk Labels will modify the disk labels.~             ~%  Use this command with care and discretion.")  dis-none);; This command command deletes the DLE buffer with no updating to the disk labels.(defcom com-disk-label-abort"Exit disk label editor, delete edit buffer, and do not write labels." ()  (if (y-or-n-p "Do you want to abort the edit session?")      (let ( ( *disk-label-buffer* *interval*))(com-select-previous-buffer)(UNLESS (send (car (send *disk-label-buffer* :inferiors)) :decoded)  (si:DISPOSE-OF-UNIT (send (car (send *disk-label-buffer* :inferiors)) :unit-number)))(if *disk-label-buffer*    (kill-buffer *disk-label-buffer* t))))    dis-none);; This command will exit the DLE buffer, and if any modifications have;; been made, will query the user if he wants to save the edits.(defcom com-disk-label-exit"Write the disk labels if necessary and exit disk label mode."()  (let ( ( *disk-label-buffer* *interval*))    (if (y-or-n-p "Do you want to write the disk label?")(com-update-disk-labels))    (com-select-previous-buffer)    (UNLESS (send (car (send *disk-label-buffer* :inferiors)) :decoded)      (si:DISPOSE-OF-UNIT (send (car (send *disk-label-buffer* :inferiors)) :unit-number)))    (if *disk-label-buffer*(kill-buffer *disk-label-buffer* t)))  dis-none)(defcom com-disk-config-abort"Exit disk configuration editor, delete edit buffer, and do not write cfg band." ()  (if (y-or-n-p "Do you want to abort the edit session?")      (let ((disk-config-buffer *interval*))(com-select-previous-buffer)(kill-buffer disk-config-buffer t)))  dis-none);; This command will exit the DLE buffer, and if any modifications have;; been made, will query the user if he wants to save the edits.(defcom com-disk-config-exit"Write the disk configuration if necessary and exit disk config mode."()  (let ((disk-config-buffer *interval*))  (if (y-or-n-p "Do you want to write the Config Band?")      (com-update-disk-config))  (com-select-previous-buffer)  (kill-buffer disk-config-buffer t))  dis-none)(defcom com-change-sort-algorithem"Let the user select a new column to sort on." ()  (let ((new-partition (getf (line-plist (bp-line (point))) :partition)))  (let ((new-sort (w:menu-choose (mapcar #'(lambda (a-symbol)(list (substitute #\space #\- (symbol-name a-symbol))      (symbol-value a-symbol)))    (get 'sorting-predicates :types-of-sorts)) :label "Sort Types")))    (setf sorting-predicate new-sort))  (dolist (disk-label-interval (send *interval* :inferiors))    (send disk-label-interval :sort-partitions))  (com-show-data) (com-show-data)  (must-redisplay *window* dis-all)  (let ((line (bp-line (send (car (send *interval* :inferiors)) :partition-data-first-bp))))      (do ((partition (send (car (send *interval* :inferiors)) :partition-list) (cdr partition)))  ((eq new-partition (getf (line-plist line) :partition )) (move-bp (point) (list line 0)))(setq line (line-next line)))))  dis-none);; This command invokes the SI:COMPARE-DISK-PARTITION function.(defcom com-compare-disk-partition"Compare the current partition with a user specified partition." ()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)))    (if disk-partition-data(let* ((partition-unit (send (send disk-partition-data :disk-label-interval) :unit-number))       (partition-name (concatenate 'string (send disk-partition-data :name)    "."    (print-cpu-name (send disk-partition-data :cpu-type))))       (target-partition (typein-line-read   (format nil "Compare partition ~a with: (\"unit-number\" \"partition-name\")"(list partition-unit partition-name))      )))  (format t (si:compare-disk-partition partition-unit     partition-name     (car target-partition)     (cadr target-partition)))    )      (barf "Current line does not describe a partition"))) dis-text);; This command invokes the SI:TRANSMIT-BAND function unless the;; destination is the local machine, when SI:COPY-DISK-PARTITION function;; is used for efficiency.(defcom com-transmit-band "Transmit the current partition to a user specified partition."()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)))    (if disk-partition-data(let* ((invalid-origin (send disk-partition-data :invalid-origin))       (invalid-length (send  disk-partition-data  :invalid-length))       (partition-unit (send (send disk-partition-data :disk-label-interval) :unit-number))       partition-name target-partition)  (if (or invalid-origin invalid-length)      (barf "The label must be written and the machine booted before you can do this"))  (setf partition-name (concatenate 'string (send disk-partition-data :name)    "."    (print-cpu-name (send disk-partition-data :cpu-type))))  (setf target-partition (typein-line-read-with-default      (format nil "(~a ~s)"  partition-unit partition-name)      "Transmit partition ~a, specify destination."      (list partition-unit partition-name)))  (if (numberp (car target-partition))      (si:copy-disk-partition partition-unit      partition-name      (car target-partition)      (cadr target-partition))      (si:transmit-band partition-namepartition-unit(car target-partition)(cadr target-partition))    ))      (barf "Current line does not describe a partition"))) dis-none);; This command invokes the SI:RECIEVE-BAND function unless the;; source on is the local machine, when SI:COPY-DISK-PARTITION function;; is used for efficiency.(defcom com-receive-band"Receive a user specified partition into the current partition." ()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)))    (if disk-partition-data(let* ((partition-unit (send (send disk-partition-data :disk-label-interval) :unit-number))       (partition-name (concatenate 'string (send disk-partition-data :name)    "."    (print-cpu-name (send disk-partition-data :cpu-type))))       target-partition       (invalid-origin (send  disk-partition-data :invalid-origin))       (invalid-length (send  disk-partition-data  :invalid-length)))  (if (or invalid-origin invalid-length)      (barf "The label must be written and the machine booted before you can do this"))  (setf target-partition (typein-line-read-with-default   (format nil "(~a ~s)"  partition-unit partition-name)   "Receive partition into ~@a, specify source. "   (list partition-unit partition-name)))  (if (numberp (car target-partition))      (si:copy-disk-partition (car target-partition)      (cadr target-partition)      partition-unit      partition-name)      (si:receive-band (car target-partition)       (cadr target-partition)       partition-unit       partition-name))  (multiple-value-bind (ignore size ignore name attributes ignore comment)     (si:find-disk-partition (cadr target-partition) partition-unit)    (setf (send disk-partition-data :type) (ldb si:%%band-type-code attributes))    (setf (send disk-partition-data :begining-safe-length)  (if (equal (ldb si:%%band-type-code Attributes) 0)      (si:measured-size-of-partition(concatenate 'string name  "."     (print-cpu-name (ldb si:%%cpu-type-code  attributes)))partition-unit)      size      ))    (setf (send disk-partition-data :cpu-type) (ldb si:%%cpu-type-code attributes))    (if (equal (length comment) 0)(setf (send disk-partition-data :comment) " ")(setf (send disk-partition-data :comment) comment))    (setf (send disk-partition-data :default-property) (LDB-TEST si:%%DEFAULT-INDICATOR attributes))    (setf (send disk-partition-data :expandable-property) (LDB-TEST  si:%%EXPANDABLE attributes))    (setf (send disk-partition-data :contractable-property) (LDB-TEST   si:%%CONTRACTABLE attributes))    (setf (send disk-partition-data :delete-protected-property) (LDB-TEST si:%%DELETE-PROTECTED       attributes))    (setf (send disk-partition-data :logical-property) (LDB-TEST  si:%%LOGICAL-PARTITION attributes))    (setf (send disk-partition-data :copy-protected-property)  (LDB-TEST si:%%COPY-PROTECTED attributes))    (setf (send disk-partition-data :diagnostic-property) (LDB-TEST si:%%DIAGNOSTIC-INDICATOR  attributes))       )  (rewrite-partition-line disk-partition-data)  (com-recenter-window))      (barf "Current line does not describe a partition"))) dis-none)(defcom com-describe-disk"describe the hardware specifics of this disk." ()  (let ((flavor (car (send *interval* :inferiors))))  (format t  format-disk-line (send flavor :disk-name) (send flavor :real-unit-number))  (format t "~%~%~a    ~s    ~s" (send flavor :disk-type) (send flavor :comments) (send flavor :version))  (format t "~%~%~a~10tBytes per Block"  (send flavor :bytes-per-block))  (format t "~%~a~10tBytes per Sector"  (send flavor :bytes-per-sector))  (format t "~%~a~10tSectors per Track"  (send flavor :sectors-per-track))  (format t "~%~a~10tHeads   ~a  Cylinders"  (send flavor :heads) (send flavor :cylinders) )  (format t "~%~a~10tSectors for Defects"  (send flavor :sectors-for-defects))  (format t "~%~%~a  Partitions  ~a-word Descriptors "  (length (send flavor :partition-list)) (send flavor :size-of-entry)))  (format t "~%~% Press the Space bar to continue"));; This command invokes the DESCRIBE-PARTITION function.  If the current;; partition is a METR or LOG band, addition info will optionally be shown.(defcom com-describe-partition "Describe the current partition."()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)))    (if disk-partition-data(let ((original-partition-name (send disk-partition-data :original-name))      (partition-name (send disk-partition-data :name))      (partition-type (send disk-partition-data :type))      (unit-number (send (send disk-partition-data :disk-label-interval) :unit-number)))  (if (not original-partition-name)      (barf "This partition has not actually been created yet."))  (if (not (string-equal partition-name original-partition-name))      (format T "The partition ~S is still offically known as ~S."        partition-name original-partition-name))  (format t "This data reflects the current state of the disk~%Press the Space bar to continue~%")  (describe-partition (concatenate 'string   original-partition-name "." (print-cpu-name   (send disk-partition-data :cpu-type)))   unit-number)  (if (and (eql (eval si:%bt-log-band) partition-type)   (y-or-n-p "Do you want to see the log information?" (beep)))      (syslog:dump-log))  (if (and (eql (eval si:%bt-meter-band) partition-type)   (y-or-n-p "Do you want to see the meter information?" (beep)))      (meter:analyze)))(barf "Current line does not describe a partition")))  dis-text);; This command makes the currently selected MCR or LOD band be the default;; for the assocoated disk label.(defcom com-change-default-partition"Make the current partition the default for the indicated disk."()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)))    (if disk-partition-data(let ((partition-type (send disk-partition-data :type))      (disk-label-interval (send disk-partition-data :disk-label-interval))      (band-type nil))  (case partition-type(1 (setf band-type :set-selected-mcr))(0 (setf band-type :set-selected-lod)))  (if band-type      (progn(send disk-label-interval band-type (send disk-partition-data :name))(rewrite-disk-line disk-label-interval))      (barf "The TYPE of the current partition cannot be a default.")))(barf "Current line does not describe a partition")))  dis-text);; This command change the default MCR partition for the assocoated disk.(defcom com-change-default-mcr-partition"Change the default MCR partition for the indicated disk."()  (let* ((disk-partition-data (getf (line-plist (bp-line (point))) :partition))(disk-cfg-overhead (getf (line-plist (bp-line (point))) :cfg-overhead))(disk-line (getf (line-plist (bp-line (point))) :disk) )(default-name nil))    (if (or disk-cfg-overhead disk-line)(if disk-cfg-overhead    (let (      (default-boot (send disk-partition-data :default-boot-parameters)))      (setf default-name (subseq (string (typein-line-read-with-default   default-name   "Change default MCR: Type in new name and press return:")) 0 4))      (if (dolist (partition (send disk-partition-data :partition-list))    (if (and (equal default-name (send partition :name))     (equal (send partition :type) 1))(return t)))  (progn    (send (send    (nth default-boot (send disk-cfg-overhead :cfg-module-data)) :cfg-data-items)  :set-boot-partition-name  default-name)    (send  disk-partition-data  :set-selected-mcr default-name)    (if (not (equal (send disk-partition-data :default-boot) default-message))(format t default-warning-message)) )  (barf "This is not a microload partition")))      (progn(setf default-name (subseq (string (typein-line-read-with-default     default-name     "Change default MCR: Type in new name and press return:"))   0 4))(if (dolist (partition (send disk-partition-data :partition-list))    (if (and (equal default-name (send partition :name))     (equal (send partition :type) 1))(return t)))    (progn    (send  disk-partition-data :set-selected-mcr default-name)    (format t default-warning-message))  (barf "This is not a microload partition"))))(progn(if (equal (send disk-partition-data :type) 1)      (setf default-name (send disk-partition-data :name))      (barf "This is not a microload partition"))(if (send  (send disk-partition-data :disk-label-interval) :cfg-overhead)    (let* ((disk-label-interval (send disk-partition-data :disk-label-interval))  (disk-cfg-overhead (send disk-label-interval :cfg-overhead))  (default-boot (send disk-label-interval :default-boot-parameters)))  (send (send (nth default-boot (send disk-cfg-overhead :cfg-module-data)) :cfg-data-items):set-boot-partition-name default-name)  (send  disk-label-interval :set-selected-mcr default-name)  (if (not (equal (send disk-label-interval :default-boot)  default-message))      (format t default-warning-message))  (setf disk-partition-data disk-label-interval))    (progn      (setf disk-partition-data (send disk-partition-data :disk-label-interval))      (send  disk-partition-data :set-selected-mcr default-name)      (format t default-warning-message)))))(rewrite-disk-line disk-partition-data))  (com-recenter-window)    dis-text);; This command change the default LOD partition for the assocoated disk.(defcom com-change-default-load-partition"Change the default LOD partition for the indicated disk."()  (let* ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)) (disk-cfg-overhead (getf (line-plist (bp-line (point))) :cfg-overhead)) (disk-line (getf (line-plist (bp-line (point))) :disk) ) (default-name nil))    (if (or disk-cfg-overhead disk-line)(if disk-cfg-overhead    (let* (  (default-boot (send disk-partition-data :default-boot-parameters))  (character-data    (send (send (nth default-boot (send disk-cfg-overhead :cfg-module-data)) :cfg-data-items):character-data)))      (setf default-name (subseq (string (typein-line-read-with-default   default-name   "Change default LOAD: Type in new name and press return:")) 0 4))      (if (dolist (partition (send disk-partition-data :partition-list))    (if (and (equal default-name (send partition :name))     (equal (send partition :type) 0))(return t)))  (progn    (dolist (item character-data)      (if (equal (subseq (send item :character-item) 0 9) "Load Name" )  (let* ((old-item (send item :character-item))  (new-name   (concatenate 'string(subseq old-item 0 (1+ (position #\: old-item))) default-name)))    (send item :set-character-item  (subseq new-name 0 (min 32 (length new-name)))))))    (send  disk-partition-data  :set-selected-lod default-name)    (if (not (equal (send disk-partition-data :default-boot) default-message))(format t default-warning-message)) )  (barf "This is not a load band")))    (progn      (setf default-name (subseq (string (typein-line-read-with-default   default-name   "Change default LOAD: Type in new name and press return:")) 0 4))      (if (dolist (partition (send disk-partition-data :partition-list))    (if (and (equal default-name (send partition :name))     (equal (send partition :type) 0))(return t)))  (progn    (send  disk-partition-data :set-selected-lod default-name)    (format t default-warning-message))  (barf "This is not a load band"))))(progn(if (equal (send disk-partition-data :type) 0)      (setf default-name (send disk-partition-data :name))      (barf "This is not a load partition"))(if (send  (send disk-partition-data :disk-label-interval) :cfg-overhead)    (let* ((disk-label-interval (send disk-partition-data :disk-label-interval))  (disk-cfg-overhead (send disk-label-interval :cfg-overhead))  (default-boot (send disk-label-interval :default-boot-parameters))  (character-data    (send (send (nth default-boot (send disk-cfg-overhead :cfg-module-data)) :cfg-data-items)  :character-data)))      (dolist (item character-data)(if (equal (subseq (send item :character-item) 0 9)   "Load Name" )    (let* ((old-item (send item :character-item))   (new-name    (concatenate 'string (subseq old-item 0 (1+ (position #\: old-item))) default-name)))      (send item :set-character-item    (subseq new-name 0 (min 32 (length new-name)))))))      (send  disk-label-interval :set-selected-lod default-name)      (if (not (equal (send (send disk-partition-data :disk-label-interval) :default-boot)      default-message))  (format t default-warning-message))      (setf disk-partition-data disk-label-interval))    (progn      (send  disk-partition-data :set-selected-lod default-name)      (format t default-warning-message)))))(rewrite-disk-line disk-partition-data))  (com-recenter-window)    dis-text)(defcom com-change-partition-name"Change the name of the specified partition."()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)))    (if disk-partition-data(let ((new-name (string (typein-line-read-with-default-case-sensitive  (send disk-partition-data :name)  "Change Partition Name: Type in new name and press return. Use quotes (\"name\") for lowercase"))))  (if (equal (char new-name 0) #\")      (setq new-name (subseq new-name 1 (position #\" new-name :from-end t)))      (setq new-name (string-upcase new-name)))  (send disk-partition-data :set-name (subseq new-name 0 (min 4 (length new-name))))  (rewrite-partition-line disk-partition-data)  (com-recenter-window))(barf "Current line does not describe a partition")))  dis-text)(defun edit-config-character-item ()"Change the character item in the configuration band"  (let* ((new-name (string (typein-line-readline-with-default   (subseq (bp-line (point)) (1+ (position #\: (bp-line (point)))))  "Change Character Data: Type in new Data and press return")))(character-item (getf (line-plist (bp-line(point))) :cfg-data))(field (car (getf (line-plist (bp-line (point))) :field)))(format-line (cdr (getf (line-plist (bp-line (point))) :field)))(*read-base* (if (equal field ':ram-base) 16. *read-base*))(*print-base* (if (equal field ':ram-base) 16. *print-base*)))    (if (equal (type-of character-item) 'disk-cfg-character-data)(let ((old-item (send character-item :character-item))   )(setq new-name (concatenate 'string (subseq old-item 0 (1+ (position #\: old-item))) new-name))(send character-item :set-character-item (subseq new-name 0 (min 32 (length new-name)))))(setf (send character-item field) new-name))    (with-read-only-suppressed (*interval*)      (com-beginning-of-line)      (com-kill-line)      (format (bp-line (point))      format-line      new-name)      ))  (com-recenter-window)  dis-text)(defcom com-change-disk-name"Change the name of the disk unit."()  (let ((disk-data (getf (line-plist (bp-line (point))) :disk)))    (if disk-data(let ((new-name (string (typein-line-read-with-default  ()  "Change Disk Name: Type in new name in quotes and press return"))))  (send disk-data :set-disk-name (subseq new-name 0 (min 16 (length new-name))))  (with-read-only-suppressed (*interval*)    (com-beginning-of-line)    (com-kill-line)    (format (bp-line (point))    format-disk-line    (send disk-data :disk-name)    (send disk-data :real-unit-number))    (com-beginning-of-line)))(barf "Current line does not describe the disk")))  (must-redisplay *window* dis-text)  dis-text)(defcom com-change-partition-attribute"Change the attribute of the specified partition."()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)))    (if disk-partition-data(let ((new-type (w:menu-choose (mapcar #'(lambda (item)     (list (symbol-name (car item)) (eval (cadr item)))) si:partition-types) :label "Attribute Types")))  (if new-type      (send disk-partition-data :set-type  new-type))  (rewrite-partition-line disk-partition-data))(barf "Current line does not describe a partition")))  dis-line)(defcom com-change-partition-properties "Change the properties for the given partition" ()    (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition))  (item-list nil))    (if disk-partition-data(let* ((partition-list (mapcar #'(lambda (item)     (list (symbol-name (car item))   ':value    (car item))   ) partition-properties))       (current-selections (dolist (item partition-properties item-list)     (if (send disk-partition-data (caddr item)) (push  (assoc (symbol-name (car item))       partition-list) item-list)))))  (multiple-value-bind (new-type return)      (w:multiple-menu-choose partition-list       :label "Partition Proprties"      :menu-margin-choices '(:doit :abort)      :highlighted-items current-selections      )    (if return(mapcar #'(lambda (item)    (if (member (car item) new-type)(setf (send disk-partition-data  (caddr item)) t)(setf (send disk-partition-data (caddr item)) nil)))partition-properties)))  (rewrite-partition-line disk-partition-data))(barf "Current line does not describe a partition")))  dis-text)(defcom com-change-partition-cpu-type"Change the CPU/OS type of the specified partition."()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)))    (if disk-partition-data(let ((new-type (w:menu-choose '(("Explorer" si:%CPU-EXPLORER );0 - #x0000 ("NuMachine" si:%CPU-NUMACHINE-68010);1 - #x0001 ("S1500" si:%CPU-S1500 );2 - #x0002 ("Term Conc" si:%cpu-TI-Terminal-concentrator-68010) ("Explorer 1B" si:%cpu-TI-Explorer-I-B) ("Explorer II" si:%cpu-TI-Explorer-II) ("CLM" si:%cpu-TI-CLM) ("NUBUS Intf" si:%cpu-TI-Nubus-Peripheral-Interface-68010) ("MSC" si:%cpu-TI-Mass-storage-controller-68010) ("Comm Carrier" si:%cpu-TI-Comm-Carrier-68010) ("TI Lisp" si:%CPU-TI-LISP);3 - #xFC00 ("GDOS" si:%CPU-GDOS );4 - #xFC01 ("System 5" si:%CPU-SYSTEM5 );5 - #xFC02 ("Generic" si:%CPU-GENERIC-BAND );6 - #xFFFF Empty Band )       :label "CPU/OS Type"       )))  (if new-type      (setf (send disk-partition-data :cpu-type)  (eval new-type)))  (rewrite-partition-line disk-partition-data))(barf "Current line does not describe a partition")))  dis-text)(defcom com-change-partition-origin"Change the origin of the specified partition."()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)))    (if disk-partition-data(let ((new-origin (typein-line-read-with-default  (format nil "~d" (send disk-partition-data :origin))  "Change Partition Origin: Type in new origin and press return")))  (send disk-partition-data :set-origin (eval new-origin))  (rewrite-partition-line disk-partition-data)  (if (equal (send disk-partition-data :origin) (send disk-partition-data :begining-origin))      (send disk-partition-data :set-invalid-origin nil)      (send disk-partition-data :set-invalid-origin T))  )(barf "Current line does not describe a partition"))  (com-show-data) (com-show-data)  (must-redisplay *window* dis-all)  (let ((line (bp-line (send (car (send *interval* :inferiors)) :partition-data-first-bp))))      (do ((partition (send (car (send *interval* :inferiors)) :partition-list) (cdr partition)))  ((eq disk-partition-data (getf (line-plist line) :partition )) (move-bp (point) (list line 0)))(setq line (line-next line))))  dis-text))(defcom com-change-cfg-offset"Change the offset of the specified configuration module."()  (let* ((disk-cfg-data (getf (line-plist (bp-line (point))) :partition))(new-origin (typein-line-read-with-default  (format nil "~d" (send disk-cfg-data :offset))  "Change Module Offset: Type in new offset and press return")))  (send disk-cfg-data :set-offset (eval new-origin))  (rewrite-cfg-module-line disk-cfg-data)  (with-read-only-suppressed (*interval*)  (if (equal (send disk-cfg-data :offset) (send disk-cfg-data :beginning-offset))      (send disk-cfg-data :set-invalid-offset nil)      (send disk-cfg-data :set-invalid-offset T))  ))  dis-text)(defcom com-change-cfg-length"Change the length of the specified configuration module."()  (let* ((disk-cfg-data (getf (line-plist (bp-line (point))) :partition))(new-origin (typein-line-read-with-default  (format nil "~d" (send disk-cfg-data :length))  "Change Length: Type in new length and press return")))  (send disk-cfg-data :set-length (eval new-origin))  (rewrite-cfg-module-line disk-cfg-data)  (if (equal (send disk-cfg-data :length) (send disk-cfg-data :beginning-safe-length))      (send disk-cfg-data :set-invalid-length nil)      (send disk-cfg-data :set-invalid-length T))  )  dis-text)(defcom com-change-boot-timeout"Change the boot timeout of the specified configuration module."()  (let* ((disk-cfg-data (getf (line-plist (bp-line (point))) :partition))(new-origin (typein-line-read-with-default  (format nil "~d" (send disk-cfg-data :boot-timeout))  "Change Boot Timeout: Type in new timeout in seconds and press return")))  (send disk-cfg-data :set-boot-timeout (eval new-origin))  (rewrite-cfg-module-line disk-cfg-data))  dis-text)(defcom com-change-cfg-revision"Change the configuration revision of the specified configuration module."()  (let* ((cfg-overhead (getf (line-plist (bp-line (point))) :cfg-overhead)) (new-origin (typein-line-read-with-default       (format nil "~d" (send cfg-overhead :revision))       "Change Revision: Type in new revision and press return")))    (if (not (stringp new-origin))(setq new-origin (string new-origin)))    (send cfg-overhead :set-revision  new-origin)    (with-read-only-suppressed (*interval*)      (move-bp (point) (send (getf (line-plist (bp-line (point))) :partition) :first-bp))      (move-bp (point) (list (array-leader (bp-line (point)) 1) 0))      (com-beginning-of-line)      (com-kill-line)      (format (bp-line (point)) format-cfg-line1     (send cfg-overhead :name)     (send cfg-overhead :generation)     (send cfg-overhead :revision))      (move-bp (point) (list (array-leader (bp-line (point)) 1) 0))      (com-kill-line)      (format (bp-line (point))format-cfg-comment-line      (send cfg-overhead :comments)))    (com-recenter-window))  dis-text)(defcom com-change-cfg-comments"Change the configuration comments of the specified configuration module."()  (let* ((cfg-overhead (getf (line-plist (bp-line (point))) :cfg-overhead))(new-origin (typein-line-readline-with-default  (format nil "~d" (send cfg-overhead :comments))  "Change the comments: Type in new revision and press return")))  (send cfg-overhead :set-comments new-origin)  (with-read-only-suppressed (*interval*)    (move-bp (point) (send (getf (line-plist (bp-line (point))) :partition) :first-bp))    (move-bp (point) (list (array-leader (bp-line (point)) 1) 0))    (com-beginning-of-line)    (com-kill-line)    (format (bp-line (point)) format-cfg-line1   (send cfg-overhead :name)   (send cfg-overhead :generation)   (send cfg-overhead :revision))    (move-bp (point) (list (array-leader (bp-line (point)) 1) 0))    (com-kill-line)    (format (bp-line (point))format-cfg-comment-line    (send cfg-overhead :comments)))      (com-recenter-window))  dis-text)(defcom com-change-cfg-generation"Change the configuration generation of the specified configuration module."()  (let* ((cfg-overhead (getf (line-plist (bp-line (point))) :cfg-overhead)) (new-origin (typein-line-read-with-default       (format nil "~d" (send cfg-overhead :generation))       "Change the Generation: Type in new revision and press return")))    (if (not (stringp new-origin))(setq new-origin (string new-origin)))    (send cfg-overhead :set-generation  new-origin)    (with-read-only-suppressed (*interval*)      (move-bp (point) (send (getf (line-plist (bp-line (point))) :partition) :first-bp))      (move-bp (point) (list (array-leader (bp-line (point)) 1) 0))      (com-beginning-of-line)      (com-kill-line)      (format (bp-line (point)) format-cfg-line1     (send cfg-overhead :name)     (send cfg-overhead :generation)     (send cfg-overhead :revision))      (move-bp (point) (list (array-leader (bp-line (point)) 1) 0))      (com-kill-line)      (format (bp-line (point))format-cfg-comment-line      (send cfg-overhead :comments)))    (com-recenter-window))  dis-text)(defcom com-change-number-of-entries"Change the number of entries in the specified configuration module."()  (let* ((disk-cfg-data (getf (line-plist (bp-line (point))) :partition))(new-origin (typein-line-read-with-default  (format nil "~d" (send disk-cfg-data :number-of-entries))  "Change Number of Entries: Type in new number of entries and press return")))    (send disk-cfg-data :set-number-of-entries (eval new-origin))    (rewrite-cfg-module-line disk-cfg-data))  dis-text)(defcom com-change-cfg-board-type"Change the board type of the specified configuration module."()  (let ((disk-cfg-data (getf (line-plist (bp-line (point))) :partition))(new-type (w:menu-choose '(("Explorer" si:%CPU-EXPLORER );0 - #x0000 ("NuMachine" si:%CPU-NUMACHINE-68010);1 - #x0001 ("S1500" si:%CPU-S1500 );2 - #x0002 ("Term Conc" si:%cpu-TI-Terminal-concentrator-68010) ("Explorer 1B" si:%cpu-TI-Explorer-I-B) ("Explorer II" si:%cpu-TI-Explorer-II) ("CLM" si:%cpu-TI-CLM) ("NUBUS Intf" si:%cpu-TI-Nubus-Peripheral-Interface-68010) ("MSC" si:%cpu-TI-Mass-storage-controller-68010) ("Comm Carrier" si:%cpu-TI-Comm-Carrier-68010) ("TI Lisp" si:%CPU-TI-LISP);3 - #xFC00 ("GDOS" si:%CPU-GDOS );4 - #xFC01 ("System 5" si:%CPU-SYSTEM5 );5 - #xFC02 ("Generic" si:%CPU-GENERIC-BAND );6 - #xFFFF Empty Band )       :label "CPU/OS Type"       )))    (if new-type(setf (send disk-cfg-data :board-type) (eval new-type)))    (rewrite-cfg-module-line disk-cfg-data))  dis-text)(defcom com-change-valid-slots"Change the solts valid for the specified configuration module."()  (let* ((disk-cfg-data (getf (line-plist (bp-line (point))) :partition)) (new-origin (typein-line-read-with-default       (format nil "~d" (send disk-cfg-data :valid-slots))       "Change Boot Timeout: Type in a list of new slot numbers and press return")))    (send disk-cfg-data :set-valid-slots  new-origin)    (rewrite-cfg-module-line disk-cfg-data))  dis-text)(defcom com-change-bootable-processor"Change the bootable processor type for the specified configuration module."()  (let* ((disk-cfg-data (getf (line-plist (bp-line (point))) :partition)) (new-type (w:menu-choose '(("Bootable Processor" "bootable")    ("Slave Processor" "slave"))  :label "Bootable/Slave processor")))    (if new-type(send disk-cfg-data :set-bootable-processor  new-type))    (rewrite-cfg-module-line disk-cfg-data))  dis-text)(defcom com-add-character-item"Add an optional character entry" ()  (let* ((new-name (string (typein-line-readline-with-default  ()  "Enter Character Data: Type in new Data and press return")))(char-item (make-instance 'disk-cfg-character-data  :character-item (subseq new-name 0 (min 32 (length new-name)))))(disk-cfg-data (getf (line-plist (bp-line (point))) :partition))(item-number (+ 6 (length (send (send disk-cfg-data :cfg-data-items) :character-data))))field-item)    (dotimes (item item-number)      (move-bp (point) (list (array-leader (bp-line (point)) 1) 0)))    (com-end-of-line)  (with-read-only-suppressed (*interval*)    (insert-moving (point) #\return)    (insert-moving (point)   (format nil format-cfg-character-line (send char-item :character-item)))    (setf (getf (line-plist (bp-line (point))) :cfg-data) char-item )    (setf field-item (cons 'character-item format-cfg-character-line))    (setf (getf (line-plist (bp-line (point))) :field) field-item)    (setf (getf (line-plist (bp-line (point))) :partition) disk-cfg-data))  (setf (send disk-cfg-data :number-of-entries) (+ (send disk-cfg-data :number-of-entries) 1 ))  (rewrite-cfg-module-line disk-cfg-data)  (setf (send (send disk-cfg-data :cfg-data-items) :character-data)(push-end char-item (send (send disk-cfg-data :cfg-data-items) :character-data))))  dis-text)(defcom com-delete-character-item"Delete an optional character entry" ()  (let* ((disk-cfg-data (getf (line-plist (bp-line (point))) :partition))(item-number (+ 6 (length (send (send disk-cfg-data :cfg-data-items) :character-data)))))    (dotimes (item item-number)      (move-bp (point) (list (array-leader (bp-line (point)) 1) 0)))    (with-read-only-suppressed (*interval*)      (com-kill-line)      (com-kill-line))    (setf (send (send disk-cfg-data :cfg-data-items) :character-data)  (nbutlast (send (send disk-cfg-data :cfg-data-items) :character-data)))  (setf (send disk-cfg-data :number-of-entries) (- (send disk-cfg-data :number-of-entries) 1 ))  (rewrite-cfg-module-line disk-cfg-data))  dis-text)    (defcom com-change-partition-blocks"Change the block allocation of the specified partition."()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)))    (if disk-partition-data(let ((new-size (typein-line-read-with-default  (format nil "~d" (send disk-partition-data :size))  "Change Partition Size: Type in new size and press return")))  (send disk-partition-data :set-size (eval new-size))  (rewrite-partition-line disk-partition-data)  (if (>= (send disk-partition-data :size) (send disk-partition-data :begining-safe-length))      (send disk-partition-data :set-invalid-length nil)      (send disk-partition-data :set-invalid-length T))  )(barf "Current line does not describe a partition"))    (com-show-data) (com-show-data)    (must-redisplay *window* dis-all)    (let ((line (bp-line (send (car (send *interval* :inferiors)) :partition-data-first-bp))))      (do ((partition (send (car (send *interval* :inferiors)) :partition-list) (cdr partition)))  ((eq disk-partition-data (getf (line-plist line) :partition )) (move-bp (point) (list line 0)))(setq line (line-next line)))))  dis-text)(defun check-partition-length (disk-label-interval)  "check for free or overlapping block numbers"  (let* ((sorting-predicate origin-sort))     (send disk-label-interval :sort-partitions)     (let ((partition-list (send disk-label-interval :partition-list)))       (do ((partition  partition-list partition-list))   ((null partition-list))      (check-valid-partition partition disk-label-interval) (setq partition-list (cdr partition-list)))))  (send disk-label-interval :sort-partitions) ; resort for user sort type  )(defun check-valid-partition (partition disk-label-interval)  (let ((current (car partition))     (rest (cdr partition)))    (send current :putprop nil :free-blocks)    (send current :putprop nil :overlapping-blocks) (cond ((null rest)(end-of-disk current disk-label-interval))       ((> (- (send (car rest) :origin) (+ (send current :origin) (send current :size))) 0)(send current :putprop (- (send (car rest) :origin)  (+ (send current :origin) (send current :size))) :free-blocks)(end-of-disk current disk-label-interval))       ((< (- (send (car rest) :origin) (+ (send current :origin) (send current :size))) 0)(send current :putprop (- (send (car rest) :origin)  (+ (send current :origin) (send current :size))  )      :overlapping-blocks)(end-of-disk current disk-label-interval))       (t (end-of-disk current disk-label-interval)))))(DEFUN END-OF-DISK (LOC disk-label-interval)  "Checks 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 minus 1."  (LET* ( (DISK-SIZE  (-   (* (send disk-label-interval :HEADS)      (send disk-label-interval :SECTORS-PER-TRACK)      (send disk-label-interval :CYLINDERS )      (send disk-label-interval :BYTES-PER-SECTOR));total bytes capacity of disk   (* (send disk-label-interval :SECTORS-FOR-DEFECTS)      (send disk-label-interval :BYTES-PER-SECTOR))));bytes for defects (BLOCK-SIZE (send disk-label-interval :BYTES-PER-BLOCK)))    (WHEN (AND (NEQ 0 DISK-SIZE) (NEQ 0 BLOCK-SIZE))      (IF (>= (+ (send loc :origin) (send loc :size))   (FLOOR DISK-SIZE BLOCK-SIZE))(send loc :putprop t :end-of-disk)(send loc :putprop nil :end-of-disk)))))(defun issue-invalid-data-warning ()  "warn user this partition is invalid"  (if (not (getf (line-plist (bp-line (point))) :unsafe))      (progn         (com-end-of-line)      (with-read-only-suppressed (*interval*)(insert-moving (point) #\return)(insert-moving (point)       (format nil format-invalid-partition))))))  (defcom com-change-partition-comments"Change the comment of the specified partition."()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)))    (if disk-partition-data(let ((new-comment (typein-line-readline-with-default   (send disk-partition-data :comment)  "Change Partition Comment: Type in new comment and press return")))  (send disk-partition-data :set-comment (subseq new-comment 0 (min 32. (length new-comment))))  (rewrite-partition-line disk-partition-data))(barf "Current line does not describe a partition")))  dis-text)(defcom com-show-data"Expand the data being shown about the current line." ()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition))(disk-label-interval (getf (line-plist (bp-line (point))) :disk)))    (if (or disk-partition-data    (and disk-label-interval (send disk-label-interval :partition-data-first-bp)))(if (eq disk-partition-data disk-label-interval)    (with-read-only-suppressed (*interval*)      (move-bp (point) (send disk-label-interval :last-bp))      (check-partition-length disk-label-interval)      (com-end-of-line)      (send disk-label-interval :insert-partition-descriptions)      )    (let* ((disk-label-interval (or disk-label-interval    (send disk-partition-data :disk-label-interval)))   (first-bp (send disk-label-interval :partition-data-first-bp))   (last-bp (send disk-label-interval :last-bp)))      (with-read-only-suppressed (*interval*)(delete-interval first-bp last-bp)(send disk-label-interval :set-partition-data-first-bp nil)(move-bp (point) (send disk-label-interval :disk-header-line-bp))))))    (if (not (or disk-partition-data disk-label-interval))(barf "The current line does not identify a disk.")))  dis-text)(defun find-end (buf-point)  (cond ((null (array-leader (bp-line buf-point) 1))  buf-point )(t (find-end (list (array-leader (bp-line buf-point) 1) 0 :normal )))))  (defcom com-show-cfg-data"Expand the data being shown about the current line." ()  (let ((disk-cfg-data (getf (line-plist (bp-line (point))) :partition))character-datacfg-data-items(*print-base* 10.)(*read-base* 10.)field-item(line (bp-line (point))))    (setf cfg-data-items (send disk-cfg-data :cfg-data-items))    (if (and (array-leader (bp-line (point)) 1)   ;; special case last line in buffer     (getf (line-plist (array-leader (bp-line (point)) 1)) :field))  ;;edit data is displayed(progn  (if (eq line (bp-line (send *interval* :last-bp)))      (send *interval* :set-last-bp      (find-end (point))))  (move-bp (point) (list (array-leader (bp-line (point)) 1) 0))  (com-beginning-of-line)  (with-read-only-suppressed (*interval*)    (com-kill-line)    (com-kill-line)    (com-kill-line)    (com-kill-line)    (com-kill-line)    (com-kill-line)    (com-kill-line)    (com-kill-line)    (dotimes (entry (send disk-cfg-data :number-of-entries))      (com-kill-line)      (com-kill-line))    (if (not (eq line (bp-line (send *interval* :last-bp))))(com-kill-line)))  (if (eq line (bp-line (send *interval* :last-bp)))      (send *interval* :set-last-bp (point))))(progn  (com-end-of-line)  (if disk-cfg-data      (with-read-only-suppressed (*interval*)(insert-moving (point) #\return)(insert-moving (point)       (format nil format-cfg-data-line1       (send cfg-data-items :ram-base)))(setf (getf (line-plist (bp-line (point))) :cfg-data) cfg-data-items )(setf (getf (line-plist (bp-line (point))) :partition) disk-cfg-data)(setf field-item (cons 'ram-base format-cfg-data-line1))(setf (getf (line-plist (bp-line (point))) :field) field-item)(setf (getf (line-plist (bp-line (point))) :tab-list) cfg-item-tab-list)(insert-moving (point) #\return)(insert-moving (point)       (format nil format-cfg-data-line2       (send cfg-data-items :boot-partition-name)))(setf (getf (line-plist (bp-line (point))) :cfg-data) cfg-data-items )(setf (getf (line-plist (bp-line (point))) :partition) disk-cfg-data)(setf field-item (cons 'boot-partition-name format-cfg-data-line2))(setf (getf (line-plist (bp-line (point))) :field) field-item)(setf (getf (line-plist (bp-line (point))) :tab-list) cfg-item-tab-list)(insert-moving (point) #\return)(insert-moving (point)       (format nil format-cfg-data-line3       (send cfg-data-items :boot-partition-unit)))(setf (getf (line-plist (bp-line (point))) :cfg-data) cfg-data-items )(setf (getf (line-plist (bp-line (point))) :partition) disk-cfg-data)(setf field-item (cons 'boot-partition-unit format-cfg-data-line3))(setf (getf (line-plist (bp-line (point))) :field) field-item)(setf (getf (line-plist (bp-line (point))) :tab-list) cfg-item-tab-list)(insert-moving (point) #\return)(insert-moving (point)       (format nil format-cfg-data-line4       (send cfg-data-items :boot-partition-slot)))(setf (getf (line-plist (bp-line (point))) :cfg-data) cfg-data-items )(setf (getf (line-plist (bp-line (point))) :partition) disk-cfg-data)(setf field-item (cons 'boot-partition-slot format-cfg-data-line4))(setf (getf (line-plist (bp-line (point))) :field) field-item)(setf (getf (line-plist (bp-line (point))) :tab-list) cfg-item-tab-list)(insert-moving (point) #\return)(insert-moving (point)       (format nil format-cfg-data-line5       (send cfg-data-items :hardware-id)))(setf (getf (line-plist (bp-line (point))) :cfg-data) cfg-data-items )(setf (getf (line-plist (bp-line (point))) :partition) disk-cfg-data)(setf field-item (cons 'hardware-id format-cfg-data-line5))(setf (getf (line-plist (bp-line (point))) :field) field-item)(setf (getf (line-plist (bp-line (point))) :tab-list) cfg-item-tab-list)(insert-moving (point) #\return)(insert-moving (point)       (format nil format-cfg-data-line6       (send cfg-data-items :software-id)))(setf (getf (line-plist (bp-line (point))) :cfg-data) cfg-data-items )(setf (getf (line-plist (bp-line (point))) :partition) disk-cfg-data)(setf field-item (cons 'software-id format-cfg-data-line6))(setf (getf (line-plist (bp-line (point))) :field) field-item)(setf character-data (send cfg-data-items :character-data))(setf (getf (line-plist (bp-line (point))) :tab-list) cfg-item-tab-list)(dolist (char-item character-data)  (insert-moving (point) #\return)  (insert-moving (point) (format nil format-cfg-character-line (send char-item :character-item)))  (setf (getf (line-plist (bp-line (point))) :cfg-data) char-item )  (setf field-item (cons 'character-item format-cfg-character-line))  (setf (getf (line-plist (bp-line (point))) :field) field-item)  (setf (getf (line-plist (bp-line (point))) :tab-list) cfg-item-tab-list)  (setf (getf (line-plist (bp-line (point))) :partition) disk-cfg-data))(insert-moving (point) #\return)(if (eq line (bp-line (send *interval* :last-bp)))    (send *interval* :set-last-bp  (point)))))))    (must-redisplay *window* dis-all)  )  dis-all)(defcom com-kill-partition"Delete the current partition from the display." ()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)))    (if disk-partition-data(with-read-only-suppressed (*interval*)  (let* ((disk-label-interval (send disk-partition-data :disk-label-interval)) (partition-list (send disk-label-interval :partition-list)) (last-bp (send disk-label-interval :last-bp)))    (if (equal (bp-line last-bp)(bp-line (point)))(send disk-label-interval :set-last-bp      (move-bp last-bp (line-previous (bp-line (point)))               (line-length (line-previous (bp-line (point)))))))    (send disk-label-interval :set-partition-list  (delete disk-partition-data partition-list :test #'eq))    (com-show-data) (com-show-data)    (must-redisplay *window* dis-all)    ))(barf "Current line does not describe a partition.")))  dis-text)(defcom com-add-partition"Add a partition to the current disk interval." ();;; Insert the new partition between the before-partition and after-partition;;; When this routine is entered, point is on the after partition line. (let ((after-partition-data (getf (line-plist (bp-line (point))) :partition))       )  (com-up-real-line)  (com-end-of-line)  (let ((before-partition-data (getf (line-plist (bp-line (point))) :partition))(disk-label-interval (getf (line-plist (bp-line (point))) :disk))new-partition)    (if disk-label-interval(move-bp (point) (or (send disk-label-interval :partition-data-first-bp)     (barf "Use Show command to first display partition data.")))(if (not (or before-partition-data after-partition-data))    (barf "The current line does not identify a disk.")    (setq disk-label-interval (send (or before-partition-dataafter-partition-data)    :disk-label-interval))))    (multiple-value-bind (new-name new-size new-origin new-type new-comment)(suggested-partition-values before-partition-data    after-partition-data    disk-label-interval)      (with-read-only-suppressed (*interval*)(setq new-partition (make-instance 'disk-partition-data     :name new-name     :type new-type     :size new-size     :origin new-origin     :comment new-comment     :begining-origin 0     :begining-safe-length 0     :invalid-origin T     :cpu-type 0     :disk-label-interval disk-label-interval)))  (send disk-label-interval :sort-partitions new-partition))    (if (not after-partition-data)(send disk-label-interval :set-last-bp (copy-bp (point))))    (com-down-real-line)    (com-show-data) (com-show-data)    (must-redisplay *window* dis-all)    (let ((line (bp-line (send disk-label-interval :partition-data-first-bp))))      (do ((partition (send disk-label-interval :partition-list) (cdr partition)))  ((eq new-partition (getf (line-plist line) :partition )) (move-bp (point) (list line 0)))(setq line (line-next line))))    (com-change-partition-name)    (com-change-partition-attribute)    (com-change-partition-origin)    (com-change-partition-blocks)    (com-change-partition-cpu-type)   )) dis-text)(defcom com-add-module"Add a module to the config band" ()  (let* ((disk-partition-data  (getf (line-plist (bp-line (point))) :partition))(disk-cfg-overhead (send disk-partition-data :cfg-overhead))(next-module (length (send disk-cfg-overhead :cfg-module-data)))temp(previous (car (last (send disk-cfg-overhead :cfg-module-data)))))    (setq temp (make-instance 'disk-cfg-data      :module-number next-module      :offset (+ (send previous :offset) (send previous :length))      :length 1      :number-of-entries 2      :board-type (si:cpu-type)      :cfg-overhead disk-cfg-overhead      :cfg-data-items      (make-instance 'disk-cfg-data-item     :module-number (+ (send previous :module-number)        si:%cfg-slot-list-entry-size)     :hardware-id (send (send previous :cfg-data-items) :hardware-id)     :software-id "Explorer processor")))    (push-end temp (send disk-cfg-overhead :cfg-module-data))    (move-bp (point) (list (line-previous (bp-line (send *interval* :last-bp))) 0))    (with-read-only-suppressed (*interval*)      (com-end-of-line)(send temp :insert-self (point)))      (must-redisplay *window* dis-all))    dis-none)(defcom com-kill-module"Delete a module from the config band" ()  (let* ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)) (disk-cfg-overhead (send disk-partition-data :cfg-overhead)))    (setf (send disk-cfg-overhead :cfg-module-data)  (remove disk-partition-data (send disk-cfg-overhead :cfg-module-data)))    (with-read-only-suppressed (*interval*)      (com-beginning-of-line)      (com-kill-line)      (com-kill-line)      (must-redisplay *window* dis-all))))  ;; Different people may want to supply various intelligent defaults, so lets keep;; this a function that others can substitute.  Notice that my version of this routine;; does not care about the disk-label-interval.(defun suggested-partition-values (before-partition after-partition &optional ignore)  (let ((suggested-name "????")(suggested-size 0)(suggested-origin 8)(suggested-type )(suggested-comment " "))    (if (and (eq sorting-predicate origin-sort)     before-partition)    (progn      (setq suggested-origin (+ (send before-partition :size)(send before-partition :origin)))      (if after-partition  (setq suggested-size (- (send after-partition :origin)  suggested-origin))))    (if after-partition(setq suggested-origin (send after-partition :origin))))    (setq suggested-type  (typecase suggested-size    ((integer 0 0)  si:%bt-empty-band)    ((integer 1 100) si:%bt-log-band)    ((integer 101 200) si:%bt-microload)    ((integer 201 5000) si:%bt-meter-band)    ((integer 5001 25000) si:%bt-file-band)    ((integer 25001 50000) si:%bt-load-band)    ((integer 50001 *) si:%bt-page-band)))    (values suggested-name suggested-size suggested-origin suggested-type suggested-comment)    ));; This command will dismount the current file system, and unless a numeric;; argument is supplied, will attempt to boot the current file partition.(defcom com-boot-file-system"Boot the file system on the current partition."()  (let ((disk-partition-data (getf (line-plist (bp-line (point))) :partition)))    (if disk-partition-data(if (equal (eval si:%bt-file-band)   (send disk-partition-data :type))    (if *numeric-arg*(fs:dismount-file-system)(fs:boot-file-system (send disk-partition-data :unit-number)     (send disk-partition-data :name)))    (barf "Current partition is not a File Partition."))(barf "Current line does not describe a partition.")))  dis-text)(defcom com-edit-config-band"Edit the configuration Band parameters" ()  (let* ((disk-config-buffer (dolist (buffer *zmacs-buffer-list*)       (when (string-equal "Disk Config Buffer"   (buffer-name buffer)) (return buffer)))) (disk-partition-data (getf (line-plist (bp-line (point))) :partition)) disk-label-interval disk-cfg-partition)   (if (getf (line-plist (bp-line (point))) :disk)       (and (setf disk-label-interval disk-partition-data)    (setf disk-partition-data (send disk-label-interval :get :cfg-partition)))       (setf disk-label-interval (send disk-partition-data :disk-label-interval)))   (setf disk-cfg-partition (send disk-label-interval :cfg-overhead))   (if (or (send disk-partition-data :invalid-origin)   (send disk-partition-data :invalid-length))       (barf "This Partition table must be written to disk and the system rebooted. CANNOT EDIT NOW.")       (progn ;;; normal case (if (not disk-config-buffer)     (progn (setf disk-config-buffer (make-instance       'zwei-disk-Config-buffer       :name "Disk Config Buffer"))    (setf (buffer-saved-major-mode  disk-config-buffer) 'disk-config-mode)    (send  disk-config-buffer :activate)    (send  disk-config-buffer :select)    )     (progn       (send  disk-config-buffer :activate)       (send  disk-config-buffer :select))) (if (not (equal (send disk-partition-data :original-name) (send disk-label-interval :cfg-name)))     (setf disk-cfg-partition (send disk-label-interval :read-cfg-data    (send disk-partition-data :original-name)))) (setf (getf (line-plist (bp-line (point))) :cfg-overhead) disk-cfg-partition) (send disk-config-buffer :set-inferiors disk-cfg-partition) (send disk-config-buffer :revert-1 disk-label-interval disk-cfg-partition) (send disk-config-buffer :insert-cfg-partition-descriptions disk-cfg-partition) dis-all ))));; Implement this last.(defcom com-update-disk-labels"Make the disk label changes indicated in the Disk Label Buffer." ()  (let ( *overlap-error* *end-of-disk-error*)    (declare (special *overlap-error* *end-of-disk-error*))    (si:with-rqb (rqb (build-rqb (car (send *interval* :inferiors))))    (if (check-label rqb (car (send *interval* :inferiors)))(progn(si:write-disk-label rqb (send (car (send *interval* :inferiors)) :unit-number))(if (send (car (send *interval* :inferiors)) :modified-p)    (progn      (si:set-cfg-boot-data (send (car (send *interval* :inferiors)) :cfg-name)      (send (car (send *interval* :inferiors)) :unit-number)      :boot-name (send (car (send *interval* :inferiors)) :selected-mcr))      (si:set-cfg-load-data (send (car (send *interval* :inferiors)) :cfg-name)      (send (car (send *interval* :inferiors)) :unit-number)      :load-name (send (car (send *interval* :inferiors)) :selected-lod)))))(if (yes-or-no-p "You may not be able to boot from the disk if this label is written~%Do you want to write the label?")    (progn      (si:write-disk-label rqb (send (car (send *interval* :inferiors)) :unit-number))      (if (send (car (send *interval* :inferiors)) :modified-p)  (progn    (si:set-cfg-boot-data (send (car (send *interval* :inferiors)) :cfg-name)         (send (car (send *interval* :inferiors)) :unit-number)         :boot-name (send (car (send *interval* :inferiors)) :selected-mcr))    (si:set-cfg-load-data (send (car (send *interval* :inferiors)) :cfg-name)         (send (car (send *interval* :inferiors)) :unit-number)         :load-name (send (car (send *interval* :inferiors)) :selected-lod)))))    (barf "Disk label not updated.")))))  dis-none)(defcom com-update-disk-config"Make the disk configuration changes indicated in the Disk Config Buffer." ()  (si:with-rqb (rqb (build-cfg-rqb *interval* ))    (si:write-cfg-partition  rqb (send (send (car (send *disk-label-buffer* :inferiors))       :get :cfg-partition) :name)                                 (send (car (send *disk-label-buffer* :inferiors)) :unit-number)))  dis-none)(defun build-cfg-rqb (disk-config-buffer)  "Put the information from the configuration band"  (let ((cfg-data (si:read-cfg-partition (send (send (car (send *disk-label-buffer* :inferiors))       :get :cfg-partition) :name) (send (car (send *disk-label-buffer* :inferiors)) :unit-number)))(cfg-overhead  (car (send disk-config-buffer :inferiors)))cfg-data-listcfg-data-itemsitemblock-start)    (si:put-disk-String-byte-addr cfg-data (send cfg-overhead :generation) si:%CFG-GENERATION 2.)    (si:put-disk-String-byte-addr cfg-data (send cfg-overhead :revision) si:%CFG-REVISION 2.)    (si:put-disk-string-byte-addr cfg-data (send cfg-overhead :comments) si:%CFG-TITLE 64.)    (setq cfg-data-list (send cfg-overhead :cfg-module-data))    (do ((slot-index 0 (1+ slot-index)) (data-list cfg-data-list (cdr data-list)))((>= slot-index 16))      (let* ((slot-base (+ si:%CFG-SLOT-LIST-OFFSET (* slot-index si:%CFG-SLOT-LIST-ENTRY-SIZE)))     (entry (car data-list)))(if entry    (progn      (Let* ((temp (dpb (send entry :length)(byte 16 16)(si:get-disk-fixnum cfg-data (/ slot-base 4.)))))(si:Put-disk-Fixnum cfg-data temp (/ slot-base 4.)))      (Let* ((temp (dpb (send entry :offset)(byte 16 0)(si:get-disk-fixnum cfg-data (/ slot-base 4.)))))(si:Put-disk-Fixnum cfg-data temp (/ slot-base 4.)))      (si:put-disk-fixnum cfg-data (send entry :number-of-entries)  (/ (+ slot-base si:%CFG-NUMBER-ENTRIES-OFFSET) 4.))      (Let* ((temp (dpb (send entry :board-type)(byte 16 16)(si:get-disk-fixnum cfg-data (/ (+ slot-base si:%CFG-MODULE-CRC) 4.)))))(si:Put-disk-Fixnum cfg-data temp (/ (+ slot-base si:%CFG-MODULE-CRC) 4.)))      (Let* ((temp (dpb (send entry :board-type)(byte 16 16)(si:get-disk-fixnum cfg-data (/ (+ slot-base si:%CFG-MODULE-CRC) 4.)))))(si:Put-disk-Fixnum cfg-data temp (/ (+ slot-base si:%CFG-MODULE-CRC) 4.)))      (si:put-disk-fixnum cfg-data (send entry :boot-timeout)  (/ (+ slot-base si:%CFG-BOOT-TIMEOUT-OFFSET) 4.))      (Let* ((temp (send entry :bootable-processor))     (temp1 (dpb (if (equal temp "bootable")     1     2) (byte 16 16) (si:get-disk-fixnum cfg-data (/ (+ slot-base si:%CFG-MODULE-SLOTS) 4.)))))(si:Put-disk-Fixnum cfg-data temp1 (/ (+ slot-base si:%CFG-MODULE-SLOTS) 4.)))      (Let* ((temp (send entry :valid-slots))     (temp1 (dpb (recode-slots temp) (byte 16 0) (si:get-disk-fixnum cfg-data (/ (+ slot-base si:%CFG-MODULE-SLOTS) 4.)))))(si:Put-disk-Fixnum cfg-data temp1 (/ (+ slot-base si:%CFG-MODULE-SLOTS) 4.)))      (setq block-start (* (send entry :offset) 1024.))      (setq cfg-data-items (send entry :cfg-data-items))      (Let* ((temp (dpb (if (or (equal (send cfg-data-items :boot-partition-slot) #\*)(equal (send cfg-data-items :boot-partition-unit) #\*))    #xFF    (send cfg-data-items :boot-partition-slot))(byte 8. 24.)(si:get-disk-fixnum cfg-data    (/ (+ block-start si:%CFG-BOOT-DEVICE-OFFSET) 4.)))))(si:Put-disk-Fixnum cfg-data temp (/ (+ block-start si:%CFG-BOOT-DEVICE-OFFSET) 4.)))      (Let* ((temp (dpb (if (or (equal (send cfg-data-items :boot-partition-slot) #\*)(equal (send cfg-data-items :boot-partition-unit) #\*))    #xFFFFFF    (send cfg-data-items :boot-partition-unit))(byte 24. 0)(si:get-disk-fixnum cfg-data    (/ (+ block-start si:%CFG-BOOT-DEVICE-OFFSET) 4.)))))(si:Put-disk-Fixnum cfg-data temp (/ (+ block-start si:%CFG-BOOT-DEVICE-OFFSET) 4.)))      (Si:put-disk-string-byte-addr cfg-data (send cfg-data-items :boot-partition-name)    (+ block-start si:%CFG-BOOT-PARTITION-NAME-OFFSET) 4.)      (si:put-entry-by-block cfg-data (send entry :offset) 0     (si:pad-string (send cfg-data-items :hardware-id) #\space 32))      (si:put-disk-fixnum cfg-data (send cfg-data-items :ram-base)  (/ (+ block-start si:%CFG-RAM-BASE-OFFSET) 4.))      (si:put-entry-by-block cfg-data  (send entry :offset) 1     (si:pad-string (send cfg-data-items :software-id) #\space 32))      (setq item (send entry :number-of-entries))      (dotimes (entry-item (- item 2) )(si:put-entry-by-block cfg-data (send entry :offset) (+ entry-item 2)       (si:pad-string (send (nth entry-item (send cfg-data-items :character-data))       :character-item) #\space 32)))      (si:set-crc-codes cfg-data slot-index))    (progn      (Let* ((temp (dpb 0(byte 16 16)(si:get-disk-fixnum cfg-data (/ slot-base 4.)))))(si:Put-disk-Fixnum cfg-data temp (/ slot-base 4.)))      (Let* ((temp (dpb 0(byte 16 0)(si:get-disk-fixnum cfg-data (/ slot-base 4.)))))(si:Put-disk-Fixnum cfg-data temp (/ slot-base 4.)))      (si:set-crc-codes cfg-data slot-index))    )))    cfg-data))(DEFUN CHECK-label (RQB  disk-label-interval &AUX PART-NAME LEN)  (declare (special *overlap-error* *end-of-disk-error*))  (IF *END-OF-DISK-ERROR*    (PROGN      (FORMAT USER:*TERMINAL-IO* "~%*** Warning: Partition(s) extend past end of disk ")      (FORMAT USER:*TERMINAL-IO* "~%***          Maximum capacity of this disk is ~d blocks. "      (-(* (send disk-label-interval :HEADS)   (send disk-label-interval :SECTORS-PER-TRACK)   (send disk-label-interval :CYLINDERS )   (send disk-label-interval :BYTES-PER-SECTOR));total bytes capacity of disk(* (send disk-label-interval :SECTORS-FOR-DEFECTS)   (send disk-label-interval :BYTES-PER-SECTOR))) )))  (IF *OVERLAP-ERROR*    (FORMAT USER:*TERMINAL-IO*    "~%*** Warning: There are overlaying partitions in this label"))  (SETF PART-NAME (si:GET-DISK-STRING RQB si:%DL-PARTITION-TABLE-NAME 4));default partition name  (MULTIPLE-VALUE-BIND (PART-BASE PART-LENGTH IGNORE IGNORE PARTITION-ATTRIBUTES)    (si:FIND-DISK-PARTITION PART-NAME RQB () T)    (AND PART-BASE       (PROGN (WHEN (NOT (= (LDB si:%%BAND-TYPE-CODE PARTITION-ATTRIBUTES) si:%BT-PARTITION-TABLE))   (FORMAT USER:*TERMINAL-IO*   "~%*** Warning: The default Partition Table ~a is not of type (Partition Table)!"   PART-NAME)) (IF (= PART-BASE (si:GET-DISK-FIXNUM RQB si:%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 (si:GET-DISK-FIXNUM RQB si:%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 (si:GET-DISK-FIXNUM RQB si:%DL-PARTITION-TABLE-LENGTH)))  (setf part-name "PRIM")  (MULTIPLE-VALUE-BIND (PART-BASE IGNORE IGNORE IGNORE PARTITION-ATTRIBUTES)    (si:FIND-DISK-PARTITION PART-NAME RQB () T)  ;; If PRIM is present on this disk...        (When PART-BASE      ;;first check for the presence of a valid config band      (let ((part-list (si:partition-list-from-rqb RQB si:%BT-Configuration-Band si:%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 si:%%DEFAULT-INDICATOR (sixth part)) ;03.25.87 DAB  (return (setq default-found t))))   ;03.23.87 DAB      (unless default-found(format user:*terminal-io*    "~%*** Warning: This label contains a PRIM partition but not a default configuration partition."))      ))      ;;then check whether PRIM is default(if (not (LDB-TEST si:%%DEFAULT-INDICATOR PARTITION-ATTRIBUTES))    (format user:*terminal-io*    "~%*** Warning: The default flag must be turned on for the PRIM partition.")      ;;then check whether PRIM is the first default microcode.    (progn      (setq part-list (si:partition-list-from-rqb RQB si:%BT-microload si:%Cpu-explorer))      (setq default-found nil)      (dolist (part part-list default-found)(when (LDB-TEST si:%%DEFAULT-INDICATOR (sixth part))  (if (string-equal part-name (first part));if 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))))))  ;; If PRIM is default or this is an Explorer II...    (when (send disk-label-interval :cfg-name)      ;;then check for a generic PTBL -- This is serious!!!      (let ((part-list (si:partition-list-from-rqb RQB si:%BT-partition-table si:%Cpu-Generic-Band))    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 check-label nil))    (progn      (setq default-found nil)      (dolist (part part-list default-found)(when (LDB-TEST si:%%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 check-label nil))      )))      )    )  T)(defun Build-rqb (disk-label-interval)  "Build the request block for updating the label"  (declare (special *overlap-error* *end-of-disk-error*))  (LET (disk-label words-per-partition)    (SETQ disk-label (si:read-disk-label (send disk-label-interval :unit-number)))    (setf words-per-partition (si:Get-disk-Fixnum disk-label   (+ si:%pt-base si:%PT-Size-of-Partition-Entries)))    (si:put-disk-string disk-label (send disk-label-interval :disk-name)si:%dl-volume-name 16)    (si:put-disk-fixnum disk-label (length (send disk-label-interval :partition-list))(+ si:%pt-base si:%PT-Number-of-Partitions))    (let ((sorting-predicate origin-sort))      (send disk-label-interval :sort-partitions))    (do ((next-partition 0 (1+ next-partition)) (loc (+ si:%pt-base si:%PT-Partition-Descriptors) (+ loc words-per-partition)) (partition-list (send disk-label-interval :partition-list) (cdr partition-list)))((eql next-partition (length (send disk-label-interval :partition-list))))      (si:put-disk-string disk-label (send (car partition-list) :name) loc 4)      (Let* ((temp (dpb (send (car partition-list) :type)si:%%band-type-code(si:get-disk-fixnum disk-label     (+ loc si:%pd-attributes)))))(si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes)))      (si:put-disk-fixnum disk-label (send (car partition-list) :size)  (+ loc si:%pd-length))      (si:put-disk-fixnum disk-label (send (car partition-list) :origin)  (+ loc si:%PD-Start))      (Let* ((temp (dpb (send (car partition-list) :cpu-type)si:%%cpu-type-code(si:get-disk-fixnum disk-label     (+ loc si:%pd-attributes)))))(si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes)))      (si:put-disk-string disk-label (send (car partition-list) :comment)  (+ loc si:%PD-Comment)  (* 4 (- words-per-partition si:%PD-Comment)))      (if (send (car partition-list) :default-property)  (Let* ((temp (dpb 1 si:%%default-indicator    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes)))  (Let* ((temp (dpb 0 si:%%default-indicator    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes))))      (if (send (car partition-list) :expandable-property)  (Let* ((temp (dpb 1 si:%%expandable    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes)))  (Let* ((temp (dpb 0 si:%%expandable    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes))))      (if (send (car partition-list) :contractable-property)  (Let* ((temp (dpb 1 si:%%contractable    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes)))  (Let* ((temp (dpb 0 si:%%contractable    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes))))      (if (send (car partition-list) :delete-protected-property)  (Let* ((temp (dpb 1 si:%%delete-protected    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes)))  (Let* ((temp (dpb 0 si:%%delete-protected    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes))))      (if (send (car partition-list) :logical-property)  (Let* ((temp (dpb 1 si:%%logical-partition    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes)))  (Let* ((temp (dpb 0 si:%%logical-partition    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes))))      (if (send (car partition-list) :copy-protected-property)  (Let* ((temp (dpb 1 si:%%copy-protected    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes)))  (Let* ((temp (dpb 0 si:%%copy-protected    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes))))      (if (send (car partition-list) :diagnostic-property)  (Let* ((temp (dpb 1 si:%%diagnostic-indicator    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes)))  (Let* ((temp (dpb 0 si:%%DIAGNOSTIC-INDICATOR    (si:get-disk-fixnum disk-label (+ loc si:%pd-attributes)))))    (si:Put-disk-Fixnum disk-label temp (+ loc si:%PD-Attributes))))      (if (send (car partition-list) :get :overlapping-blocks)  (setf *overlap-error* t))      (if (send (car partition-list) :get :end-of-disk)  (setf *end-of-disk-error* t))      )    disk-label));;---------;; Flavor definitions;; This flavor is the main buffer definition.(defflavor zwei-disk-label-buffer   ((pathname )    (saved-major-mode 'disk-label-mode)    (read-only-p t)    first-bp      last-bp      (plist '()))   (zmacs-buffer)  :settable-instance-variables  :gettable-instance-variables  :initable-instance-variables)(defflavor zwei-disk-config-buffer   ((pathname )    (saved-major-mode 'disk-config-mode)    (read-only-p t)    first-bp      last-bp      (plist '()))   (zmacs-buffer)  :settable-instance-variables  :gettable-instance-variables  :initable-instance-variables);; A disk-label-interval is created for each disk that is known about.;; They are recorded as inferriors in the DLE buffer.(defflavor disk-label-interval   ((unit-number)    (real-unit-number)    (disk-name)    (disk-type)    (default-boot)    (comments)    (type-word 'disk)    (bytes-per-block)    (bytes-per-sector)    (sectors-per-track)    (heads)    (cylinders)    (size-of-entry)    (sectors-for-defects)    (partition-list)    (selected-mcr)    (selected-mcr-unit nil)    (selected-lod)    (selected-lod-unit nil)    (default-boot-parameters nil)    (version)    (modified-p)    (disk-header-line-bp)    (cfg-name nil)    (cfg-overhead nil)    (partition-data-first-bp)    (decoded))   (section-node)  :gettable-instance-variables  :settable-instance-variables  :initable-instance-variables);; A disk-partition-data instance is created for each partition on a disk.;; This instance is kept as a property :partition on the corresponding;; line in the disk buffer for that partition.(defflavor disk-partition-data   ((name)    (original-name)    (type)    (size)    (data-length)    (begining-safe-length)    (origin)    (begining-origin)    (cpu-type)    (comment)    (invalid-origin)    (invalid-length)    (expandable-property)    (contractable-property)    (delete-protected-property)    (logical-property)    (copy-protected-property)    (default-property)    (diagnostic-property)    (disk-label-interval))   (si:property-list-mixin)  :gettable-instance-variables  :settable-instance-variables  :initable-instance-variables)(defflavor disk-cfg-overhead   ((name)    (generation)    (revision)    (comments)    (crc)    (module-0)    (module-1)    (module-2)    (module-3)    (module-4)    (module-5)    (module-6)    (module-7)    (module-8)    (module-9)    (module-A)    (module-B)    (module-C)    (module-D)    (module-E)    (module-F)    (cfg-module-data))   (section-node si:property-list-mixin)  :gettable-instance-variables  :settable-instance-variables  :initable-instance-variables)(defflavor disk-cfg-data   ((module-number)    (offset)    (beginning-offset)    (length)    (beginning-safe-length)    (boot-timeout)    (number-of-entries)    (board-type)    (valid-slots)    (bootable-processor)    (invalid-offset)    (invalid-length)    (cfg-data-items)    (cfg-overhead))   (section-node si:property-list-mixin)  :gettable-instance-variables  :settable-instance-variables  :initable-instance-variables)(defflavor disk-cfg-data-item   ((module-number)    (ram-base)    (boot-partition-slot)    (boot-partition-name)    (boot-partition-unit)    (hardware-id)    (software-id)    (character-data))   (si:property-list-mixin)  :gettable-instance-variables  :settable-instance-variables  :initable-instance-variables)(defflavor disk-cfg-character-data   ((character-item))   (si:property-list-mixin)  :gettable-instance-variables  :settable-instance-variables  :initable-instance-variables);; This is the main method that fills the DLE buffer with data.;; It creates and initializes an interval for each disk that is known.(defmethod (zwei-disk-label-buffer :revert-1)(&optional (disk-unit nil)  decoded-p &rest ignore)  "Read disk information and format DLE buffer."  (if (not disk-unit)      (setf disk-unit (send (car inferiors) :unit-number)    decoded-p (send (car inferiors) :decoded)))  (setf plist '())  (setf inferiors '())  (setf read-only-p t)  (set-buffer-file-id self "Disk label buffer")  (with-read-only-suppressed (self)    (delete-interval self)    (let ((disk-label-interval-instance    (make-instance 'disk-label-interval   :superior self   :unit-number disk-unit   :decoded decoded-p)))      (send disk-label-interval-instance :revert-1)            (push-end disk-label-interval-instance inferiors)      (insert-moving (buffer-point self) #\return)      disk-label-interval-instance))    )(defmethod (zwei-disk-label-buffer :revert)(&rest ignore)  "Revert the disk-label-editor buffer"  (let ((disk-label-buffer *interval*)disk-label-interval)    (setq disk-label-interval (send  disk-label-buffer :revert-1 ))    (check-partition-length disk-label-interval)    (with-read-only-suppressed (*interval*)      (send  disk-label-interval :insert-partition-descriptions))))(defmethod (zwei-disk-config-buffer :revert)(&rest ignore)  "Revert the disk-config-editor buffer"  (com-disk-config-abort)  (send *disk-label-buffer* :select)  (com-edit-config-band));;; This is tha main method that fills the config buffer with data.(defmethod (zwei-disk-config-buffer :revert-1)(disk-label-interval &optional overhead &rest ignore)     "Format Configuration editing buffer."    (if (not overhead)(setf overhead (getf (line-plist (bp-line (send self :first-bp)))      :cfg-overhead)))    (setf plist '())    (setf inferiors '())    (setf read-only-p t)    (set-buffer-file-id self "Disk Config buffer")    (with-read-only-suppressed (self)      (delete-interval self)      (setf first-bp (copy-bp (point)))      (insert-moving (point) #\return)      (insert-moving (point)     (format nil format-disk-line (send disk-label-interval :disk-name)     (send disk-label-interval :real-unit-number)))      (setf (getf (line-plist (bp-line (point))) :partition)    self)            (setf (getf (line-plist (bp-line (point))) :disk) self)      (insert-moving (point) #\return)      (insert-moving (point) (format nil format-cfg-line1 (send overhead :name) (send overhead :generation) (send overhead :revision)))      (setf (getf (line-plist (bp-line (point))) :partition)    self)      (setf (getf (line-plist (bp-line (point))) :cfg-overhead)    overhead)      (setf (getf (line-plist (bp-line (point))) :tab-list)    cfg-info-tab-list)      (insert-moving (point) #\return)      (insert-moving (point) (format nil format-cfg-comment-line (send overhead :comments) ))      (setf (getf (line-plist (bp-line (point))) :partition)    self)      (setf (getf (line-plist (bp-line (point))) :cfg-overhead)    overhead)      (setf (getf (line-plist (bp-line (point))) :tab-list)    cfg-comment-tab-list)      (insert-moving (point) #\return)      (push-end overhead inferiors)      )       );; This method gathers information from a configuration band(defmethod (disk-label-interval :read-cfg-data) (cfg-band-name)  "Read the information from the configuration band"  (let (cfg-info)  (si:with-rqb (cfg-data (si:read-cfg-partition cfg-band-name unit-number))  (let (cfg-data-listitem)    (setq cfg-info (make-instance 'disk-cfg-overhead    :name (send (send self :get :cfg-partition) :name)    :generation (si:Get-disk-String-byte-addr cfg-data si:%CFG-GENERATION 2.)    :revision (si:Get-disk-String-byte-addr cfg-data si:%CFG-REVISION 2.)    :comments (si:Get-disk-string-byte-addr cfg-data si:%CFG-TITLE 64.)            :module-0 si:%cfg-slot-list-offset            :module-1 (+ si:%cfg-slot-list-offset si:%cfg-slot-list-entry-size)            :module-2 (+ si:%cfg-slot-list-offset (* 2 si:%cfg-slot-list-entry-size))            :module-3 (+ si:%cfg-slot-list-offset (* 3 si:%cfg-slot-list-entry-size))            :module-4 (+ si:%cfg-slot-list-offset (* 4 si:%cfg-slot-list-entry-size))            :module-5 (+ si:%cfg-slot-list-offset (* 5 si:%cfg-slot-list-entry-size))            :module-6 (+ si:%cfg-slot-list-offset (* 6 si:%cfg-slot-list-entry-size))            :module-7 (+ si:%cfg-slot-list-offset (* 7 si:%cfg-slot-list-entry-size))            :module-8 (+ si:%cfg-slot-list-offset (* 8 si:%cfg-slot-list-entry-size))            :module-9 (+ si:%cfg-slot-list-offset (* 9 si:%cfg-slot-list-entry-size))            :module-A (+ si:%cfg-slot-list-offset (* 10 si:%cfg-slot-list-entry-size))            :module-B (+ si:%cfg-slot-list-offset (* 11 si:%cfg-slot-list-entry-size))            :module-C (+ si:%cfg-slot-list-offset (* 12 si:%cfg-slot-list-entry-size))            :module-D (+ si:%cfg-slot-list-offset (* 13 si:%cfg-slot-list-entry-size))            :module-E (+ si:%cfg-slot-list-offset (* 14 si:%cfg-slot-list-entry-size))            :module-F (+ si:%cfg-slot-list-offset (* 15 si:%cfg-slot-list-entry-size))    ))    (dotimes (slot-index 16 cfg-data-list)    (let* ((slot-base (+ si:%CFG-SLOT-LIST-OFFSET (* slot-index si:%CFG-SLOT-LIST-ENTRY-SIZE)))   (start-and-length (si:get-disk-fixnum cfg-data (/ slot-base 4.)))   (block-length (* (ldb (byte 16. 16.) start-and-length) 1024))   (block-start  (* (ldb (byte 16. 0) start-and-length) 1024))   (number-entries (si:get-disk-fixnum cfg-data (/ (+ slot-base si:%CFG-NUMBER-ENTRIES-OFFSET) 4.)))   (board-type (ldb (byte 16. 16.)    (si:get-disk-fixnum cfg-data (/ (+ slot-base si:%CFG-MODULE-CRC) 4.))))   (temp (si:get-disk-fixnum cfg-data (/ (+ slot-base si:%CFG-MODULE-SLOTS) 4.)))   (module-slots (ldb (byte 16. 0) temp))   (module-flags (ldb (byte 16. 16.) temp))   (slot-and-unit (si:get-disk-fixnum cfg-data (/ (+ block-start si:%CFG-BOOT-DEVICE-OFFSET) 4.)))        (boot-slot (ldb (byte 8. 24.) slot-and-unit))   (boot-unit (ldb (byte 24. 0) slot-and-unit))   (boot-name (Si:get-disk-string-byte-addr cfg-data   (+ block-start si:%CFG-BOOT-PARTITION-NAME-OFFSET) 4.))   (entry-start  (/ block-start 1024))   (pn (si:get-entry-by-block cfg-data entry-start 0))   cfg-data-item   (entry-list nil))      (if (or (= boot-slot #xFF);both values are WILD   ;06.12.87 DAB  (= boot-unit #xFFFFFF));both values are WILD      (setf boot-slot #\* boot-unit #\*)      (setf boot-slot (ldb (byte 8. 24.) slot-and-unit)    boot-unit (ldb (byte 24. 0) slot-and-unit)))      (setq item      (make-instance 'disk-cfg-data        :module-number slot-base        :offset (/ block-start 1024):beginning-offset (/ block-start 1024)        :length (/ block-length 1024):beginning-safe-length (/ block-length 1024)        :boot-timeout (si:get-disk-fixnum cfg-data          (/ (+ slot-base si:%CFG-BOOT-TIMEOUT-OFFSET) 4.))        :number-of-entries number-entries        :board-type  board-type        :valid-slots (decode-slots module-slots)        :bootable-processor (if (equal module-flags 1) "bootable"  "slave"):invalid-offset nil:invalid-length nil        :cfg-data-items (setq cfg-data-item (make-instance 'disk-cfg-data-item :module-number slot-base               :ram-base (si:get-disk-fixnum cfg-data  (/ (+ block-start si:%CFG-RAM-BASE-OFFSET) 4.))                :boot-partition-slot boot-slot :boot-partition-unit boot-unit               :boot-partition-name boot-name                :hardware-id pn             :software-id (si:get-entry-by-block cfg-data entry-start 1))      ):cfg-overhead  cfg-info))      (if (not (equal (send item :length) 0))  (push-end item cfg-data-list))    (send cfg-data-item :set-character-data  (dotimes (entry (- number-entries 2) entry-list)      (push-end (make-instance 'disk-cfg-character-data     :character-item (si:get-entry-by-block cfg-data entry-start (+ entry 2)))entry-list)))        ) ;;; let*    )    (setf (send cfg-info :cfg-module-data) cfg-data-list)    (multiple-value-bind (ignore ignore entry-number)(si:find-module-from-rqb cfg-data :type (si:cpu-type) :entry-number nil)    (send self :set-default-boot-parameters (1- entry-number))    )))    cfg-info))(defun decode-slots (module-slot-byte &aux (slot-list nil))  "determine which slots are valid positions"  (dotimes (slot-index 16 slot-list)    (if (logbitp slot-index module-slot-byte)(push-end slot-index  slot-list))))(defun recode-slots (module-slot-list)  "determine which slots are valid positions" (cond ((null module-slot-list) 0)    (t (logior (lsh 1 (car module-slot-list)) (recode-slots (cdr module-slot-list))))));; This method gathers information for a particular disk.(defmethod (disk-label-interval :after :init)(ignore)  (si:with-rqb (disk-label (si:read-disk-label unit-number))   (let* ( temp  (words-per-partition (si:Get-disk-Fixnum disk-label   (+ si:%pt-base si:%PT-Size-of-Partition-Entries)))  (number-of-partitions (si:Get-disk-fixnum disk-label    (+ si:%pt-base si:%PT-Number-of-Partitions))))     (if (numberp unit-number) (setf real-unit-number unit-number) (setf real-unit-number (symeval-in-closure unit-number 'si:remote-disk-unit)))    (setf disk-name (si:get-disk-string disk-label si:%dl-volume-name 16))    (setf disk-type (si:get-disk-string disk-label si:%DL-DEVICE-NAME 12))    (setf comments (si:get-disk-string disk-label si:%DL-comment 96))    (setf version (format nil "~a Version ~d"  (si:get-disk-string disk-label si:%dl-base 4)  (si:get-disk-fixnum disk-label si:%DL-version)))    (let ((temp (si:get-disk-fixnum disk-label si:%bytes-per)))      (setf bytes-per-block (ldb si:%%bytes-per-block temp))      (setf bytes-per-sector (ldb si:%%bytes-per-sector temp)))    (let ((temp (si:get-disk-fixnum disk-label si:%sector-heads)))      (setf sectors-per-track (ldb si:%%sectors-per-track temp))      (setf heads (ldb si:%%number-of-heads temp)))    (let ((temp (si:get-disk-fixnum disk-label si:%cylinders)))      (setf cylinders (ldb si:%%number-of-cylinders temp))      (setf sectors-for-defects (ldb si:%%number-of-sectors-for-defects temp)))    (if (numberp unit-number)  ; if not a number a remote disk(if (equal unit-number (si:nvram-default-unit)) ; check nvram for default    ;;;          unit equal to the unit the user requested    (setf default-boot default-message)    (setf default-boot not-default-message))(setf default-boot remote-disk-message))    (setf name (format nil "Disk ~a" disk-name))    (setf size-of-entry  (si:GET-DISK-FIXNUM disk-label (+ si:%pt-base si:%PT-SIZE-OF-PARTITION-ENTRIES)))    (setf defun-line (bp-line (point)))    (setf selected-mcr (si:find-default-microload disk-label))    (setf selected-lod (si:find-default-load disk-label))    (do ((next-partition 0 (1+ next-partition)) (loc (+ si:%pt-base si:%PT-Partition-Descriptors) (+ loc words-per-partition)))((eql next-partition number-of-partitions))      (send self :sort-partitions    (prog1    (setf temp (make-instance 'disk-partition-data       :name (si:get-disk-string disk-label loc 4)       :original-name (si:get-disk-string disk-label loc 4)       :type (ldb si:%%band-type-code  (si:get-disk-fixnum disk-label (+ loc si:%PD-Attributes)))       :size (si:get-disk-fixnum disk-label (+ loc si:%pd-length))       :data-length (if (equal (ldb si:%%band-type-code(si:get-disk-fixnum disk-label (+ loc si:%PD-Attributes))) 0)(si:measured-size-of-partition  (concatenate 'string       (si:get-disk-string disk-label loc 4) "."       (print-cpu-name (ldb si:%%cpu-type-code        (si:get-disk-fixnum disk-label  (+ loc si:%pd-attributes)))))  unit-number)  (si:get-disk-fixnum disk-label (+ loc si:%pd-length))  )       :origin (si:get-disk-fixnum disk-label (+ loc si:%PD-Start))       :begining-origin (si:get-disk-fixnum disk-label (+ loc si:%PD-Start))       :cpu-type (ldb si:%%cpu-type-code (si:get-disk-fixnum disk-label  (+ loc si:%pd-attributes)))       :comment (when (> words-per-partition si:%pd-comment)  (si:get-disk-string disk-label      (+ loc si:%PD-Comment)      (* 4 (- words-per-partition si:%PD-Comment))))       :disk-label-interval self       :default-property (LDB-TEST si:%%DEFAULT-INDICATOR   (si:get-disk-fixnum disk-label       (+ loc si:%pd-attributes)))       :expandable-property (LDB-TEST si:%%EXPANDABLE      (si:get-disk-fixnum disk-label  (+ loc si:%pd-attributes)))       :contractable-property (LDB-TEST si:%%CONTRACTABLE(si:get-disk-fixnum disk-label    (+ loc si:%pd-attributes)))       :delete-protected-property (LDB-TEST si:%%DELETE-PROTECTED     (si:get-disk-fixnum disk-label    (+ loc si:%pd-attributes)))       :logical-property (LDB-TEST si:%%LOGICAL-PARTITION   (si:get-disk-fixnum disk-label       (+ loc si:%pd-attributes)))       :copy-protected-property (LDB-TEST si:%%COPY-PROTECTED  (si:get-disk-fixnum disk-label   (+ loc si:%pd-attributes)))       :diagnostic-property (LDB-TEST si:%%DIAGNOSTIC-INDICATOR      (si:get-disk-fixnum disk-label  (+ loc si:%pd-attributes)))       ))    (send temp :set-begining-safe-length (send temp :data-length))    (if (equal 0 (length (send temp :comment)))( send temp :set-comment " "))))      (if (and (equal 10 (send temp :type))       (send temp :Default-property))  (and (setf cfg-name (send temp :name))  (send self :putprop temp :cfg-partition))))    (if cfg-name(let (mcr-name mcr-unit load-name load-unit      )  (send self :set-cfg-overhead (send self :read-cfg-data     cfg-name))  (multiple-value-setq (mcr-name mcr-unit)    (si:get-cfg-boot-data  cfg-name (send self :unit-number)))  (send self :set-selected-mcr mcr-name)  (send self :set-selected-mcr-unit mcr-unit)  (multiple-value-setq (load-name load-unit)    (si:get-cfg-load-data  cfg-name (send self :unit-number)))  (send self :set-selected-lod load-name)  (send self :set-selected-lod-unit load-unit)  ))  )))(DEFUN print-cpu-name (TYPE-CODE)  (SELECT TYPE-CODE (si:%CPU-CHAPARRAL "Explorer");0 - #x0000  (si:%CPU-EXPLORER "Explorer");0 - #x0000  (si:%CPU-NUMACHINE-68010 "NuMachine");1 - #x0001  (si:%CPU-NUMACHINE "NuMachine");1 - #x0001  (si:%CPU-NUMACHINE-68020 "S1500");2 - #x0002  (si:%CPU-S1500 "S1500");2 - #x0002          (si:%cpu-TI-Terminal-concentrator-68010 "Term Conc")          (si:%cpu-TI-Explorer-I-B "Explorer 1B")          (si:%cpu-TI-Explorer-II "Explorer II")          (si:%cpu-TI-CLM "CLM")          (si:%cpu-TI-Nubus-Peripheral-Interface-68010 "NUBUS Intf")          (si:%cpu-TI-Mass-storage-controller-68010  "MSC")          (si:%cpu-TI-Comm-Carrier-68010 "Comm Carrier")     (si:%CPU-TI-LISP "TI Lisp");3 - #xFC00  (si:%CPU-GDOS "GDOS");4 - #xFC01  (si:%CPU-SYSTEM5 "System 5");5 - #xFC02  (si:%CPU-GENERIC-BAND "Generic");6 - #xFFFF Empty Band  (OTHERWISE (FORMAT () "CPU:#x~16r" TYPE-CODE))));; This method will add a new partition if supplied and then;; re-sort the partitions list.;; This method should eventually check for under/overlapping partitions.(defmethod (disk-label-interval :sort-partitions)(&optional new-partition)  (if new-partition (push-end new-partition partition-list))  (setf partition-list(sort partition-list sorting-predicate)));; This method inserts the FORMAT-DISK-LINE into the buffer.(defmethod (disk-label-interval :revert-1)()  (setf first-bp (list "" 0 :NORMAL))  (insert-moving (buffer-point  superior) #\return)  (setf disk-header-line-bp (copy-bp (buffer-point superior)))  (insert-moving (buffer-point superior) (format nil format-disk-line disk-name real-unit-number))  (setf (getf (line-plist (bp-line (buffer-point superior))) :partition)self)  (setf (getf (line-plist (bp-line (buffer-point superior))) :tab-list)    disk-tab-list)  (setf (getf (line-plist (bp-line (buffer-point  superior))) :disk) self)  (insert-moving (buffer-point superior) #\return)  (insert-moving (buffer-point superior) (format nil format-cfg-line cfg-name selected-mcr selected-mcr-unit selected-lod selected-lod-unit (or modified-p "") ))  (setf (getf (line-plist (bp-line (buffer-point superior))) :partition)self)  (setf (getf (line-plist (bp-line (buffer-point superior))) :cfg-overhead)cfg-overhead)  (setf (getf (line-plist (bp-line (buffer-point superior))) :tab-list)    cfg-header-tab-list)  (setf (getf (line-plist (bp-line (buffer-point  superior))) :disk) self)  (insert-moving (buffer-point superior) #\return)  (insert-moving (buffer-point superior) (format nil default-boot-message default-boot))  (insert-moving (buffer-point  superior) #\return)  (setf last-bp (copy-bp (point)))  );; This method inserts the PARTITION-LINE-HEADER intot he buffer. (defmethod (disk-label-interval :insert-partition-descriptions)()  (setf partition-data-first-bp (copy-bp (point)))  (insert-moving (buffer-point  superior) (format nil format-partition-line-header))  (setf (getf (line-plist (bp-line (buffer-point  superior))) :disk) self)  (dolist (disk-partition-data partition-list)    (send disk-partition-data :insert-self (buffer-point superior)))  (insert-moving (buffer-point  superior) #\return)  (setf last-bp (copy-bp (point)))  );; This method inserts the cfg parameters on the screen(defmethod (zwei-disk-config-buffer :insert-cfg-partition-descriptions)(overhead-info)  (with-read-only-suppressed (*interval*)    (com-end-of-line)    (insert-moving (point)  #\return)    (insert-moving (point) #\return)    (insert-moving (point)   (format nil format-cfg-line-header))    (setf (getf (line-plist (bp-line (point))) overhead-info) self)    (let ((loop-count 0))    (dolist (disk-cfg-data (send overhead-info :cfg-module-data))      (send disk-cfg-data :set-module-number loop-count)      (send disk-cfg-data :insert-self (buffer-point self))      (setf loop-count (1+ loop-count))))    (insert-moving (point) #\return)    (setf last-bp (copy-bp (point)))));; This method inserts the PARTITION-LINE into the buffer(defmethod (disk-partition-data :insert-self)(buffer-point &aux free over)    (insert-moving buffer-point #\return)    (insert-moving buffer-point   (format nil  format-partition-line   name   (si:le-get-partition-type type)   origin   size   (print-cpu-name cpu-type)   (let (flags)     (if expandable-property (push-end '#\E flags) (push-end '#\space flags))     (if contractable-property (push-end '#\c flags) (push-end '#\space flags))     (if delete-protected-property (push-end '#\P flags) (push-end '#\space flags))     (if logical-property (push-end '#\L flags) (push-end '#\space flags))     (if copy-protected-property (push-end '#\C flags) (push-end '#\space flags))     (if default-property (push-end '#\D flags) (push-end '#\space flags))     (if diagnostic-property (push-end '#\d flags) (push-end '#\space flags))     flags)   comment))    (setf (getf (line-plist (bp-line buffer-point)) :partition)  self)    (setf (getf (line-plist (bp-line buffer-point)) :tab-list) partition-tab-list)    (if (or invalid-origin invalid-length)      (issue-invalid-data-warning ))    (if (setf free (send self :get :free-blocks))(progn  (insert-moving buffer-point #\return)  (insert-moving buffer-point (format nil free-blocks-message free))))    (if (setf over (send self :get :overlapping-blocks))(progn  (insert-moving buffer-point #\return)  (insert-moving buffer-point (format nil overlapping-blocks-message over))))    (if (send self :get :end-of-disk)(progn  (insert-moving buffer-point #\return)  (insert-moving buffer-point (format nil end-of-disk-message )))));; This method inserts the cfg-PARTITION-LINE into the buffer(defmethod (disk-cfg-data :insert-self)(buffer-point)    (insert-moving buffer-point #\return)    (insert-moving buffer-point   (format nil  format-cfg-partition-line   module-number   offset   length   boot-timeout   number-of-entries   (print-cpu-name board-type)   bootable-processor   valid-slots   ))    (setf (getf (line-plist (bp-line buffer-point)) :partition)  self)    (setf (getf (line-plist (bp-line buffer-point)) :tab-list)  module-tab-list));; If something on the DISK-LINE has changed this function is called;; to re-write the line.(defun rewrite-disk-line (disk-label-interval)  (send disk-label-interval :set-modified-p disk-modified-flag)  (with-read-only-suppressed (*interval*)    (move-bp (point) (send disk-label-interval :disk-header-line-bp))    (com-kill-line)    (insert-moving (point)   (format nil format-disk-line (send disk-label-interval :disk-name)   (send disk-label-interval :real-unit-number)))    (setf (getf (line-plist (bp-line (point))) :partition)  disk-label-interval)    (setf (getf (line-plist (bp-line (point))) :disk) disk-label-interval)    (com-down-real-line)    (com-beginning-of-line)    (com-kill-line)    (format (bp-line (point)) format-cfg-line (send disk-label-interval :cfg-name)   (send disk-label-interval :selected-mcr)   (send disk-label-interval :selected-mcr-unit)   (send disk-label-interval :selected-lod)   (send disk-label-interval :selected-lod-unit)   (or (send disk-label-interval :modified-p) "") )    (setf (getf (line-plist (bp-line (point))) :partition)  disk-label-interval)    (setf (getf (line-plist (bp-line (point))) :cfg-overhead)  (send disk-label-interval :cfg-overhead))    (setf (getf (line-plist (bp-line (point))) :disk) disk-label-interval)    (com-down-real-line)    (com-beginning-of-line)    (com-kill-line)    (format (bp-line (point)) default-boot-message (send disk-label-interval :default-boot))));; If something on the PARTITION-LINE is changed this function is called;; to re-write the line.)(defun rewrite-partition-line (disk-partition-data)  (with-read-only-suppressed (*interval*)    (com-beginning-of-line)    (com-kill-line)    (format (bp-line (point))    format-partition-line    (send disk-partition-data :name)    (si:le-get-partition-type (send disk-partition-data :type))    (send disk-partition-data :origin)    (send disk-partition-data :size)    (print-cpu-name (send disk-partition-data :cpu-type))    (let (flags)      (if (send disk-partition-data :expandable-property)  (push-end '#\E flags)  (push-end '#\space flags))      (if (send disk-partition-data :contractable-property)  (push-end '#\c flags)  (push-end '#\space flags))      (if (send disk-partition-data :delete-protected-property)  (push-end '#\P flags)  (push-end '#\space flags))      (if (send disk-partition-data :logical-property)  (push-end '#\L flags)  (push-end '#\space flags))      (if (send disk-partition-data :copy-protected-property)  (push-end '#\C flags)  (push-end '#\space flags))      (if (send disk-partition-data :default-property)  (push-end '#\D flags)  (push-end '#\space flags))      (if (send disk-partition-data :diagnostic-property)  (push-end '#\d flags)  (push-end '#\space flags))      flags)    (send disk-partition-data :comment))    (com-beginning-of-line))  (com-recenter-window))(defun rewrite-cfg-module-line (disk-cfg-data)  (with-read-only-suppressed (*interval*)    (com-beginning-of-line)    (com-kill-line)    (format (bp-line (point))      format-cfg-partition-line      (send disk-cfg-data :module-number)      (send disk-cfg-data :offset)      (send disk-cfg-data :length)      (send disk-cfg-data :boot-timeout)      (send disk-cfg-data :number-of-entries)      (print-cpu-name (send disk-cfg-data :board-type))      (send disk-cfg-data :bootable-processor)      (send disk-cfg-data :valid-slots)      )    (com-beginning-of-line))  (com-recenter-window));; This next function enables the "line boxing functionality" for those  ;; lines which a :partition property.  ;(defun (:property disk-label-mode mouse-line-box-predicate)(line);  (getf (line-plist line) :partition));(defun (:property disk-config-mode mouse-line-box-predicate)(line);  (getf (line-plist line) :partition))(DEFPROP disk-label-mode disk-label-editor-mouse-highlight-function highlight-function)(DEFPROP disk-config-mode disk-label-editor-mouse-highlight-function highlight-function)(DEFPROP com-disk-label-editor-find-highlighted-string "Edit Item" :mouse-short-documentation)(DEFPROP com-disk-config-editor-find-highlighted-string "Edit Item" :mouse-short-documentation)(defcom com-disk-label-editor-find-highlighted-string "Find Reference from Mouse box" ()  (let ((*kill-history* disk-kill-history))  (multiple-value-bind (char x  ignore line index ignore)    (mouse-char *window*)  (if (getf (line-plist line) :tab-list)      (let (save-function)(MULTIPLE-VALUE-BIND (ignore start ignore ignore ignore)    (highlighted-string-under-mouse-dle *window* (getf (line-plist line) :tab-list)char x index line)  (setq save-function (dolist (item function-list (cadr item))   (if (equal (eval (car item)) start)       (return (cadr item)))))  (if save-function      (progn(com-mouse-mark-region)(funcall save-function))      (com-mouse-mark-region))))    (com-mouse-mark-region))        dis-none)))(defcom com-disk-config-editor-find-highlighted-string "Find Reference from Mouse box" ()  (let ((*kill-history* disk-kill-history))  (multiple-value-bind (char x ignore line index ignore)    (mouse-char *window*)  (if (getf (line-plist line) :tab-list)      (let (save-function)(MULTIPLE-VALUE-BIND (ignore start ignore ignore ignore)    (highlighted-string-under-mouse-dle *window* (getf (line-plist line) :tab-list)char x index line)  (setq save-function (dolist (item cfg-function-list (cadr item))   (if (equal (eval (car item)) start)       (return (cadr item)))))  (if save-function      (progn(com-mouse-mark-region)(funcall save-function))      (com-mouse-mark-region))))    (com-mouse-mark-region))        dis-none)))(DEFUN highlighted-string-under-mouse-dle (WINDOW tab-list char x index line                                       &AUX start-index end-index start-loc end-loc ft )  "Returns the symbol which the mouse is pointing at in WINDOW, if that symbol is in one ofthe fonts listed in BOLD-FONTS.  NIL if not pointing at one.The values are the string line pointed at,and the start and end indices of the highlighted string as a substring in that line,and the start and end pixel locations of the string.All values are NIL if the position is not on a valid symbol."  (DECLARE (VALUES LINE START END START-LOC end-loc start-y height))  (SETQ ft (tv:font-char-width-table (AREF (w:sheet-font-map window) (CHAR-FONT char))))  (dolist (tab-stop  tab-list )    (if  (>= index (eval (car tab-stop)))(progn  (setq start-index  (eval (car tab-stop)))  (if (and (car (cdr tab-stop))   (not (equal 0 (car (cdr tab-stop)))))      (setq end-index (+ (eval (car tab-stop)) (car (cdr tab-stop)))))  (if (and (null end-index)    (null (car (cdr tab-stop))))      (setq end-index (length line)))  (do ((count index (1- count))       (loc x))      ((<= count start-index) (setq start-loc loc))    (DECF loc (font-char-width (1- count))))  (if (equal 0 (car (cdr tab-stop)))      (setq end-loc  start-loc)      (setq end-loc (do ((count index (1+ count)) (loc x))((>= count  end-index) loc)      (INCF loc (font-char-width  count)))))  (return (VALUES line start-index  end-index start-loc end-loc)))))  (if (and start-loc end-loc)      (VALUES line start-index  end-index start-loc end-loc)      (VALUES line index index x x)))(DEFUN disk-label-editor-mouse-highlight-function (MOUSE-BLINKER window char char-x char-y line index width                                            &aux  tab-list)  width index char-x  (setq tab-list (getf (line-plist line) :tab-list))  (MULTIPLE-VALUE-bind (ignore ignore ignore startloc endloc)    (highlighted-string-under-mouse-dle window tab-list char char-x index line)  (COND ((getf (line-plist line) :tab-list)         (UNLESS (EQ window (W:BLINKER-SHEET MOUSE-BLINKER))           (w:BLINKER-SET-SHEET MOUSE-BLINKER window))         (SHEET-SET-BLINKER-CURSORPOS window MOUSE-BLINKER startloc CHAR-Y)   ;         (W:BLINKER-SET-SIZE MOUSE-BLINKER                             (abs (- endloc startloc))                             (W:FONT-BLINKER-HEIGHT (AREF (w:sheet-font-map window) (CHAR-FONT char))))         (W:BLINKER-SET-VISIBILITY MOUSE-BLINKER T))        (t (w:blinker-set-visibility mouse-blinker nil)))));;--------------------------------------------------;; Make sure this is always the last thing in the buffer(compile-flavor-methods disk-label-intervaldisk-partition-datazwei-disk-label-bufferdisk-cfg-overheaddisk-cfg-datadisk-cfg-data-itemdisk-cfg-character-data)