LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031322. :SYSTEM-TYPE :LOGICAL :VERSION 19. :TYPE "LISP" :NAME "DISK-LABEL-PRIMITIVES" :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 2758637159. :AUTHOR "REL3" :LENGTH-IN-BYTES 11686. :LENGTH-IN-BLOCKS 12. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                   ;;; -*- Mode:Common-Lisp; Package:SI; 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) 1985,1987 Texas Instruments Incorporated. All rights reserved.;;; Edit History;;;;;;                   Patch;;;   Date    Author  Number   Description;;;------------------------------------------------------------------------------;;;   10-9-86  MBC     ---     Change SUBSTRING to SUBSEQ.  (One NSUBSTRING remains.);;;Add :START to Read-From-String call in Decode-Unit-Argument.;;;   8-4-86   MBC     ---      Move PAD-NAME-FIELD and *PARTITION-NAME-CASE-SENSITIVE*;;; from Disk-label-editor file, so they'll be defined;;; for Find-Disk-Partiiton.;;; 01-31-86   ab       --     Common Lisp conversion for VM2.;;;                            These functions originally came from IO;DISK;;;                              and DLEDIT.;;; 10-15-86   ab       --     Changes for 2K page-size. ;;; 02-17-87   DAB      --     Change to base 10.;;; 03.23.87   DAB      --     Added partition-name-string support.;;; This file contains the minimum disk-label accessing support routines needed;;; for disk i/o (in the absence of the full disk-label editor).(DEFPARAMETER LABEL-VERSION 2.)  (DEFVAR *MAX-PTBL-SIZE* 9.   "The maximum number of blocks that can be used for the partition table.") ;New 12-12-85(DEFVAR *PARTITION-NAME-CASE-SENSITIVE* ()) ;global flag for case sensitive. If t partition                                                ; name will not be mapped to uppercase(DEFUN PAD-NAME-FIELD (IN-STRING REQUIRED-LENGTH);new function  "Returns a string of length required-length with trailing blanks"  (LET (OUT-STRING-EXIT)    (IF (SYMBOLP IN-STRING)(SETF IN-STRING (STRING IN-STRING)))    (DO ((I (LENGTH IN-STRING) (1+ I)) (OUT-STRING IN-STRING (STRING-APPEND OUT-STRING " ")))((>= I REQUIRED-LENGTH) (SETF OUT-STRING-EXIT       (IF *PARTITION-NAME-CASE-SENSITIVE*   (STRING OUT-STRING)   (STRING-UPCASE OUT-STRING))))))) (DEFUN GET-DISK-STRING (RQB WORD-ADDRESS N-CHARACTERS &OPTIONAL (SHARE-P NIL))  "Return a string containing the contents of a part of RQB's data.The data consists of N-CHARACTERS characters starting at data word WORD-ADDRESS.  (The first word of data is WORD-ADDRESS = 0).SHARE-P non-NIL means return an indirect array that overlaps the RQB."  (COND    (SHARE-P     (NSUBSTRING (RQB-8-BIT-BUFFER RQB) (* 4. WORD-ADDRESS) (+ (* 4. WORD-ADDRESS) N-CHARACTERS)))    (T     (LET* ((STR     (SUBSEQ (RQB-8-BIT-BUFFER RQB) (* 4. WORD-ADDRESS)(+ (* 4. WORD-ADDRESS) N-CHARACTERS)))    (IDX (POSITION 0. (THE STRING (STRING STR)) :FROM-END T :TEST-NOT #'CHAR-EQUAL)))       (ADJUST-ARRAY STR (LIST (IF IDX (1+ IDX) 0.)))       STR))))  (DEFUN PUT-DISK-STRING (RQB STR WORD-ADDRESS N-CHARACTERS)  "Store the contents of string STR into RQB's data at WORD-ADDRESS.N-CHARACTERS characters are stored, padding STR with zeros if it is not that long."  (LET ((START (* 4. WORD-ADDRESS))(END (+ (* 4. WORD-ADDRESS) N-CHARACTERS)))    (ARRAY-INITIALIZE (RQB-8-BIT-BUFFER RQB) 0. START END)    (COPY-ARRAY-PORTION STR 0. (LENGTH STR) (RQB-8-BIT-BUFFER RQB) START(MIN END (+ START (LENGTH STR))))))  (DEFUN WRITE-DISK-LABEL (RQB UNIT)  (OR (STRING-EQUAL (GET-DISK-STRING RQB 0. 4.) "LABL")     (FERROR () "Attempt to write garbage label"))  (DISK-WRITE RQB UNIT 0. 1.)  (DISK-WRITE RQB UNIT (AREF-32B (RQB-BUFFER RQB) %DL-PARTITION-TABLE-START)      (AREF-32B (RQB-BUFFER RQB) %DL-PARTITION-TABLE-LENGTH) T 1.)) (DEFUN READ-DISK-LABEL (UNIT &AUX RQB (RQB1 (GET-DISK-RQB)))  (UNWIND-PROTECT      (PROGN(DISK-READ RQB1 UNIT 0.);; Continue only if this looks like a valid label.(WHEN (AND (STRING-EQUAL (GET-DISK-STRING RQB1 %DL-BASE 4.) "LABL")   (<= (GET-DISK-FIXNUM RQB1 %DL-VERSION) LABEL-VERSION))  ;; Make Disk-Label-Buffer-RQB  (if needed) this needs to be changed  (LET ((RQB-SIZE (1+ *MAX-PTBL-SIZE*)));ALLOWS EXPANDABLE UP TO (-1 (* 16. 9) = 143.    (SETQ RQB (GET-DISK-RQB RQB-SIZE))    ;; copy first block into disk label buffer since buffer changed.    (COPY-ARRAY-PORTION (RQB-BUFFER RQB1) 0. (* 2. disk-block-word-size)(RQB-BUFFER RQB) 0. (* 2. disk-block-word-size))    (DISK-READ RQB UNIT (AREF-32B (RQB-BUFFER RQB) %DL-PARTITION-TABLE-START)       (AREF-32B (RQB-BUFFER RQB) %DL-PARTITION-TABLE-LENGTH) T 1.)))(AND RQB1 (RETURN-DISK-RQB RQB1)))    ())  RQB) (DEFUN GET-PACK-NAME (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*))  "Returns the disk pack name from the pack name field in the 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 (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-EQUAL))     (SUB-PACK-NAME (IF COLON-FOUND      (SUBSEQ PACK-NAME (1+ COLON-FOUND))      ())))(WHEN SUB-PACK-NAME  (SETQ PACK-NAME SUB-PACK-NAME)))      (UNLESS DECODEDP(DISPOSE-OF-UNIT UNIT)))    PACK-NAME)) (DEFUN NEW-GET-PACK-NAME (UNIT &AUX RQB PACK-NAME)  (UNWIND-PROTECT (PROGN   (SETQ RQB (READ-DISK-LABEL UNIT))   (when rqb (SETQ PACK-NAME (GET-DISK-STRING RQB %DL-VOLUME-NAME 16.))))    (RETURN-DISK-RQB RQB))  PACK-NAME)  (DEFUN GET-PARTITION-LIST (&OPTIONAL TYPE PROCESSOR-TYPE unit);!!! add processor type UNIX Support 03.25.87 DAB Add unit  "Returns all of the partitions of type TYPE from all disk devices currently online.  You have to pass the type as one of the %PT-type-mumble types as defined in qdev.  This function should only be used for explorer disks with attribute bits.  PROCESSOR-TYPE can be of type %PT-type-mumble, a number, or any valid user/cpu extension.  USe PRINT-PARTITION-USER-TYPES  to view valid extensions.  Returns a list of list <unit> <name> <attributes> <Starting block> <Length> <Comment> <Partiton-name-string>." ;03.26.87 DA  (LET (PARTITIONS decodedp)    ;; For all online disk units.    (unless (closurep unit)      (MULTIPLE-VALUE-SETQ (UNIT DECODEDP)(DECODE-UNIT-ARGUMENT UNIT "reading label")))    (setq processor-type (select-user-type processor-type));03.19.87 DAB    (when  (and unit (not (listp unit))) (setf unit (list unit)));03.25.87 DAB    (DOLIST (UNIT (if unit unit (ALL-DISK-UNITS)));03.25.87 DAB      (WITH-RQB (DISK-LABEL (READ-DISK-LABEL UNIT));; For all partitions in this label.(WHEN DISK-LABEL;ignore disks without LABLs  (DO ((N-PARTITIONS (GET-DISK-FIXNUM DISK-LABEL (+ %PT-BASE %PT-NUMBER-OF-PARTITIONS)))       (WORDS-PER-PART (GET-DISK-FIXNUM DISK-LABEL (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES)))       (I 0 (1+ I))       (LOC (+ %PT-BASE %PT-PARTITION-TABLE-OVERHEAD-SIZE) (+ LOC WORDS-PER-PART)))      ((= I N-PARTITIONS))    ;; If this partition qualifies.    (WHEN (and (if (NULL TYPE) T  ;03.26.87 DAB                           (= TYPE      (LDB %%BAND-TYPE-CODE (GET-DISK-FIXNUM DISK-LABEL (+ LOC %PD-ATTRIBUTES)))))       (IF (NULL PROCESSOR-TYPE) T   (= PROCESSOR-TYPE      (LDB %%CPU-TYPE-CODE   (GET-DISK-FIXNUM DISK-LABEL (+ LOC %PD-ATTRIBUTES)))))       )      ;; Add this partition to list.      (SETQ PARTITIONS    (NCONC PARTITIONS   (LIST     (LIST UNIT (GET-DISK-STRING DISK-LABEL (+ LOC %PD-NAME) 4)   (GET-DISK-FIXNUM DISK-LABEL (+ LOC %PD-ATTRIBUTES))   (GET-DISK-FIXNUM DISK-LABEL (+ LOC %PD-START))   (GET-DISK-FIXNUM DISK-LABEL (+ LOC %PD-LENGTH))   (GET-DISK-STRING DISK-LABEL (+ LOC %PD-COMMENT);03.23.87 DAB    ;; get the partition comment length from the label         (* 4       (- (GET-DISK-FIXNUM DISK-LABEL  (+ %PT-BASE     %PT-SIZE-OF-PARTITION-ENTRIES)) (GET-DISK-FIXNUM DISK-LABEL  (+ %PT-BASE     %PT-COMMENT-UNKNOWN)))))   (string-append  (GET-DISK-STRING DISK-LABEL (+ LOC %PD-NAME) 4)   ".";03.23.87 DAB   (si:keyword-user-type     (ldb si:%%cpu-type-code (GET-DISK-FIXNUM disk-label (+ LOC %PD-ATTRIBUTES)))))   ))   )))))))    (UNLESS DECODEDP;03.25.87 DAB      (DISPOSE-OF-UNIT (car UNIT)))    PARTITIONS))(DEFUN SYMBOLIC-CHAOS-ADDRESS (NUM)  (GET-HOST-FROM-ADDRESS NUM :CHAOS)) ;;; MBC 7-18-86   Z-To-C(Defun Decode-Unit-Argument (Unit Use &Optional Ignore (Write-P Nil) &Aux Tem)  "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    ((Numberp Unit) Unit);Local disk    ((And (Stringp Unit);Magtape interface.  (String-Equal Unit "MT" :END1 2)) (Fs::Make-Band-Magtape-Handler Write-P))    ((And (Symbolp Unit) (Decode-Local-Pack-Names Unit)))    ((And (Stringp Unit);This fix is incomplete; disable till finished. 10-6-86 MBC;  (not (Position #\: (The String (String Unit)) :Test #'Char-Equal));avoid EH: problem  (Decode-Local-Pack-Names (Ignore-Errors (Read-From-String Unit)))))    ((Stringp Unit)     (If (Zerop (Length Unit)) (Ferror () "Unit is an empty string."))     ;;make @lm1 work as well as lm1     ;;if a host is stupid enuf to have a name like @Losing  then use @@Losing     (If (String-Equal #\@ (Subseq Unit 0 1)) (Setq Unit (Subseq Unit 1)))     (Let ((Host-String     (Subseq Unit 0(Setq Tem (Position #\: (The String (String Unit)) :Test #'Char-Equal))))   (Remote-Disk-Unit (If (Null Tem) () (Read-From-String Unit () () :START (1+ Tem)))))       (Declare (Special Remote-Disk-Unit))       (If (Or (Zerop (Length Host-String)) (Send Local-Host :Pathname-Host-Namep Host-String))   (If Remote-Disk-Unit       (Decode-Local-Pack-Names Remote-Disk-Unit)       *Default-Disk-Unit*)   (Let ((Remote-Disk-Conn   ;;Open connection to foreign disk   ;;; Load macro from CHAOS;CHAOS-USER before compiling.  10-01-86 MBC   (Chaos:Connect Host-String "REMOTE-DISK" 25.)) (Remote-Disk-Stream))     (Declare (Special Remote-Disk-Conn Remote-Disk-Stream))     (And (Stringp Remote-Disk-Conn)  (Ferror () "Cannot connect to ~S: ~A" Unit Remote-Disk-Conn))     (Setq Remote-Disk-Stream (Chaos:Make-Stream Remote-Disk-Conn))     (Format Remote-Disk-Stream "SAY Disk being hacked remotely by ~A@~A -- ~A~%" User-Id     (Symbolic-Chaos-Address Chaos:My-Address) Use)     (Funcall Remote-Disk-Stream :Force-Output)     (Values       (Closure '(Remote-Disk-Conn Remote-Disk-Stream Remote-Disk-Unit)'Remote-Disk-Handler)       ())))))    (T (Values Unit T))))(DEFUN DECODE-LOCAL-PACK-NAMES (UNIT)  "tries to return a unit number when given a pack name"  (IF UNIT    (IF (NUMBERP UNIT)      UNIT      (PROGN(WHEN (SYMBOLP UNIT)  (SETQ UNIT (SYMBOL-NAME UNIT)))(DOTIMES (INDEX DISK-TYPE-TABLE-LENGTH NIL)  (IF (STRING-EQUAL UNIT (GET-PACK-NAME-FROM-TABLE INDEX))    (RETURN INDEX)))))    ())) ;;; Only funcall valid UNITs.  Number and NIL are not valid.  12-6-85 MBC(DEFUN DISPOSE-OF-UNIT (UNIT)  (OR (NUMBERP UNIT) (NULL UNIT) (FUNCALL UNIT :DISPOSE)))  band of this processor type  with the default bit set. It will return a string of the partition name of the first partition   which it finds."  (unless cpu-type (setf cpu-type (cpu-type)));03.25.87  (setq cpu-type (select-user-type cpu-type)) ;03.23.87 DAB  (LOOP FOR INDEX FROM (+ %PT-BASE %PT-PARTITION-DESCRIPTORS) TO(+ %PT-BASE %PT-PARTITION-DESCRIPTORS   (* (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-NUMBER-OF-PARTITIONS))      (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES))))BY (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-SIZE-OF-PARTITION-ENTRIES)) DO(IF (AND      (= (L