Changeset 271

Timestamp:

08/18/11 10:30:09 (21 months ago)

Author:

rjs

Message:

Update from System 78.

Location:

trunk/lisp/lmcons

Files:

• adrtst.lisp (deleted)
• cadld.lisp (modified) (5 diffs)
• cadmac.lisp (deleted)
• cadrd.lisp (deleted)
• cc.lisp (modified) (23 diffs)
• ccgsyl.lisp (modified) (1 diff)
• cclow.lisp (deleted)
• cl.lisp (deleted)
• dcheck.lisp (modified) (24 diffs)
• dpdiag.lisp (deleted)
• dsptst.lisp (deleted)
• ldbg.lisp (deleted)
• lmlmtv.lisp (deleted)
• lmtv.lisp (deleted)
• qf.lisp (deleted)
• qfmac.lisp (deleted)
• qunfas.lisp (deleted)
• shftst.lisp (deleted)
• talk.lisp (deleted)
• tdbg.lisp (deleted)
• unfasl.lisp (deleted)

trunk/lisp/lmcons/cadld.lisp

@@ -1 @@
-;;; -*-LISP-*- Patch file for CADR microcode loader
+;;; -*- MODE: LISP; PACKAGE: CADR; BASE: 8 -*- Patch file for CADR microcode loader
 
 (INCLUDE |LMDOC;.COMPL PRELUD|)
