;;; -*- Mode:COMMON-LISP; Package:SYSTEM-INTERNALS; Base:10.; COLD-LOAD:T  -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(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) 1980, Massachusetts Institute of Technology
;;; Copyright (C) 1984-1989 Texas Instruments Incorporated. All rights reserved.


;;;
;;; Edit History
;;;
;;;                   Patch
;;;   Date    Author  Number   Description
;;;------------------------------------------------------------------------------
;;; 02-27-89 JLM		Added CONFIG-HOST-NAME-P and GET-CFG-HOST-NAME for MP.
;;; 12-21-88 RJF     --      	Changed a couple of lambda expressions in to functions since
;;;                            	genasys couldn't handle
;;; 11-10-88 DAB               Added update-partition-comments to remote-disk-handler.
;;; 11-01-88 DAB               Added :log to *mx-partition-types*.
;;; 10-24-88 DAB               Changed partition-exists-p to truncate partition-name to four characters.
;;; 10-21-88   DAB             many changes to support remote-disk-handler.
;;; 10/8/88    ab    D-IO 5-4  Make :partition-start hidden in modify & delete partition.
;;;                            Handle UNIT arg consistently in partition routines.
;;; 10/7/88    ab    D-IO 5-3  New way to probe for parition on-file that works after (add:micronet-reset nil).
;;; 10/5/88    ab    D-IO 5-2  Fix UPDATE-PARTITION-COMMENT for remote Explorer units from mx.
;;; 08/29/88   ab    D-IO 5-1  Additions for mX dynamic partition support.
;;; 02.03.88	MBC	       Conditionalize GET-PACK-HOST-NAME to call GET-STARTUP-HOST-NAME
;;;				when no :DISK is present.
;;; 01.11.88   MBC	       Use Resource-Present-P conditionals. 	
;;; 10.16.87  MBC	       ADDIN conditionals
;;; 4-22-86   SDK      --      - New file of stuff from Label Editor that need to 
;;;                            be present when it is not.
;;; 10-15-86   ab      --      - Changes for 2K page-size.
;;; 2-3-87     MRR     --      Changed CURRENT-BAND to read configuration partition.
;;;                            Added CURRENT-MICROLOAD, CURRENT-BAND-IN-PTBL, CURRENT-LOAD-IN-PTBL, 
;;;                            and CURRENT-MICROLOAD-IN-PTBL.  
;;; 2-13-87    MRR     --      Fixed CURRENT-BAND to handle wild MCR name and unit. Waiting for 
;;;                            decode-unit-argument to be fixed to handle remote machines correctly.
;;; 3-19-87    MRR     --      Fixed bug in CURRENT-BAND and restored decode-unit-argument stuff.

(Define-unless :DISK

(DEFUN SET-PACK-NAME (&rest ignore)		;PACK-NAME &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*))
  (FERROR NIL "Cannot set pack name in ADDIN enviroment"))

)

(define-when :DISK

(DEFUN SET-PACK-NAME (PACK-NAME &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*))
  "Allows the user to set the disk pack name field in the disk label. Unit
 may be a local unit id, a string containing a remote machine name or a
 string containing a remote machine name, colon, remote unit id."
  (LET ((HOST-PACK-NAME (STRING-APPEND (GET-PACK-HOST-NAME UNIT) ":" PACK-NAME)))
    (MULTIPLE-VALUE-BIND (UNIT DECODEDP)
	(DECODE-UNIT-ARGUMENT UNIT "setting pack name")
      (NEW-SET-PACK-NAME HOST-PACK-NAME UNIT)
      (UNLESS (EQ (TYPE-OF UNIT) :CLOSURE)
	(SET-PACK-NAME-FROM-TABLE UNIT PACK-NAME))
      (UNLESS DECODEDP
	(DISPOSE-OF-UNIT UNIT))))
  PACK-NAME)
)

(Define-unless :DISK
(DEFUN NEW-SET-PACK-NAME (&rest ignore)	;PACK-NAME &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*))
  (FERROR NIL "Cannot set NEW pack name in ADDIN enviroment"))
)

(define-when :DISK
(DEFUN NEW-SET-PACK-NAME (PACK-NAME UNIT &AUX RQB)
  (UNWIND-PROTECT (PROGN
		    (SETQ RQB (READ-DISK-LABEL UNIT))
		    (PUT-DISK-STRING RQB PACK-NAME %DL-VOLUME-NAME 16.)
		    (WRITE-DISK-LABEL RQB UNIT))
    (RETURN-DISK-RQB RQB))
  PACK-NAME)
)


