LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031324. :SYSTEM-TYPE :LOGICAL :VERSION 21. :TYPE "LISP" :NAME "DISK-PARTITION" :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 2758637199. :AUTHOR "REL3" :LENGTH-IN-BYTES 51033. :LENGTH-IN-BLOCKS 50. :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-15-86   ab      --      - Changes for 2K page-size. ;;; 12-11-86   ab              - More 2K fixes.;;; 12/18/86   hw              - When copying disk partition to remote system,;;;                              don't release destination unit until copy is complete.;;; 01-12-86   MBC       - Two fixes for load-mcr-file: Byte swap only Explorer I,;;; and flush last disk block to disk when partially valid.;;; 01-28-87   KB              - Modify Print-Herald for better description of partitions.;;;                              Modify *Legal-Notice* to be two lines, make current legal notice;;;                              into *Full-Legal-Notice*. Added functions First-Print-Herald,;;;                              Initial-Screen-Heading, and TI-Show-Legal-Notice.;;; 02-06-87  DAB              - Describe-partition numbers were not converted to base 10.;;; 02-16-87  DAB              - Describe-partition did not recognize rel2 compressed load band. Now it does.;;; 02.24.87  MBC Make PARSE-MCR-FILE-FOR-VERSION be dependent on CPU type.;;; 02-25-87  HW               - change eh:*ucode-name-alist* to sys:* microcode-name-alist*;;; 03.12.87  DAb for BICE     - Print-herald changes;;; 03.17.87 DAB               - Added new partition type ANCHOR BAND.;;; 03.23.87 DAB               - Added parse-partition-name capabilities. Lots of small changes.;;; 03.31.87 KB                - Changed Initial-Screen-Heading and First-Print-Herald to move instructional text.;;; 04.07.87 DAB               - Fixed Describe-partition to check processor type before getting the true microcode;;;                              version. The offsets are diffenent for Explorer II.;;; Unit is unit number on local disk controller or a string.;;; If a string, TEST is a source of test data;;; MT is magtape;;;  otherwise it is assumed to be the chaosnet name of a remote machine.(PROCLAIM '(SPECIAL BAND-FORMAT-IS-COMPRESSED-CODE)) ;;; :READ-COMPARE not supported, nothing uses it.(DEFUN REMOTE-DISK-HANDLER (OP &REST ARGS)  (DECLARE (SPECIAL REMOTE-DISK-CONN REMOTE-DISK-STREAM REMOTE-DISK-UNIT))  (CASE OP    (:READ     (LET ((RQB (FIRST ARGS))   (BLOCK (SECOND    ARGS))   (OFFSET (THIRD ARGS))   (N-BLOCKS (FOURTH ARGS)))       (FORMAT REMOTE-DISK-STREAM "READ ~D ~D ~D~%" REMOTE-DISK-UNIT BLOCK N-BLOCKS)       (SEND REMOTE-DISK-STREAM :FORCE-OUTPUT)       (DO ((BLOCK (-     BLOCK     OFFSET)      (1+ BLOCK))    (N-BLOCKS N-BLOCKS (1- N-BLOCKS))    (BLOCK-PKT-1 (GET-DISK-STRING RQB (* disk-block-word-size OFFSET) 484. T))    (BLOCK-PKT-2 (GET-DISK-STRING RQB (+ 121. (* disk-block-word-size OFFSET)) 484. T))    (BLOCK-PKT-3 (GET-DISK-STRING RQB (+ 242. (* disk-block-word-size OFFSET)) 56. T)))   ((ZEROP N-BLOCKS) (RETURN-ARRAY BLOCK-PKT-3) (RETURN-ARRAY BLOCK-PKT-2)    (RETURN-ARRAY BLOCK-PKT-1)) ;; Get 3 packets and form a block in the buffer ;; RECEIVE-PARTITION-PACKET will throw if it gets to eof. (RECEIVE-PARTITION-PACKET REMOTE-DISK-CONN BLOCK-PKT-1) (RECEIVE-PARTITION-PACKET REMOTE-DISK-CONN BLOCK-PKT-2) (RECEIVE-PARTITION-PACKET REMOTE-DISK-CONN BLOCK-PKT-3) ;; Advance magic strings to next block (%P-STORE-CONTENTS-OFFSET (+ (%P-CONTENTS-OFFSET BLOCK-PKT-1 3.) disk-block-byte-size)   BLOCK-PKT-1   3.) (%P-STORE-CONTENTS-OFFSET (+ (%P-CONTENTS-OFFSET BLOCK-PKT-2 3.) disk-block-byte-size)   BLOCK-PKT-2   3.) (%P-STORE-CONTENTS-OFFSET (+ (%P-CONTENTS-OFFSET BLOCK-PKT-3 3.) disk-block-byte-size)   BLOCK-PKT-3   3.))))    (:WRITE     (LET ((RQB (FIRST ARGS))   (BLOCK (SECOND    ARGS))   (OFFSET (THIRD ARGS))   (N-BLOCKS (FOURTH ARGS)))       (FORMAT REMOTE-DISK-STREAM "WRITE ~D ~D ~D~%" REMOTE-DISK-UNIT BLOCK N-BLOCKS)       (SEND REMOTE-DISK-STREAM :FORCE-OUTPUT)       (DO ((BLOCK BLOCK      (1+ BLOCK))    (N-BLOCKS N-BLOCKS (1- N-BLOCKS))    (BLOCK-PKT-1 (GET-DISK-STRING RQB (* disk-block-word-size OFFSET) 484. T))    (BLOCK-PKT-2 (GET-DISK-STRING RQB (+ 121. (* disk-block-word-size OFFSET)) 484. T))    (BLOCK-PKT-3 (GET-DISK-STRING RQB (+ 242. (* disk-block-word-size OFFSET)) 56. T)))   ((ZEROP N-BLOCKS) (RETURN-ARRAY BLOCK-PKT-3) (RETURN-ARRAY BLOCK-PKT-2)    (RETURN-ARRAY BLOCK-PKT-1)) ;; Transmit three packets from block in buffer (TRANSMIT-PARTITION-PACKET REMOTE-DISK-CONN BLOCK-PKT-1) (TRANSMIT-PARTITION-PACKET REMOTE-DISK-CONN BLOCK-PKT-2) (TRANSMIT-PARTITION-PACKET REMOTE-DISK-CONN BLOCK-PKT-3) ;; Advance magic strings to next block (%P-STORE-CONTENTS-OFFSET (+ (%P-CONTENTS-OFFSET BLOCK-PKT-1 3.)  disk-block-byte-size)   BLOCK-PKT-1   3.) (%P-STORE-CONTENTS-OFFSET (+ (%P-CONTENTS-OFFSET BLOCK-PKT-2 3.)  disk-block-byte-size)   BLOCK-PKT-2   3.) (%P-STORE-CONTENTS-OFFSET (+ (%P-CONTENTS-OFFSET BLOCK-PKT-3 3.)  disk-block-byte-size)   BLOCK-PKT-3   3.))))    (:DISPOSE (CHAOS::CLOSE-CONN REMOTE-DISK-CONN))    (:UNIT-NUMBER REMOTE-DISK-UNIT)    (:MACHINE-NAME (SYMBOLIC-CHAOS-ADDRESS (CHAOS:FOREIGN-ADDRESS REMOTE-DISK-CONN)))    (:SAY (FORMAT REMOTE-DISK-STREAM "SAY ~A~%" (CAR ARGS))  (FUNCALL REMOTE-DISK-STREAM :FORCE-OUTPUT))    (:HANDLES-LABEL NIL)))  (DEFUN RECEIVE-PARTITION-PACKET (CONN INTO)  (LET ((PKT (CHAOS:GET-NEXT-PKT CONN)))    (AND (NULL PKT) (FERROR () "Connection ~S broken" CONN))    (SELECT (CHAOS:PKT-OPCODE PKT)      (CHAOS:DAT-OP (COPY-ARRAY-CONTENTS (CHAOS:PKT-STRING PKT) INTO)    (LET ((CORRECT (AREF PKT (+ (FLOOR (ARRAY-TOTAL-SIZE INTO) 2.) 8.)))  (ACTUAL (CHECKSUM-STRING INTO)))      (OR (= CORRECT ACTUAL)  (FORMAT T "~&Checksum error, correct=~O, actual=~O~%" CORRECT ACTUAL)))    (CHAOS:RETURN-PKT PKT))      (CHAOS:EOF-OP (CHAOS:RETURN-PKT PKT) (THROW 'EOF  ()))      (CHAOS:CLS-OP       (UNWIND-PROTECT (FERROR 'REMOTE-DISK-ERROR (CHAOS:PKT-STRING PKT)) (CHAOS:RETURN-PKT PKT)))      (OTHERWISE       (FERROR () "~S is illegal packet opcode, pkt ~S, received for connection ~S"       (CHAOS:PKT-OPCODE PKT) PKT CONN)))))  (DEFUN TRANSMIT-PARTITION-PACKET (CONN OUTOF)  (LET ((PKT (CHAOS:GET-PKT)))    (COPY-ARRAY-CONTENTS OUTOF (CHAOS:PKT-STRING PKT))    (SETF (AREF PKT (+ (FLOOR (ARRAY-TOTAL-SIZE OUTOF) 2.) 8.)) (CHECKSUM-STRING OUTOF))    (setf (CHAOS:PKT-NBYTES PKT) (+ (ARRAY-TOTAL-SIZE OUTOF) 2.))    (CHAOS:SEND-PKT CONN PKT)))  (DEFUN CHECKSUM-STRING (STR)  (DO ((CKSM 0. (+ (AREF STR I) CKSM))       (I 0. (1+ I))       (N (ARRAY-TOTAL-SIZE STR)))      ((>= I N)       (LOGAND 65535. CKSM))))  ;;; Explorer I 16 bit halfwords are swapped.;;; 2nd full word of mcr file is cpu type.;;; Explorer I just happened to have ZEROs here.(defun MCR-FILE-CPU-TYPE (filename)  "Return the USER-TYPE (cpu type) of the microcode in FILENAME."  (let (cpu-type)    (WITH-OPEN-FILE (FILE FILENAME :DIRECTION :INPUT :CHARACTERS NIL :BYTE-SIZE 16.)      (send file :tyi)      (send file :tyi)      (setf cpu-type (send file :tyi)))    cpu-type))       ;;; Put a microcode file onto my own disk.(DEFUN LOAD-MCR-FILE (FILENAME PART &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*)      &AUX PART-BASE PART-SIZE RQB partition-name-string)  "Load microcode from file FILENAME into partition PART on unit UNIT.PART can be a partition name or a partition-name-string, such as \"PART.Explorer\", where \"Explorer\" is the user/cputype.UNIT can be a disk unit number or the name of a machine on the chaosnet."   ;03.23.87 DAB  (SETQ FILENAME(IF (NUMBERP FILENAME)    (SEND (PATHNAME "SYS:UBIN;CONTROL") :NEW-TYPE-AND-VERSION "MCR" FILENAME)    (MERGE-PATHNAMES FILENAME)))  (OR (MEMBER (SEND FILENAME :CANONICAL-TYPE) '(:MCR "MCR") :TEST #'EQUALP)      (FERROR () "~A is not a MCR file." FILENAME))  (SETQ UNIT(DECODE-UNIT-ARGUMENT UNIT (FORMAT () "Loading ~A into ~A partiton" FILENAME PART) () T))  (UNWIND-PROTECT (PROGN    (SETQ RQB (GET-DISK-RQB))    (MULTIPLE-VALUE-SETQ (PART-BASE PART-SIZE NIL PART nil partition-name-string) ;03.23.87 DAB      (FIND-DISK-PARTITION-FOR-WRITE PART () UNIT () "MCR"))    (UNLESS (NULL PART-BASE)      (let ((EXPLORER-1-MODE (zerop (MCR-FILE-CPU-TYPE filename))))(WITH-OPEN-FILE (FILE FILENAME :DIRECTION :INPUT      :CHARACTERS NIL :BYTE-SIZE 16.)  (BLOCK DONE    (DO ((BUF16 (ARRAY-LEADER RQB %IO-RQ-LEADER-BUFFER)) (BLOCK PART-BASE   (1+ BLOCK)) (N PART-SIZE (1- N)))((ZEROP N) (FERROR () "Failed to fit in partition"))      (DO ((LH)   (RH)   (I 0. (+ I 2.)))  ((= I 512.)   (DISK-WRITE RQB UNIT BLOCK))(if EXPLORER-1-MODE;Do correct byte swap    (SETQ LH (FUNCALL FILE :TYI)  RH (FUNCALL FILE :TYI))    (SETQ RH (FUNCALL FILE :TYI)  LH (FUNCALL FILE :TYI)))(COND  ((OR (NULL LH) (NULL RH))   (unless (zerop I)     (DISK-WRITE RQB UNIT BLOCK));Force last block if neccessary   (UPDATE-PARTITION-COMMENT  partition-name-string (MICROCODE-NAME FILENAME) UNIT);03.23.87   (RETURN-FROM DONE ())))(SETF (AREF BUF16 I) RH)(SETF (AREF BUF16 (1+ I)) LH))))))))    (DISPOSE-OF-UNIT UNIT)    (RETURN-DISK-RQB RQB)))  ;;;  Form a partition name by appending the filename to the internal;;;  microcode version.  The filename is truncated in preference to lopping;;;  off the version.(DEFUN MICROCODE-NAME (FILENAME)  (LET ((NAME (PATHNAME-NAME FILENAME))(VERSION (FORMAT () "~d" (PARSE-MCR-FILE-FOR-VERSION FILENAME))))    (STRING-APPEND (SUBSEQ NAME 0. (MIN (LENGTH NAME) (- 15. (LENGTH VERSION)))) " " VERSION)))  ;;;  Look in a MCR file for the internal microcode version number;;;  If Explorer I then its in 4h word, otherwise its in 3rd word.;;;     2.24.87 MBC(DEFUN PARSE-MCR-FILE-FOR-VERSION (FILENAME)  (let (cpu-type lh rh)    (WITH-OPEN-FILE (MCR-FILE FILENAME :DIRECTION :INPUT :CHARACTERS NIL :BYTE-SIZE 16.)      (send MCR-FILE :tyi)      (send MCR-FILE :tyi)      (setf cpu-type (send MCR-FILE :tyi))      (send mcr-file :tyi)      (if (zerop cpu-type);Explorer 1 ==> needs byte swap  (progn    (LOOP REPEAT 2. DOING (SEND MCR-FILE :TYI));and version is in 4th full word    (setf LH (SEND MCR-FILE :TYI)  RH (SEND MCR-FILE :TYI)))  (setf RH (SEND MCR-FILE :TYI);Other ==> no swapLH (SEND MCR-FILE :TYI)));version is in 3rd full word      (dpb LH (byte 16. 16.) (dpb RH (byte 16. 0.) 0.)))))(DEFUN SYS-COM-block-NUMBER (16B-BUFFER INDEX)  (* disk-blocks-per-page     (ldb %%va-page-number  (get-16b-array-word 16b-buffer index))))(defun sys-com-page-number (16B-BUFFER INDEX)  (ldb %%va-page-number       (get-16b-array-word 16b-buffer index)))(DEFUN lod-partition-info (rqb unit part-base &aux buf)  (DISK-READ RQB UNIT (+ PART-BASE disk-blocks-per-page))  (SETQ buf (rqb-buffer rqb))  (LET ((compressed (AREF BUF (* 2 %SYS-COM-BAND-FORMAT)))(size (SYS-COM-block-NUMBER BUF %SYS-COM-VALID-SIZE))(ucode (AREF BUF (* 2 %SYS-COM-DESIRED-MICROCODE-VERSION)))(highest-va (SYS-COM-PAGE-NUMBER BUF %SYS-COM-HIGHEST-VIRTUAL-ADDRESS)))    (IF (= band-format-is-compressed-code compressed);; 2K band. Everything is ok(VALUES size ucode compressed highest-va)(VALUES  (PROGN    (DISK-READ RQB UNIT (+ PART-BASE 1));old SCA location    (SYS-COM-block-NUMBER BUF 1));old location of valid-size  (AREF BUF (* 2 24.));old location of desired ucode  (AREF BUF (* 2 8.));old location of band format code  (SYS-COM-PAGE-NUMBER BUF 25.))));old location of highest va  )(DEFUN COPY-DISK-PARTITION-BACKGROUND (FROM-UNIT FROM-PART TO-UNIT TO-PART STREAM STARTING-HUNDRED)  (PROCESS-RUN-FUNCTION "copy partition"#'(LAMBDA (FU FP TU TP *TERMINAL-IO* SH)    (COPY-DISK-PARTITION FU FP TU TP 10. 300. SH))FROM-UNIT FROM-PART TO-UNIT TO-PART STREAM STARTING-HUNDRED))  ;;; Copying a partition from one unit to another(DEFUN COPY-DISK-PARTITION (FROM-UNIT FROM-PART TO-UNIT TO-PART &OPTIONAL (N-blocks-AT-A-TIME 85.) (DELAY NIL)    (STARTING-HUNDRED 0.) (WHOLE-THING-P NIL) &AUX FROM-PART-BASE FROM-PART-SIZE TO-PART-BASE    TO-PART-SIZE RQB PART-COMMENT to-partition-name-string  from-partition-name-string);03.23.87 DAB  "Copy partition FROM-PART on FROM-UNIT to partition TO-PART on TO-UNIT.FROM-PART and TO-PART can be partition names or partition-name-strings, such as \"PART.Explorer\", where \"Explorer\" isthe user/cpu type.While names of other machines can be specified as units, this is not very fast for copying between machines.  Use SI:RECEIVE-BAND or SI:TRANSMIT-BAND for that."  (SETQ FROM-UNIT (DECODE-UNIT-ARGUMENT FROM-UNIT (FORMAT () "reading ~A partition" FROM-PART))TO-UNIT (DECODE-UNIT-ARGUMENT TO-UNIT (FORMAT () "writing ~A partition" TO-PART) () T))  (UNWIND-PROTECT (PROGN    (SETQ RQB (GET-DISK-RQB N-blocks-AT-A-TIME))    (MULTIPLE-VALUE-SETQ      (FROM-PART-BASE FROM-PART-SIZE nil from-part nil from-partition-name-string);03.23.87 DAB      (FIND-DISK-PARTITION-FOR-READ FROM-PART () FROM-UNIT)) ;CONFIRM-read is T, prompt for duplicates.    (MULTIPLE-VALUE-SETQ      (TO-PART-BASE TO-PART-SIZE nil to-part nil to-partition-name-string);03.23.87 DAB      (FIND-DISK-PARTITION-FOR-WRITE TO-PART () TO-UNIT))  ;CONFIRM-write is T, prompt for duplicates.    (WHEN TO-PART-BASE      (SETQ PART-COMMENT (PARTITION-COMMENT  from-partition-name-string FROM-UNIT)) ;03.23.87 DAB      (FORMAT T "~&Copying ~S" PART-COMMENT)      (AND(OR (NUMBERP FROM-PART)    (STRING-EQUAL FROM-PART "LOD" :START1 0. :END1 3. :START2 0. :END2 3.))(NOT WHOLE-THING-P)(NOT  (AND (CLOSUREP FROM-UNIT)       (EQ (CLOSURE-FUNCTION FROM-UNIT) 'FS::BAND-MAGTAPE-HANDLER)))(LET (RQB size)  (UNWIND-PROTECT      (PROGN(SETQ rqb (get-disk-rqb disk-blocks-per-page))(SETQ size (lod-partition-info rqb from-unit from-part-base))(COND  ((AND (> SIZE 8.) (<= SIZE FROM-PART-SIZE))   (SETQ FROM-PART-SIZE SIZE)   (FORMAT T   "... using measured size of ~D. blocks."   SIZE))))    (RETURN-DISK-RQB RQB))))      (WHEN (> FROM-PART-SIZE TO-PART-SIZE)(FERROR ()"Source partition length, ~D. blocks, is larger than destination length, ~D."FROM-PART-SIZE TO-PART-SIZE))      (FORMAT T "~%")      (UPDATE-PARTITION-COMMENT  to-partition-name-string "Incomplete Copy" TO-UNIT) ;03.23.87 DAB      (COND((AND (CLOSUREP TO-UNIT);magtape needs to know this stuff before      (FUNCALL TO-UNIT :HANDLES-LABEL));writing file. (FUNCALL TO-UNIT :PUT PART-COMMENT :COMMENT) (FUNCALL TO-UNIT :PUT FROM-PART-SIZE :SIZE)))      (DO ((FROM-ADR (+ FROM-PART-BASE (* 100. STARTING-HUNDRED))     (+ FROM-ADR AMT))   (TO-ADR (+ TO-PART-BASE (* 100. STARTING-HUNDRED)) (+ TO-ADR AMT))   (FROM-HIGH (+ FROM-PART-BASE FROM-PART-SIZE))   (TO-HIGH (+ TO-PART-BASE TO-PART-SIZE))   (N-BLOCKS (* 100. STARTING-HUNDRED) (+ N-BLOCKS AMT))   (N-HUNDRED STARTING-HUNDRED)   (AMT))  ((OR (>= FROM-ADR FROM-HIGH) (>= TO-ADR TO-HIGH)))(SETQ AMT      (MIN (- FROM-HIGH FROM-ADR) (- TO-HIGH TO-ADR) N-blocks-AT-A-TIME))(COND  ((NOT (= AMT N-blocks-AT-A-TIME)) (RETURN-DISK-RQB RQB)   (SETQ RQB (GET-DISK-RQB AMT))))(DISK-READ RQB FROM-UNIT FROM-ADR)(DISK-WRITE RQB TO-UNIT TO-ADR)(COND  ((NOT (= (FLOOR (+ N-BLOCKS AMT) 100.) N-HUNDRED))   (SETQ N-HUNDRED (1+ N-HUNDRED)) (FORMAT T "~D " N-HUNDRED)))(IF DELAY    (PROCESS-SLEEP DELAY)    (PROCESS-ALLOW-SCHEDULE)));kludge      (UPDATE-PARTITION-COMMENT  to-partition-name-string PART-COMMENT TO-UNIT))) ;03.23.87 DAB    ;;Unwind-protect forms    (RETURN-DISK-RQB RQB))  (DISPOSE-OF-UNIT FROM-UNIT)  (UNLESS (NUMBERP to-unit) (PROCESS-ALLOW-SCHEDULE))   ;don't release TO-UNIT until we're done  (DISPOSE-OF-UNIT TO-UNIT));PRINTS DIFFERENCES(DEFUN COMPARE-DISK-PARTITION (FROM-UNIT FROM-PART TO-UNIT TO-PART &OPTIONAL (N-BLOCKS-AT-A-TIME 85.) (DELAY NIL)       (STARTING-HUNDRED 0.) (WHOLE-THING-P NIL) &AUX FROM-PART-BASE FROM-PART-SIZE TO-PART-BASE       TO-PART-SIZE RQB RQB2 NO-ERRORS to-partition-name-string  from-partition-name-string)  "Compare partition FROM-PART on FROM-UNIT to partition TO-PART on TO-UNIT.FROM-PART and TO-PART can be partition names or partition-name-strings, such as \"PART.Explorer\", where \"Explorer\" isthe user/cpu type.While names of other machines can be specified as units, this is not very fast for copying between machines.  Use SI:RECEIVE-BAND or SI:TRANSMIT-BAND for that." ;03.23.87 DAB  (SETQ FROM-UNIT (DECODE-UNIT-ARGUMENT FROM-UNIT (FORMAT () "reading ~A partition" FROM-PART))TO-UNIT (DECODE-UNIT-ARGUMENT TO-UNIT (FORMAT () "reading ~A partition" TO-PART)))  (UNWIND-PROTECT (PROGN    (SETQ NO-ERRORS T)    (SETQ RQB (GET-DISK-RQB N-BLOCKS-AT-A-TIME))    (SETQ RQB2 (GET-DISK-RQB N-BLOCKS-AT-A-TIME))    (MULTIPLE-VALUE-SETQ      (FROM-PART-BASE FROM-PART-SIZE nil from-part nil from-partition-name-string);03.23.87       (FIND-DISK-PARTITION-FOR-READ FROM-PART () FROM-UNIT))    (MULTIPLE-VALUE-SETQ      (TO-PART-BASE TO-PART-SIZE nil to-part nil to-partition-name-string);03.23.87 DAB      (FIND-DISK-PARTITION-FOR-READ TO-PART () TO-UNIT))    (FORMAT T "~&Comparing ~S and ~S" (PARTITION-COMMENT from-partition-name-string FROM-UNIT)    (PARTITION-COMMENT to-partition-name-string TO-UNIT)) ;03.23.87 DAB    (AND (STRING-EQUAL FROM-PART "LOD" :START1 0. :END1 3. :START2 0. :END2 3.) (NOT WHOLE-THING-P) (LET (RQB size)  (UNWIND-PROTECT      (PROGN(SETQ rqb (get-disk-rqb disk-blocks-per-page))(SETQ size (lod-partition-info rqb from-unit from-part-base))(COND  ((AND (> SIZE 8.) (<= SIZE FROM-PART-SIZE))   (SETQ FROM-PART-SIZE SIZE)   (FORMAT T   "... using measured size of ~D. blocks."   SIZE))))    (RETURN-DISK-RQB RQB))))    (DO ((FROM-ADR (+ FROM-PART-BASE (* 100. STARTING-HUNDRED)) (+ FROM-ADR AMT)) (TO-ADR (+ TO-PART-BASE (* 100. STARTING-HUNDRED)) (+ TO-ADR AMT)) (FROM-HIGH (+ FROM-PART-BASE FROM-PART-SIZE)) (TO-HIGH (+ TO-PART-BASE TO-PART-SIZE)) (N-BLOCKS (* 100. STARTING-HUNDRED) (+ N-BLOCKS AMT)) (N-HUNDRED STARTING-HUNDRED) (AMT) (BUF (RQB-BUFFER RQB)) (BUF2 (RQB-BUFFER RQB2)))((OR (>= FROM-ADR FROM-HIGH) (>= TO-ADR TO-HIGH)))      (SETQ AMT    (MIN (- FROM-HIGH FROM-ADR) (- TO-HIGH TO-ADR) N-BLOCKS-AT-A-TIME))      (COND((NOT (= AMT N-BLOCKS-AT-A-TIME)) (RETURN-DISK-RQB RQB) (RETURN-DISK-RQB RQB2) (SETQ RQB (GET-DISK-RQB AMT)) (SETQ RQB2 (GET-DISK-RQB AMT)) (SETQ BUF (RQB-BUFFER RQB)) (SETQ BUF2 (RQB-BUFFER RQB2))))      (DISK-READ RQB FROM-UNIT FROM-ADR)      (DISK-READ RQB2 TO-UNIT TO-ADR)      (UNLESS (LET ((ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T))(%STRING-EQUAL (RQB-8-BIT-BUFFER RQB) 0. (RQB-8-BIT-BUFFER RQB2) 0.       (* 1024. AMT)))(DO ((C 0. (1+ C))     (ERRS 0.)     (LIM (* 512. AMT)))    ((OR (= C LIM) (= ERRS 3.)))  (COND    ((NOT (= (AREF BUF C) (AREF BUF2 C)))     (FORMAT T "~%ERR Block ~O Halfword ~O, S1: ~O S2: ~O "     (+       (- FROM-ADR (+ FROM-PART-BASE (* STARTING-HUNDRED 100.)))       (FLOOR C 512.))     (REM C 512.) (AREF BUF C) (AREF BUF2 C))     (SETQ NO-ERRORS ()) (SETQ ERRS (1+ ERRS))))))      (COND((NOT (= (FLOOR N-BLOCKS 100.) N-HUNDRED)) (SETQ N-HUNDRED (FLOOR N-BLOCKS 100.)) (FORMAT T "~D " N-HUNDRED)))      (IF DELAY  (PROCESS-SLEEP DELAY)  (PROCESS-ALLOW-SCHEDULE)));kludge    )    ;;Unwind-protect forms    (RETURN-DISK-RQB RQB)    (RETURN-DISK-RQB RQB2)    (DISPOSE-OF-UNIT FROM-UNIT)    (DISPOSE-OF-UNIT TO-UNIT));NO-ERRORS returns a meaningful value  NO-ERRORS)  (DEFUN FIND-DISK-PARTITION (NAME &OPTIONAL RQB (UNIT *DEFAULT-DISK-UNIT*) (ALREADY-READ-P NIL)    CONFIRM-WRITE CONFIRM-READ    &KEY    ATTRIBUTE &allow-other-keys    &AUX (RETURN-RQB NIL)  cpu-type) ;03.23.87 DAB  "Search the label of disk unit UNIT for a partition named NAME. :ATTRIBUTE - Requires partition to have an attribute with this value.  The optional keyword :CPU-TYPE has been removed. Use the following syntax for NAME to select specific user/cpu  partitions: \"NAME.USER/CPU\".  When COMFIRM-WRITE or COMFIRM-READ  is non-nil and duplicate partitions of NAME exist a selection menu will   prompt the user for a specific partition, otherwise a fatal error occur.  If CONFIRM-WRITE or CONFIRM-READ is :NO-ERROR, then the first occurrence of NAME will be returned.Returns six values describing what was found, or NIL if none found.The values are:  1. the number of the first block in the partition  2. the length of the partition in disk blocks  3. the location in the label (in words) of the data for this partition  4. the partition name (NAME is merely returned)  5. the partition attributes  6. a partition-name-string in the format: \"NAME.USER\" , where USER is the user/cpu designator.If partition name case sensitivity was used during EDIT-DISK-LABEL the global variable   si:*partition-name-case-sensitive*  must be set to T, otherwise find-disk-partition will return   the first occurrence of band regardless of alphabetic case." ;03.23.87 DAB  (DECLARE (VALUES FIRST-BLOCK N-BLOCKS LABEL-LOC NAME))  (setf (values name cpu-type)  ;03.23.87 DAB  look for "NAME.CPU"(parse-partition-name name))  (SETF NAME (PAD-NAME-FIELD NAME 4));2.1 fix patrition name must be padded left with spaces  (IF (AND (CLOSUREP UNIT) (FUNCALL UNIT :HANDLES-LABEL))      (FUNCALL UNIT :FIND-DISK-PARTITION NAME)      (MULTIPLE-VALUE-BIND (UNIT DECODEDP)  (DECODE-UNIT-ARGUMENT UNIT "update partition comment")(UNWIND-PROTECT (PROGN  (IF (OR (NULL RQB) (NULL ALREADY-READ-P))      (SETQ RETURN-RQB T    RQB (READ-DISK-LABEL UNIT)))  (FIND-DISK-PARTITION-1 NAME RQB UNIT CONFIRM-WRITE CONFIRM-READ :ATTRIBUTE ATTRIBUTE :CPU-TYPE CPU-TYPE));03.23.87 DAB  (IF RETURN-RQB      (RETURN-DISK-RQB RQB))  (UNLESS DECODEDP    (DISPOSE-OF-UNIT UNIT))))))(DEFUN FIND-DISK-PARTITION-1 (NAME RQB UNIT CONFIRM-WRITE  &OPTIONAL confirm-read &key ATTRIBUTE CPU-TYPE)  (DECLARE (SPECIAL ALPHABETIC-CASE-AFFECTS-STRING-COMPARSION));03.23.87 DAB  (when rqb     (BLOCK FIND-DISK-PARTITION      ;;This function has been rewritten to handle duplicate partitions. If they exist, a selection menu is displayed when      ;; either CONFIRM-READ or CONFIRM-WRITE is non-nil.   03.23.87 DAB      (let ((list-of-duplicates ()))(DO ((N-PARTITIONS (GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-NUMBER-OF-PARTITIONS)))     (WORDS-PER-PART (GET-DISK-FIXNUM RQB (+ %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)     NIL)  (LET ((ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON *PARTITION-NAME-CASE-SENSITIVE*))    (when      (AND ;; pad name field is necessary because the old dledit did not pad with places (STRING-EQUAL (PAD-NAME-FIELD (GET-DISK-STRING RQB (+ LOC %PD-NAME) 4) 4) NAME) ;;The new dledit does. I have to pad here to find old name less than four chars. (FIND-DISK-PARTITION-2 RQB LOC ATTRIBUTE CPU-TYPE))            (push (list (GET-DISK-FIXNUM RQB (+ LOC %PD-START))  (GET-DISK-FIXNUM RQB (+ LOC %PD-LENGTH))  LOC NAME  (GET-DISK-FIXNUM RQB (+ LOC %PD-ATTRIBUTES))  (GET-DISK-STRING RQB (+ LOC %PD-COMMENT)   (* 4      (-(GET-DISK-FIXNUM RQB (+ %PT-BASE    %PT-SIZE-OF-PARTITION-ENTRIES))(GET-DISK-FIXNUM RQB (+ %PT-BASE %PT-COMMENT-UNKNOWN)))))  (string-append NAME "."   ;03.23.87 DAB    (si:keyword-user-type      (ldb si:%%cpu-type-code (GET-DISK-FIXNUM RQB (+ LOC %PD-ATTRIBUTES))))))    list-of-duplicates))))(cond ((null list-of-duplicates) (RETURN-FROM FIND-DISK-PARTITION () t));no partition found, return nil.      ((= (length list-of-duplicates) 1); only one partition found.               (setf list-of-duplicates (car list-of-duplicates)))      ((or (equal confirm-write :NO-ERROR)   (equal confirm-read :NO-ERROR))               (setf list-of-duplicates (car (last list-of-duplicates))))      (t;duplicates found, display and return.               (if (or confirm-write confirm-read)   (progn     (setf list-of-duplicates   (select-duplicate-partitions list-of-duplicates"Duplicates partition found. Select one of the following:"))     (unless list-of-duplicates (RETURN-FROM FIND-DISK-PARTITION () T)));aborted out of selection   (ferror 'duplicate-partitions-exist   "Duplicate partitions exist with name ~a. Use the following partition name syntax to select a specific partition: \"NAME.USER\", where USER is the user/cpu type." NAME))       ))      (if (AND CONFIRM-WRITE(not (FQUERY FORMAT:YES-OR-NO-QUIETLY-P-OPTIONS     "Do you really want to clobber partition ~A ~                                     ,user/cpu type ~A ~     ~:[~*~;on unit ~D ~](~A) ~S? "     (fourth list-of-duplicates ) ;NAME;03.13.87     (keyword-user-type (ldb si:%%cpu-type-code (fifth list-of-duplicates)))     (NUMBERP UNIT) UNIT (GET-PACK-NAME UNIT)     (sixth list-of-duplicates)     )));03.13.87       (RETURN-FROM FIND-DISK-PARTITION () T))(RETURN-FROM FIND-DISK-PARTITION (first list-of-duplicates) (second list-of-duplicates)     (third list-of-duplicates) (fourth list-of-duplicates)     (fifth list-of-duplicates)     (seventh list-of-duplicates) ;return partition-name-string 03.23.87 DAB ));let      );block    ))(DEFUN FIND-DISK-PARTITION-2 (RQB PLOC ATTRIBUTE CPU-TYPE)  (LET* ((ATTRIBUTES-FIELD (GET-DISK-FIXNUM RQB (+ PLOC %PD-ATTRIBUTES))) (PART-ATTRIBUTE (LDB %%BAND-TYPE-CODE ATTRIBUTES-FIELD)) (PART-CPU-TYPE (LDB %%CPU-TYPE-CODE ATTRIBUTES-FIELD)))    (AND (IF ATTRIBUTE     (= ATTRIBUTE PART-ATTRIBUTE)     T) (IF CPU-TYPE     (= CPU-TYPE PART-CPU-TYPE)     T))))  (DEFUN FIND-DISK-PARTITION-FOR-READ (NAME &OPTIONAL RQB (UNIT *DEFAULT-DISK-UNIT*)     (ALREADY-READ-P NIL) (NUMBER-PREFIX "LOD") (Confirm-read t))  "Like FIND-DISK-PARTITION except there is error checking and coercion.NAME can be a number, a partition name or a partition-name-string, such as \"NAME.Explorer\".If NAME is a number, its printed representation is appended to NUMBER-PREFIXto get the partition name to use.If CONFIRM-READ is non-nil and duplicate partitions exist with name NAME a selection menu will be displayed,otherwise a fatal error will occur.Use PRINT-PARTITION-USER-TYPES to view valid user/cpu extensions."  (DECLARE (VALUES FIRST-BLOCK N-BLOCKS LABEL-LOC NAME ATTRIBUTES partition-name-string)) ;03.23.87 DAB  (COND    ((NUMBERP NAME) (SETQ NAME (FORMAT () "~A~D" NUMBER-PREFIX NAME)))    ((SYMBOLP NAME) (SETQ NAME (SYMBOL-NAME NAME)))    ((NOT (STRINGP NAME)) (FERROR () "~S is not a valid partition name" NAME)))  (MULTIPLE-VALUE-BIND (FIRST-BLOCK N-BLOCKS LABEL-LOC PNAME ATTRIBUTES  partition-name-string) ;03.23.87 DAB      (FIND-DISK-PARTITION NAME RQB UNIT ALREADY-READ-P () confirm-read)    (IF (NOT (NULL FIRST-BLOCK))(VALUES FIRST-BLOCK N-BLOCKS LABEL-LOC PNAME ATTRIBUTES partition-name-string) ;03.23.87 dab(FERROR () "No partition named \"~A\" exists on disk unit ~D."  name UNIT))));; Replaced use of CURRENT-LOADED-BAND with *LOADED-BAND*.  Removed support;; for non-explorer systems.   Patch 1-75, ab(DEFUN FIND-DISK-PARTITION-FOR-WRITE (NAME &OPTIONAL RQB (UNIT *DEFAULT-DISK-UNIT*)      (ALREADY-READ-P NIL) (NUMBER-PREFIX "LOD"))  "Like FIND-DISK-PARTITION except there is error checking, coercion, and confirmation.NAME can be a number, a partition name or a partition-name-string, such as \"NAME.Explorer\".If NAME is a number, its printed representation is appended to NUMBER-PREFIXto get the partition name to use.Use PRINT-PARTITION-USER-TYPES to view valid user/cpu extensions.Returns NIL if the partition specified is valid but the user refuses to confirm." ;03.23.87 DAB  (DECLARE (VALUES FIRST-BLOCK N-BLOCKS LABEL-LOC NAME partition-name-string)) ;03.23.87 DAB  (COND    ((NUMBERP NAME) (SETQ NAME (FORMAT () "~A~D" NUMBER-PREFIX NAME)))    ((SYMBOLP NAME) (SETQ NAME (SYMBOL-NAME NAME)))    ((NOT (STRINGP NAME)) (FERROR () "~S is not a valid partition name" NAME)))  (IF (AND (EQ UNIT *DEFAULT-DISK-UNIT*) (STRING-EQUAL NAME *LOADED-BAND*))      ;; For now, writing over current running band is not supported.      (PROGN(FORMAT T "~& Do not attempt to write into the current band. You will lose.")())      (MULTIPLE-VALUE-BIND (FIRST-BLOCK N-BLOCKS LABEL-LOC PNAME ATTRIBUTES partition-name-string);03.23.87 DAB  (FIND-DISK-PARTITION NAME RQB UNIT ALREADY-READ-P T)(IF (NOT (NULL FIRST-BLOCK))    (VALUES FIRST-BLOCK N-BLOCKS LABEL-LOC PNAME ATTRIBUTES partition-name-string);03.23.87 DAB    (IF (NULL N-BLOCKS)(FERROR () "No partition named \"~A\" exists on disk unit ~D." NAME UNIT)())))))(DEFUN SELECT-duplicate-partitions (list-of-duplicates DOC-STRING);03.23.87 DAB  "Displays a selection menu of duplicate partitions."  (let (menu-list)    (dolist (duplicate-list list-of-duplicates)      (push (list      (format nil "~1,1t ~a ~6,1t ~a ~24,1t ~a ~52,1t ~a"      (fourth duplicate-list)      (si:le-get-partition-type (ldb si:%%band-type-code (fifth duplicate-list)))      (si:keyword-user-type (ldb si:%%cpu-type-code (fifth duplicate-list)))      (sixth duplicate-list))      duplicate-list)    menu-list))    (setq menu-list (append (list      (format nil "~1,1t Name ~6,1t Partition Type ~21,1t User/Cpu-Type ~51,1t Comment"))    (list '("" :no-select nil))    menu-list))    (if (find-symbol "MENU-CHOOSE" 'W);Is window system loaded? COLD-LOAD 03.25.87(FUNCALL (FIND-SYMBOL "MENU-CHOOSE" 'W) menu-list :label doc-string)(car (last list-of-duplicates)));03.25.87 DAB    ))(DEFUN PARTITION-COMMENT (PART UNIT &optional (CONFIRM-READ t) &AUX RQB DESC-LOC)  "Return the comment in the disk label for partition PART, unit UNIT.PART can be a partition name or a partition-name-string, such as \"PART.Explorer\".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.When duplicate partitions of PART exist and CONFIRM-READ is non-nil a selection menu will be display,otherwise a fatal error occurs." ;03.23.87 DAB  (IF (AND (CLOSUREP UNIT) (FUNCALL UNIT :HANDLES-LABEL))      (FUNCALL UNIT :PARTITION-COMMENT PART)      (MULTIPLE-VALUE-BIND (UNIT DECODEDP)  (DECODE-UNIT-ARGUMENT UNIT "update partition comment")(UNWIND-PROTECT (PROGN  (SETQ RQB (READ-DISK-LABEL UNIT))  (MULTIPLE-VALUE-SETQ (NIL NIL DESC-LOC)       (FIND-DISK-PARTITION PART RQB UNIT () () confirm-read)) ;03.23.87 DAB  (COND    ((NULL DESC-LOC) NIL)    (T     (GET-DISK-STRING RQB (+ 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))))))))  (RETURN-DISK-RQB RQB)  (UNLESS DECODEDP    (DISPOSE-OF-UNIT UNIT))))))  (DEFUN DESCRIBE-PARTITION (PART &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*) (LABEL-RQB NIL) (CONFIRM-READ t) ;03.23.87 DAB   &AUX RQB COMPRESSED-FORMAT-P   VALID-SIZE HIGHEST-VIRTUAL-ADDRESS DESIRED-UCODE-VERSION DONT-DISPOSE UCODE-TRUE-VERSION   compressed)  "Print information about partition PART on unit UNIT.PART can be a partition name or a partition-name-string, such as \"PART.Explorer\", where \"Explorer\" isthe user/cpu type.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.When duplicate partitions of PART exist and CONFIRM-READ is non-nil a selection menu will be display,otherwise a fatal error occurs.If partition name case sensitivity was used during EDIT-DISK-LABEL the global variable   *partition-name-case-sensitive* must be set to T, otherwise describe-partition will return   the first occurrence of band regardless of alphabetic case.If PART is numeric it will always be mapped to upercase." ;03.23.87 DAB    (DECLARE (SPECIAL BAND-FORMAT-IS-COMPRESSED-CODE))  (SETF (VALUES UNIT DONT-DISPOSE)(DECODE-UNIT-ARGUMENT UNIT (FORMAT () "describing ~A partition" PART)))  (UNWIND-PROTECT (PROGN    (MULTIPLE-VALUE-BIND (PART-BASE PART-SIZE NIL PART ATTRIBUTES);nil was labl-loc(FIND-DISK-PARTITION-FOR-READ PART LABEL-RQB UNIT (AND LABEL-RQB) "LOD" confirm-read) ;03.23.87 DAB      (SETQ RQB (GET-DISK-RQB disk-blocks-per-page))      (SETQ VALID-SIZE    (COND      ((EQ %BT-LOAD-BAND (LDB %%BAND-TYPE-CODE ATTRIBUTES))       (MULTIPLE-VALUE-SETQ (valid-size desired-ucode-version compressed highest-virtual-address) (lod-partition-info rqb unit part-base)) (SETQ COMPRESSED-FORMAT-P       (= BAND-FORMAT-IS-COMPRESSED-CODE compressed)) (SETQ VALID-SIZE       (IF (AND (> VALID-SIZE 8.) (<= VALID-SIZE PART-SIZE))   VALID-SIZE   PART-SIZE)) VALID-SIZE)      ((EQ %BT-MICROLOAD (LDB %%BAND-TYPE-CODE ATTRIBUTES))       (DISK-READ RQB UNIT PART-BASE)       (LET ((BUF (RQB-BUFFER RQB))) (SETQ UCODE-TRUE-VERSION       (if (= (DPB (AREF BUF 3.) (BYTE 16. 16.) ;Verify processor type. 04.07.87 DAB   (DPB (AREF BUF 2.) (BYTE 16. 0) 0)   )      5);Explorer II?   (DPB (AREF BUF 5.) (BYTE 16. 16.)(DPB (AREF BUF 4.) (BYTE 16. 0) 0));Explorer II 04.07.87 DAB   (DPB (AREF BUF 7.) (BYTE 16. 16.)(DPB (AREF BUF 6.) (BYTE 16. 0) 0));Explorer    )       ))       PART-SIZE)      (T PART-SIZE)))      (FORMAT T "~%Partition ~A starts at ~D and is ~D blocks long."      (IF *PARTITION-NAME-CASE-SENSITIVE*  PART  (STRING-UPCASE PART))      PART-BASE PART-SIZE)      (IF COMPRESSED-FORMAT-P  (PROGN    (FORMAT T "~%It is a compressed world-load.")    (FORMAT T    "~%Data length is ~D blocks, highest virtual page number is ~D."    VALID-SIZE HIGHEST-VIRTUAL-ADDRESS))  (FORMAT T "~%It is in non-compressed format, data length ~D blocks."  VALID-SIZE))      (IF UCODE-TRUE-VERSION  (FORMAT T "~%Contains microcode version ~D." UCODE-TRUE-VERSION))      (IF DESIRED-UCODE-VERSION  (FORMAT T "~%Goes with microcode version ~D." DESIRED-UCODE-VERSION))      (PRINT-PARTITION-DESCRIPTOR ATTRIBUTES)))    (UNLESS DONT-DISPOSE      (DISPOSE-OF-UNIT UNIT))    (WHEN RQB      (RETURN-DISK-RQB RQB))))(DEFUN DESCRIBE-PARTITIONS (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*) &AUX DONT-DISPOSE)  "Describes all of the partitions of UNIT, or the standard disk if unit is not supplied."  (MULTIPLE-VALUE-SETQ (UNIT DONT-DISPOSE)       (DECODE-UNIT-ARGUMENT UNIT "describing partitions"))  (UNWIND-PROTECT (LOOP    FOR    (BAND . REST)    IN    (PARTITION-LIST () UNIT)    DOING    (FORMAT T "~%")    (DESCRIBE-PARTITION      (string-append BAND "." (keyword-user-type (ldb %%cpu-type-code (fifth rest))))      UNIT () :no-error))    (UNLESS DONT-DISPOSE      (DISPOSE-OF-UNIT UNIT))))  (DEFUN PRINT-PARTITION-DESCRIPTOR (ATTRIBUTES &OPTIONAL (STREAM T))  "formats to stream the properties of this partition"  (FORMAT STREAM "~%It is a ~a of CPU type ~a"  (LE-GET-PARTITION-TYPE (LDB %%BAND-TYPE-CODE ATTRIBUTES))  (LE-GET-PARTITION-CPU-TYPE (LDB %%CPU-TYPE-CODE ATTRIBUTES)))  (FORMAT STREAM  "~@[~%   Default band: ~a~]~@[,~%   Expandable: ~d~]~                 ~@[,~%   Contractable: ~a~]~@[,~%   Delete protected: ~a~]~                 ~@[,~%   Logical partition: ~a~]~@[,~%   Copy protected: ~a~]~@[,~%   Diagnostic: ~a~]"  (LDB-TEST %%DEFAULT-INDICATOR ATTRIBUTES) (LDB-TEST %%EXPANDABLE ATTRIBUTES)  (LDB-TEST %%CONTRACTABLE ATTRIBUTES) (LDB-TEST %%DELETE-PROTECTED ATTRIBUTES)  (LDB-TEST %%LOGICAL-PARTITION ATTRIBUTES) (LDB-TEST %%COPY-PROTECTED ATTRIBUTES)  (LDB-TEST %%DIAGNOSTIC-INDICATOR ATTRIBUTES)));;;2.1 changes: added used defined types;;;Added to support partition-name-strings  Valid user/cpu extension.(defvar partition-user-type-alist    ;03.23.87 DAB`(("EXPLORER"  ,%CPU-EXPLORER) ("EXP"  ,%CPU-EXPLORER)  ("NUMACHINE" ,%CPU-NUMACHINE) ("NUM" ,%CPU-NUMACHINE)          ("S1500" ,%CPU-S1500)  ("Terminal-Concentrator" ,%cpu-TI-Terminal-concentrator-68010)  ("Terminal Concentrator" ,%cpu-TI-Terminal-concentrator-68010)          ("TCON" ,%cpu-TI-Terminal-concentrator-68010)  ("Explorer-IB" ,%cpu-TI-Explorer-I-B) ("Explorer IB" ,%cpu-TI-Explorer-I-B)          ("EXP1B" ,%cpu-TI-Explorer-I-B)          ("Explorer-II" ,%cpu-TI-Explorer-II) ("Explorer II" ,%cpu-TI-Explorer-II) ("EXP2" ,%cpu-TI-Explorer-II)          ("CLM" ,%cpu-TI-CLM)          ("Nubus-Peripheral-Interface" ,%cpu-TI-Nubus-Peripheral-Interface-68010 )          ("Nubus Peripheral Interface" ,%cpu-TI-Nubus-Peripheral-Interface-68010 )          ("NPI" ,%cpu-TI-Nubus-Peripheral-Interface-68010 )          ("Mass-Storage-Controller" ,%cpu-TI-Mass-storage-controller-68010 )          ("Mass Storage Controller" ,%cpu-TI-Mass-storage-controller-68010 )          ("MSC" ,%cpu-TI-Mass-storage-controller-68010)          ("Comm-Carrier" ,%cpu-TI-Comm-Carrier-68010 ) ("Comm. Carrier"  ,%cpu-TI-Comm-Carrier-68010 )          ("COMC" ,%cpu-TI-Comm-Carrier-68010 )          ("TI-LISP" ,%CPU-TI-LISP) ("TI LISP" ,%CPU-TI-LISP) ("TILP" ,%CPU-TI-LISP)          ("GDOS" ,%CPU-GDOS)          ("SYSTEM5"  ,%CPU-SYSTEM5) ("SYSTEM 5" ,%CPU-SYSTEM5) ("SYS5" ,%CPU-SYSTEM5)          ("GENERIC" ,%CPU-GENERIC-BAND) ("GEN" ,%CPU-GENERIC-BAND)          )  "A list of valid partition user type strings.")(defvar partition-user-type-keyword-alist  ;03.23.87 DAB         `((,%CPU-EXPLORER :EXPLORER)  (,%CPU-NUMACHINE :NUMACHINE)  (,%CPU-S1500 :S1500)  (,%cpu-TI-Terminal-concentrator-68010 :Terminal-Concentrator )  (,%cpu-TI-Explorer-I-B :Explorer-IB)  (,%cpu-TI-Explorer-II :Explorer-II)  (,%cpu-TI-CLM :CLM)  (,%cpu-TI-Nubus-Peripheral-Interface-68010 :Nubus-Peripheral-Interface)  (,%cpu-TI-Mass-storage-controller-68010 :Mass-Storage-Controller)  (,%cpu-TI-Comm-Carrier-68010 :Comm-Carrier)  (,%CPU-TI-LISP :TI-LISP )  (,%CPU-GDOS :GDOS)  (,%CPU-SYSTEM5 :SYSTEM5)  (,%CPU-GENERIC-BAND :GENERIC))  "A list of valid partition user type keywords.")(DEFUN LE-GET-PARTITION-TYPE (TYPE-CODE)  (SELECT TYPE-CODE (%BT-LOAD-BAND "(Load Band)");0  (%BT-MICROLOAD "(Microcode)");1  (%BT-PAGE-BAND "(Page Band)");2  (%BT-FILE-BAND "(File Band)");3  (%BT-METER-BAND "(Meter Band)");4  (%BT-TEST-ZONE "(Test Zone)");5  (%BT-FORMAT-PARAMETER "(Format Parameters)");6  (%BT-VOLUME-LABEL "(Volume Label)");7Fixed 12-12-85  (%BT-SAVE-AREA "(System Save Area)");8  (%BT-PARTITION-TABLE "(Partition table)");9  (%BT-CONFIGURATION-BAND "(Configuration band)");10.  (%BT-LOG-BAND "(System Log)");11.New 12-12-85  (%BT-ANCHOR-BAND "(Anchor Band)");#x15New 03.17.87 DAB          (%BT-EMPTY-BAND "(Empty)");#xFFNew 12-12-85  (OTHERWISE (FORMAT () "(Type Code: ~16r(hex))" TYPE-CODE)))) ;;;2.1 changes: added to allow CPU types editing(DEFUN LE-GET-PARTITION-CPU-TYPE (TYPE-CODE)  (SELECT TYPE-CODE (%CPU-CHAPARRAL "(Explorer)   ");0 - #x0000  (%CPU-EXPLORER "(Explorer)   ");0 - #x0000  (%CPU-NUMACHINE-68010 "(NuMachine)  ");1 - #x0001  (%CPU-NUMACHINE "(NuMachine)  ");1 - #x0001  (%CPU-NUMACHINE-68020 "(S1500)      ");2 - #x0002  (%CPU-S1500 "(S1500)      ");2 - #x0002          (%cpu-TI-Terminal-concentrator-68010 "(Term Conc)  ")          (%cpu-TI-Explorer-I-B "(Explorer 1B)")          (%cpu-TI-Explorer-II "(Explorer II)")          (%cpu-TI-CLM "(CLM)        ")          (%cpu-TI-Nubus-Peripheral-Interface-68010 "(NUBUS Intf) ")          (%cpu-TI-Mass-storage-controller-68010  "(MSC)        ")          (%cpu-TI-Comm-Carrier-68010 "(Comm Carrier)")     (%CPU-TI-LISP "(TI Lisp)    ");3 - #xFC00  (%CPU-GDOS "(GDOS)       ");4 - #xFC01  (%CPU-SYSTEM5 "(System 5)   ");5 - #xFC02  (%CPU-GENERIC-BAND "(Generic)    ");6 - #xFFFF Empty Band  (OTHERWISE (FORMAT () "(CPU:#x~16r)" TYPE-CODE))))   (defun print-partition-user-types (&optional (stream *standard-output*)) ;03.23.87 Dab  "Print the user/cpu type codes in the list PARTITION-USER-TYPE-ALIST."  (format stream "~%User/CPU Type Codes.~% Value    Name")  (dolist (item partition-user-type-alist)    (format stream "~%#x~16r ~10t~s" (second item) (car item))))(defun select-user-type (user-type);03.23.87 DAB  "Returns the numeric value of user-type. User-type is a string such as \"explorer\" ,shorthand notation \"EXP\"   or a number. Numbers are read in base 10."    (COND    ((NULL USER-TYPE) ())    ((NUMBERP USER-TYPE);add to allow user define values     (IF (AND (>= USER-TYPE 0) (<= USER-TYPE #xFFFF)) USER-TYPE))    (T     (unless (stringp user-type)       (setq user-type (string USER-TYPE)))     (if (numberp (read-from-string user-type)) (let ((*read-base* 10.)) (read-from-string user-type));return the number (LET ((ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON nil))   (setf user-type (assoc user-type partition-user-type-alist :test #'string-equal))) (if user-type     (second user-type)     #x1FFFF);if not found, return a number that will not match.;if unknown return a number greater than #xFFFF. The CPU will never match! )     )))(defun keyword-user-type (user-type);03.23.87 DAB  "Returns the keyword corresponsing to the numeric value of user-type."    (when USER-TYPE    (when (stringp user-type)  (setf user-type (select-user-type user-type)))    (setf user-type (assoc user-type partition-user-type-keyword-alist))    (if user-type (second user-type):unknown)))(defun Parse-partition-name (Name &optional Direction) ;03.23.87 DAB  "Parse NAME into name and user/cpu components. NAME can have the following syntax: \"PART.TYPE\", \"PART\",\"PART.#XFFFF\",   \"PART.EXP2\", \"PART.5\" or \"PART.EXPLORER II\", where PART in the name of the partition and the remainer of the string   is the user/cpu extension. Numbers are read in base 10.   This functions returns two values.   The first values will be the partition name. The second value returned is the user/cpu type.   A number is returned for the user/cpu value if direction is :NUMBER (default),   a keyword is returned if direction is :KEYWORD.   Valid user/cpu extension are contained in the variable PARTITION-USER-TYPE-ALIST. The function    PRINT-PARTITION-USER-TYPES will display the list."  (if (stringp name)    (let (position  )      (setf (values nil position)  (find #\. name :test #'=))      (if (null position)  NAME                                                (let ((partition-name (subseq name 0 position))     ;"NAME.USER"(partition-user-type (subseq name (1+ position))))  ;skip delimiter    (select direction      (:keyword (values partition-name (keyword-user-type partition-user-type)))      (t ;direction = nil or :numeric       (values partition-name (select-user-type partition-user-type))))))      )    NAME))(DEFVAR *LEGAL-NOTICE* "~%Copyright (c) 1985, 1986, 1987 Texas Instruments. All Rights Reserved.Enter (TI-Show-Legal-Notice) for complete restricted rights notices.~%");;; Note: the TI-Show-Legal-Notice function is declared external in the TICL package. ;;; This allows the user, from the user package to type in the function without a ;;; package prefix. We don't need to defun it with a prefix here because the SYS package;;; uses ticl.(DEFUN TI-Show-Legal-Notice (&optional (STREAM *Standard-Output*))  (FORMAT stream *full-legal-notice*)  (values));;; Careful.  don't type linefeeds in text, just put ~% where a line;;; feed should be.  To make it span lines nicer, put a ~ at the end of;;; a line to indicate continuation.  (Broken up and verified by TWE.)(DEFVAR *FULL-LEGAL-NOTICE*"~%**********************************************************************~%                       ~    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,1986,1987 Texas Instruments. All Rights Reserved.~%~    Explorer is a trademark of Texas Instruments Incorporated.~%~    **********************************************************************");; This is called explicitly by LISP-REINITIALIZE.;; Removed reference to CURRENT-LOADED-BAND and replaced with *LOADED-BAND*. 1-75, ab;; System patch 2-61, -ab.  Put legal notice and shutdown check in lisp-reinitialize.(DEFVAR *DEFAULT-PRODUCT-DESCRIPTION-VERBOSITY* :no-proper-components)(DEFUN PRINT-HERALD (&OPTIONAL STREAM (VERBOSE-P NIL SUPP-P))  " PRINT-HERALD prints a description of all the software installed on the system  to STREAM, in either a trimmed or verbose style.  STREAM    defaults to *STANDARD-OUTPUT*  If VERBOSE-P is non-nil, then verbose style is used to display the herald. This displays all               component systems of all defined products.  If VERBOSE-P is nil, then a trimmed style is used. This displays only products and systems                that are not proper components of a product.  VERBOSE-P defaults to a trimmed style.  For example,  (PRINT-HERALD nil T) displays what systems are installed and their patch level.                       This includes systems with no patches. This is the verbose style.  (PRINT-HERALD nil nil) displays only optional systems and patched systems. This is the                       trimmed style.  (PRINT-HERALD)       displays the herald in whatever style you selected last."  (DECLARE (SPECIAL *MICROCODE-NAME-ALIST*) (SPECIAL *LOADED-MCR-BAND*))  (SETF STREAM (OR STREAM *STANDARD-OUTPUT*))  (IF SUPP-P    (SETQ *DEFAULT-PRODUCT-DESCRIPTION-VERBOSITY* (IF VERBOSE-P    T    :NO-PROPER-COMPONENTS)))  (FORMAT STREAM "~2&Explorer ~A ~A" (OR (GET-SITE-OPTION :SITE-PRETTY-NAME) SITE-NAME)  LOCAL-PRETTY-HOST-NAME)  (IF (EQ LOCAL-HOST ASSOCIATED-MACHINE)    (FORMAT STREAM ".")    (FORMAT STREAM ", with File Server ~A." (FUNCALL ASSOCIATED-MACHINE :NAME-AS-FILE-COMPUTER)))  (FORMAT STREAM "~&Load band ~A" *LOADED-BAND*)  (WHEN (AND (BOUNDP 'SYSTEM-ADDITIONAL-INFO) (PLUSP (ARRAY-ACTIVE-LENGTH SYSTEM-ADDITIONAL-INFO)))    (FORMAT STREAM " (~A)" SYSTEM-ADDITIONAL-INFO))  (FORMAT STREAM " loaded from disk ~A," DISK-PACK-NAME)  (FORMAT STREAM " Microcode ~A" *LOADED-MCR-BAND*)  (WHEN (ASSOC MICROCODE-TYPE-CODE *MICROCODE-NAME-ALIST*)    (FORMAT STREAM " (~A ~d)" (CDR (ASSOC MICROCODE-TYPE-CODE *MICROCODE-NAME-ALIST*))    %MICROCODE-VERSION-NUMBER))  (FORMAT STREAM ".")  (IF (NOT (FBOUNDP 'DESCRIBE-SYSTEM-VERSIONS))    (FORMAT STREAM "~%Fresh Cold Load~%")    (PROGN      (FORMAT STREAM "~&~D MB of physical memory, ~D MB of virtual memory."      (ROUND (SYSTEM-COMMUNICATION-AREA %SYS-COM-MEMORY-SIZE) (TRUNCATE 1M-BYTE 4))      (IF (= PROCESSOR-TYPE-CODE CHAPARRAL-TYPE-CODE)(ROUND (* PAGE-SIZE (SWAP-STATUS NIL)) (TRUNCATE 1M-BYTE 4))(ROUND VIRTUAL-MEMORY-SIZE 262144)))      (DESCRIBE-SYSTEM-VERSIONS STREAM)))  (WHEN (FBOUNDP 'CHECK-FOR-ABNORMAL-SHUTDOWN)    (CHECK-FOR-ABNORMAL-SHUTDOWN STREAM)))(DEFUN Initial-Screen-Heading ()  "Draws the Initial Lisp Listener boot screen title and Legal Notice."  (LET* ((STREAM *Terminal-IO*) (left-margin 10) (width (SEND stream :inside-width)) (height (SEND stream :inside-height)) (Y (SEND stream :cursor-y))         (font1 fonts:mets) char-left tm-x)    (WHEN (VARIABLE-BOUNDP fonts:ti-logo);This avoids possible problems in the cold load stream      (setf char-left (+ left-margin       (SEND stream :character-width #\T fonts:ti-logo)       40));Leave some space beside the bug      ;; First position the cursor down past our heading, since our screen writing will be Explicit.      (DOTIMES (x (1+ (TRUNCATE (w:font-char-height fonts:ti-logo) (SEND stream :line-height))))(FORMAT stream "~%"));Make room for the TI bug      ;; Display the TI-Logo      (SEND stream :string-out-explicit "T"    left-margin Y    width height fonts:ti-logo w:alu-xor)      (SETQ Y (+ Y (FLOOR (- (w:font-char-height fonts:ti-logo)                             (w:font-char-height font1))                          2)))      ;; Display the main title in a large font. Its first returned value is its ending x-location.      ;; This x-location is where the Trademark is placed, so store the tm-x.      (SETQ tm-x (SEND stream :string-out-explicit "Texas Instruments Explorer"       char-left Y       width height font1 w:alu-ior))      (SEND stream :string-out-explicit "TM"    tm-x Y width height fonts:tr8b w:alu-ior))    (if (VARIABLE-BOUNDP *legal-notice*)(format stream *legal-notice*))    (FORMAT STREAM "~%")))(DEFUN First-Print-Herald (&optional (STREAM *Terminal-IO*))  "Prints the Print-Herald on the boot screen, then describes how to see the full partition contents.If the user has not logged in, then it suggests how to login."    (print-herald stream nil)    (FORMAT stream "~2%Press the ~:c key for Explorer Help Information.~%" #\help)    (FORMAT stream "Press ~c to display the System Menu.~%" #\mouse-r-2)    (FORMAT stream "Enter (NEW-USER) if this is your first time on an Explorer.~%")    (FORMAT stream "~%Enter (PRINT-HERALD T T) for full partition contents.~%")    (UNLESS (PLUSP (LENGTH USER-ID))      (FORMAT STREAM "Please login. Enter (LOGIN your-name)~%")))on command history (defun LE-Com-Control-A ()  (Format *terminal-io* "~%Partition types are:~%")  (condition-case ();add condition call. SYS:ABort will now only