@@ -17 +17 @@
               ((= (LENGTH FILE-NAME) 1) 
                 (SETQ FILE-NAME (APPEND FILE-NAME '(ULOAD DSK LISPM1)))))
-  #Q    (IF (NULL FILE-NAME) (SETQ FILE-NAME "AI: LISPM1; UCADR ULOAD")
-            (SETQ FILE-NAME (SI:FILE-PARSE-NAME
-                              FILE-NAME NIL
-                              (SI:FILE-PARSE-NAME "AI: LISPM1; UCADR ULOAD"))))
+  #Q    (SETQ FILE-NAME
+              (FS:MERGE-PATHNAME-DEFAULTS (OR FILE-NAME "SYS: UBIN; UCADR ULOAD >")))
         (COND ((EQ MODE 'LOAD-WITHOUT-SYMBOLS)
                 (SETQ LOAD-WITHOUT-SYMBOLS-FLAG T)
@@ -85 +83 @@
                #Q (PROCESS-ALLOW-SCHEDULE)  ;Come up for a breath
                (CC-END-ADDING-SYMBOLS)
-               (SETQ CC-FILE-SYMBOLS-LOADED-FROM FILE)
+               (SETQ CC-FILE-SYMBOLS-LOADED-FROM
+                     #M FILE-NAME
+                     #Q (FUNCALL FILE ':TRUENAME))      ;So EQ will work later
                (GO COM)))
         (CC-ADD-TYPED-SYMBOL TEM (READ FILE) (READ-FIXNUM FILE))
@@ -197 +197 @@
                (PRIN1-THEN-SPACE WD)
                (AND (< REG-ADR RACME)
-                    (CC-TYPE-OUT WD CC-UINST-DESC T))
+                    (CC-TYPE-OUT WD CC-UINST-DESC T T))
                (PRINT 'MACHINE)
                (SETQ WD (LOGDPB RD3 4020 (LOGDPB RD2 2020 RD1)))
                (PRIN1-THEN-SPACE WD)
                (AND (< REG-ADR RACME)
-                    (CC-TYPE-OUT WD CC-UINST-DESC T))
+                    (CC-TYPE-OUT WD CC-UINST-DESC T T))
                (PRINT '-----))))
   (AND (NOT (< REG-ADR RAMMO))                          ;IF LOADING M, ALSO CHECK A
@@ -231 +231 @@
         (SETQ ADR (1+ ADR))
         (GO L)))
+

trunk/lisp/lmcons/cc.lisp

@@ -293 +293 @@
 (IF-FOR-LISPM
 (DEFUN CC-SELECT-SYMBOL-TABLE (FILENAME)
-  (LET ((TEM (ASSOC FILENAME CC-SYMBOL-TABLES-LOADED)))
+  (LET ((TEM (ASSQ FILENAME CC-SYMBOL-TABLES-LOADED)))
     (COND (TEM (SETQ CC-FILE-SYMBOLS-LOADED-FROM (CAR TEM)
                      CC-SYMBOLS-SIZE (CADR TEM)
@@ -330 +330 @@
 
 (DEFUN CC-END-ADDING-SYMBOLS ()
-   (SETQ CC-SYMBOLS-ARRAY-SIZE CC-SYMBOLS-SIZE)
+   ;(SETQ CC-SYMBOLS-ARRAY-SIZE CC-SYMBOLS-SIZE)  ;Don't do this, it just causes wastage later
    #M (*REARRAY CC-SYMBOLS-NAME T CC-SYMBOLS-SIZE)
    #Q (ADJUST-ARRAY-SIZE CC-SYMBOLS-NAME CC-SYMBOLS-SIZE)
@@ -416 +416 @@
                       (COND ((ZEROP DELTA) NAME)
                             ((AND (> DELTA 0)
-                                  (< DELTA 20))
+                                  (< DELTA 100))
                              (LIST NAME DELTA))
                             (T NIL))))))))
@@ -466 +466 @@
 ;DEFINITIONS OF VARIOUS WORD FORMATS, FOR BOTH TYPE-OUT AND TYPE-IN
 
-(DECLARE (SPECIAL CC-Q-DESC CC-A-DESC CC-HWD-DESC CC-BYTE-DESC CC-INST-DESC
+(DECLARE (SPECIAL CC-Q-DESC CC-A-DESC CC-HWD-DESC CC-BYTE-DESC CC-INST-DESC CC-ASCII-BYTE-DESC
                   CC-I-DEST-DESC CC-I-ADDR-DESC CC-I-BR-DESC
                   CC-I-11-DESC CC-I-12-DESC CC-I-13-DESC CC-I-15-DESC
@@ -475 +475 @@
                   CC-SEXP-DESC))
 
-(SETQ CC-MODE-DESC-TABLE '(
-        (H . CC-HWD-DESC) (B . CC-BYTE-DESC)
-        (Q . CC-Q-DESC) (A . CC-A-DESC) (/_ . CC-REG-ADDR-DESC)
-        (I . CC-INST-DESC) (U . CC-UINST-DESC) (V . CC-O-UINST-DESC) (S . CC-SEXP-DESC)
-        (/# . CC-BITS-DESC)
-))
+(DEFCONST CC-MODE-DESC-TABLE '((H . CC-HWD-DESC) (B . CC-BYTE-DESC)
+                               (Q . CC-Q-DESC) (A . CC-A-DESC) (/_ . CC-REG-ADDR-DESC)
+                               (I . CC-INST-DESC) (T . CC-ASCII-BYTE-DESC)
+                               (U . CC-UINST-DESC) (V . CC-O-UINST-DESC) (S . CC-SEXP-DESC)
+                               (/# . CC-BITS-DESC)
+                               (N . CC-SIGNED-WORD-DESC)))
 
 
@@ -504 +504 @@
 ; (NUM <FIELD-POSITION>)
 ;       pure numeric field, prompting with "#: ".
+; (SIGNED-NUM <FIELD-POSITION>) by special hack, it allows fields bigger than fixnum size.
 ; (SUB-FIELD <DESCRIPTION-NAME>)
 ;       call sub-description.
@@ -534 +535 @@
 ; (BITS)  typeout only, type bit numbers of set bits.
 
-(SETQ CC-REG-ADDR-DESC '( (CALL CC-PRINT-ADDRESS-1 0030) ))
-
-(SETQ CC-BITS-DESC '( (BITS)))
-
-(SETQ CC-HWD-DESC '( (NUM 2020) (CTYPE /,/,) (NUM 0020)
-))
-
-(SETQ CC-BYTE-DESC '( (NUM 0010) (CTYPE /,) (NUM 1010) (CTYPE /,)
-                      (NUM 2010) (CTYPE /,) (NUM 3010)
-))
-
-(SETQ CC-SEXP-DESC '( (CALL CC-Q-PRINT-TOPLEV-1 0035) ))
+(DEFCONST CC-REG-ADDR-DESC '( (CALL CC-PRINT-ADDRESS-1 0030) ))
+
+(DEFCONST CC-BITS-DESC '( (BITS)))
+
+(DEFCONST CC-SIGNED-WORD-DESC '( (SIGNED-NUM 0040)))
+
+(DEFCONST CC-HWD-DESC '( (NUM 2020) (CTYPE /,/,) (NUM 0020)))
+
+(DEFCONST CC-BYTE-DESC '( (NUM 0010) (CTYPE /,) (NUM 1010) (CTYPE /,)
+                         (NUM 2010) (CTYPE /,) (NUM 3010)))
+
+(DEFCONST CC-ASCII-BYTE-DESC '( (CHAR 0010) (CHAR 1010)
+                               (CHAR 2010) (CHAR 3010)))
+
+(DEFCONST CC-SEXP-DESC '( (CALL CC-Q-PRINT-TOPLEV-1 0035) ))
 
 
-(SETQ CC-Q-DESC '( (SELECT-FIELD CDR 3602 (NIL CDR-TRAP CDR-NIL CDR-NEXT))
-                   (SELECT-FIELD FLAG-BIT 3501 (NIL FLAG-BIT))
-                   (SELECT-FIELD DATA-TYPE 3005
+(DEFCONST CC-Q-DESC '( (SELECT-FIELD CDR 3602 (NIL CDR-TRAP CDR-NIL CDR-NEXT))
+                      (SELECT-FIELD FLAG-BIT 3501 (NIL FLAG-BIT))
+                      (SELECT-FIELD DATA-TYPE 3005
                        (NIL NULL FREE SYMBOL SYMBOL-HEADER FIX EXTENDED-NUMBER HEADER
                         GC-FORWARD EXTERNAL-VALUE-CELL-POINTER ONE-Q-FORWARD
@@ -558 +562 @@
                             SELECT-METHOD INSTANCE INSTANCE-HEADER
                         ENTITY T T T T T T T))
-                   (NUM 0030)
-))
-
-(SETQ CC-A-DESC '( (CONSTANT 3005 2)    ;ARRAY-HEADER DATA-TYPE
-                   (SELECT-FIELD ARRAY-TYPE 2305
+                      (NUM 0030)))
+
+(DEFCONST CC-A-DESC '( (CONSTANT 3005 2)        ;ARRAY-HEADER DATA-TYPE
+                      (SELECT-FIELD ARRAY-TYPE 2305
                        (T ART-1B ART-2B ART-4B ART-8B ART-16B ART-32B ART-Q 
                         ART-Q-LIST ART-STRING ART-STACK-GROUP-HEAD ART-SPECIAL-PDL 
@@ -573 +576 @@
                    (SELECT-FIELD LONG 1301 (NIL LONG))
                    (SELECT-FIELD SPARE-BIT 1201 (NIL SPARE-BIT))
-                   (TYPE-FIELD INDEX-LENGTH 0012 NIL)
-))
+                   (TYPE-FIELD INDEX-LENGTH 0012 NIL)))
 
-(SETQ CC-INST-DESC '( (SELECT-FIELD OP-CODE 1104
+(DEFCONST CC-INST-DESC '( (SELECT-FIELD OP-CODE 1104
                        (CALL CALL0 MOVE CAR
                         CDR CADR CDDR CDAR
@@ -590 +592 @@
                         CC-I-ADDR-DESC CC-I-ADDR-DESC CC-I-ADDR-DESC 
                         CC-I-ADDR-DESC CC-I-ADDR-DESC CC-I-ADDR-DESC 
-                        NIL CC-I-15-DESC NIL NIL))
-))
-
-(SETQ CC-I-DEST-DESC '( (SELECT-FIELD DEST 1503
+                        NIL CC-I-15-DESC NIL NIL))))
+
+(DEFCONST CC-I-DEST-DESC '( (SELECT-FIELD DEST 1503
                           (IGNORE STACK NEXT LAST
                            RETURN NEXTQ LASTQ NEXT-LIST))
 ))
 
-(SETQ CC-I-ADDR-DESC '( (COND ADR-TYPE 1001 (CC-I-ADDR-F-DESC CC-I-ADDR-R-DESC))
+(DEFCONST CC-I-ADDR-DESC '( (COND ADR-TYPE 1001 (CC-I-ADDR-F-DESC CC-I-ADDR-R-DESC))
 ))
 
-(SETQ CC-I-ADDR-F-DESC '( (TYPE FEF) (NUM 0010) ))
-
-(SETQ CC-I-ADDR-R-DESC '( (SELECT-FIELD ADR 0602 (QTPG LCL ARG PDL))
-                          (NUM 0006)
-))
-
-(SETQ CC-I-BR-DESC '( (SELECT-FIELD BRANCH 1503
+(DEFCONST CC-I-ADDR-F-DESC '( (TYPE FEF) (NUM 0010) ))
+
+(DEFCONST CC-I-ADDR-R-DESC '( (SELECT-FIELD ADR 0602 (QTPG LCL ARG PDL))
+                             (NUM 0006)))
+
+(DEFCONST CC-I-BR-DESC '( (SELECT-FIELD BRANCH 1503
                        (BR BR-NIL BR-NOT-NIL BR-NIL-OR-POP
                         BR-NOT-NIL-OR-POP BR-ATOM BR-NOT-ATOM T))
@@ -613 +613 @@
 ))
 
-(SETQ CC-I-11-DESC '( (SELECT-FIELD OP 1503
+(DEFCONST CC-I-11-DESC '( (SELECT-FIELD OP 1503
                         (T + - * // LOGAND LOGXOR LOGIOR))
 ))
 
-(SETQ CC-I-12-DESC '( (SELECT-FIELD OP 1503
+(DEFCONST CC-I-12-DESC '( (SELECT-FIELD OP 1503
                         (= > < EQ SCDR SCDDR 1+ 1-))
 ))
 
-(SETQ CC-I-13-DESC '( (SELECT-FIELD OP 1503
+(DEFCONST CC-I-13-DESC '( (SELECT-FIELD OP 1503
                         (BIND BINDNIL BINDPOP SETNIL SETZERO PUSH-E MOVEM POP))
 ))
 
-(SETQ CC-I-15-DESC '( (TYPE-FIELD MISC-OP 0011 NIL)
+(DEFCONST CC-I-15-DESC '( (TYPE-FIELD MISC-OP 0011 NIL)
                       (OUTPUT (CALL CC-I-MISC-NAME 0011)) ))    
 
@@ -858 +858 @@
 ;;; Print a string.  Note that it is truncated to at most 200 characters to
 ;;; avoid printing infinite garbage
+(DEFVAR CC-Q-PRINT-STRING-MAXL 200)
+
 (DEFUN CC-Q-PRINT-STRING (ADR)
   (QF-ARRAY-SETUP (QF-MAKE-Q (QF-POINTER ADR) DTP-ARRAY-POINTER))
@@ -867 +869 @@
        (CH)
        (WD))
-      ((OR (>= I LEN) (= I 200))
+      ((OR (>= I LEN) (= I CC-Q-PRINT-STRING-MAXL))
        (AND (< I LEN) (PRINC '/././.) CC-OUTPUT-STREAM)
        NIL)
@@ -968 +970 @@
               ((EQ (CAR ITEM) 'NUM)
                 (PRIN1-THEN-SPACE (LOGLDB (CADR ITEM) WD)))
+              ((EQ (CAR ITEM) 'SIGNED-NUM)
+               (PRIN1-THEN-SPACE (CC-UNSIGNED-TO-SIGNED (CADR ITEM)
+                                                        (LOGLDB-BIG (CADR ITEM) WD))))
+              ((EQ (CAR ITEM) 'CHAR)
+                (TYO (LOGLDB (CADR ITEM) WD)))
               ((EQ (CAR ITEM) 'CONSTANT))
               ((EQ (CAR ITEM) 'INPUT))
@@ -999 +1006 @@
         (GO L1)
 ))
+
+;like LDB, but can load fields bigger than fixnum size.
+(DEFUN LOGLDB-BIG (FLD WD)
+  (PROG (ANS BITS BITS-OVER SHIFT)
+        (SETQ SHIFT 0 ANS 0 BITS (LOGLDB 0006 FLD) BITS-OVER (LOGLDB 0620 FLD))
+    L   (SETQ ANS (LOGIOR ANS (ASH (LOGLDB (LOGDPB BITS-OVER 0620 (MIN BITS 23.)) WD) SHIFT)))
+        (IF (
+ (SETQ BITS (- BITS 23.)) 0) (RETURN ANS))
+        (SETQ SHIFT (+ SHIFT 23.)
+              BITS-OVER (+ BITS-OVER 23.))
+        (GO L)))
+
+(DEFUN CC-UNSIGNED-TO-SIGNED (FLD WD)
+  (LET ((SIGN-BIT (ASH 1 (1- (LDB 0006 FLD)))))
+    (IF (NOT (ZEROP (LOGAND SIGN-BIT WD)))
+        (MINUS (1+ (LOGXOR WD (1- (ASH SIGN-BIT 1)))))
+        WD)))
 
 (DEFUN CC-C-OR-D-ADR-OUT (TYPE VAL SYM-BASE)
@@ -1345 +1369 @@
   (CC-UCODE-LOADER 'LOAD-WITHOUT-SYMBOLS FILE NIL))
 
-(DEFUN CC-LOAD-UCODE-SYMBOLS (FILE &OPTIONAL MERGEP)
-  (COND ((EQUAL FILE CC-FILE-SYMBOLS-LOADED-FROM))
+(DEFUN CC-LOAD-UCODE-SYMBOLS-FOR-VERSION (VERSION)
+  (CC-LOAD-UCODE-SYMBOLS (FUNCALL (FS:PARSE-PATHNAME "SYS: UBIN; UCADR")
+                                  ':NEW-TYPE-AND-VERSION "SYM" VERSION)))
+
+(DEFUN CC-LOAD-UCODE-SYMBOLS (FILE &OPTIONAL MERGEP &AUX TRUENAME)
+  (SETQ FILE (FS:MERGE-PATHNAME-DEFAULTS FILE)
+        TRUENAME (FUNCALL FILE ':TRUENAME))
+  (COND ((EQ TRUENAME CC-FILE-SYMBOLS-LOADED-FROM))
         ((AND (NULL MERGEP)
-              (CC-SELECT-SYMBOL-TABLE FILE)))
+              (CC-SELECT-SYMBOL-TABLE TRUENAME)))
         (T
-         (CC-UCODE-LOADER 'LOAD-SYMBOLS FILE MERGEP)
-         (CC-RECORD-SYMBOL-TABLE (SETQ CC-FILE-SYMBOLS-LOADED-FROM FILE)))))
+         (CC-UCODE-LOADER 'LOAD-SYMBOLS TRUENAME MERGEP)
+         (CC-RECORD-SYMBOL-TABLE TRUENAME))))
 
 (DEFUN CC-COMPARE-UCODE (FILE)
@@ -1387 +1417 @@
 
 
+
 (DEFUN CC NIL                   ;MAIN LOOP OF CONS CONSOLE PROGRAM
-  (PROG (CC-ARG CC-SYL CC-VAL CC-UPDATE-DISPLAY-FLAG CC-OPEN-REGISTER 
+  (PROG ((BASE 8.) (IBASE 8.) (PACKAGE (PKG-FIND-PACKAGE "CADR"))
+         CC-ARG CC-SYL CC-VAL CC-UPDATE-DISPLAY-FLAG CC-OPEN-REGISTER 
           CC-LAST-OPEN-REGISTER CC-LAST-VALUE-TYPED COM-CH TEM) 
         (SETQ QF-SWAP-IN-LOOP-CHECK NIL)
@@ -1936 +1968 @@
                    (PRINC '| |)
                    (PRINC (NTH (LOGLDB %%REGION-SPACE-TYPE BITS)
-                               '(FREE OLD NEW STATIC FIXED EXITED EXIT EXTRA-PDL
-                                 WIRED USER-PAGED COPY 13 14 15 16 17))))
+                               '(FREE OLD NEW NEW1 NEW2 NEW3 NEW4 NEW5 NEW6
+                                 STATIC FIXED EXTRA-PDL COPY 15 16 17))))
                 (TERPRI))))))
 
 
-(DEFPROP ATOM CC-DESCRIBE-ATOM CC-COLON-CMD)
-
-(DEFUN CC-DESCRIBE-ATOM (TEM)
+(DEFUN (ATOM CC-COLON-CMD) (TEM)
   (SETQ CC-GETSYL-UNRCH NIL CC-GETSYL-UNRCH-TOKEN NIL) ;FLUSH DELIMITER
   (SETQ TEM (READ))     ;GET NAME OF ATOM USING LISP SYNTAX
@@ -2385 +2415 @@
 (DECLARE (SPECIAL %%PHT2-PHYSICAL-PAGE-NUMBER %%PHT2-META-BITS %%PHT2-MAP-ACCESS-CODE))
 
+(DECLARE (SPECIAL A-MEMORY-VIRTUAL-BASE-ADDRESS))
+
+(SETQ A-MEMORY-VIRTUAL-BASE-ADDRESS (DPB (LSH A-MEMORY-VIRTUAL-ADDRESS -27)
+                                         2701
+                                         (DPB A-MEMORY-VIRTUAL-ADDRESS 0027 0)))
+
 (DEFUN CC-CHECK-LEVEL-2-BLOCK (VIRTUAL-BASE LEVEL-2-BLOCK-NUMBER)
  (PROG (L2M PHT-ADR PHT-VALUE VIR-ADR NUM-CHECKED-OK L2MAP-SA)
@@ -2396 +2432 @@
                              (SETQ VIR-ADR (+ VIRTUAL-BASE (LSH ADR-IN-BLOCK 8)))))
               (COND ((< PHT-ADR 0)
-                     (COND ((< VIR-ADR A-MEMORY-VIRTUAL-ADDRESS)
+                     (COND ((< VIR-ADR A-MEMORY-VIRTUAL-BASE-ADDRESS)
                             (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS
                                          VIR-ADR 'NOT-FOUND-IN-PHT))
@@ -2407 +2443 @@
                                      (SETQ PHT-VALUE (PHYS-MEM-READ (1+ PHT-ADR))))))
                      (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS VIR-ADR 'DIFFERS-FROM-PHT))
+                     (PRINT (LIST 'MAP-VALUE L2M
+                                  'PHT-VALUE PHT-VALUE 
+                                  'PHT-ADR PHT-ADR 
+                                  'LEVEL-2-MAP-ADR (+ (LSH LEVEL-2-BLOCK-NUMBER
+                                                           5)
+                                                      ADR-IN-BLOCK))))
+                    ((NOT (= (LOGLDB %%PHT2-META-BITS L2M)
+                             (LOGLDB %%PHT2-META-BITS PHT-VALUE)))
+                     (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS VIR-ADR 'META-BITS-DIFFER))
                      (PRINT (LIST 'MAP-VALUE L2M
                                   'PHT-VALUE PHT-VALUE 
@@ -2641 +2686 @@
 (DEFUN (CODE CC-COLON-CMD) (ARG)
    (TERPRI)
-   (LET ((PC (QF-POINTER (CC-SHIFT (CC-SYMBOLIC-EXAMINE-REGISTER 'LC) -1)))
-         (FEF (CC-REGISTER-EXAMINE (+ (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
-                                      RAPBO))))
+   (LET ((PC (COND (CC-OPEN-REGISTER 0)
+                   (T (QF-POINTER (CC-SHIFT (CC-SYMBOLIC-EXAMINE-REGISTER 'LC) -1)))))
+         (FEF (COND (CC-OPEN-REGISTER (CC-REGISTER-EXAMINE CC-OPEN-REGISTER))
+                    (T (CC-REGISTER-EXAMINE (+ (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
+                                               RAPBO))))))
      (DECLARE (FIXNUM PC FEF))
      (COND ((NOT (= (QF-DATA-TYPE FEF) DTP-FEF-POINTER))
             (PRINC '|The current function is not a FEF.|) (TERPRI))
            (T (SETQ FEF (QF-POINTER FEF))
-              (PRINC '|Current FEF is |)
+              (PRINC (COND (CC-OPEN-REGISTER '|FEF is |)
+                           (T '|Current FEF is |)))
               (CC-Q-PRINT-TOPLEV (CC-MEM-READ (+ %FEFHI-FCTN-NAME FEF)))
               (TERPRI)
               (LET ((RELPC (- PC (* 2 FEF))))
                 (DECLARE (FIXNUM RELPC))
-                (COND ((OR (< RELPC 10) (> RELPC 10000))
+                (COND ((AND (NULL CC-OPEN-REGISTER) (OR (< RELPC 10) (> RELPC 10000)))
                        (PRINC '|The PC does not seem to be pointer to the running FEF.|)
                        (TERPRI))
-                      (T (CC-DISASSEMBLE-FEF FEF (COND ((EQ ARG 1) NIL)
+                      (T (CC-DISASSEMBLE-FEF FEF (COND ((OR CC-OPEN-REGISTER (EQ ARG 1)) NIL)
                                                        (T RELPC))))))))))
 
@@ -2934 +2982 @@
     (SELECT-FIELD DEFERRED-SEQUENCE-BREAK 2201 (NIL DEFERRED-SEQUENCE-BREAK)) ))
 
+(declare (special cc-ilong-range cc-ilong-set cc-ilong-list cc-ilong-high-half))
+
+(defun ilong-initialize-search ()
+  (setq cc-ilong-range '(0 30000))
+  (setq cc-ilong-set nil)
+  (setq cc-ilong-list nil)
+  (setq cc-ilong-high-half t))
+
+(defun ilong-setup nil
+  (if cc-ilong-set (ilong-clear))
+  (setq cc-ilong-list nil)
+  (let ((last (+ (car cc-ilong-range) (cadr cc-ilong-range))))
+    (do ((adr (car cc-ilong-range) (1+ adr))
+         wd
+         (ilong (dpb 1 cons-ir-ilong 0)))
+        ((>= adr last)
+          t)
+      (cond ((zerop (logand ilong (setq wd (cc-read-c-mem adr))))
+             (cc-write-c-mem adr (logior ilong wd)))
+            (t (push adr cc-ilong-list)))))
+  (setq cc-ilong-set t))
+
+(defun ilong-clear nil
+  (let ((last (+ (car cc-ilong-range) (cadr cc-ilong-range))))
+    (do ((adr (car cc-ilong-range) (1+ adr))
+         (ilong-mask (logxor -1 (dpb 1 cons-ir-ilong 0))))
+        ((>= adr last))
+      (cond ((memq adr cc-ilong-list))
+            (t (cc-write-c-mem adr (logand ilong-mask (cc-read-c-mem adr)))))))
+  (setq cc-ilong-set nil))
+
+;if last trial won, subdivide interval
+;if lost,try other half of interval.
+(defun ilong-trial (win)
+  (if cc-ilong-set (ilong-clear))
+  (cond (win (setq cc-ilong-range (list (car cc-ilong-range)
+                                        (// (cadr cc-ilong-range) 2)))
+             (setq cc-ilong-high-half nil))
+        (cc-ilong-high-half
+         (format t "~%lost on both halves of range ~s ~s"
+                 (- (car cc-ilong-range) (cadr cc-ilong-range))
+                 (+ (car cc-ilong-range) (cadr cc-ilong-range)))
+         (break foo t))
+        (t   (setq cc-ilong-range (list (+ (car cc-ilong-range) (cadr cc-ilong-range))
+                                        (cadr cc-ilong-range)))
+             (setq cc-ilong-high-half t)))
+  (format t "~% range now ~s" cc-ilong-range)
+  (ilong-setup))

trunk/lisp/lmcons/ccgsyl.lisp

@@ -12 +12 @@
 (IF-FOR-LISPM
 (DEFUN USER:CC ()
-   (LET ((PACKAGE (PKG-FIND-PACKAGE 'CADR)))
-      (CADR:CC))))
+  (CADR:CC)) )
 
 (DECLARE (SPECIAL CC-GETSYL-UNRCH CC-GETSYL-UNRCH-TOKEN CC-LOW-LEVEL-FLAG))

trunk/lisp/lmcons/dcheck.lisp

@@ -1 @@
-;;; -*- Mode:Lisp; Package:CADR; Base:8; Lowercase:yes -*-
+;;; -*- Mode:Lisp; Package:CADR; Base:8 -*-
 
 ;;; DCHECK - for checking out newly-constructed disk controls
@@ -121 +121 @@
                                   MEM-PARITY-ERROR NXM-ERROR CCW-CYCLE READ-COMPARE-DIFFERENCE
                                   INTERNAL-PARITY-ERROR ))
+     
      #M (PROGN (PRINC '| SEL-UNIT-BLOCK-CTR=|) (PRIN1 (LSH STATUS -24.))))
 
-(defun dc-print-marksman-status ()
-  (let ((sts))
-    (dc-print-status)
-    (terpri)
-    (let ((da (phys-mem-read dc-da-adr)))
-      (format t "~%Disk address: cylinder ~o, head ~o, block ~o (octal)~%"
-                (ldb 2020 da) (ldb 1010 da) (ldb 0010 da)))
-    (princ "Current status: ")
-    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
-    (cc-print-set-bits sts '( track-zero landing-zone ill-cmd ready
-                              spin-out-of-limit end-of-cyl diag-error track-zero-error ))
-    (princ ", Re-read status: ")
-    (dc-exec-1 5)
-    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
-    (cc-print-set-bits sts '( track-zero landing-zone ill-cmd ready
-                              spin-out-of-limit end-of-cyl diag-error track-zero-error ))
-
-    (dc-exec-1 200005)
-    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
-    (princ '|sector-length=|)
-    (prin1 (logldb 0002 sts))
-    (tyo 40)
-    (cc-print-set-bits sts '( nil nil illegal-set-sector sector-switches-overridden
-                              illegal-rezero-or-illegal-seek illegal-cylinder illegal-command
-                              write-protect-violation ))
-    (terpri)
-    (dc-exec-1 400005)
-    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
-    (princ '|last cmd byte 1=|)
-    (prin1 sts)
-    (dc-exec-1 600005)
-    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
-    (princ '|, byte 2=|)
-    (prin1 sts)
-    (dc-exec-1 1000005)
-    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
-    (princ '|, cur cyl=|)
-    (prin1 sts)
-    (dc-exec-1 1200005)
-    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
-    (princ '|, sec//trk-1=|)
-    (prin1 sts)
-    (dc-exec-1 1400005)
-    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
-    (princ '|, diag sts 1=|)
-    (prin1 sts)
-    (dc-exec-1 1600005)
-    (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
-    (princ '|, diag sts 2=|)
-    (prin1 sts)))
-
 ;;; Seek, print status if error
-(DEFUN DC-SEEK (CYL)
+(DEFUN DC-SEEK (CYL &OPTIONAL (UNIT 0))
+  (PHYS-MEM-WRITE DC-DA-ADR (ASH UNIT 28.))
   (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE)
   (PHYS-MEM-WRITE DC-START-ADR 0)
   (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
-  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 0))
-  (PHYS-MEM-WRITE DC-CMD-ADR (logdpb cyl 3010 (logdpb 100 2010 DC-SEEK)))
+  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 (ASH UNIT 28.)))
+  (PHYS-MEM-WRITE DC-CMD-ADR (LOGDPB CYL 3010 (LOGDPB 100 2010 DC-SEEK)))
   (PHYS-MEM-WRITE DC-START-ADR 0)
   (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
-  (OR MARKSMAN-P
-      (DO () ((LDB-TEST 0201 (PHYS-MEM-READ DC-STS-ADR))) ;Await attention
-        #M (SLEEP 0.03)
-        #Q (PROCESS-ALLOW-SCHEDULE)
-        ))
+  (DO () ((LDB-TEST 0201 (PHYS-MEM-READ DC-STS-ADR))) ;Await attention
+    #M (SLEEP 0.03)
+    #Q (PROCESS-ALLOW-SCHEDULE)
+    )
   (DC-CHECK-STATUS DC-SOME-ERROR-BITS))
 
-(defun dc-recal-marksman ()
-  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
-  (dc-exec 10000005 0 0 0 0 nil 0)
-  (dc-print-marksman-status))
-
-;;; Run internal marksman diagnostics (this doesn't work, maybe we don't have the firmware)
-(defun dc-diag-marksman (test-number)
-  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
-  (PHYS-MEM-WRITE DC-CMD-ADR (logdpb (+ 200 test-number) 2010 5))
-  (PHYS-MEM-WRITE DC-START-ADR 0)
-  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
-  (dc-print-marksman-status))
-
 ;;; Perform a read or write, check specified status bits.
-(DEFUN DC-EXEC (CMD CYL HEAD BLOCK CLP CCW ERR-BITS)
+(DEFUN DC-EXEC (CMD CYL HEAD BLOCK CLP CCW ERR-BITS &OPTIONAL (UNIT 0))
+  (PHYS-MEM-WRITE DC-DA-ADR (ASH UNIT 28.))
   (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE)
   (PHYS-MEM-WRITE DC-START-ADR 0)
   (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
-  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 (+ (LSH HEAD 8) BLOCK)))
+  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB UNIT 3404 (LOGDPB CYL 2014 (+ (LSH HEAD 8) BLOCK))))
   (PHYS-MEM-WRITE DC-CLP-ADR CLP)
   (AND CCW (PHYS-MEM-WRITE CLP CCW))
@@ -234 +172 @@
   (LET ((VAL (PHYS-MEM-READ-24 DC-STS-ADR)))
     (COND ((NOT (ZEROP (LOGAND MASK VAL)))
-           (DC-PRINT-STATUS1 VAL)))))
+           (DC-PRINT-STATUS1 VAL)
+           (let ((ecc (phys-mem-read dc-ecc-adr))
+                 (da  (phys-mem-read dc-da-adr))
+                 (ma  (phys-mem-read dc-ma-adr)))
+             (format t "CYL ~O, HEAD ~O, SEC ~O, MA ~O, ECC pat ~O, ECC pos ~O"
+                     (ldb 2014 da) (ldb 1010 da) (ldb 0010 da)
+                     (dpb (ldb 2010 ma) 2010 (ldb 0020 ma))
+                     (ldb 2020 ecc) (ldb 0020 ecc)))
+           T))))
 
 ;;; This function provides a scope loop for debugging problems starting up
@@ -261 +207 @@
 ;;; Test function
 
-(DEFUN DCHECK (&AUX CONTROLLER-TYPE)
+(DEFUN DCHECK (&OPTIONAL (UNIT 0) &AUX CONTROLLER-TYPE)
   (SETQ CONTROLLER-TYPE (LDB (BITS 2 22.) (PHYS-MEM-READ DC-MA-ADR)))
   (FORMAT T
@@ -267 +213 @@
       CONTROLLER-TYPE)
   ;Don't do this, the hardware isn't necessarily right.  This IS a diagnostic, after all.
-  ;(SETQ MARKSMAN-P (= CONTROLLER-TYPE 1))
-  (FORMAT T "~&Operating as if ~:[Trident~;Marksman~]~%" MARKSMAN-P)
+  ;(SETQ FOO-P (= CONTROLLER-TYPE 1))
+  ;(FORMAT T "~&Operating as if ~:[Trident~;Marksman~]~%" MARKSMAN-P)
   ;; Part 1 - verify bus response to reading and writing disk-address register
   (PHYS-MEM-WRITE DC-DA-ADR 1777777777) ;28 bits
@@ -319 +265 @@
   ;; Part 3.5 - check that the block counter is counting.  This checks
   ;; that the disk is rotating and that the index/sector pulse logic works.
+  (PHYS-MEM-WRITE DC-DA-ADR (ASH UNIT 28.))
   #Q (DCHECK-BLOCK-COUNTER)
-  ;; Part 3.6 - recalibrate.  Marksman needs this if I/O reset has been done.
+  ;; Part 3.6 - recalibrate.  
   (FORMAT T "~&Recalibrate...")
-  (DC-RECALIBRATE)
+  (DC-RECALIBRATE UNIT)
   ;; Part 4 - Test disk bus bits and basic command logic by seeking
   (COND ((NOT BYPASS-SEEKS)
-         (DCHECK-SEEK (if marksman-p 209. 814.))
-         (DO I (if marksman-p 128. 512.) (LSH I -1) (ZEROP I)
-           (DCHECK-SEEK I))))
+         (DCHECK-SEEK 814. UNIT)
+         (DO I 512. (LSH I -1) (ZEROP I)
+           (DCHECK-SEEK I UNIT))))
   (and local-disk-p (break the-rest-of-this-aint-gonna-work))
   ;; Part 5 - Check address logic by reading with a CLP that points at NXM
@@ -334 +281 @@
   ;;   MA is naturally going to be wrong also since no memory cycles at all will happen.
   (LET ((MASK   ;Bits which are suspect (this stuff is only 22 bits, fits in fixnum)
-         (LOGIOR (DCHECK-CLP-ADR NXM-LOC1) (DCHECK-CLP-ADR NXM-LOC2) (DCHECK-CLP-ADR NXM-LOC3)
-                 (DCHECK-CCW-ADR NXM-LOC3) (DCHECK-CCW-ADR NXM-LOC2) (DCHECK-CCW-ADR NXM-LOC1)
+         (LOGIOR (DCHECK-CLP-ADR NXM-LOC1 UNIT)
+                 (DCHECK-CLP-ADR NXM-LOC2 UNIT)
+                 (DCHECK-CLP-ADR NXM-LOC3 UNIT)
+                 (DCHECK-CCW-ADR NXM-LOC3 UNIT)
+                 (DCHECK-CCW-ADR NXM-LOC2 UNIT)
+                 (DCHECK-CCW-ADR NXM-LOC1 UNIT)
                  )))
     (COND ((NOT (ZEROP MASK))
@@ -352 +303 @@
     (PHYS-MEM-WRITE I (+ (LSH (LOGXOR 377 I) 8) I)))
   (PRINT 'WRITE)
-  (DC-EXEC DC-WRITE 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS)
+  (DC-EXEC DC-WRITE 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT)
   (LET ((MA (DC-READ-MA)))
     #M (DECLARE (FIXNUM MA))
@@ -361 +312 @@
     (PHYS-MEM-WRITE I 0))
   (PRINT 'READ)
-  (DC-EXEC DC-READ 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS)
+  (DC-EXEC DC-READ 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT)
   (LET ((MA (DC-READ-MA)))
     #M (DECLARE (FIXNUM MA))
@@ -392 +343 @@
   (PRINC "Trying reads of various blocks; will get HEADER-COMPARE if disk bus bits bad")
   (TERPRI)
-  (DC-EXEC DC-READ 0 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS)
+  (DC-EXEC DC-READ 0 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT)
   (PRINC " cyl 0 ")
   (DO CYL 1 (LSH CYL 1) (= CYL 2000)
-    (DC-EXEC DC-READ CYL 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS)
+    (DC-EXEC DC-READ CYL 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT)
     (PRINC " cyl ")
     (PRIN1 CYL))
@@ -404 +355 @@
   (PRINC '|End of DCHECK.  Now run the format program and the ECC test program.|))
 
+(defun dc-read-cyl (cyl)
+    (DC-EXEC DC-READ CYL 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS )
+    (PRINC " cyl ")
+    (PRIN1 CYL))
+
+(defun dc-read-block (cyl head block)
+    (DC-EXEC DC-READ CYL head block CCW-LOC 0 DC-ALL-ERROR-BITS )
+    (PRINC " cyl ")
+    (PRIN1 CYL)
+    (princ "   block ")
+    (prin1 block)
+    (princ "   head ")
+    (prin1 head))
+ 
 (DEFUN DC-RESET NIL
   (PHYS-MEM-WRITE DC-CMD-ADR DC-STOP)
   (PHYS-MEM-WRITE DC-CMD-ADR 0))
 
-(DEFUN DC-RECALIBRATE NIL
-  (DC-EXEC DC-RECAL 0 0 0 0 NIL 0)
+(DEFUN DC-RECALIBRATE (&OPTIONAL (UNIT 0))
+  (DC-EXEC DC-RECAL 0 0 0 0 NIL 0 UNIT)
   (DO () ((NOT (BIT-TEST 1_8 (PHYS-MEM-READ DC-STS-ADR))))
     (PROCESS-ALLOW-SCHEDULE)))
 
-(DEFUN DC-FAULT-CLEAR NIL
-  (DC-EXEC DC-FAULT-CLEAR 0 0 0 0 NIL 0)
+(DEFUN DC-FAULT-CLEAR (&OPTIONAL (UNIT 0))
+  (DC-EXEC DC-FAULT-CLEAR 0 0 0 0 NIL 0 UNIT)
   (DO () ((NOT (BIT-TEST 1_8 (PHYS-MEM-READ DC-STS-ADR))))
     (PROCESS-ALLOW-SCHEDULE)))
@@ -446 +411 @@
 #Q
 (DEFUN DCHECK-BLOCK-COUNTER ()
-  (DO ((DESIRED-VALUES #10R (IF MARKSMAN-P
-                                '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)
-                                ;; Vandals: Yes, a value of 17. can appear here
-                                '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)))
+  (DO ((DESIRED-VALUES #10R  ;; Vandals: Yes, a value of 17. can appear here
+                                '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17))
        (GOOD-VALUES NIL)
        (BAD-VALUES NIL)
@@ -473 +436 @@
 
 ;;; Check address logic, return bits which failed
-(DEFUN DCHECK-CLP-ADR (ADR)
+(DEFUN DCHECK-CLP-ADR (ADR &OPTIONAL (UNIT 0))
   (LET ((MA 0))
     (DECLARE (FIXNUM MA))
-    (DC-EXEC DC-READ 0 0 0 ADR NIL 0)
+    (DC-EXEC DC-READ 0 0 0 ADR NIL 0 UNIT)
     (COND ((NOT (= (LOGAND 14000000 (PHYS-MEM-READ-24 DC-STS-ADR))
                    14000000))  ;NXM and CCW CYCLE
@@ -497 +460 @@
    (DC-EXEC DC-READ 0 0 0 CCW-LOC 1000 0)))
 
-(DEFUN DCHECK-CCW-ADR (ADR)
+;Tight writing loop.  This is the same as the write in part 6 of DCHECK.
+(DEFUN DCHECK-WRITE-LOOP NIL
+  (DO I 0 (1+ I) (= I 40)                       ;Loc 0-37 get floating 1's
+      (PHYS-MEM-WRITE I (#M LSH #Q ASH 1 I)))
+  (DO I 0 (1+ I) (= I 40)                       ;Loc 40-77 get floating 0's
+      (PHYS-MEM-WRITE (+ 40 I) (- (#M LSH #Q ASH 1 32.) (#M LSH #Q ASH 1 I))))
+  (DO I 100 (1+ I) (= I 400)                    ;Loc 100-377 get address pattern
+      (PHYS-MEM-WRITE I (+ (LSH (LOGXOR 377 I) 8) I)))
+  (DO () ((KBD-TYI-NO-HANG))
+    (DC-EXEC DC-WRITE 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS)
+    (LET ((MA (DC-READ-MA)))
+      (COND ((NOT (= MA 377))
+             (TERPRI) (PRINC '|MA wrong on write of pattern, correct=377, actual=|)
+             (PRIN1 MA))))))
+
+
+(defun dcheck-check-da-block-increments nil
+  (dotimes (block  blocks-per-track)
+    (cc-disk-xfer dc-read (+ (* 100 blocks-per-cylinder)
+                             block)
+                1 2)))
+
+(defun dcheck-check-da-head-increments nil
+  (dotimes (head (// blocks-per-cylinder blocks-per-track))
+    (cc-disk-xfer dc-read (+ (* 100 blocks-per-cylinder)
+                             (1- blocks-per-track)
+                             (* head blocks-per-track))
+                1 2)))
+
+(defun dcheck-check-da-cylinder-increments nil
+  (dotimes (cyl n-cylinders)
+    (cc-disk-xfer dc-read (+ (* cyl blocks-per-cylinder)
+                             (1- blocks-per-cylinder))
+                  1 2)))
+
+(defun dcheck-check-da-cylinder-increments-1 nil
+  (do ((adr 12 (1+ adr))
+       (core-page 1 (1+ core-page))
+       (n (* 2 blocks-per-cylinder) (1- n)))
+      ((= n 0))
+    (phys-mem-write adr (+ (cc-shift adr 8) (cond ((= n 1) 0) (t 1)))))
+  (dotimes (cyl (- n-cylinders 2))
+    (dc-exec dc-read cyl 0 0 12 nil dc-all-error-bits)))
+
+(DEFUN DCHECK-CCW-ADR (ADR &OPTIONAL (UNIT 0))
   (LET ((MA 0))
     (DECLARE (FIXNUM MA))
-    (DC-EXEC DC-READ 0 0 0 CCW-LOC (SETQ ADR (LOGAND 77777400 ADR)) 0)
+    (DC-EXEC DC-READ 0 0 0 CCW-LOC (SETQ ADR (LOGAND 77777400 ADR)) 0 UNIT)
     (COND ((NOT (= (LOGAND 14000000 (PHYS-MEM-READ-24 DC-STS-ADR))
                    04000000))  ;NXM and -CCW CYCLE
@@ -517 +524 @@
 
 ;;; Alternating seek test
-(DEFUN DCHECK-SEEK (CYL)
+(DEFUN DCHECK-SEEK (CYL &OPTIONAL (UNIT 0))
   (TERPRI)
   (PRINC '|Should be seeking between cylinders 0 and |)
@@ -524 +531 @@
   (PRINC '| - type space when OK. |)
   (DO () (#M (NOT (ZEROP (LISTEN))) #Q (KBD-TYI-NO-HANG))
-    (DC-SEEK 0)
-    (DC-SEEK CYL))
+    (DC-SEEK 0 UNIT)
+    (DC-SEEK CYL UNIT))
   #M (TYI)
   (TERPRI))
@@ -547 +554 @@
     (PHYS-MEM-WRITE ADR VAL2)
     (PHYS-MEM-READ ADR)))
+
+
 
 ;;; ECC Test (in DCFU) error-message printer
@@ -606 +615 @@
 ;;; Read/Write test
 
-(declare (special dc-write-read-trace))
-(setq dc-write-read-trace t)
+(defvar dc-write-read-trace t)
+(defvar dc-test-unit 0)
 
 ;;; Low-level routine, does a write and a read and compares
@@ -616 +625 @@
   ;; Trace
   (and dc-write-read-trace
-       (format t '|~%WRITE-READ-TEST: cyl=~O, head=~O, blk=~O, pattern=~A|
-                 cyl head blk pattern-func))
+       (format t '|~%WRITE-READ-TEST: unit=~O, cyl=~O, head=~O, blk=~O, pattern=~A|
+                 dc-test-unit cyl head blk pattern-func))
   ;; Fill memory with pattern
   (do i 0 (1+ i) (= i 400)
     (phys-mem-write (+ offset i) (funcall pattern-func i)))
   ;; Write it out
-  (dc-exec dc-write cyl head blk 777 (+ offset 0) dc-all-error-bits)
+  (dc-exec dc-write cyl head blk 777 (+ offset 0) dc-all-error-bits dc-test-unit)
   (do i 0 (1+ i) (= i 400)
       (phys-mem-write (+ offset i) 0))
   ;; Read it back
-  (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits)  
+  (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits dc-test-unit)
   ;; Check pattern
   (do ((i 0 (1+ i))
@@ -656 +665 @@
   ;; Trace
   (and dc-write-read-trace
-       (format t "~%READ-TEST: cyl=~O, head=~O, blk=~O"
-                 cyl head blk))
+       (format t "~%READ-TEST: unit=~O, cyl=~O, head=~O, blk=~O"
+                 dc-test-unit cyl head blk))
   ;; Read it
-  (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits)  
+  (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits dc-test-unit)
 )
 
@@ -741 +750 @@
 ;;; This version is kludged up, you should step only one addr at a time!
 (defun dc-write-read-test (&optional response-list
-                                     (all-list (if marksman-p
-                                                   '( (do 0 210.)
-                                                      (do 0 4)
-                                                      (do 0 21.))
-                                                   '( (do 0 815.)
-                                                      (do 0 5)
-                                                      (do 0 17.) ))))
+                                     (all-list '( (do 0 815.)
+                                                 (do 0 5)
+                                                 (do 0 17.) )))
   (multiple-value-bind (cyl head blk pattern-func)
       (dc-get-addr-specs response-list all-list)
@@ -757 +762 @@
   (dc-write-read-test '(all all all all)))
 
-(defun dc-read-test (&optional response-list (all-list (if marksman-p
-                                                           '( (do 0 210.)
-                                                              (do 0 4)
-                                                              (do 0 21.))
-                                                           '( (do 0 815.)
-                                                              (do 0 5)
-                                                              (do 0 17.) ))))
+(defun dc-read-test (&optional response-list (all-list '( (do 0 815.)
+                                                         (do 0 5)
+                                                         (do 0 17.) )))
   (multiple-value-bind (cyl head blk pattern-func)
       (dc-get-addr-specs response-list all-list T)
@@ -952 +953 @@
 ;This function reads in a track and types out some approximation of what's on it
 ;If cyl is nil, decode what's in core
-(defun decode-track (cyl head &optional (blk 0))
+(defun decode-track (cyl head &optional (blk 0) (unit 0))
   (cond ((not (null cyl))
          ;; First, read in 20. blocks, which is more than 20160. bytes
@@ -958 +959 @@
            (dbg-write-xbus i (+ (lsh (1+ i) 8)
                                 (cond ((= i 19.) 0) (t 1)))))  
-         (dc-exec dc-read-all cyl head blk 0 nil dc-some-error-bits)
+         (dc-exec dc-read-all cyl head blk 0 nil dc-some-error-bits unit)
          (get-buffer) ;gobble it down from other machine
          ))