;; Both SET-PACK-HOST-NAME and GET-PACK-HOST-NAME are minimumly conditionalized
;; because the functions they call are ADDIN conditionalized, 
;; BUT they could be streamlined for the ADDIN environment.
;;
(DEFUN SET-PACK-HOST-NAME (NAME &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*))
  "Sets the HOST portion of the HOST:PACK-NAME field in the disk label."
  (LET (PACK-NAME)
    (MULTIPLE-VALUE-BIND (UNIT DECODEDP)
	(DECODE-UNIT-ARGUMENT UNIT "getting pack name")
      (SETQ PACK-NAME (NEW-GET-PACK-NAME UNIT))
      (LET* ((COLON-FOUND (POSITION #\: (THE STRING (STRING PACK-NAME)) :TEST #'CHAR=))
	     (SUB-PACK-NAME (IF COLON-FOUND
				(SUBSEQ PACK-NAME (+ 1. COLON-FOUND))
				())))
	(NEW-SET-PACK-NAME
	  (STRING-APPEND (STRING-RIGHT-TRIM ":" NAME) ":" (OR SUB-PACK-NAME "")) UNIT))
      (UNLESS DECODEDP
	(DISPOSE-OF-UNIT UNIT)))
    NAME))  



(DEFUN GET-PACK-HOST-NAME (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*))
  "Return just the HOST name, either from an Explorer disk label or a Startup file."
  (LET (PACK-NAME)
    (MULTIPLE-VALUE-BIND (UNIT DECODEDP)
	(DECODE-UNIT-ARGUMENT UNIT "getting pack name")
      (IF (and (numberp unit) (not (resource-present-p :DISK)))	;Its a local unit & we're DISKless then
	  (setf pack-name (get-startup-host-name))	;use misc disk cmd to get it from MAC.  02.03.88 MBC
	  (SETQ PACK-NAME (NEW-GET-PACK-NAME UNIT))
	  (LET* ((COLON-FOUND (POSITION #\: (THE STRING (STRING PACK-NAME)) :TEST #'CHAR=))
		 (SUB-PACK-NAME (IF COLON-FOUND
				    (SUBSEQ PACK-NAME 0. COLON-FOUND)
				    ())))
	    (WHEN SUB-PACK-NAME
	      (SETQ PACK-NAME SUB-PACK-NAME))))
      (UNLESS DECODEDP
	(DISPOSE-OF-UNIT UNIT)))
    PACK-NAME))
  
(defun GET-CFG-HOST-NAME (&optional (CONFIG (GET-CONFIGURATION)))	; jlm 2-27-89
  "Return just the HOST name, from an Explorer CFG partition."
  (let* ((Pointer (Get-Module-Pointer Config))
	 (Module  (Get-Config-Module  Config Pointer))
	 (Entries (When Pointer (Module-Entries Pointer)))
	 )
    (dotimes (entry entries)
      (let ((name (read-module-entry module entry "Host Name")))
	(when (and name
		   (not (string-equal "*" name :end2 1)))
	  (return (string-trim " " name))
	)))))

(defun config-host-name-p (&optional (config (get-configuration)))	; jlm 2-27-89
  (when (GET-CFG-HOST-NAME config)
    t))

;; Rel 3.0 - changed to use the configuration partition 

(define-when :DISK
  
(DEFUN CURRENT-BAND (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*) MICRO-P
		       &key CFG-UNIT CFG-BAND)
    "If using PRIM-style boot , the name and unit of the default Lisp system (LOD)
specifed in the CFG-BAND are returned.  If using the old boot without a configuration
band, the partition table of UNIT is searched for a load band with the default bit set,
and just the name is returned.  If no default band is found, NIL is returned.

UNIT can be a disk drive number, or for access to remote machines, the UNIT argument
can be a string containing the name of a machine and the unit number (e.g. \"P1:0\").
However, remote access just looks at the disk label, not the CFG band.
If MICRO-P is non-nil then return the default microcode band info instead.

If CFG-UNIT and CFG-BAND are unspecified, then the default CFG band on UNIT, or
the first CFG band on the default disk is used."
    
  (let (dispose) 
    (if (or
	  (closurep (multiple-value-setq (unit dispose)
		      (decode-unit-argument unit "reading current band")))
	  (not (prim-p)))			;remote or doesn't have PRIM.
	(prog1 
	  (CURRENT-BAND-IN-PTBL UNIT MICRO-P)
	  (when dispose (dispose-of-unit unit)) 
	  )
						;otherwise, must be local
	(multiple-value-setq (cfg-unit cfg-band)
	  (find-units-and-cfg-band unit cfg-unit cfg-band))
	(unless cfg-unit
	  (ferror nil "The disk is configured with a PRIM band, but not a CFG band."))
	(multiple-value-bind (name get-unit ignore)	
	    (if micro-p
		(get-Cfg-Boot-Data cfg-band cfg-unit)
		(get-cfg-load-data cfg-band cfg-unit))
	  (when (string-equal #\* get-unit)	;if the unit is wild.
	    (setq get-unit (find-prim)))	;wild unit means where prim was loaded from.
	  
	  (when (string-equal #\* name)		;if the name is wild
	    (setq name (CURRENT-BAND-IN-PTBL get-unit micro-p)))	;return the name from the label
	  (values name get-unit)))
    )						;let
  )
  
  
(DEFUN CURRENT-MICROLOAD (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*)
			    &key CFG-UNIT CFG-BAND)  
    "If using PRIM-style boot, the name and unit of the default microload specifed
in the CFG-BAND are returned.  If using the old boot without a configuration
band, the partition table of UNIT is searched for a microcode with the default bit set,
and just the name is returned.

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

If CFG-UNIT and CFG-BAND are unspecified then the default CFG band on UNIT, or
the first CFG band on the default disk is used."
    (current-band unit t :cfg-unit cfg-unit :cfg-band cfg-band))
  )

(define-unless :DISK
;;;; these are supposed to reflect the currently selected defaults
;;;  which are in <volume>:lispm:startup.  12.1.87 MBC
  
(DEFUN CURRENT-BAND (&OPTIONAL &rest ignore)
  NIL)
  
(DEFUN CURRENT-MICROLOAD (&OPTIONAL &rest ignore)
  NIL)
)


(define-when :DISK
  
(DEFUN CURRENT-BAND-In-Ptbl (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*) MICRO-P)
  (if micro-p
      (CURRENT-MICROLOAD-In-Ptbl unit)
      (CURRENT-LOAD-In-Ptbl unit)))

(DEFUN CURRENT-MICROLOAD-In-Ptbl (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*))
  (second (get-default-partition unit %BT-Microload %CPU-EXPLORER)))

(DEFUN CURRENT-LOAD-In-Ptbl (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*))
  (second (get-default-partition unit %BT-Load-Band %CPU-EXPLORER)))
)

(DEFUN GET-UCODE-VERSION-OF-BAND (PART &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*) &AUX PART-BASE PART-SIZE RQB DONT-DISPOSE)
  "Return the microcode version number that partition PART on unit UNIT should be run with.
This is only meaningful when used on a LOD partition.
UNIT can be a disk unit number, the name of a machine on the chaos net,
or machine name, colon, and unit number on the machine."
  (MULTIPLE-VALUE-SETQ (UNIT DONT-DISPOSE)
    (DECODE-UNIT-ARGUMENT UNIT (FORMAT () "Finding microcode for ~A partition" PART)))
  (UNWIND-PROTECT (PROGN
		    (MULTIPLE-VALUE-SETQ (PART-BASE PART-SIZE)
		      (FIND-DISK-PARTITION-FOR-READ PART () UNIT))
		    (SETQ RQB (GET-DISK-RQB disk-blocks-per-page))
		    (COND
		      ((OR (NUMBERP PART) (STRING-EQUAL PART "LOD" :End1 3. :end2 3.))
		       ;; Read in PAGE that SCA occupies.
		       (DISK-READ RQB UNIT (+ PART-BASE disk-blocks-per-page) disk-blocks-per-page)
		       (LET ((BUF (RQB-BUFFER RQB)))
			 (AREF BUF (* 2. %SYS-COM-DESIRED-MICROCODE-VERSION))))))
    (UNLESS DONT-DISPOSE
      (DISPOSE-OF-UNIT UNIT))
    (RETURN-DISK-RQB RQB)))


;;ab 10/5/88.  Fix UPDATE-PARTITION-COMMENT to work on remote Explorer disks.
;;;partition-comment move to disk-partition

