;;; -*- 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 (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) 1985-1989 Texas Instruments Incorporated. All rights reserved. ;;; ;;; Edit History ;;; ;;; Patch ;;; Date Author Number Description ;;;------------------------------------------------------------------------------ ;;; 10-21-88 DAB Added remote-disk-host to the closure to support remote-disk to a microExplorer. ;;; 10-5-88 ab disk-io 5-3 ;;; Fix GET-PARTITION-LIST on remote Explorer disks from mX. ;;; 8/29/88 ab disk-io 5-1 ;;; Two minor bug fixes for mX. ;;; 04-22-88 ab disk-io 4-9 ;;; Fix GET-PARTITION-DESCRIPTOR for microexplorer--make it ;;; always put logical unit in list, not physical. Also always ;;; pad partition name to 4 characters like Explorer does. ;;; 03.02.88 MBC Give :DISKless versions of get-pack-name proper arg list. ;;; 01.11.88 MBC Use Resource-Present-P conditionals. ;;; 10.16.87 MBC ADDIN conditionals. (define-unless :DISK (DEFCONSTANT consider-all -1) (DEFUN Get-Partition-Descriptor (n acb &optional (start-offset %GPL-Partition-Descriptor-Start)) (LET* ((start-byte (+ start-offset (* n Addin-Partition-Descriptor-Size))) (unit (add:parm-16b acb (add:16b-parm-number %APD-Physical-Unit start-byte))) (type (add:parm-16b acb (add:16b-parm-number %APD-Type start-byte))) (start-block (add:parm-32b acb (add:32b-parm-number %APD-Start-Block start-byte))) (size (add:parm-32b acb (add:32b-parm-number %APD-Size start-byte))) (name (add:get-acb-string acb (+ start-byte %APD-Name))) (comment (add:get-acb-string acb (+ start-byte %APD-Comment)))) (LIST ;; mX returns phys unit--convert to logical (npi-phys-to-log unit) ;; name may be < 4 characters. "canonicalize" by padding. (IF (>= (LENGTH (THE string name)) 4.) name (SETQ name (pad-name-field name 4.))) type start-block size comment ;; construct long-name (STRING-APPEND name ".EXPLORER") )) ) (DEFUN Get-Partition-List-Number-Entries (&optional type disk-unit) "Returns the number of partitions of type TYPE on real DISK-UNIT." (UNLESS type (SETQ type consider-all)) (CHECK-ARG type (NUMBERP type) "a number") (UNLESS disk-unit (SETQ disk-unit consider-all)) (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-Number-Partition-List-Entries) ;; Input parameters (add:load-parms-16b acb disk-unit type) ;; Execute command (add:transmit-packet-and-wait acb ch) (add:check-error acb) ;; Return values (add:parm-16b acb (add:16b-parm-number %GPL-Number-Partition-Entries))) (setf (add:requestor-complete acb) t) (add:return-acb-fast acb)))) ;;End of DEFINE-UNLESS ) ;;ab 10/5/88. Fix GET-PARTITION-LIST to work on remote Explorer disks. (DEFUN GET-PARTITION-LIST (&optional type processor-type disk-unit) (COND ((OR (CLOSUREP disk-unit) (resource-present-p :disk)) (get-partition-list-explorer type processor-type disk-unit)) (t (get-partition-list-microExplorer type processor-type disk-unit)))) ;;ab 10/5/88. Fix GET-PARTITION-LIST to work on remote Explorer disks. (Defun GET-PARTITION-LIST-explorer (&optional type processor-type disk-unit) "Returns all of the partitions of type TYPE from online disk device DISK-UNIT; each as a list: ( ). 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. When DISK-UNIT is nil, all disks are used. PROCESSOR-TYPE is an integer used to screen for partitions by processor type. If PROCESSOR-TYPE is T, all processor types are returned. If PROCESSOR-TYPE is nil, only this Explorer CPU type and Generic types are returned." (DECLARE (UNSPECIAL processor-type)) (Let ((Nupi-SLot (Ldb (Byte 4 0) Nupi-Slot-Number)) (Config (Get-Configuration)) Partitions Decodep) ;; Convert arguments as needed: (unless (eq Processor-Type T) (Setf Processor-Type (Select-User-Type Processor-Type))) (Unless (Closurep Disk-Unit) (Multiple-Value-Setq (Disk-Unit Decodep) (Decode-Unit-Argument Disk-Unit "Reading Label"))) (When (And Disk-Unit (Not (Listp Disk-Unit))) (Setf Disk-Unit (List Disk-Unit))) ;; For all online disk units, (Dolist (Unit (Or Disk-Unit (All-Disk-Units))) (With-Rqb (Disk-Label (Read-Disk-Label Unit)) ;; For all partitions in this label, (When Disk-label ; ignore disks without LABLs (Let ((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)))) (Dotimes (I N-Partitions) (Let* ((Loc (+ %PT-BASE %PT-PARTITION-TABLE-OVERHEAD-SIZE (* I Words-Per-Part))) (Attributes (Get-Disk-Fixnum Disk-Label (+ Loc %PD-ATTRIBUTES))) (Part-Type (Ldb %%BAND-TYPE-CODE Attributes)) (Cpu-Type (Ldb %%CPU-TYPE-CODE Attributes)) (Crom-Cpu-Type (Crom-Cpu-Type)) (Default (Not (Zerop (Ldb %%DEFAULT-INDICATOR Attributes)))) (Name (Get-Disk-String Disk-Label (+ Loc %PD-NAME) 4)) (Comment-Len (* 4 (- Words-Per-Part (Get-Disk-Fixnum Disk-Label (+ %PT-BASE %PT-COMMENT-UNKNOWN)))))) ;; Each partition qualifies -- (When (And ; when it satisfies processor type (If Processor-Type (Or (Eq Processor-Type T) (Eq Processor-Type Cpu-Type)) (Or (Eq Cpu-Type %CPU-GENERIC-BAND) (Eq Cpu-Type Crom-Cpu-Type) (Eq Cpu-Type %CPU-EXPLORER))) ; allow Exp-II use of Exp-I bands for now. (Or (Null Type) (= Part-Type Type)) ;; and (if page or file partition), is allocated by the config module: (If (assoc part-type *CFG-controlled-partition-types-alist* :test #'eq) (Partition-Owned-P Part-Type Name Unit Nupi-Slot Default Config) T) ; T if not page or file band. ) ; and ;; It qualifies -- add this partition to the list. (Setq Partitions (Nconc Partitions (List (List Unit Name 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) Comment-Len) (String-Append Name "." (Si:Keyword-User-Type Cpu-Type)) ) ; list ) ; List ) ; nconc ) ; setq ) ; when ) ; let ) ; dotimes ) ; Let ) ; When ) ; with rqb ) ; Dolist (Unless Decodep (Dispose-Of-Unit (Car Disk-Unit))) Partitions) ) ;;ab 10/5/88. Fix GET-PARTITION-LIST to work on remote Explorer disks. (DEFUN GET-PARTITION-LIST-microExplorer (&optional type processor-type disk-unit) "Returns a list of partition descriptors for all partitions of type TYPE on DISK-UNIT." (DECLARE (UNSPECIAL processor-type) (IGNORE processor-type)) (UNLESS type (SETQ type consider-all)) (CHECK-ARG type (NUMBERP type) "a number") (UNLESS disk-unit (SETQ disk-unit consider-all)) (UNLESS (EQL disk-unit consider-all) (SETQ disk-unit (get-real-unit disk-unit))) (LET ((num-entries (get-partition-list-number-entries type disk-unit))) (WHEN num-entries (let ((acb (add:get-acb (* (1+ num-entries) ;1 extra for overhead (+ 16. Addin-Partition-Descriptor-Size)) t)) ;ab 8/29/88 (ch (add:find-channel Disk-Channel))) (unwind-protect (progn ;; Fill in command overhead (add:init-acb acb %MC-Disk-Cmd %DC-Get-Partition-List) ;; Input parameters (add:load-parms-16b acb disk-unit type) ;; Execute command (add:transmit-packet-and-wait acb ch) (add:check-error acb) ;; Return values (LOOP for i from 0 below num-entries collecting (get-partition-descriptor i acb) into pd-list finally (RETURN pd-list))) (setf (add:requestor-complete acb) t) (add:return-acb-fast acb)))))) ;;; Addin conditional... (define-when :DISK (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.)) ;;; End of Unless :DISK inclusion. ) ;;ab 8/29/88. Make one version of READ-DISK-LABEL that supports remote host access. (DEFUN READ-DISK-LABEL (UNIT &AUX RQB (RQB1 (GET-DISK-RQB))) ;ab - Support editing exp disks from mx. (COND ((OR (resource-present-p :disk) (CLOSUREP unit)) (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) (t (FERROR nil "Read disk label not supported on microExplorer.")))) (defun (:cond (not (resource-present-p :DISK)) GET-PACK-NAME) (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*)) ;3.2.88 MBC (get-volume-name unit)) (DEFUN (:cond (resource-present-p :DISK) 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 (:cond (not (resource-present-p :DISK)) NEW-GET-PACK-NAME) (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*)) ;3.2.88 MBC (get-volume-name unit)) (DEFUN (:cond (resource-present-p :DISK) 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 SYMBOLIC-CHAOS-ADDRESS (NUM) (GET-HOST-FROM-ADDRESS NUM :CHAOS)) (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))))) ())) (DEFUN DISPOSE-OF-UNIT (UNIT) (OR (NUMBERP UNIT) (NULL UNIT) (FUNCALL UNIT :DISPOSE))) (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) (remote-disk-host (parse-host host-string))) ;10-19-88 DAB (Declare (Special Remote-Disk-Conn Remote-Disk-Stream remote-disk-host )) (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-host) ;10-21-88 DAB 'Remote-Disk-Handler) ()))))) (T (Values Unit T))))