;;; -*- 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 ;;;------------------------------------------------------------------------------ ;;; 05-03-89 DAB Modified REMOTE-DISK-HANDLER-for-explorer to append the host name to the ;;; remote-disk-unit when remote-disk-unit is a symbol. Case of unit "host:packname". ;;; 04-28-89 JLM Added optional arg CONFIRM-WRITE to FIND-DISK-PARTITION-FOR-WRITE to allow simple ;;; quashing of confirm query. ;;; 04-18-89 DAB Fixed MEASURED-SIZE-OF-PARTITION to check the attributes of as partition and not asssume ;;; load bands are named "LODx". ;;; 03-28-89 LAS Update copyright years to include 1989 ;;; 03-15-89 DAB Fixed LE-GET-PARTITION-CPU-TYPE. It was not recognizing the partition cpu type of "NUBUS INTF" ;;; 12-15-88 DAb Fixed load-mcr-file to put "Incomplete Copy" on destination partition before copy. If user ;;; abort copy the partition comment will reflex a bad partitiom. ;;; ************************** Rel 5.0 12-15-88 DAB. ;;; 11-10-88 DAB Added find-disk-partition to remote-disk-handler. ;;; 11-01-88 DAB Added :log to mx-GET-PARTITION-TYPE . ;;; 10-24-88 DAB Fixed FIND-DISK-PARTITION-microExplorer to truncate partition-name to 4 character. ;;; 10-21-88 DAB Many changes to support remote-disk-handler for microExplorer. ;;; 10-5-88 ab Disk-io 5-2 Fixed PRINT-DISK-LABEL, GET-PARTITION-COMMENT and ;;; FIND-DISK-PARTITION for remote Explorer disks from mX. ;;; 09-08-88 DAB Fixed load-mcr-file to work when the user enters a number for filename. ;;; 06/02/88 KJF - Fix to initial-screen-heading to get rid of compiler warnings. ;;; 06-02-88 ab d-io 16 o Cosmetic change to PRINT-DISK-LABEL on mX. ;;; 06-01-88 DAB Expanded the error message the user gets when attempting to overwrite the current band ;;; in find-disk-partition-for-write. ;;; 5-18-88 ab Disk-IO 4.11- Fix DESCRIBE-PARTITION on MCRs for microExplorer. ab for MBC. ;;; 4-22-88 ab Disk-IO 4.9 - Fix FIND-DISK-PARTITION to handle unit numbers ;;; correctly on the microExplorer. ;;; 4-15-88 KJF - BITBLT LOGO in light-brown in initial-screen-heading. ;;; 4-04-88 DAB - Fixed find-disk-partition-1. It was not handling case sensitivity properly. ;;; 2/26/88 ab - Moved the mX verson of PRINT-DISK-LABEL [(not (resource-present-p :disk))] ;;; here from DISK-LABEL-EDITOR file. ;;; 2/23/88 ab 4.10 - Add 1988 to list of copyright years. ;;; 2/17/88 DNG Modify INITIAL-SCREEN-HEADING by moving some variable ;;; bindings inside the WHEN so they don't break in a minimal band. ;;; 2/08/88 DNG Conditionalize FIRST-PRINT-HERALD for minimal band. ;;; 01.27.88 MBC Fix find-disk-label no :DISK to handle "name.Explorer". ;;; 01/25/88 ab - Delete top-level LOAD of bitblt-ti-logo file. It won't ;;; work since this file is cold-loaded. Made the ;;; loading of "SYS:IO;BITBLT-TI-LOGO" a part of the IO defsystem ;;; which is loaded after the cold band is built. ;;; 01/25/88 KJF - Added changes for color to initial-screen-heading ;;; from patch -> patch.io;io-3-46. Must use proper alu's ;;; when system is color. Also, display LOGO in color. ;;; 01/22/88 LG - TI Logo now bitblted instead of :draw-char to allow it to work on the ;;; microExplorer. ;;; 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. ;;; 6/25/87 AB - Use USABLE-ADDRESS-SPACE-LIMIT function to compute virtual ;;; memory size so that PRINT-HERALD never displays virtual memory ;;; size greater than 128MB [SPR 5809]. ;;; 09/01/87 CRW - Add Network Namespace namestring to PRINT-HERALD [SPR 3367]. ;;; 01.11.88 MBC Convert addin conditionals to Define-When & Define-Unless. ;;; 01.21.88 MBC Allow MAC to have a METR band. ;;; 07/27/88 clm - Fixed GET-MCR-PATHNAME for cases where requested mcr version doesn't exist. ;;; 08/29/88 ab D-IO 5-1 - Additions/modifications for mX dynamic partition support. ;;; 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. ;;; 09-08-87 DAB Added :wait operation to remote-disk-server. (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 REMOTE-DISK-host)) (case (getf (send REMOTE-DISK-host :host-attributes) :machine-type) (:MICROEXPLORER (apply 'remote-disk-handler-for-microexplorer op args)) (T (apply 'remote-disk-handler-for-explorer op args)))) (DEFUN REMOTE-DISK-HANDLER-for-explorer (OP &REST ARGS) (DECLARE (SPECIAL REMOTE-DISK-CONN REMOTE-DISK-STREAM REMOTE-DISK-UNIT remote-disk-host)) (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~%" (if (and REMOTE-DISK-UNIT ; DAB 05-03-89 (not (closurep remote-disk-unit)) (symbolp REMOTE-DISK-UNIT)) ; DAB 05-03-89 Case of "host:packname" ;;append the host to the unit, otherwise remote-disk-server will error trying to parse a bad packname as a host. (string-append remote-disk-host ":" (string remote-disk-unit)) 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)) (:wait (or (chaos::conn-finished-p REMOTE-DISK-CONN) (process-wait "Remote Disk Server" #'(lambda (conn) ;09-08-87 DAB (chaos::conn-finished-p 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 REMOTE-DISK-HANDLER-for-microexplorer (OP &REST ARGS) (DECLARE (SPECIAL REMOTE-DISK-CONN REMOTE-DISK-STREAM REMOTE-DISK-UNIT)) (let ((result-string (make-string 2000)) (wait-for-response? nil)) (CASE OP ((:write :read) (apply #'REMOTE-DISK-HANDLER-for-explorer op args)) ;11-10-88 DAB (:find-disk-partition (FORMAT REMOTE-DISK-STREAM "MAC-DISK si:find-disk-partition (:return-value ~A nil ~d)~%" (car args) ;11-10-88 DAB (or REMOTE-DISK-Unit "sys:*DEFAULT-DISK-UNIT*")) (SEND REMOTE-DISK-STREAM :FORCE-OUTPUT) (setf wait-for-response? T)) (:Print-DISK-LABEL (FORMAT REMOTE-DISK-STREAM "MAC-DISK si:print-DISK-LABEL (~d STREAM)~%" (or REMOTE-DISK-Unit "sys:*DEFAULT-DISK-UNIT*")) (SEND REMOTE-DISK-STREAM :FORCE-OUTPUT) (setf wait-for-response? T)) (:DESCRIBE-PARTITION (FORMAT REMOTE-DISK-STREAM "MAC-DISK DESCRIBE-PARTITION (~a ~D)~%" (car args) (or REMOTE-DISK-Unit "sys:*DEFAULT-DISK-UNIT*") ) (SEND REMOTE-DISK-STREAM :FORCE-OUTPUT) (setf wait-for-response? T)) (:ADD-PAGE-BAND (FORMAT REMOTE-DISK-STREAM "MAC-DISK si:ADD-PAGE-BAND (:partition-name ~a :unit ~D :size ~d)~%" (car args) (or REMOTE-DISK-Unit "sys:*DEFAULT-DISK-UNIT*") (third args)) (SEND REMOTE-DISK-STREAM :FORCE-OUTPUT) (setf wait-for-response? T)) (:ADD-PARTITION (FORMAT REMOTE-DISK-STREAM "MAC-DISK si:ADD-PARTITION (~a ~D ~d :partition-type ~s)~%" (car args) (or REMOTE-DISK-Unit "sys:*DEFAULT-DISK-UNIT*") (third args) (fourth args)) (SEND REMOTE-DISK-STREAM :FORCE-OUTPUT) (setf wait-for-response? T)) (:MODIFY-PARTITION (FORMAT REMOTE-DISK-STREAM "MAC-DISK si:MODIFY-PARTITION (~a ~D ~d :partition-type ~s :new-partition-type ~s :new-partition-name ~a :partition-start ~d :query nil)~%" (car args) (or REMOTE-DISK-Unit "sys:*DEFAULT-DISK-UNIT*") (third args) (fourth args) (fifth args) (sixth args) (EIGHTH args)) (SEND REMOTE-DISK-STREAM :FORCE-OUTPUT) (setf wait-for-response? T)) (:DELETE-PARTITION (FORMAT REMOTE-DISK-STREAM "MAC-DISK si:DELETE-PARTITION (~a ~D :partition-type ~s :start ~d :query nil)~%" (car args) (or REMOTE-DISK-Unit "sys:*DEFAULT-DISK-UNIT*") (third args) (fourth args)) (SEND REMOTE-DISK-STREAM :FORCE-OUTPUT) (setf wait-for-response? T)) (:ADD-OR-MODIFY-PARTITION (FORMAT REMOTE-DISK-STREAM "MAC-DISK si:ADD-OR-MODIFY-PARTITION (~a ~D ~d ~s nil)~%" (car args) (or REMOTE-DISK-Unit "sys:*DEFAULT-DISK-UNIT*") (third args) (fourth args) ) (SEND REMOTE-DISK-STREAM :FORCE-OUTPUT) (setf wait-for-response? T)) (:resize-load-band (FORMAT REMOTE-DISK-STREAM "MAC-DISK si:resize-load-band (~a ~D)~%" (car args) (or REMOTE-DISK-Unit "sys:*DEFAULT-DISK-UNIT*")) (SEND REMOTE-DISK-STREAM :FORCE-OUTPUT) (setf wait-for-response? T)) (:DISPOSE (CHAOS::close-CONN REMOTE-DISK-CONN)) (:wait (or (chaos::conn-finished-p REMOTE-DISK-CONN) (process-wait "Remote Disk Server" #'(lambda (conn) ;09-08-87 DAB (chaos::conn-finished-p 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)) (when wait-for-response? (send remote-disk-stream :string-in () result-string) (string-right-trim #x0 result-string))) ) (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)) (defun get-mcr-pathname (control-file) ;; 4/20/88 CLM - Added; needed for the new mcr naming convention (e.g. exp1-ucode-540.mcr#1). ;; 5/26/88 CLM - Fixed problem arising when there are MX mcr files of both new and ;; old naming style. For old style, getting "ucode" as the version #. ;; 7/27/88 clm - Fixed so that if new-named microcodes don't exist, just return the ;; control-file arg (i.e., the mcr file is not in this directory). (let ((mcr-dir (directory (send control-file :new-pathname :name (concatenate 'string (send control-file :name) "-*") :type :mcr))) (default-version 1) ) ;;get the current version number (if mcr-dir (progn (dolist (x mcr-dir) (let* ((name (send x :name)) (version (with-input-from-string (n (subseq name (1+ (position #\- name :from-end t)))) (read n)))) (when (numberp version) (setq default-version (max version default-version))))) (send control-file :new-pathname :name (concatenate 'string (send control-file :name) (format nil "-~s" default-version)) :type :mcr) ) control-file))) ;;; 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/cpu type. UNIT can be a disk unit number or the name of a machine on the chaosnet." ;03.23.87 DAB ;; 4/20/88 CLM - Modified to handle the new mcr naming convention (e.g. exp1-ucode-540.mcr#1). (SETQ FILENAME (IF (NUMBERP FILENAME) (SEND (PATHNAME "SYS:UBIN;") :new-pathname :name (or (cdr (assoc microcode-type-code *Microcode-Name-Alist*)) "CONTROL") :TYPE "MCR" :VERSION FILENAME) (MERGE-PATHNAMES FILENAME ".mcr"))) ;12-19-88 DAB (OR (MEMBER (SEND FILENAME :CANONICAL-TYPE) '(:MCR "MCR") :TEST #'EQUALP) (FERROR () "~A is not a MCR file." FILENAME)) ;;in the new scheme of things, the names of microcode files are a variation ;;on the name of the control file (unless (probe-file filename) (setq filename (get-mcr-pathname 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)))) (UPDATE-PARTITION-COMMENT partition-name-string "Incomplete Copy" UNIT) ;12-15-88 DAB (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) ;; 4/20/88 CLM - For mcrs created under the new naming convention, the version number ;; will always be #1. This means we no longer get the version number ;; by parsing the mcr file (using PARSE-MCR-FILE-FOR-VERSION), we now ;; use the version number in the filename itself. ;; 5/12/88 CLM - Fix for cases where FILENAME is not a pathname object. Make sure all ;; objects are converted to pathname objects. (LET ((NAME (PATHNAME-NAME FILENAME)) (VERSION (FORMAT () "~d" (send (send (pathname filename) :truename) :version) ))) (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 swap LH (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 ) ;;ab 8/29/88. New. (DEFUN get-lod-partition-info (partition-name unit) (DECLARE (VALUES valid-size ucode band-format-code highest-va)) (LET (rqb part-base) (MULTIPLE-VALUE-SETQ (part-base) (find-disk-partition-for-read partition-name nil unit)) (UNWIND-PROTECT (PROGN (SETQ rqb (get-disk-rqb disk-blocks-per-page)) (lod-partition-info rqb unit part-base)) (WHEN rqb (return-disk-rqb rqb)) )) ) (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\" is the 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\" is the 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) ;;ab 10/5/88. Fix FIND-DISK-PARTITION to work on remote Explorer disks. (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 decodedp) "Find a partition from get-partition-list, that matches name. If RQB not NIL an error will be signalled. 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." (DECLARE (VALUES FIRST-BLOCK N-BLOCKS LABEL-LOC NAME)) (unless (closurep unit) (setf (values UNIT DECODEDP) ;dab (DECODE-UNIT-ARGUMENT UNIT (FORMAT () "finding ~A partition" NAME)))) (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 (find-disk-partition-microExplorer name nil unit nil nil nil)) (T (find-disk-partition-explorer name rqb unit already-read-p confirm-write confirm-read :attribute attribute)))) ((or (ARRAYP rqb) (resource-present-p :disk)) (find-disk-partition-explorer name rqb unit already-read-p confirm-write confirm-read)) (T (find-disk-partition-microExplorer name nil unit nil nil nil))) (when decodedp (dispose-of-unit unit)))) ;;ab 10/5/88. Fix FIND-DISK-PARTITION to work on remote Explorer disks. (DEFUN find-disk-partition-explorer (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 (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)))))) ;;ab 10/5/88. Fix FIND-DISK-PARTITION to work on remote Explorer disks. (DEFUN FIND-DISK-PARTITION-microExplorer (NAME &OPTIONAL RQB (UNIT *DEFAULT-DISK-UNIT*) (ALREADY-READ-P NIL) CONFIRM-WRITE CONFIRM-READ &key &allow-other-keys) (DECLARE (VALUES FIRST-BLOCK N-BLOCKS LABEL-LOC NAME) (ignore confirm-read confirm-write already-read-p)) (when rqb (ferror NIL "RQB not allowed, since it'll be ignored.")) (CHECK-ARG unit (or (closurep unit) (AND (INTEGERP unit) (NOT (MINUSP unit)))) "a valid disk unit number") (if (closurep unit) ;11-10-88 DAB (let (result) (setf result (funcall unit :find-disk-partition name)) (values-list (read-from-string result))) (let ((part-list (si:get-partition-list)) (short-name (subseq (pad-name-field (parse-partition-name name) 4) 0 4))) ;10-24-88 DAB (dolist (en part-list) (when (AND (= (FIRST en) unit) ;ab 4-18-88 disk-io 4-9 (STRING-EQUAL short-name (pad-name-field (SECOND en) 4))) (return (fourth en) (fifth en) 0 (second en) (third en) (seventh en))))))) (define-when :DISK (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 (if ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON ;03-22-88 DAB string-equal does not check this var anymore. (STRING= (PAD-NAME-FIELD (GET-DISK-STRING RQB (+ LOC %PD-NAME) 4) 4) NAME) (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 () ())) ;no partition found, return nil. ;12-14-88 DAB Was () and T.2nd value needs to be nil to cause error later. ((= (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 (format nil "Multiple partitions named ~S exist on this volume. Select one of the following:" NAME) )) (unless list-of-duplicates (RETURN-FROM FIND-DISK-PARTITION () T))) ;aborted out of selection (ferror 'duplicate-partitions-exist "Multiple 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 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 )) ;;; End of Find Disk Partition ADDIN-P exclusion. ) (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-PREFIX to 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") (confirm-write t)) ;jlm 4/29/89 "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-PREFIX to 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. This will crash the system and corrupt the current band.") ()) (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-WRITE) ;jlm 4/29/89 (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) ()))))) ;;ab 10/5/88. Fix PARTITION-COMMENT to work on remote Explorer disks. (DEFUN PARTITION-COMMENT (PART UNIT &optional (CONFIRM-READ t) &aux decodedp) (unless (closurep unit) (setf (values UNIT DECODEDP) ;dab (DECODE-UNIT-ARGUMENT UNIT (FORMAT () "describing ~A partition" 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 (partition-comment-microExplorer part unit)) (T (partition-comment-explorer part unit confirm-read)))) ((resource-present-p :disk) (partition-comment-explorer part unit confirm-read)) (T (partition-comment-microExplorer part unit))) (when decodedp (dispose-of-unit unit)))) ;;ab 10/5/88. Fix PARTITION-COMMENT to work on remote Explorer disks. (DEFUN partition-comment-microExplorer (PART UNIT &optional (CONFIRM-READ t)) (declare (ignore part unit confirm-read)) "") ;;ab 10/5/88. Fix PARTITION-COMMENT to work on remote Explorer disks. (DEFUN PARTITION-COMMENT-Explorer (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." (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)))))) ;; 2/9/88 DNG return no values. ;(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\" is ;the 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)) ; (VALUES))) (DEFUN DESCRIBE-PARTITION (PART &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*) (LABEL-RQB NIL) (CONFIRM-READ t)) ;03.23.87 DAB "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\" is the 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 (MULTIPLE-VALUE-BIND (UNIT DECODEDP) (DECODE-UNIT-ARGUMENT UNIT (FORMAT () "describing ~A partition" PART)) ;;changed to handle remote-disk-handler for a microExplorer 10-31-88 DAB (unwind-protect (COND ((CLOSUREP unit) (case (getf (send (symeval-in-closure unit 'REMOTE-DISK-host) :host-attributes) :machine-type) (:MICROEXPLORER (DESCRIBE-PARTITION-for-microexplorer part unit)) (T (DESCRIBE-PARTITION-for-explorer part unit label-rqb confirm-read)))) (t (DESCRIBE-PARTITION-for-explorer part unit label-rqb confirm-read)) ) (UNLESS DECODEDP (DISPOSE-OF-UNIT UNIT))) )) (DEFUN DESCRIBE-PARTITION-for-explorer (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\" is the 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) ) 0) (DPB (AREF BUF 7.) (BYTE 16. 16.) ;Explorer I 5.18.88 ab (DPB (AREF BUF 6.) (BYTE 16. 0) 0)) (DPB (AREF BUF 5.) (BYTE 16. 16.) ;Explorer II OR microExplorer 5 18.88 ab/MBC (DPB (AREF BUF 4.) (BYTE 16. 0) 0))) )) 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)) (VALUES)) (DEFUN DESCRIBE-PARTITION-for-microExplorer ;New function 10-31-88 DAB (PART &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*)) (if (closurep unit) (let (result) (setf result (funcall unit :DESCRIBE-PARTITION part)) (format T "~a" result)) )) (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) ("Terminal Conc" ,%cpu-TI-Terminal-concentrator-68010) ; DAB 03-15-89 ("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 ) ("Nubus Intf" ,%cpu-TI-Nubus-Peripheral-Interface-68010 ) ; DAB 03-15-89 ("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 ) ("Comm Carrier" ,%cpu-TI-Comm-Carrier-68010 ) ; DAB 03-15-89 ("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 mx-GET-PARTITION-TYPE (TYPE-CODE) ;ab 8/29/88 (SELECT TYPE-CODE ;;; These strings could be made compatible with MAC file extension ;;; we actually use for these partitions. 10.16.87 MBC (%BT-LOAD-BAND "Load Band") (%BT-MICROLOAD "Microcode") (%BT-PAGE-BAND "Page Band") (%BT-FILE-BAND "File Band") (%BT-METER-BAND "Meter Band") ;1.21.88 MBC (%BT-LOG-BAND "Log Band") ;11-01-88 DAB (OTHERWISE (FORMAT () "(Type Code: ~16r(hex))" TYPE-CODE)))) (DEFUN LE-GET-PARTITION-TYPE (TYPE-CODE) ;ab 8/29/88 (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)") ;7 Fixed 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)") ;#x15 New 03.17.87 DAB (%BT-EMPTY-BAND "(Empty)") ;#xFF New 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 IB)") ; DAB 03-15-89 (%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)) ;;ab 2/23/88. (DEFVAR *LEGAL-NOTICE* "~%Copyright (c) 1985, 1986, 1987, 1988, 1989 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 (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,1986,1987,1988,1989 Texas Instruments. All Rights Reserved.~%~ Explorer is a trademark of Texas Instruments Incorporated.~%~ *************************************************************************") (DEFVAR *DEFAULT-PRODUCT-DESCRIPTION-VERBOSITY* :no-proper-components) ;; This is called explicitly by LISP-REINITIALIZE. ;;AB 6/25/87. Use USABLE-ADDRESS-SPACE-LIMIT function to compute virtual memory size so that ;; PRINT-HERALD never displays virtual memory size greater than 128MB [SPR 5809]. ;;DNG 2/9/88 Return no values. (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 ~%Using primary Network Namespace ~a" (ROUND (SYSTEM-COMMUNICATION-AREA %SYS-COM-MEMORY-SIZE) (TRUNCATE 1M-BYTE 4)) (IF (FBOUNDP 'usable-address-space-limit) ;ab (MULTIPLE-VALUE-BIND (nwords limited-by) (usable-address-space-limit) (IF (EQ limited-by :address-space) (ROUND *max-address-space-size* (TRUNCATE 1M-BYTE 4)) (FLOOR nwords (TRUNCATE 1m-byte 4)))) (ROUND (* PAGE-SIZE (SWAP-STATUS NIL)) (TRUNCATE 1M-BYTE 4))) (string-upcase NAME:*NET-DOMAIN*) ;;; (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)) (VALUES)) (DEFPARAMETER bitblt-ti-logo :unbound "Bitblt-able image of the TI logo.") (DEFUN Initial-Screen-Heading () "Draws the Initial Lisp Listener boot screen title and Legal Notice." (LET* ((STREAM *Terminal-IO*) ;; added to get rid of compiler warnings if use w:light-brown in ;; (tv:prepare-color (stream w:light-brown) ... - see below. 07/12/88 KJF (color w:light-brown)) (DECLARE (SPECIAL bitblt-ti-logo)) (WHEN (OR (VARIABLE-BOUNDP fonts:ti-logo) ;This avoids possible problems in the cold load stream (VARIABLE-BOUNDP bitblt-ti-logo)) (let* ((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 (logo-height (if (VARIABLE-BOUNDP fonts:ti-logo) (w:font-char-height fonts:ti-logo) (array-dimension bitblt-ti-logo 1))) (logo-width (if (VARIABLE-BOUNDP fonts:ti-logo) (SEND stream :character-width #\T fonts:ti-logo) (array-dimension bitblt-ti-logo 1)))) (setf char-left (+ left-margin logo-width 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 logo-height (SEND stream :line-height)))) (FORMAT stream "~%")) ;Make room for the TI bug ;; Display the TI-Logo (IF (BOUNDP 'bitblt-ti-logo) ;; Use the bitblt image of the logo if it exists PMH 1/20/88 (tv:prepare-color (stream color) ;; Make LOGO brown. 04/15/88 KJF. (SEND stream :bitblt w:combine ;; don't use xor, will not look right on color. KJF. (array-dimension bitblt-ti-logo 1) (array-dimension bitblt-ti-logo 0) bitblt-ti-logo 0 0 left-margin y)) ;; else use the TI-LOGO font's image. ;; When on a color system, display the logo in TI Brown. Must use alu-transp. 10-21-87 - KJF. ;; Had to fill in the default args. for :string-out-explicit to get color. (SEND stream :string-out-explicit "T" left-margin Y width height fonts:ti-logo w:combine 0 nil ;; don't use xor, will not look right on color. KJF. (tv:sheet-line-height stream) color)) (SETQ Y (+ Y (FLOOR (- logo-height (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:combine)) ;; Was w:alu-ior. Changed for color release. 10-21-87 KJF (SEND stream :string-out-explicit "TM" tm-x Y width height fonts:tr8b w:combine))) ;; Was w:alu-ior. Changed for color release. 10-21-87 KJF (if (VARIABLE-BOUNDP *legal-notice*) (format stream *legal-notice*)) (FORMAT STREAM "~%"))) ;; 2/08/88 DNG - Conditionalized for use in minimal delivery bands. (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." (when (fboundp 'PRINT-HERALD) (print-herald stream nil)) (terpri stream) (when (get 'tv:window 'si:flavor) ; when window system loaded (FORMAT stream "~%Press the ~:c key for Explorer Help Information.~%" #\help) (FORMAT stream "Press ~c to display the System Menu." #\mouse-r-2)) (when (fboundp 'NEW-USER) (FORMAT stream "~%Enter (NEW-USER) if this is your first time on an Explorer.")) (when (fboundp 'PRINT-HERALD) (FORMAT stream "~2%Enter (PRINT-HERALD T T) for full partition contents.")) (terpri stream) (UNLESS (or (PLUSP (LENGTH USER-ID)) (not (fboundp 'login))) (FORMAT STREAM "Please login. Enter (LOGIN your-name)~%")) (VALUES)) ;;ab 3/30/88 Moved PRINT-DISK-LABEL here from DISK-LABEL-EDITOR. ;;ab 10/5/88. Fixed PRINT-DISK-LABEL to support printing of remote Explorer labels from mX. (DEFUN PRINT-DISK-LABEL (&OPTIONAL (UNIT *DEFAULT-DISK-UNIT*) (STREAM *STANDARD-OUTPUT*)) "Print the contents of a disk label. A unit can be a disk drive number, a string containing the name of a machine, or a string containing the remote machine name, colon, remote unit id." (MULTIPLE-VALUE-BIND (UNIT DECODEDP) (DECODE-UNIT-ARGUMENT UNIT "reading label") (COND ((CLOSUREP unit) (case (getf (send (symeval-in-closure unit 'REMOTE-DISK-host) :host-attributes) :machine-type) ;10-21-88 DAB (:MICROEXPLORER (print-disk-label-microexplorer unit stream)) (T (print-disk-label-explorer unit stream decodedp)))) ((resource-present-p :disk) (print-disk-label-explorer unit stream decodedp)) (t ;mx case (print-disk-label-microexplorer unit stream))) )) ;;ab 2/26/88 Moved mX version of PRINT-DISK-LABEL here from DISK-LABEL-EDITOR. ;;ab 6/2/88 Change dir name from LISPM to microExp in doc string, 2nd clause. ;;ab 8/29/88 Added volume space info to display. ;;ab 6/2/88 Change dir name from LISPM to microExp in doc string, 2nd clause. (DEFUN print-disk-label-microexplorer (unit stream) "Print the contents of the partition files in the MICROEXP directory of a MAC volume." (declare (special *mx-directory-name*)) (if (closurep unit) ;10-21-88 DAB If it a closure call remote-disk and it will handle it. (unwind-protect (let (result) (setf result (funcall unit :print-disk-label)) (format stream "~a" result)) (si:dispose-of-unit unit)) (LET ((part-list (get-partition-list nil nil unit))) (FORMAT stream "~2%Disk Volume ~a (logical unit ~d)" (STRING-UPCASE (get-volume-name-internal unit)) unit) (MULTIPLE-VALUE-BIND (free alloc tot) ;ab (get-volume-space-info unit) (FORMAT stream "~%~:d Blocks (kbytes) total on volume. ~:d Allocated, ~:d Free." tot alloc free)) (COND (part-list (FORMAT stream "~%Partition-files in MACINTOSH directory ~a:~a:" (STRING-UPCASE (get-volume-name-internal unit)) *mx-directory-name*) (format stream "~2% Starting") (FORMAT stream "~% Name Partition Type Block Length") ;;; ; 123456789 123456789 123456789 123456789 12345 (format stream "~% ---- -------------- -------- ------") (DOLIST (entry part-list) (FORMAT stream "~% ~4a ~14a ~9d ~7d" (SECOND entry) (mx-get-partition-type (THIRD entry)) (FOURTH entry) (FIFTH entry)))) (t (FORMAT stream "~2%There are no partition-files in MACINTOSH directory ~a:~a:" (STRING-UPCASE (get-volume-name-internal unit)) *mx-directory-name*)))) ) nil) ;;; Moved from edit-disk-partition ; DAB 04-13-89 (DEFUN MEASURED-SIZE-OF-PARTITION (PART &OPTIONAL (UNIT *DEFAULT-DISK-UNIT*) &AUX PART-BASE PART-SIZE RQB DONT-DISPOSE size MEMORY-SIZE compressed desired-ucode-version attributes) "Return the number of blocks of partition PART on unit UNIT actually containing data. Except for LOD partitions, this is the total size. The second value, for LOD partitions, is the required PAGE partition size. The third value, for LOD partitions, is the desired microcode version. 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." (DECLARE (:VALUES PARTITION-DATA-SIZE VIRTUAL-MEMORY-SIZE MICROCODE-VERSION)) (SETF (VALUES UNIT DONT-DISPOSE) (DECODE-UNIT-ARGUMENT UNIT (FORMAT () "sizing ~A partition" PART))) (UNWIND-PROTECT (PROGN (SETQ RQB (GET-DISK-RQB disk-blocks-per-page)) (MULTIPLE-VALUE-SETQ (PART-BASE PART-SIZE nil nil attributes) (FIND-DISK-PARTITION-FOR-READ PART () UNIT)) (COND ((OR (NUMBERP PART) (STRING-EQUAL PART "LOD" :end1 3 :end2 3) (EQ %BT-LOAD-BAND (LDB %%BAND-TYPE-CODE ATTRIBUTES))) ; DAB 04-18-89 Some MX partition do not use "LOD" (MULTIPLE-VALUE-SETQ (size desired-ucode-version compressed memory-size) (lod-partition-info rqb unit part-base)) (LET* ((FINAL-SIZE (IF (AND (> SIZE 8.) (<= SIZE PART-SIZE)) SIZE PART-SIZE)) ) (VALUES FINAL-SIZE (IF compressed MEMORY-SIZE FINAL-SIZE) desired-ucode-version))) (T PART-SIZE))) (UNLESS DONT-DISPOSE (DISPOSE-OF-UNIT UNIT)) (RETURN-DISK-RQB RQB)))