(DEFUN UPDATE-PARTITION-COMMENT (PART STRING UNIT &aux decodedp)
  (unless (closurep unit) ;11-10-88 DAB
    (setf (values UNIT DECODEDP)     ;dab
	  (DECODE-UNIT-ARGUMENT UNIT (FORMAT () "Updating ~A partition comments" PART))))
  (unwind-protect
      (COND ((and (CLOSUREP unit) (boundp-in-closure unit 'REMOTE-DISK-host))
	     (case (getf (send (symeval-in-closure unit 'REMOTE-DISK-host) :host-attributes) :machine-type)
	       (:MICROEXPLORER (update-partition-comment-microexplorer part string unit))
	       (T (update-partition-comment-explorer part string unit))))
	    ((resource-present-p :disk)
	     (update-partition-comment-explorer part string unit))

	    (T (update-partition-comment-microexplorer part string unit)	 	 
	       ))
    (when decodedp (dispose-of-unit unit))))

;;ab 10/5/88.  Fix UPDATE-PARTITION-COMMENT to work on remote Explorer disks.
(DEFUN UPDATE-PARTITION-COMMENT-microexplorer (PART STRING UNIT)
  (declare (ignore part string unit))
  nil)

;;ab 10/5/88.  Fix UPDATE-PARTITION-COMMENT to work on remote Explorer disks.
(DEFUN UPDATE-PARTITION-COMMENT-Explorer (PART STRING UNIT)
  "Set the comment in the disk label for partition PART, unit UNIT to STRING.
UNIT can be a disk unit number, the name of a machine on the chaos net,
or machine name, colon, and unit number on the machine."
  (IF (AND (CLOSUREP UNIT) (FUNCALL UNIT :HANDLES-LABEL))
      (FUNCALL UNIT :UPDATE-PARTITION-COMMENT PART STRING)
      (MULTIPLE-VALUE-BIND (UNIT DECODEDP)
	  (DECODE-UNIT-ARGUMENT UNIT "update partition comment")
	(UNWIND-PROTECT (UPDATE-PARTITION-COMMENT-1
			  PART
			  STRING
			  UNIT)
	  (UNLESS DECODEDP
	    (DISPOSE-OF-UNIT UNIT))))))


(Define-when :DISK
  
(DEFUN UPDATE-PARTITION-COMMENT-1 (PART STRING UNIT &AUX RQB DESC-LOC)
  (UNWIND-PROTECT (PROGN
		    (SETQ RQB (READ-DISK-LABEL UNIT))
		    (MULTIPLE-VALUE-SETQ (NIL NIL DESC-LOC)
		      (FIND-DISK-PARTITION-FOR-READ PART RQB UNIT T ()))
		    (PUT-DISK-STRING RQB STRING (+ DESC-LOC %PD-COMMENT)
				     (* 4.
					(-
					  (GET-DISK-FIXNUM RQB
							   (+ %PT-BASE
							      %PT-SIZE-OF-PARTITION-ENTRIES))
					  (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-COMMENT-UNKNOWN)))))
		    (WRITE-DISK-LABEL RQB UNIT))
    (RETURN-DISK-RQB RQB)))
)




(DEFUN TEST-PARTITION-PROPERTY (PART-NAME UNIT TARGET-PROPERTY &OPTIONAL
				(ATTRIBUTE-WORD
				  (MULTIPLE-VALUE-BIND (IGNORE IGNORE IGNORE IGNORE ATTS)
				      (FIND-DISK-PARTITION PART-NAME () UNIT)
				    ATTS)))
  " Test the attribute-word of partition on unit for presence of target-property.
 Valid keywords for the TARGET-PROPERTY argument are:
 :Expandable, :Contractable, :Delete-protected, :Logical-partition, :Copy-protected,
 :Default, :Diagnostic."
  (AND ATTRIBUTE-WORD (LDB-TEST (TRANSLATE-PARTITION-PROPERTY TARGET-PROPERTY) ATTRIBUTE-WORD)))  



(DEFUN TRANSLATE-PARTITION-PROPERTY (PROPERTY)
  " Translates a keyword into the %mumble offset for use with ldb-test"
  (DECLARE
    (SPECIAL %%EXPANDABLE %%CONTRACTABLE %%DELETE-PROTECTED %%LOGICAL-PARTITION %%COPY-PROTECTED
	     %%DEFAULT-INDICATOR %%DIAGNOSTIC-INDICATOR))
  (SELECT PROPERTY (:EXPANDABLE %%EXPANDABLE) (:CONTRACTABLE %%CONTRACTABLE)
	  (:DELETE-PROTECTED %%DELETE-PROTECTED) (:LOGICAL-PARTITION %%LOGICAL-PARTITION)
	  (:COPY-PROTECTED %%COPY-PROTECTED) (:DEFAULT %%DEFAULT-INDICATOR)
	  (:DIAGNOSTIC %%DIAGNOSTIC-INDICATOR)))


;; ab 8/29/88

;;Useful for EXP & mX.
(DEFUN band-active-p (band-descriptor)
  "Returns true if band specified by BAND-DESCRIPTOR is currently in use by the system, else
returns NIL.  The current load band and any page band are examples of active bands.
  BAND-DESCRIPTOR is a list of partition information such as in the sublists returned
by GET-PARTITION-LIST."
  (COND ((OR (= %bt-page-band (LDB %%band-type-code (THIRD band-descriptor)))
	     (= %bt-load-band (LDB %%band-type-code (THIRD band-descriptor))))
	 (DOTIMES (band number-of-page-devices nil)
	   (MULTIPLE-VALUE-BIND (nil start nil nil nil nil nil nil real-unit)
	       (get-swap-band-info band)
	     (WHEN (AND (= start (FOURTH band-descriptor))
			(= real-unit (get-real-unit-no-check (FIRST band-descriptor))))
	       (RETURN-FROM band-active-p t)))))
	
	((= %bt-file-band (LDB %%band-type-code (THIRD band-descriptor)))
	 (AND (FIND-PACKAGE 'fs)
	      (BOUNDP (INTERN "LM-PARTITION-BASE" 'fs))
	      (= (FOURTH band-descriptor) (SYMBOL-VALUE (INTERN "LM-PARTITION-BASE" 'fs)))
	      (= (FIRST band-descriptor) (SYMBOL-VALUE (INTERN "LM-UNIT" 'fs)))))
	
	((= %bt-meter-band (LDB %%band-type-code (THIRD band-descriptor)))
	 (AND (FIND-PACKAGE 'meter)
              (BOUNDP 'si:%meter-global-enable)
	      si:%meter-global-enable
	      (= (FIRST band-descriptor) (SYMBOL-VALUE (INTERN "METER-LOGICAL-UNIT" 'meter)))
	      (= (FOURTH band-descriptor) (SYMBOL-VALUE (INTERN "DISK-PARTITION-START" 'meter)))))
	
	((= %bt-log-band (LDB %%band-type-code (THIRD band-descriptor)))
	 (AND (FIND-PACKAGE 'syslog)
              (BOUNDP (INTERN "*LOG-ENABLED*" 'syslog))
	      (SYMBOL-VALUE (INTERN "*LOG-ENABLED*" 'syslog))
	      (= (FIRST band-descriptor) (SYMBOL-VALUE (INTERN "*LOG-UNIT*" 'syslog)))
	      (= (FOURTH band-descriptor) (SYMBOL-VALUE (INTERN "*START-BLOCK*" 'syslog)))))

	;; Check other microExplorer partitions
	((AND (NOT (resource-present-p :DISK))
	      (NOT (type-symbol-from-type-number (LDB %%band-type-code (THIRD band-descriptor)))))
	 (FERROR nil "Descriptor ~s is for an unknown partition-type" band-descriptor))
	
	;; Other Explorer partitions are inactive by default.
	(t nil)
	)
  )

;; This can exist for regular EXPLORER also.
(DEFUN partition-exists-p (part-name unit type-num &optional start)
  (LOOP for p in (get-partition-list type-num nil unit)
	  with compare-name = (subseq (pad-name-field part-name 4.) 0 4) ;10-24-88 DAB
	  do (WHEN (AND (= unit (FIRST p))
			(STRING-EQUAL compare-name
				      (SECOND p))
 			(= type-num (LDB %%band-type-code (THIRD p)))
			(OR (NULL start) (= start (FOURTH p))))
	       (RETURN p)))
  )


(define-unless :disk				       ;mx-only

(DEFPARAMETER *mx-directory-name* "MicroExp")
(DEFPARAMETER *mx-partition-types*  '((:load 0) (:mcr 1) (:page 2) (:file 3) (:metr 4)  (:log 11))) ;11-01-88 DAB


(DEFUN type-number-from-type-symbol (symbol)
  (OR (SECOND (ASSOC symbol *mx-partition-types* :test #'EQ))
      (FERROR nil "~s is an unknown partition type" symbol)))

(DEFUN type-symbol-from-type-number (number)
  (LOOP for (sym num) in *mx-partition-types* do
	(WHEN (= num number)
	  (RETURN sym))
	finally (RETURN nil)))

;; Note that this will return the correct, current volume name even if user has changed the disk
;; name since we booted.  The correct name is also stored into our MAC-resident volume data structures when
;; this routine is called.
(DEFUN get-volume-name-internal (unit &optional (access-physical-volume t))
  
  (IF unit
      (SETQ unit (get-real-unit unit))
      (SETQ unit load-unit))
  (let ((acb (add:get-acb Small-Disk-Command-Size t))
	(ch (add:find-channel Disk-Channel)))
    (unwind-protect
	(PROGN
	  ;; Fill in command overhead
	  (add:init-acb acb %MC-Disk-Cmd %DC-Get-Volume-Name-New)
	  
	  ;; Input parameters
	  (add:load-parms-16b acb unit (IF access-physical-volume 1 0))
	  
	  ;; Execute command
	  (add:transmit-packet-and-wait acb ch)
	  (add:check-error acb)
	  
	  ;; Return values
	  (add:get-acb-string acb %GVI-Volume-Name))
      (setf (add:requestor-complete acb) t)
      (add:return-acb-fast acb)))
  
  )

;;ab 10/8/88.  New.
(DEFUN mx-decode-unit-name (volume-name &aux tem)
  "Tries to return a unit number when given a volume name (a symbol or string)."
  (WHEN (SYMBOLP volume-name)
    (SETQ volume-name (SYMBOL-NAME volume-name)))
  (SETQ tem
	(DOTIMES (INDEX DISK-TYPE-TABLE-LENGTH NIL)
	  (IF (STRING-EQUAL volume-name (GET-PACK-NAME-FROM-TABLE INDEX))
	      (RETURN INDEX))))
  (OR tem
      ;; Name of volume may have been changed by user since microExplorer booted.
      (LOOP for n in (all-disk-units) do
	    (WHEN (STRING-EQUAL (get-volume-name-internal n) volume-name)
	      (RETURN n)))))

;;ab 10/8/88.  New.
(Defun mx-Decode-Unit (Unit &optional (reason "Modifying partition"))
  "First value is decoded unit.  Second if T if arg was not already a decoded unit.
If second value is NIL, the caller should call DISPOSE-OF-Unit eventually."
  (Cond
    ((AND (integerp Unit)
	  (NOT (MINUSP unit))) Unit)
    ((And (Symbolp Unit) (mx-decode-unit-name unit)))
    ((And (Stringp Unit)
	  (if (Position #\: (The String (String Unit)) :Test #'Char-Equal)
	      (decode-unit-argument unit  reason)
	      (mx-decode-unit-name (Ignore-Errors (Read-From-String Unit))))))
    (t
     (FERROR nil "~a is not a valid unit argument (a positive number or name of an online disk volume)"
	     unit)))
  )


(DEFUN display-part-file-map (unit)
  (SETQ unit (mx-decode-unit unit))				       ;ab 10/8/88
  (PRINT-DISK-LABEL unit)
  
  (let ((acb (add:get-acb Small-Disk-Command-Size t))
	(ch (add:find-channel Disk-Channel)))
    (unwind-protect
	(progn
	  ;; Fill in command overhead
	  (add:init-acb acb %MC-Disk-Cmd %DC-Display-Partition-File-Map)
	  
	  ;; Input parameters
	  (add:load-parms-16b acb (get-real-unit unit))
	  
	  ;; Execute command
	  (add:transmit-packet-and-wait acb ch)
	  (add:check-error acb))
      (setf (add:requestor-complete acb) t)
      (add:return-acb-fast acb)))
  )

(DEFUN get-volume-space-info (unit)
  (DECLARE (VALUES free allocated total))
  (SETQ unit (mx-decode-unit unit))				       ;ab 10/8/88
  
  (let ((acb (add:get-acb Small-Disk-Command-Size t))
	(ch (add:find-channel Disk-Channel)))
    (unwind-protect
	(PROGN
	  ;; Fill in command overhead
	  (add:init-acb acb %MC-Disk-Cmd %DC-Get-Volume-Space-Info)
	  
	  ;; Input parameters
	  (add:load-parms-16b acb (get-real-unit unit))
	  
	  ;; Execute command
	  (add:transmit-packet-and-wait acb ch)
	  (add:check-error acb)
	  
	  ;; Return values
	  (LET ((total-blocks
		  (add:parm-16b acb (add:16b-parm-number %GVI-Total-Blocks)))
		(free-blocks 
		  (add:parm-16b acb (add:16b-parm-number %GVI-Blocks-Free)))
		(block-size 
		  (add:parm-32b acb (add:32b-parm-number %GVI-Block-Size)))
		total free)
	    ;; # Total Kbytes (explorer blocks) on volume
	    (SETQ total (FLOOR (* total-blocks block-size) disk-block-byte-size))
	    ;; # Kbytes free
	    (SETQ free (FLOOR (* free-blocks block-size) disk-block-byte-size))
	    (VALUES
	      free
	      ;; Kbytes allocated
	      (- total free)
	      total)))
      (setf (add:requestor-complete acb) t)
      (add:return-acb-fast acb)))
  
  )

(DEFPARAMETER *illegal-partition-name-chars* '(#\space #\* #\\ #\/ #\#))

(DEFUN get-valid-partition-name (partition-name &optional (len 4))
  (CHECK-ARG partition-name (OR (STRINGP partition-name) (SYMBOLP partition-name))
	     "a string or symbol")
  (LET (valid-name)
    (SETQ valid-name (SUBSEQ (THE string (STRING partition-name)) 0 len))
    (SETQ valid-name (SUBSEQ (THE string valid-name) 0 (POSITION #\space valid-name)))
    (DOLIST (CHAR *illegal-partition-name-chars*)
      (WHEN (POSITION char valid-name)
	(FERROR nil "Partition-name ~s contains invalid character ~:c" partition-name char)))
    valid-name)
  )

;;RJF 12/21/88
(defun check-for-process-key (entry) (STRING (PROCESS-NAME (CAR entry))))

(defun check-for-process-predicate (object) (TYPEP (CAR object) 'process)) 

;;ab 10/7/88, RJF 12/21/88
(DEFUN check-for-process (process-name &aux res res2)
  "Find a process whose name has the substring PROCESS-NAME in it.  First value returned
is a process whose name is an exact match for process-name.  Second value is a list of
all processes containing substring PROCESS-NAME.  
  PROCESS-NAME can be a symbol or a string.  If it is a symbol, it is checked for
both with and without hyphens."
  (DECLARE (VALUES exact-match-process list-of-close-matches))
  (COND ((FBOUNDP 'SUB-APROPOS)
	 (SETF res (SUB-APROPOS process-name active-processes
				:dont-print t
				:key #'check-for-process-key 
				:predicate #'check-for-process-predicate))
	 (WHEN (NULL res)
	   (SETF res (SUB-APROPOS (STRING-CAPITALIZE (STRING process-name) :spaces t) active-processes
				:dont-print t
				:key #'check-for-process-key 
				:predicate #'check-for-process-predicate)))
	 (LOOP for el in res
	       collecting (CAR el) into p-lst
	       finally (SETQ res p-lst))
	 (LOOP for p in res
	       with p-lst do
	       (WHEN (TYPEP p 'process)
		 (WHEN (OR (STRING-EQUAL (SEND p :name) (STRING process-name))
			   (STRING-EQUAL (SEND p :name) (STRING-CAPITALIZE (STRING process-name) :spaces t)))
		   (PUSH p p-lst)))
	       finally (SETQ res2 (LIST (CAR p-lst) res)))
	 (VALUES (FIRST res2) (SECOND res2)))
	(t
	 (LOOP with p-lst = nil
	       for (p) in active-processes do
	       (WHEN (TYPEP p 'process)
		 (WHEN (OR (STRING-EQUAL (SEND p :name) (STRING process-name))
			   (STRING-EQUAL (SEND p :name) (STRING-CAPITALIZE (STRING process-name) :spaces t)))
		   (PUSH p p-lst)))
	       finally (RETURN (CAR p-lst) p-lst))))
  )

;;ab 10/7/88
(DEFUN check-for-partition-file (filename)
  (LET ((p (check-for-process "Micronet port handler")))
    ;; If micronet port handler process gone (as before DISK-SAVE), the PROBE-FILE will hang. 
    ;; So re-enable him briefly then turn him off afterwards.
    (UNWIND-PROTECT
	(PROGN 
	  (UNLESS p (add:micronet-reset t))
	  (with-sys-host-accessible (IGNORE-ERRORS (PROBE-FILE filename))))
      (UNLESS p (add:micronet-reset nil))))
  )

(DEFUN add-partition (partition-name unit size &key (partition-type :load))
  "Create a new partition named PARTITION-NAME on UNIT SIZE number of blocks of the
type specified by the PARTITION-TYPE keyword value.
   PARTITION-NAME can be a symbol or a string.  Up to 31 characters are used in the
new partition-file's name, but the first 4 characters must be unique on this volume.
   UNIT should be the logical unit number or name of an online unit (not a floppy disk).
   SIZE should be a positive integer.  An error will be signalled if there is not enough
free disk space to create a partition that large.
   PARTITION-TYPE should be a valid partition type keyword as in *MX-PARTITION-TYPES*."
  (LET (type-num namestring filestring volume
	real-unit short-name free part-list)
    (SETQ unit (mx-decode-unit unit (format nil "Adding partition ~a" partition-name)))
    (if (closurep unit)	;10-21-88 DAB Remote-disk?			;ab 10/8/88
	(let (result)
	  (setf result (funcall unit :add-partition  partition-name unit size partition-type))
	  (format T "~a" result))
	;else
	(CHECK-ARG partition-name (OR (STRINGP partition-name) (SYMBOLP partition-name))
		   "a string or symbol")
	(CHECK-ARG size (AND (NUMBERP size) (PLUSP size)) "a positive number")
	
	(SETQ partition-name (STRING partition-name))
	
	(SETQ type-num (type-number-from-type-symbol partition-type)
	      volume (get-volume-name-internal unit)
	      real-unit (get-real-unit unit)
	      partition-name (get-valid-partition-name partition-name (- 31. 5))	;31 char max including .TYPE
	      short-name (get-valid-partition-name partition-name)
	      filestring (STRING-APPEND partition-name "."
					(SYMBOL-NAME partition-type))
	      namestring (STRING-APPEND volume ":" *mx-directory-name* ":" filestring))
	
	(WHEN (> (LENGTH (THE string filestring)) 31.)
	  (FERROR nil "File name string ~s longer than 31. characters." filestring))
	
	(SETQ part-list (partition-exists-p short-name unit type-num))
	(WHEN part-list
	  (FERROR nil "Partition named ~s already exists on unit ~s." short-name unit))
	
	(COND ((<= (+ size 100.) (SETQ free (get-volume-space-info unit)))
	       ;;There is enough space on disk
	       (let ((acb (add:get-acb Medium-Disk-Command-Size t))
		     (ch (add:find-channel Disk-Channel)))
		 (unwind-protect
		     (PROGN
		       ;; Fill in command overhead
		       (add:init-acb acb %MC-Disk-Cmd %DC-Add-Partition)
		       
		       ;; Input parameters
		       (add:set-parm-16b acb (add:16b-parm-number %MP-Physical-Unit)
					 real-unit)
		       (add:set-parm-16b acb (add:16b-parm-number %MP-Partition-Type)
					 type-num)
		       (add:set-parm-32b acb (add:32b-parm-number %MP-Partition-Length) size)
		       (add:put-acb-string acb %MP-Part-Name (pad-name-field short-name 4.))
		       (add:put-acb-string acb %MP-File-Name filestring)
		       (add:put-acb-string acb %MP-Whole-File-Name namestring)
		       
		       ;; Execute command
		       (add:transmit-packet-and-wait acb ch)
		       (add:check-error acb))
		   (setf (add:requestor-complete acb) t)
		   (add:return-acb-fast acb)))
	       (flush-volume unit)
	       t)
	      
	      (t (FERROR nil "Not enough free space (only ~s blocks) on volume ~s"
			 free volume)))))
  )

(DEFUN modify-partition (partition-name unit new-size
			 &key (partition-type :load)
			 new-partition-name new-partition-type
			 (query t) partition-start)
  "Modify the existing partition named PARTITION-NAME on UNIT.  The most common use is
to change a partition's size to NEW-SIZE number of blocks.  The partition's name
may optionally be changed to the value of the NEW-PARTITION-NAME keyword or its type
may be changed to the type specified by the NEW-PARTITION-TYPE keyword.
   PARTITION-NAME can be a symbol or a string.  Up to 31 characters are used in the
new partition-file's name, but the first 4 characters must be unique on this volume.
NEW-PARTITION-NAME has the same constrains, with NIL signifying no name change.
   UNIT should be the logical unit number or name of an online unit (not a floppy disk).
   NEW-SIZE should be a positive integer.  An error will be signalled if there is not enough
free disk space for a partition that large.
   PARTITION-TYPE should be a valid partition type keyword as in *MX-PARTITION-TYPES*.
The value of the NEW-PARTITION-TYPE keyword may also be NIL signifying no type change.
   MODIFY-PARTITION will warn about modifying active partitions such as the current load
band or any page band unless QUERY is NIL."  
  (DECLARE (ARGLIST partition-name unit new-size &key (partition-type :load)
		    new-partition-name new-partition-type (query t)))
  (LET (type-num new-type-num volume real-unit free start size
	file-exists part-list
	short-name new-short-name namestring new-namestring
	filestring new-filestring filename new-filename rename-p)
    
    (SETQ unit (mx-decode-unit unit (format nil "Modifying partition ~a" partition-name)))
    (if (closurep unit)				;ab 10/8/88
	(let (result)
	  (setf result (funcall unit :modify-partition 
				partition-name unit new-size partition-type
				new-partition-name  new-partition-type query partition-start))
	  (format T "~a" result))
						;ab 10/8/88
	(CHECK-ARG new-size (OR (NULL new-size)
				(AND (NUMBERP new-size) (PLUSP new-size)))
		   "a positive number or NIL")
	(CHECK-ARG partition-start (OR (NULL partition-start)
				       (AND (NUMBERP partition-start) (PLUSP partition-start)))
		   "a positive number or NIL")
	(CHECK-ARG partition-type (AND (KEYWORDP partition-type)
				       (ASSOC partition-type *mx-partition-types*))
		   "a partition type keyword in the list *mx-partition-types*")
	(WHEN (NULL new-partition-type) (SETQ new-partition-type partition-type))
	(CHECK-ARG new-partition-type (AND (KEYWORDP new-partition-type)
					   (ASSOC new-partition-type *mx-partition-types*))
		   "a partition type keyword in the list *mx-partition-types*")
	(CHECK-ARG partition-name (OR (STRINGP partition-name) (SYMBOLP partition-name))
		   "a string or symbol")
	(WHEN (NULL new-partition-name) (SETQ new-partition-name partition-name))
	(CHECK-ARG new-partition-name (OR (STRINGP new-partition-name) (SYMBOLP new-partition-name))
		   "a string or symbol")
	(SETQ partition-name (STRING partition-name)
	      new-partition-name (STRING new-partition-name))
	
	(SETQ type-num (type-number-from-type-symbol partition-type)
	      new-type-num (type-number-from-type-symbol new-partition-type)
	      volume (get-volume-name-internal unit)
	      real-unit (get-real-unit unit)
	      partition-name (SUBSEQ (THE string (STRING partition-name)) 0.
				     (- 31. 5))	;31 char max including .TYPE
	      new-partition-name (SUBSEQ (THE string (STRING new-partition-name)) 0.
					 (- 31. 5))	;31 char max including .TYPE
	      short-name (get-valid-partition-name partition-name)
	      new-short-name (get-valid-partition-name new-partition-name)
	      filestring (STRING-APPEND partition-name "."
					(SYMBOL-NAME partition-type))
	      new-filestring (STRING-APPEND new-partition-name "."
					    (SYMBOL-NAME new-partition-type))
	      
	      namestring (STRING-APPEND volume ":" *mx-directory-name* ":" filestring)
	      new-namestring (STRING-APPEND volume ":" *mx-directory-name* ":" new-filestring)
	      rename-p (NOT (STRING-EQUAL namestring new-namestring)))
	
	(WHEN (> (LENGTH (THE string filestring)) 31.)
	  (FERROR nil "File name string ~s longer than 31. characters." filestring))
	(WHEN (> (LENGTH (THE string new-filestring)) 31.)
	  (FERROR nil "File name string ~s longer than 31. characters." new-filestring))
	
	;; Ensure partition exists on volume.
	(SETQ part-list (partition-exists-p short-name unit type-num start)
	      size (FIFTH part-list))
	(UNLESS part-list
	  (FERROR nil "Partition ~s of type ~s not found on unit ~s."
		  short-name partition-type unit))
	(WHEN (NULL start) (SETQ start (FOURTH part-list)))
	
	(SETQ filename (STRING-APPEND "lm:" namestring)
	      new-filename (STRING-APPEND "lm:" new-namestring))
	
	;; Possibly double check by probing for file.  Something is wrong if above test
	;; succeedes and this one fails.
	(WHEN query
	  (SETQ file-exists (check-for-partition-file filename))	;ab 10/7/88
	  (WHEN (NOT file-exists)
	    (FERROR nil "Partition-file ~s does not exist." filename)))
	
	(WHEN (NULL new-size) (SETQ new-size size))
	(COND ((<= (+ (- new-size size) 100.) (SETQ free (get-volume-space-info unit)))
	       ;;There is enough space on disk
	       
	       (WHEN (AND (band-active-p part-list)
			  query)
		 (UNLESS (Y-OR-N-P "*** WARNING ***  ~%Partition ~s on unit ~s is currently active.  Modify anyway?"
				   short-name unit)
		   (RETURN-FROM modify-partition nil)))
	       
	       (let ((acb (add:get-acb Medium-Disk-Command-Size t))
		     (ch (add:find-channel Disk-Channel)))
		 (unwind-protect
		     (PROGN
		       ;; Fill in command overhead
		       (add:init-acb acb %MC-Disk-Cmd %DC-Modify-Partition)
		       
		       ;; Input parameters
		       (add:set-parm-16b acb (add:16b-parm-number %MP-Physical-Unit)
					 real-unit)
		       (add:set-parm-16b acb (add:16b-parm-number %MP-Partition-Type)
					 type-num)
		       (add:put-acb-string acb %MP-Part-Name (pad-name-field short-name 4.))
		       (add:put-acb-string acb %MP-File-Name filestring)
		       (add:put-acb-string acb %MP-Whole-File-Name namestring)
		       ;; Size = 0 means MODIFY op is for name/type change only.
		       (add:set-parm-32b acb (add:32b-parm-number %MP-Partition-Length)
					 (IF (= size new-size) 0 new-size))
		       (add:set-parm-32b acb (add:32b-parm-number %MP-Partition-Start)
					 (IF (NULL start) 0 start))
		       (add:set-parm-16b acb (add:16b-parm-number %MP-New-Partition-Type)
					 new-type-num)
		       (add:put-acb-string acb %MP-New-Part-Name (pad-name-field new-short-name 4.))
		       (add:put-acb-string acb %MP-New-File-Name new-filestring)
		       (add:put-acb-string acb %MP-New-Whole-File-Name new-namestring)
		       (add:set-parm-16b acb (add:16b-parm-number %MP-Flags)
					 (IF rename-p 1 0))
		       
		       ;; Execute command
		       (add:transmit-packet-and-wait acb ch)
		       (add:check-error acb))
		   (setf (add:requestor-complete acb) t)
		   (add:return-acb-fast acb)))
	       (flush-volume unit)
	       t)
	      
	      (t (FERROR nil "Not enough free space (only ~s blocks) on volume ~s"
			 free volume)))))
  )


(DEFUN delete-partition (partition-name unit &key (partition-type :load)
			 start (query t))
  "Delete the partition named PARTITION-NAME on UNIT.
   PARTITION-NAME can be a symbol or a string.  Up to 31 characters are used in the
new partition-file's name, but the first 4 characters must be unique on this volume.
   UNIT should be the logical unit number or name of an online unit (not a floppy disk).
   PARTITION-TYPE should be a valid partition type keyword as in *MX-PARTITION-TYPES*.
   DELETE-PARTITION will warn about modifying active partitions such as the current load
band or any page band unless QUERY is NIL."
  (DECLARE (ARGLIST partition-name unit &key (partition-type :load) (query t)))
  (SETQ unit (mx-decode-unit unit (format nil "Deleting partition ~a" partition-name)))		;ab 10/8/88
  (if (closurep unit)				;ab 10/8/88
      (let (result)
	(setf result (funcall unit :delete-partition
			      partition-name unit partition-type start query))
	(format T "~a" result))
      
      (CHECK-ARG start (OR (NULL start)
			   (AND (NUMBERP start) (PLUSP start)))
		 "a positive number or NIL")
      (CHECK-ARG partition-type (AND (KEYWORDP partition-type)
				     (ASSOC partition-type *mx-partition-types*))
		 "a partition type keyword in the list *mx-partition-types*")
      (CHECK-ARG partition-name (OR (STRINGP partition-name) (SYMBOLP partition-name))
		 "a string or symbol")
      (SETQ partition-name (STRING partition-name))
      
      (LET (part-list type-num volume real-unit short-name
	    filestring namestring filename file-exists)
	(SETQ type-num (type-number-from-type-symbol partition-type)
	      volume (get-volume-name-internal unit)
	      real-unit (get-real-unit unit)
	      partition-name (SUBSEQ (THE string (STRING partition-name)) 0.
				     (- 31. 5))	;31 char max including .TYPE
	      short-name (get-valid-partition-name partition-name)
	      filestring (STRING-APPEND partition-name "."
					(SYMBOL-NAME partition-type))
	      namestring (STRING-APPEND volume ":" *mx-directory-name* ":" filestring))
	
	(SETQ part-list (partition-exists-p short-name unit type-num start))
	(UNLESS part-list
	  (FERROR nil "Partition named ~s does not exist on unit ~s (filename ~s)"
		  short-name unit namestring))
	
	(SETQ filename (STRING-APPEND "lm:" namestring))
	;; Possibly double check by probing for file.  Something is wrong if above test
	;; succeedes and this one fails.
	(WHEN query
	  (SETQ file-exists (check-for-partition-file filename))	;ab 10/7/88
	  (WHEN (NOT file-exists)
	    (FERROR nil "Partition-file ~s does not exist." filename)))
	
	(WHEN (AND (band-active-p part-list)
		   query)
	  (UNLESS (Y-OR-N-P "*** WARNING ***  ~%Partition ~s on unit ~s is currently active.  Delete anyway?"
			    short-name unit)
	    (RETURN-FROM delete-partition nil)))
	
	(let ((acb (add:get-acb Medium-Disk-Command-Size t))
	      (ch (add:find-channel Disk-Channel)))
	  (unwind-protect
	      (PROGN
		;; Fill in command overhead
		(add:init-acb acb %MC-Disk-Cmd %DC-Delete-Partition)
		
		;; Input parameters
		(add:set-parm-16b acb (add:16b-parm-number %MP-Physical-Unit)
				  real-unit)
		(add:set-parm-16b acb (add:16b-parm-number %MP-Partition-Type)
				  type-num)
		(add:set-parm-32b acb (add:32b-parm-number %MP-Partition-Start)
				  (IF (NULL start) 0 start))
		(add:put-acb-string acb %MP-Part-Name (pad-name-field short-name 4.))
		(add:put-acb-string acb %MP-File-Name filestring)
		(add:put-acb-string acb %MP-Whole-File-Name namestring)
		
		;; Execute command
		(add:transmit-packet-and-wait acb ch)
		(add:check-error acb))
	    (setf (add:requestor-complete acb) t)
	    (add:return-acb-fast acb)))
	
	(flush-volume unit)
	)
      ))

(DEFUN find-unique-partition-name (&optional (prefix "P") (unit *default-disk-unit*) (type-num 0))
  (LOOP for i from 0 below 999.
	for part-name = (STRING-APPEND prefix (FORMAT nil "~3,'0,d" i)) do
	(WHEN (NOT (partition-exists-p part-name unit type-num))
	  (RETURN-FROM find-unique-partition-name part-name))
	finally (FERROR nil "Cannot find unique partition name on unit ~d." unit))
  )


(DEFUN add-page-band (&key partition-name (unit *default-disk-unit*) (size 5000.))
  "Create a new page partition-file and dynamically add it to the system's virtual memory.
   SIZE specifies the partition size in blocks.  The default is 5000 (5 MBytes).
   If non-NIL, the value of the PARTITION-NAME keyword should be a string or a symbol specifying
the partition name.  Only the first 4 characters will be used (and must be unique for this disk).
When PARTITION-NAME is NIL or unsupplied, the name defaults to a unique partition name for this
volume.
   UNIT should be a logical unit number or name of an online disk (not a floppy)."
  (SETQ unit (mx-decode-unit unit (format nil "Adding page band ~a" partition-name)))
  (if (closurep unit)  ;10-21-88 DAB remote-disk? ;ab 10/8/88
      (let (result)
	(setf result (funcall unit :add-page-band  partition-name unit size))
	(format T "~a" result))
      ;else
      (CHECK-ARG partition-name (OR (NULL partition-name)
				    (STRINGP partition-name)
				    (SYMBOLP partition-name))
		 "a string, symbol or NIL")
      (IF (NULL partition-name)
	  (SETQ partition-name (find-unique-partition-name "P" unit (type-number-from-type-symbol :page)))
	  (get-valid-partition-name partition-name))
      (add-partition partition-name unit size :partition-type :page)
      (change-swap-space-allocation))
  t)


(DEFUN resize-load-band (&optional (partition-name *loaded-band*) (unit *default-disk-unit*))
  "Re-size the load band named PARTITION-NAME on UNIT so that it does not consume unneded disk space.
   The PARTITION-NAME keyword should be a string or a symbol specifying a partition name.  
Only the first 4 characters will be used (and must be unique for this disk).
   UNIT should be a logical unit number or name of an online disk (not a floppy)."
  (SETQ unit (mx-decode-unit unit (format nil "Resizing load band ~a" partition-name)))
  (if (closurep unit) ;10-21-88 DAB				;ab 10/8/88
      (let (result)
	(setf result (funcall unit :resize-load-band 
			      partition-name unit))
	(format T "~a" result))
      ;else						;ab 10/8/88
      (SETQ partition-name (get-valid-partition-name partition-name))
      (MULTIPLE-VALUE-BIND (length-in-blocks)
	  (get-lod-partition-info partition-name unit)
	(modify-partition partition-name unit (+ length-in-blocks 100.) :query nil))
      ))


(DEFUN add-or-modify-partition (partition-name unit size partition-type &optional (query t))
  "Check to see if partition PARTITION-NAME on unit (type PARTITION-TYPE) exists and is at
least SIZE blocks long.  Does nothing if partition exists.  If partition does not exist or is
too small, will either create or expand automatically (with QUERY = NIL) or ask the user first
\(when QUERY = t)."
  (SETQ unit (mx-decode-unit unit (format nil "Adding or Modifying partition ~a" partition-name) ))
  (if (closurep unit)   ;10-21-88 DAB remote-disk?				;ab 10/8/88
      (let (result)
	(setf result (funcall unit :add-or-modify-partition
			      partition-name unit size partition-type query))
	(format T "~a" result))
      ;else
      (CHECK-ARG size (AND (NUMBERP size) (PLUSP size)) "a positive number")
      (CHECK-ARG partition-type (AND (KEYWORDP partition-type)
				     (ASSOC partition-type *mx-partition-types*))
		 "a partition type keyword in the list *mx-partition-types*")
      (SETQ partition-name (get-valid-partition-name partition-name (- 31. 5))) ;dab
      
      (LET (type-num part-list)
	(SETQ type-num (type-number-from-type-symbol partition-type)
	      part-list (partition-exists-p partition-name unit type-num))
	(COND ((AND part-list
		    (<= size (FIFTH part-list)))
	       ;; Exists and is right size--return flag
	       :EXISTS)
	      ((AND part-list query)
	       ;; Exists but size wrong, ask user
	       (WHEN (Y-OR-N-P "Partition ~s on unit ~s is too small.  Attempt to expand it?"
			       partition-name unit)
		 (modify-partition partition-name unit size
				   :partition-type partition-type :query query)))
	      (part-list
	       ;; Exists wrong size, just modify without asking
	       (modify-partition partition-name unit size
				 :partition-type partition-type :query query))
	      ((AND (NULL part-list) query)
	       ;; Doesn't exist, ask user.
	       (WHEN (Y-OR-N-P "Partition ~s does not exist on unit ~d.  Attempt to create it?"
			       partition-name unit)
		 (add-partition partition-name unit size :partition-type partition-type)))
	      ((NULL part-list)
	       ;; Doesn't exist, don't ask user.
	       (add-partition partition-name unit size :partition-type partition-type))
	      )))
  )



(DEFUN flush-volume (unit &aux name)
  "Cause a FLUSH-VOLUME to occur on the MAC so all volume information is written to disk for
the volume specified by UNIT."
  (SETQ unit (mx-decode-unit unit))				       ;ab 10/8/88
  (COND ((MEMBER unit (all-disk-units))
	 (SETQ name (get-volume-name-internal unit))
	 
	 (let ((acb (add:get-acb Small-Disk-Command-Size t))
	       (ch (add:find-channel Disk-Channel)))
	   (unwind-protect
	       (PROGN
		 ;; Fill in command overhead
		 (add:init-acb acb %MC-Disk-Cmd %DC-Flush-Volume)
		 
		 ;; Input parameters
		 (add:put-acb-string acb %GVI-Volume-Name name)
		 
		 ;; Execute command
		 (add:transmit-packet-and-wait acb ch)
		 (add:check-error acb))
	     (setf (add:requestor-complete acb) t)
	     (add:return-acb-fast acb)))
	 
	 t)
	(nil (FERROR nil "~s is not an on-line unit")))
  )


(DEFUN flush-file (filename &aux pathname namestring real-pathname)
  (CHECK-ARG filename (OR (STRINGP filename)
			  (SYMBOLP filename)
			  (PATHNAMEP filename))
	     "a parsable pathname")
  (SETQ pathname (PATHNAME filename))
  (SETQ real-pathname (TRANSLATED-PATHNAME pathname)
	namestring (SEND real-pathname :string-for-host))
  (MULTIPLE-VALUE-BIND (file-exists nil)
      (check-for-partition-file real-pathname)	       ;ab 10/7/88
    
    (COND (file-exists  
	   (let ((acb (add:get-acb Medium-Disk-Command-Size t))
		 (ch (add:find-channel Disk-Channel)))
	     (unwind-protect
		 (PROGN
		  ;;  Fill in command overhead
		   (add:init-acb acb %MC-Disk-Cmd  %DC-Flush-File)
		   
		   ;; Input parameters
		   (add:put-acb-string acb %MP-Whole-File-Name namestring) 
		   
		   ;; Execute command
		   (add:transmit-packet-and-wait acb ch)
		   (add:check-error acb))
	       (setf (add:requestor-complete acb) t)
	       (add:return-acb-fast acb)))
	   
	   t)
	  (t nil)))
  )

(DEFUN flush-partition-file (partition unit &optional (TYPE :load) &aux namestring vol)
  (SETQ unit (mx-decode-unit unit))				       ;ab 10/8/88
  (SETQ partition (disk-restore-decode partition)
	vol (get-volume-name-internal unit)
	namestring (STRING-APPEND
		     "lm:" vol ":" *mx-directory-name* ":" partition "."
		     (SYMBOL-NAME type)))
  (flush-file namestring))

)