LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031320. :SYSTEM-TYPE :LOGICAL :VERSION 15. :TYPE "LISP" :NAME "DISK-LABEL-INTERMEDIATES" :DIRECTORY ("REL3-SOURCE" "IO") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758637132. :AUTHOR "REL3" :LENGTH-IN-BYTES 10359. :LENGTH-IN-BLOCKS 11. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                ;;; -*- 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 (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) 1980, Massachusetts Institute of Technology;;; Copyright (C) 1984,1987 Texas Instruments Incorporated. All rights reserved.;;;;;; Edit History;;;;;;                   Patch;;;   Date    Author  Number   Description;;;------------------------------------------------------------------------------;;; 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.(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)  (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)  (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*))  "Given a HOST:PACK-NAME in the disk label, this will return just the HOST portion."  (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 0. COLON-FOUND)      ())))(WHEN SUB-PACK-NAME  (SETQ PACK-NAME SUB-PACK-NAME)))      (UNLESS DECODEDP(DISPOSE-OF-UNIT UNIT)))    PACK-NAME))  ;; Rel 3.0 - changed to use the configuration partition (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 configurationband, 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 argumentcan 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, orthe 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 specifedin the CFG-BAND are returned.  If using the old boot without a configurationband, 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 argumentcan 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, orthe first CFG band on the default disk is used."  (current-band unit t :cfg-unit cfg-unit :cfg-band cfg-band))(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)))  (DEFUN UPDATE-PARTITION-COMMENT (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))))))  (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)))  f partitions existing on MACHINES.MACHINES defaults to all free Lisp machines.Only partitions whose names start with WHICH are mentioned.WHICH defaults to \"LOD\"."  (CHECK-ARG WHICH (OR (STRINGP WHICH) (EQ WHICH T)) "a string or T")  (PROGN    (DOLIST (M MACHINES)      (UNWIND-PROTECT (SETF(VALUES UNIT DONT-DISPOSE)(DECODE-UNIT-ARGUMENT M "Examining Label"))(SETQ PARTITION-LIST (PARTITION-LIST () UNIT))(UNLESS DONT-DISPOSE  (DISPOSE-OF-UNIT UNIT)))      (DOLIST (PARTITION PARTITION-LIST)(AND (OR (EQ WHICH T) (STRING-EQUAL (CAR PARTITION) WHICH :end1 WL :end2 WL))     (PLUSP (LENGTH (FOURTH PARTITION)))     (IF (SETQ TEM (ASSOC (FOURTH PARTITION) PARTITION-LIST-ALIST :TEST #'EQUAL)) (RPLACD (LAST TEM) (CONS (LIST M (FIRST PARTITION)) ())) (PUSH (LIST* (FOURTH PARTITION) (LIST M (FIRST PARTITION)) ()) PARTITION-LIST-ALIST))))))  (SETQ PARTITION-LIST-ALIST (SO