Changeset 271

Show
Ignore:
Timestamp:
08/18/11 10:30:09 (3 years ago)
Author:
rjs
Message:

Update from System 78.

Location:
trunk/lisp/lmcons
Files:
17 removed
4 modified

Legend:

Unmodified
Added
Removed
  • trunk/lisp/lmcons/cadld.lisp

    r214 r271  
    1 ;;; -*-LISP-*- Patch file for CADR microcode loader 
     1;;; -*- MODE: LISP; PACKAGE: CADR; BASE: 8 -*- Patch file for CADR microcode loader 
    22 
    33(INCLUDE |LMDOC;.COMPL PRELUD|) 
     
    1717              ((= (LENGTH FILE-NAME) 1)  
    1818                (SETQ FILE-NAME (APPEND FILE-NAME '(ULOAD DSK LISPM1))))) 
    19   #Q    (IF (NULL FILE-NAME) (SETQ FILE-NAME "AI: LISPM1; UCADR ULOAD") 
    20             (SETQ FILE-NAME (SI:FILE-PARSE-NAME 
    21                               FILE-NAME NIL 
    22                               (SI:FILE-PARSE-NAME "AI: LISPM1; UCADR ULOAD")))) 
     19  #Q    (SETQ FILE-NAME 
     20              (FS:MERGE-PATHNAME-DEFAULTS (OR FILE-NAME "SYS: UBIN; UCADR ULOAD >"))) 
    2321        (COND ((EQ MODE 'LOAD-WITHOUT-SYMBOLS) 
    2422                (SETQ LOAD-WITHOUT-SYMBOLS-FLAG T) 
     
    8583               #Q (PROCESS-ALLOW-SCHEDULE)  ;Come up for a breath 
    8684               (CC-END-ADDING-SYMBOLS) 
    87                (SETQ CC-FILE-SYMBOLS-LOADED-FROM FILE) 
     85               (SETQ CC-FILE-SYMBOLS-LOADED-FROM 
     86                     #M FILE-NAME 
     87                     #Q (FUNCALL FILE ':TRUENAME))      ;So EQ will work later 
    8888               (GO COM))) 
    8989        (CC-ADD-TYPED-SYMBOL TEM (READ FILE) (READ-FIXNUM FILE)) 
     
    197197               (PRIN1-THEN-SPACE WD) 
    198198               (AND (< REG-ADR RACME) 
    199                     (CC-TYPE-OUT WD CC-UINST-DESC T)) 
     199                    (CC-TYPE-OUT WD CC-UINST-DESC T T)) 
    200200               (PRINT 'MACHINE) 
    201201               (SETQ WD (LOGDPB RD3 4020 (LOGDPB RD2 2020 RD1))) 
    202202               (PRIN1-THEN-SPACE WD) 
    203203               (AND (< REG-ADR RACME) 
    204                     (CC-TYPE-OUT WD CC-UINST-DESC T)) 
     204                    (CC-TYPE-OUT WD CC-UINST-DESC T T)) 
    205205               (PRINT '-----)))) 
    206206  (AND (NOT (< REG-ADR RAMMO))                          ;IF LOADING M, ALSO CHECK A 
     
    231231        (SETQ ADR (1+ ADR)) 
    232232        (GO L))) 
     233 
  • trunk/lisp/lmcons/cc.lisp

    r213 r271  
    293293(IF-FOR-LISPM 
    294294(DEFUN CC-SELECT-SYMBOL-TABLE (FILENAME) 
    295   (LET ((TEM (ASSOC FILENAME CC-SYMBOL-TABLES-LOADED))) 
     295  (LET ((TEM (ASSQ FILENAME CC-SYMBOL-TABLES-LOADED))) 
    296296    (COND (TEM (SETQ CC-FILE-SYMBOLS-LOADED-FROM (CAR TEM) 
    297297                     CC-SYMBOLS-SIZE (CADR TEM) 
     
    330330 
    331331(DEFUN CC-END-ADDING-SYMBOLS () 
    332    (SETQ CC-SYMBOLS-ARRAY-SIZE CC-SYMBOLS-SIZE) 
     332   ;(SETQ CC-SYMBOLS-ARRAY-SIZE CC-SYMBOLS-SIZE)  ;Don't do this, it just causes wastage later 
    333333   #M (*REARRAY CC-SYMBOLS-NAME T CC-SYMBOLS-SIZE) 
    334334   #Q (ADJUST-ARRAY-SIZE CC-SYMBOLS-NAME CC-SYMBOLS-SIZE) 
     
    416416                      (COND ((ZEROP DELTA) NAME) 
    417417                            ((AND (> DELTA 0) 
    418                                   (< DELTA 20)) 
     418                                  (< DELTA 100)) 
    419419                             (LIST NAME DELTA)) 
    420420                            (T NIL)))))))) 
     
    466466;DEFINITIONS OF VARIOUS WORD FORMATS, FOR BOTH TYPE-OUT AND TYPE-IN 
    467467 
    468 (DECLARE (SPECIAL CC-Q-DESC CC-A-DESC CC-HWD-DESC CC-BYTE-DESC CC-INST-DESC 
     468(DECLARE (SPECIAL CC-Q-DESC CC-A-DESC CC-HWD-DESC CC-BYTE-DESC CC-INST-DESC CC-ASCII-BYTE-DESC 
    469469                  CC-I-DEST-DESC CC-I-ADDR-DESC CC-I-BR-DESC 
    470470                  CC-I-11-DESC CC-I-12-DESC CC-I-13-DESC CC-I-15-DESC 
     
    475475                  CC-SEXP-DESC)) 
    476476 
    477 (SETQ CC-MODE-DESC-TABLE '( 
    478         (H . CC-HWD-DESC) (B . CC-BYTE-DESC) 
    479         (Q . CC-Q-DESC) (A . CC-A-DESC) (/_ . CC-REG-ADDR-DESC) 
    480         (I . CC-INST-DESC) (U . CC-UINST-DESC) (V . CC-O-UINST-DESC) (S . CC-SEXP-DESC) 
    481         (/# . CC-BITS-DESC) 
    482 )) 
     477(DEFCONST CC-MODE-DESC-TABLE '((H . CC-HWD-DESC) (B . CC-BYTE-DESC) 
     478                               (Q . CC-Q-DESC) (A . CC-A-DESC) (/_ . CC-REG-ADDR-DESC) 
     479                               (I . CC-INST-DESC) (T . CC-ASCII-BYTE-DESC) 
     480                              (U . CC-UINST-DESC) (V . CC-O-UINST-DESC) (S . CC-SEXP-DESC) 
     481                               (/# . CC-BITS-DESC) 
     482                               (N . CC-SIGNED-WORD-DESC))) 
    483483 
    484484 
     
    504504; (NUM <FIELD-POSITION>) 
    505505;       pure numeric field, prompting with "#: ". 
     506; (SIGNED-NUM <FIELD-POSITION>) by special hack, it allows fields bigger than fixnum size. 
    506507; (SUB-FIELD <DESCRIPTION-NAME>) 
    507508;       call sub-description. 
     
    534535; (BITS)  typeout only, type bit numbers of set bits. 
    535536 
    536 (SETQ CC-REG-ADDR-DESC '( (CALL CC-PRINT-ADDRESS-1 0030) )) 
    537  
    538 (SETQ CC-BITS-DESC '( (BITS))) 
    539  
    540 (SETQ CC-HWD-DESC '( (NUM 2020) (CTYPE /,/,) (NUM 0020) 
    541 )) 
    542  
    543 (SETQ CC-BYTE-DESC '( (NUM 0010) (CTYPE /,) (NUM 1010) (CTYPE /,) 
    544                       (NUM 2010) (CTYPE /,) (NUM 3010) 
    545 )) 
    546  
    547 (SETQ CC-SEXP-DESC '( (CALL CC-Q-PRINT-TOPLEV-1 0035) )) 
     537(DEFCONST CC-REG-ADDR-DESC '( (CALL CC-PRINT-ADDRESS-1 0030) )) 
     538 
     539(DEFCONST CC-BITS-DESC '( (BITS))) 
     540 
     541(DEFCONST CC-SIGNED-WORD-DESC '( (SIGNED-NUM 0040))) 
     542 
     543(DEFCONST CC-HWD-DESC '( (NUM 2020) (CTYPE /,/,) (NUM 0020))) 
     544 
     545(DEFCONST CC-BYTE-DESC '( (NUM 0010) (CTYPE /,) (NUM 1010) (CTYPE /,) 
     546                         (NUM 2010) (CTYPE /,) (NUM 3010))) 
     547 
     548(DEFCONST CC-ASCII-BYTE-DESC '( (CHAR 0010) (CHAR 1010) 
     549                               (CHAR 2010) (CHAR 3010))) 
     550 
     551(DEFCONST CC-SEXP-DESC '( (CALL CC-Q-PRINT-TOPLEV-1 0035) )) 
    548552 
    549553 
    550 (SETQ CC-Q-DESC '( (SELECT-FIELD CDR 3602 (NIL CDR-TRAP CDR-NIL CDR-NEXT)) 
    551                    (SELECT-FIELD FLAG-BIT 3501 (NIL FLAG-BIT)) 
    552                    (SELECT-FIELD DATA-TYPE 3005 
     554(DEFCONST CC-Q-DESC '( (SELECT-FIELD CDR 3602 (NIL CDR-TRAP CDR-NIL CDR-NEXT)) 
     555                      (SELECT-FIELD FLAG-BIT 3501 (NIL FLAG-BIT)) 
     556                      (SELECT-FIELD DATA-TYPE 3005 
    553557                       (NIL NULL FREE SYMBOL SYMBOL-HEADER FIX EXTENDED-NUMBER HEADER 
    554558                        GC-FORWARD EXTERNAL-VALUE-CELL-POINTER ONE-Q-FORWARD 
     
    558562                            SELECT-METHOD INSTANCE INSTANCE-HEADER 
    559563                        ENTITY T T T T T T T)) 
    560                    (NUM 0030) 
    561 )) 
    562  
    563 (SETQ CC-A-DESC '( (CONSTANT 3005 2)    ;ARRAY-HEADER DATA-TYPE 
    564                    (SELECT-FIELD ARRAY-TYPE 2305 
     564                      (NUM 0030))) 
     565 
     566(DEFCONST CC-A-DESC '( (CONSTANT 3005 2)        ;ARRAY-HEADER DATA-TYPE 
     567                      (SELECT-FIELD ARRAY-TYPE 2305 
    565568                       (T ART-1B ART-2B ART-4B ART-8B ART-16B ART-32B ART-Q  
    566569                        ART-Q-LIST ART-STRING ART-STACK-GROUP-HEAD ART-SPECIAL-PDL  
     
    573576                   (SELECT-FIELD LONG 1301 (NIL LONG)) 
    574577                   (SELECT-FIELD SPARE-BIT 1201 (NIL SPARE-BIT)) 
    575                    (TYPE-FIELD INDEX-LENGTH 0012 NIL) 
    576 )) 
     578                   (TYPE-FIELD INDEX-LENGTH 0012 NIL))) 
    577579 
    578 (SETQ CC-INST-DESC '( (SELECT-FIELD OP-CODE 1104 
     580(DEFCONST CC-INST-DESC '( (SELECT-FIELD OP-CODE 1104 
    579581                       (CALL CALL0 MOVE CAR 
    580582                        CDR CADR CDDR CDAR 
     
    590592                        CC-I-ADDR-DESC CC-I-ADDR-DESC CC-I-ADDR-DESC  
    591593                        CC-I-ADDR-DESC CC-I-ADDR-DESC CC-I-ADDR-DESC  
    592                         NIL CC-I-15-DESC NIL NIL)) 
    593 )) 
    594  
    595 (SETQ CC-I-DEST-DESC '( (SELECT-FIELD DEST 1503 
     594                        NIL CC-I-15-DESC NIL NIL)))) 
     595 
     596(DEFCONST CC-I-DEST-DESC '( (SELECT-FIELD DEST 1503 
    596597                          (IGNORE STACK NEXT LAST 
    597598                           RETURN NEXTQ LASTQ NEXT-LIST)) 
    598599)) 
    599600 
    600 (SETQ CC-I-ADDR-DESC '( (COND ADR-TYPE 1001 (CC-I-ADDR-F-DESC CC-I-ADDR-R-DESC)) 
     601(DEFCONST CC-I-ADDR-DESC '( (COND ADR-TYPE 1001 (CC-I-ADDR-F-DESC CC-I-ADDR-R-DESC)) 
    601602)) 
    602603 
    603 (SETQ CC-I-ADDR-F-DESC '( (TYPE FEF) (NUM 0010) )) 
    604  
    605 (SETQ CC-I-ADDR-R-DESC '( (SELECT-FIELD ADR 0602 (QTPG LCL ARG PDL)) 
    606                           (NUM 0006) 
    607 )) 
    608  
    609 (SETQ CC-I-BR-DESC '( (SELECT-FIELD BRANCH 1503 
     604(DEFCONST CC-I-ADDR-F-DESC '( (TYPE FEF) (NUM 0010) )) 
     605 
     606(DEFCONST CC-I-ADDR-R-DESC '( (SELECT-FIELD ADR 0602 (QTPG LCL ARG PDL)) 
     607                             (NUM 0006))) 
     608 
     609(DEFCONST CC-I-BR-DESC '( (SELECT-FIELD BRANCH 1503 
    610610                       (BR BR-NIL BR-NOT-NIL BR-NIL-OR-POP 
    611611                        BR-NOT-NIL-OR-POP BR-ATOM BR-NOT-ATOM T)) 
     
    613613)) 
    614614 
    615 (SETQ CC-I-11-DESC '( (SELECT-FIELD OP 1503 
     615(DEFCONST CC-I-11-DESC '( (SELECT-FIELD OP 1503 
    616616                        (T + - * // LOGAND LOGXOR LOGIOR)) 
    617617)) 
    618618 
    619 (SETQ CC-I-12-DESC '( (SELECT-FIELD OP 1503 
     619(DEFCONST CC-I-12-DESC '( (SELECT-FIELD OP 1503 
    620620                        (= > < EQ SCDR SCDDR 1+ 1-)) 
    621621)) 
    622622 
    623 (SETQ CC-I-13-DESC '( (SELECT-FIELD OP 1503 
     623(DEFCONST CC-I-13-DESC '( (SELECT-FIELD OP 1503 
    624624                        (BIND BINDNIL BINDPOP SETNIL SETZERO PUSH-E MOVEM POP)) 
    625625)) 
    626626 
    627 (SETQ CC-I-15-DESC '( (TYPE-FIELD MISC-OP 0011 NIL) 
     627(DEFCONST CC-I-15-DESC '( (TYPE-FIELD MISC-OP 0011 NIL) 
    628628                      (OUTPUT (CALL CC-I-MISC-NAME 0011)) ))     
    629629 
     
    858858;;; Print a string.  Note that it is truncated to at most 200 characters to 
    859859;;; avoid printing infinite garbage 
     860(DEFVAR CC-Q-PRINT-STRING-MAXL 200) 
     861 
    860862(DEFUN CC-Q-PRINT-STRING (ADR) 
    861863  (QF-ARRAY-SETUP (QF-MAKE-Q (QF-POINTER ADR) DTP-ARRAY-POINTER)) 
     
    867869       (CH) 
    868870       (WD)) 
    869       ((OR (>= I LEN) (= I 200)) 
     871      ((OR (>= I LEN) (= I CC-Q-PRINT-STRING-MAXL)) 
    870872       (AND (< I LEN) (PRINC '/././.) CC-OUTPUT-STREAM) 
    871873       NIL) 
     
    968970              ((EQ (CAR ITEM) 'NUM) 
    969971                (PRIN1-THEN-SPACE (LOGLDB (CADR ITEM) WD))) 
     972              ((EQ (CAR ITEM) 'SIGNED-NUM) 
     973               (PRIN1-THEN-SPACE (CC-UNSIGNED-TO-SIGNED (CADR ITEM) 
     974                                                        (LOGLDB-BIG (CADR ITEM) WD)))) 
     975              ((EQ (CAR ITEM) 'CHAR) 
     976                (TYO (LOGLDB (CADR ITEM) WD))) 
    970977              ((EQ (CAR ITEM) 'CONSTANT)) 
    971978              ((EQ (CAR ITEM) 'INPUT)) 
     
    9991006        (GO L1) 
    10001007)) 
     1008 
     1009;like LDB, but can load fields bigger than fixnum size. 
     1010(DEFUN LOGLDB-BIG (FLD WD) 
     1011  (PROG (ANS BITS BITS-OVER SHIFT) 
     1012        (SETQ SHIFT 0 ANS 0 BITS (LOGLDB 0006 FLD) BITS-OVER (LOGLDB 0620 FLD)) 
     1013    L   (SETQ ANS (LOGIOR ANS (ASH (LOGLDB (LOGDPB BITS-OVER 0620 (MIN BITS 23.)) WD) SHIFT))) 
     1014        (IF ( 
     1015 (SETQ BITS (- BITS 23.)) 0) (RETURN ANS)) 
     1016        (SETQ SHIFT (+ SHIFT 23.) 
     1017              BITS-OVER (+ BITS-OVER 23.)) 
     1018        (GO L))) 
     1019 
     1020(DEFUN CC-UNSIGNED-TO-SIGNED (FLD WD) 
     1021  (LET ((SIGN-BIT (ASH 1 (1- (LDB 0006 FLD))))) 
     1022    (IF (NOT (ZEROP (LOGAND SIGN-BIT WD))) 
     1023        (MINUS (1+ (LOGXOR WD (1- (ASH SIGN-BIT 1))))) 
     1024        WD))) 
    10011025 
    10021026(DEFUN CC-C-OR-D-ADR-OUT (TYPE VAL SYM-BASE) 
     
    13451369  (CC-UCODE-LOADER 'LOAD-WITHOUT-SYMBOLS FILE NIL)) 
    13461370 
    1347 (DEFUN CC-LOAD-UCODE-SYMBOLS (FILE &OPTIONAL MERGEP) 
    1348   (COND ((EQUAL FILE CC-FILE-SYMBOLS-LOADED-FROM)) 
     1371(DEFUN CC-LOAD-UCODE-SYMBOLS-FOR-VERSION (VERSION) 
     1372  (CC-LOAD-UCODE-SYMBOLS (FUNCALL (FS:PARSE-PATHNAME "SYS: UBIN; UCADR") 
     1373                                  ':NEW-TYPE-AND-VERSION "SYM" VERSION))) 
     1374 
     1375(DEFUN CC-LOAD-UCODE-SYMBOLS (FILE &OPTIONAL MERGEP &AUX TRUENAME) 
     1376  (SETQ FILE (FS:MERGE-PATHNAME-DEFAULTS FILE) 
     1377        TRUENAME (FUNCALL FILE ':TRUENAME)) 
     1378  (COND ((EQ TRUENAME CC-FILE-SYMBOLS-LOADED-FROM)) 
    13491379        ((AND (NULL MERGEP) 
    1350               (CC-SELECT-SYMBOL-TABLE FILE))) 
     1380              (CC-SELECT-SYMBOL-TABLE TRUENAME))) 
    13511381        (T 
    1352          (CC-UCODE-LOADER 'LOAD-SYMBOLS FILE MERGEP) 
    1353          (CC-RECORD-SYMBOL-TABLE (SETQ CC-FILE-SYMBOLS-LOADED-FROM FILE))))) 
     1382         (CC-UCODE-LOADER 'LOAD-SYMBOLS TRUENAME MERGEP) 
     1383         (CC-RECORD-SYMBOL-TABLE TRUENAME)))) 
    13541384 
    13551385(DEFUN CC-COMPARE-UCODE (FILE) 
     
    13871417 
    13881418 
     1419 
    13891420(DEFUN CC NIL                   ;MAIN LOOP OF CONS CONSOLE PROGRAM 
    1390   (PROG (CC-ARG CC-SYL CC-VAL CC-UPDATE-DISPLAY-FLAG CC-OPEN-REGISTER  
     1421  (PROG ((BASE 8.) (IBASE 8.) (PACKAGE (PKG-FIND-PACKAGE "CADR")) 
     1422         CC-ARG CC-SYL CC-VAL CC-UPDATE-DISPLAY-FLAG CC-OPEN-REGISTER  
    13911423          CC-LAST-OPEN-REGISTER CC-LAST-VALUE-TYPED COM-CH TEM)  
    13921424        (SETQ QF-SWAP-IN-LOOP-CHECK NIL) 
     
    19361968                   (PRINC '| |) 
    19371969                   (PRINC (NTH (LOGLDB %%REGION-SPACE-TYPE BITS) 
    1938                                '(FREE OLD NEW STATIC FIXED EXITED EXIT EXTRA-PDL 
    1939                                  WIRED USER-PAGED COPY 13 14 15 16 17)))) 
     1970                               '(FREE OLD NEW NEW1 NEW2 NEW3 NEW4 NEW5 NEW6 
     1971                                 STATIC FIXED EXTRA-PDL COPY 15 16 17)))) 
    19401972                (TERPRI)))))) 
    19411973 
    19421974 
    1943 (DEFPROP ATOM CC-DESCRIBE-ATOM CC-COLON-CMD) 
    1944  
    1945 (DEFUN CC-DESCRIBE-ATOM (TEM) 
     1975(DEFUN (ATOM CC-COLON-CMD) (TEM) 
    19461976  (SETQ CC-GETSYL-UNRCH NIL CC-GETSYL-UNRCH-TOKEN NIL) ;FLUSH DELIMITER 
    19471977  (SETQ TEM (READ))     ;GET NAME OF ATOM USING LISP SYNTAX 
     
    23852415(DECLARE (SPECIAL %%PHT2-PHYSICAL-PAGE-NUMBER %%PHT2-META-BITS %%PHT2-MAP-ACCESS-CODE)) 
    23862416 
     2417(DECLARE (SPECIAL A-MEMORY-VIRTUAL-BASE-ADDRESS)) 
     2418 
     2419(SETQ A-MEMORY-VIRTUAL-BASE-ADDRESS (DPB (LSH A-MEMORY-VIRTUAL-ADDRESS -27) 
     2420                                         2701 
     2421                                         (DPB A-MEMORY-VIRTUAL-ADDRESS 0027 0))) 
     2422 
    23872423(DEFUN CC-CHECK-LEVEL-2-BLOCK (VIRTUAL-BASE LEVEL-2-BLOCK-NUMBER) 
    23882424 (PROG (L2M PHT-ADR PHT-VALUE VIR-ADR NUM-CHECKED-OK L2MAP-SA) 
     
    23962432                             (SETQ VIR-ADR (+ VIRTUAL-BASE (LSH ADR-IN-BLOCK 8))))) 
    23972433              (COND ((< PHT-ADR 0) 
    2398                      (COND ((< VIR-ADR A-MEMORY-VIRTUAL-ADDRESS) 
     2434                     (COND ((< VIR-ADR A-MEMORY-VIRTUAL-BASE-ADDRESS) 
    23992435                            (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS 
    24002436                                         VIR-ADR 'NOT-FOUND-IN-PHT)) 
     
    24072443                                     (SETQ PHT-VALUE (PHYS-MEM-READ (1+ PHT-ADR)))))) 
    24082444                     (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS VIR-ADR 'DIFFERS-FROM-PHT)) 
     2445                     (PRINT (LIST 'MAP-VALUE L2M 
     2446                                  'PHT-VALUE PHT-VALUE  
     2447                                  'PHT-ADR PHT-ADR  
     2448                                  'LEVEL-2-MAP-ADR (+ (LSH LEVEL-2-BLOCK-NUMBER 
     2449                                                           5) 
     2450                                                      ADR-IN-BLOCK)))) 
     2451                    ((NOT (= (LOGLDB %%PHT2-META-BITS L2M) 
     2452                             (LOGLDB %%PHT2-META-BITS PHT-VALUE))) 
     2453                     (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS VIR-ADR 'META-BITS-DIFFER)) 
    24092454                     (PRINT (LIST 'MAP-VALUE L2M 
    24102455                                  'PHT-VALUE PHT-VALUE  
     
    26412686(DEFUN (CODE CC-COLON-CMD) (ARG) 
    26422687   (TERPRI) 
    2643    (LET ((PC (QF-POINTER (CC-SHIFT (CC-SYMBOLIC-EXAMINE-REGISTER 'LC) -1))) 
    2644          (FEF (CC-REGISTER-EXAMINE (+ (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP) 
    2645                                       RAPBO)))) 
     2688   (LET ((PC (COND (CC-OPEN-REGISTER 0) 
     2689                   (T (QF-POINTER (CC-SHIFT (CC-SYMBOLIC-EXAMINE-REGISTER 'LC) -1))))) 
     2690         (FEF (COND (CC-OPEN-REGISTER (CC-REGISTER-EXAMINE CC-OPEN-REGISTER)) 
     2691                    (T (CC-REGISTER-EXAMINE (+ (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP) 
     2692                                               RAPBO)))))) 
    26462693     (DECLARE (FIXNUM PC FEF)) 
    26472694     (COND ((NOT (= (QF-DATA-TYPE FEF) DTP-FEF-POINTER)) 
    26482695            (PRINC '|The current function is not a FEF.|) (TERPRI)) 
    26492696           (T (SETQ FEF (QF-POINTER FEF)) 
    2650               (PRINC '|Current FEF is |) 
     2697              (PRINC (COND (CC-OPEN-REGISTER '|FEF is |) 
     2698                           (T '|Current FEF is |))) 
    26512699              (CC-Q-PRINT-TOPLEV (CC-MEM-READ (+ %FEFHI-FCTN-NAME FEF))) 
    26522700              (TERPRI) 
    26532701              (LET ((RELPC (- PC (* 2 FEF)))) 
    26542702                (DECLARE (FIXNUM RELPC)) 
    2655                 (COND ((OR (< RELPC 10) (> RELPC 10000)) 
     2703                (COND ((AND (NULL CC-OPEN-REGISTER) (OR (< RELPC 10) (> RELPC 10000))) 
    26562704                       (PRINC '|The PC does not seem to be pointer to the running FEF.|) 
    26572705                       (TERPRI)) 
    2658                       (T (CC-DISASSEMBLE-FEF FEF (COND ((EQ ARG 1) NIL) 
     2706                      (T (CC-DISASSEMBLE-FEF FEF (COND ((OR CC-OPEN-REGISTER (EQ ARG 1)) NIL) 
    26592707                                                       (T RELPC)))))))))) 
    26602708 
     
    29342982    (SELECT-FIELD DEFERRED-SEQUENCE-BREAK 2201 (NIL DEFERRED-SEQUENCE-BREAK)) )) 
    29352983 
     2984(declare (special cc-ilong-range cc-ilong-set cc-ilong-list cc-ilong-high-half)) 
     2985 
     2986(defun ilong-initialize-search () 
     2987  (setq cc-ilong-range '(0 30000)) 
     2988  (setq cc-ilong-set nil) 
     2989  (setq cc-ilong-list nil) 
     2990  (setq cc-ilong-high-half t)) 
     2991 
     2992(defun ilong-setup nil 
     2993  (if cc-ilong-set (ilong-clear)) 
     2994  (setq cc-ilong-list nil) 
     2995  (let ((last (+ (car cc-ilong-range) (cadr cc-ilong-range)))) 
     2996    (do ((adr (car cc-ilong-range) (1+ adr)) 
     2997         wd 
     2998         (ilong (dpb 1 cons-ir-ilong 0))) 
     2999        ((>= adr last) 
     3000          t) 
     3001      (cond ((zerop (logand ilong (setq wd (cc-read-c-mem adr)))) 
     3002             (cc-write-c-mem adr (logior ilong wd))) 
     3003            (t (push adr cc-ilong-list))))) 
     3004  (setq cc-ilong-set t)) 
     3005 
     3006(defun ilong-clear nil 
     3007  (let ((last (+ (car cc-ilong-range) (cadr cc-ilong-range)))) 
     3008    (do ((adr (car cc-ilong-range) (1+ adr)) 
     3009         (ilong-mask (logxor -1 (dpb 1 cons-ir-ilong 0)))) 
     3010        ((>= adr last)) 
     3011      (cond ((memq adr cc-ilong-list)) 
     3012            (t (cc-write-c-mem adr (logand ilong-mask (cc-read-c-mem adr))))))) 
     3013  (setq cc-ilong-set nil)) 
     3014 
     3015;if last trial won, subdivide interval 
     3016;if lost,try other half of interval. 
     3017(defun ilong-trial (win) 
     3018  (if cc-ilong-set (ilong-clear)) 
     3019  (cond (win (setq cc-ilong-range (list (car cc-ilong-range) 
     3020                                        (// (cadr cc-ilong-range) 2))) 
     3021             (setq cc-ilong-high-half nil)) 
     3022        (cc-ilong-high-half 
     3023         (format t "~%lost on both halves of range ~s ~s" 
     3024                 (- (car cc-ilong-range) (cadr cc-ilong-range)) 
     3025                 (+ (car cc-ilong-range) (cadr cc-ilong-range))) 
     3026         (break foo t)) 
     3027        (t   (setq cc-ilong-range (list (+ (car cc-ilong-range) (cadr cc-ilong-range)) 
     3028                                        (cadr cc-ilong-range))) 
     3029             (setq cc-ilong-high-half t))) 
     3030  (format t "~% range now ~s" cc-ilong-range) 
     3031  (ilong-setup)) 
  • trunk/lisp/lmcons/ccgsyl.lisp

    r215 r271  
    1212(IF-FOR-LISPM 
    1313(DEFUN USER:CC () 
    14    (LET ((PACKAGE (PKG-FIND-PACKAGE 'CADR))) 
    15       (CADR:CC)))) 
     14  (CADR:CC)) ) 
    1615 
    1716(DECLARE (SPECIAL CC-GETSYL-UNRCH CC-GETSYL-UNRCH-TOKEN CC-LOW-LEVEL-FLAG)) 
  • trunk/lisp/lmcons/dcheck.lisp

    r218 r271  
    1 ;;; -*- Mode:Lisp; Package:CADR; Base:8; Lowercase:yes -*- 
     1;;; -*- Mode:Lisp; Package:CADR; Base:8 -*- 
    22 
    33;;; DCHECK - for checking out newly-constructed disk controls 
     
    121121                                  MEM-PARITY-ERROR NXM-ERROR CCW-CYCLE READ-COMPARE-DIFFERENCE 
    122122                                  INTERNAL-PARITY-ERROR )) 
     123      
    123124     #M (PROGN (PRINC '| SEL-UNIT-BLOCK-CTR=|) (PRIN1 (LSH STATUS -24.)))) 
    124125 
    125 (defun dc-print-marksman-status () 
    126   (let ((sts)) 
    127     (dc-print-status) 
    128     (terpri) 
    129     (let ((da (phys-mem-read dc-da-adr))) 
    130       (format t "~%Disk address: cylinder ~o, head ~o, block ~o (octal)~%" 
    131                 (ldb 2020 da) (ldb 1010 da) (ldb 0010 da))) 
    132     (princ "Current status: ") 
    133     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr))) 
    134     (cc-print-set-bits sts '( track-zero landing-zone ill-cmd ready 
    135                               spin-out-of-limit end-of-cyl diag-error track-zero-error )) 
    136     (princ ", Re-read status: ") 
    137     (dc-exec-1 5) 
    138     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr))) 
    139     (cc-print-set-bits sts '( track-zero landing-zone ill-cmd ready 
    140                               spin-out-of-limit end-of-cyl diag-error track-zero-error )) 
    141  
    142     (dc-exec-1 200005) 
    143     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr))) 
    144     (princ '|sector-length=|) 
    145     (prin1 (logldb 0002 sts)) 
    146     (tyo 40) 
    147     (cc-print-set-bits sts '( nil nil illegal-set-sector sector-switches-overridden 
    148                               illegal-rezero-or-illegal-seek illegal-cylinder illegal-command 
    149                               write-protect-violation )) 
    150     (terpri) 
    151     (dc-exec-1 400005) 
    152     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr))) 
    153     (princ '|last cmd byte 1=|) 
    154     (prin1 sts) 
    155     (dc-exec-1 600005) 
    156     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr))) 
    157     (princ '|, byte 2=|) 
    158     (prin1 sts) 
    159     (dc-exec-1 1000005) 
    160     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr))) 
    161     (princ '|, cur cyl=|) 
    162     (prin1 sts) 
    163     (dc-exec-1 1200005) 
    164     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr))) 
    165     (princ '|, sec//trk-1=|) 
    166     (prin1 sts) 
    167     (dc-exec-1 1400005) 
    168     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr))) 
    169     (princ '|, diag sts 1=|) 
    170     (prin1 sts) 
    171     (dc-exec-1 1600005) 
    172     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr))) 
    173     (princ '|, diag sts 2=|) 
    174     (prin1 sts))) 
    175  
    176126;;; Seek, print status if error 
    177 (DEFUN DC-SEEK (CYL) 
     127(DEFUN DC-SEEK (CYL &OPTIONAL (UNIT 0)) 
     128  (PHYS-MEM-WRITE DC-DA-ADR (ASH UNIT 28.)) 
    178129  (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE) 
    179130  (PHYS-MEM-WRITE DC-START-ADR 0) 
    180131  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle 
    181   (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 0)) 
    182   (PHYS-MEM-WRITE DC-CMD-ADR (logdpb cyl 3010 (logdpb 100 2010 DC-SEEK))) 
     132  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 (ASH UNIT 28.))) 
     133  (PHYS-MEM-WRITE DC-CMD-ADR (LOGDPB CYL 3010 (LOGDPB 100 2010 DC-SEEK))) 
    183134  (PHYS-MEM-WRITE DC-START-ADR 0) 
    184135  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle 
    185   (OR MARKSMAN-P 
    186       (DO () ((LDB-TEST 0201 (PHYS-MEM-READ DC-STS-ADR))) ;Await attention 
    187         #M (SLEEP 0.03) 
    188         #Q (PROCESS-ALLOW-SCHEDULE) 
    189         )) 
     136  (DO () ((LDB-TEST 0201 (PHYS-MEM-READ DC-STS-ADR))) ;Await attention 
     137    #M (SLEEP 0.03) 
     138    #Q (PROCESS-ALLOW-SCHEDULE) 
     139    ) 
    190140  (DC-CHECK-STATUS DC-SOME-ERROR-BITS)) 
    191141 
    192 (defun dc-recal-marksman () 
    193   (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle 
    194   (dc-exec 10000005 0 0 0 0 nil 0) 
    195   (dc-print-marksman-status)) 
    196  
    197 ;;; Run internal marksman diagnostics (this doesn't work, maybe we don't have the firmware) 
    198 (defun dc-diag-marksman (test-number) 
    199   (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle 
    200   (PHYS-MEM-WRITE DC-CMD-ADR (logdpb (+ 200 test-number) 2010 5)) 
    201   (PHYS-MEM-WRITE DC-START-ADR 0) 
    202   (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle 
    203   (dc-print-marksman-status)) 
    204  
    205142;;; Perform a read or write, check specified status bits. 
    206 (DEFUN DC-EXEC (CMD CYL HEAD BLOCK CLP CCW ERR-BITS) 
     143(DEFUN DC-EXEC (CMD CYL HEAD BLOCK CLP CCW ERR-BITS &OPTIONAL (UNIT 0)) 
     144  (PHYS-MEM-WRITE DC-DA-ADR (ASH UNIT 28.)) 
    207145  (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE) 
    208146  (PHYS-MEM-WRITE DC-START-ADR 0) 
    209147  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle 
    210   (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 (+ (LSH HEAD 8) BLOCK))) 
     148  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB UNIT 3404 (LOGDPB CYL 2014 (+ (LSH HEAD 8) BLOCK)))) 
    211149  (PHYS-MEM-WRITE DC-CLP-ADR CLP) 
    212150  (AND CCW (PHYS-MEM-WRITE CLP CCW)) 
     
    234172  (LET ((VAL (PHYS-MEM-READ-24 DC-STS-ADR))) 
    235173    (COND ((NOT (ZEROP (LOGAND MASK VAL))) 
    236            (DC-PRINT-STATUS1 VAL))))) 
     174           (DC-PRINT-STATUS1 VAL) 
     175           (let ((ecc (phys-mem-read dc-ecc-adr)) 
     176                 (da  (phys-mem-read dc-da-adr)) 
     177                 (ma  (phys-mem-read dc-ma-adr))) 
     178             (format t "CYL ~O, HEAD ~O, SEC ~O, MA ~O, ECC pat ~O, ECC pos ~O" 
     179                     (ldb 2014 da) (ldb 1010 da) (ldb 0010 da) 
     180                     (dpb (ldb 2010 ma) 2010 (ldb 0020 ma)) 
     181                     (ldb 2020 ecc) (ldb 0020 ecc))) 
     182           T)))) 
    237183 
    238184;;; This function provides a scope loop for debugging problems starting up 
     
    261207;;; Test function 
    262208 
    263 (DEFUN DCHECK (&AUX CONTROLLER-TYPE) 
     209(DEFUN DCHECK (&OPTIONAL (UNIT 0) &AUX CONTROLLER-TYPE) 
    264210  (SETQ CONTROLLER-TYPE (LDB (BITS 2 22.) (PHYS-MEM-READ DC-MA-ADR))) 
    265211  (FORMAT T 
     
    267213      CONTROLLER-TYPE) 
    268214  ;Don't do this, the hardware isn't necessarily right.  This IS a diagnostic, after all. 
    269   ;(SETQ MARKSMAN-P (= CONTROLLER-TYPE 1)) 
    270   (FORMAT T "~&Operating as if ~:[Trident~;Marksman~]~%" MARKSMAN-P) 
     215  ;(SETQ FOO-P (= CONTROLLER-TYPE 1)) 
     216  ;(FORMAT T "~&Operating as if ~:[Trident~;Marksman~]~%" MARKSMAN-P) 
    271217  ;; Part 1 - verify bus response to reading and writing disk-address register 
    272218  (PHYS-MEM-WRITE DC-DA-ADR 1777777777) ;28 bits 
     
    319265  ;; Part 3.5 - check that the block counter is counting.  This checks 
    320266  ;; that the disk is rotating and that the index/sector pulse logic works. 
     267  (PHYS-MEM-WRITE DC-DA-ADR (ASH UNIT 28.)) 
    321268  #Q (DCHECK-BLOCK-COUNTER) 
    322   ;; Part 3.6 - recalibrate.  Marksman needs this if I/O reset has been done. 
     269  ;; Part 3.6 - recalibrate.   
    323270  (FORMAT T "~&Recalibrate...") 
    324   (DC-RECALIBRATE) 
     271  (DC-RECALIBRATE UNIT) 
    325272  ;; Part 4 - Test disk bus bits and basic command logic by seeking 
    326273  (COND ((NOT BYPASS-SEEKS) 
    327          (DCHECK-SEEK (if marksman-p 209. 814.)) 
    328          (DO I (if marksman-p 128. 512.) (LSH I -1) (ZEROP I) 
    329            (DCHECK-SEEK I)))) 
     274         (DCHECK-SEEK 814. UNIT) 
     275         (DO I 512. (LSH I -1) (ZEROP I) 
     276           (DCHECK-SEEK I UNIT)))) 
    330277  (and local-disk-p (break the-rest-of-this-aint-gonna-work)) 
    331278  ;; Part 5 - Check address logic by reading with a CLP that points at NXM 
     
    334281  ;;   MA is naturally going to be wrong also since no memory cycles at all will happen. 
    335282  (LET ((MASK   ;Bits which are suspect (this stuff is only 22 bits, fits in fixnum) 
    336          (LOGIOR (DCHECK-CLP-ADR NXM-LOC1) (DCHECK-CLP-ADR NXM-LOC2) (DCHECK-CLP-ADR NXM-LOC3) 
    337                  (DCHECK-CCW-ADR NXM-LOC3) (DCHECK-CCW-ADR NXM-LOC2) (DCHECK-CCW-ADR NXM-LOC1) 
     283         (LOGIOR (DCHECK-CLP-ADR NXM-LOC1 UNIT) 
     284                 (DCHECK-CLP-ADR NXM-LOC2 UNIT) 
     285                 (DCHECK-CLP-ADR NXM-LOC3 UNIT) 
     286                 (DCHECK-CCW-ADR NXM-LOC3 UNIT) 
     287                 (DCHECK-CCW-ADR NXM-LOC2 UNIT) 
     288                 (DCHECK-CCW-ADR NXM-LOC1 UNIT) 
    338289                 ))) 
    339290    (COND ((NOT (ZEROP MASK)) 
     
    352303    (PHYS-MEM-WRITE I (+ (LSH (LOGXOR 377 I) 8) I))) 
    353304  (PRINT 'WRITE) 
    354   (DC-EXEC DC-WRITE 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS) 
     305  (DC-EXEC DC-WRITE 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT) 
    355306  (LET ((MA (DC-READ-MA))) 
    356307    #M (DECLARE (FIXNUM MA)) 
     
    361312    (PHYS-MEM-WRITE I 0)) 
    362313  (PRINT 'READ) 
    363   (DC-EXEC DC-READ 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS) 
     314  (DC-EXEC DC-READ 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT) 
    364315  (LET ((MA (DC-READ-MA))) 
    365316    #M (DECLARE (FIXNUM MA)) 
     
    392343  (PRINC "Trying reads of various blocks; will get HEADER-COMPARE if disk bus bits bad") 
    393344  (TERPRI) 
    394   (DC-EXEC DC-READ 0 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS) 
     345  (DC-EXEC DC-READ 0 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT) 
    395346  (PRINC " cyl 0 ") 
    396347  (DO CYL 1 (LSH CYL 1) (= CYL 2000) 
    397     (DC-EXEC DC-READ CYL 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS) 
     348    (DC-EXEC DC-READ CYL 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT) 
    398349    (PRINC " cyl ") 
    399350    (PRIN1 CYL)) 
     
    404355  (PRINC '|End of DCHECK.  Now run the format program and the ECC test program.|)) 
    405356 
     357(defun dc-read-cyl (cyl) 
     358    (DC-EXEC DC-READ CYL 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS ) 
     359    (PRINC " cyl ") 
     360    (PRIN1 CYL)) 
     361 
     362(defun dc-read-block (cyl head block) 
     363    (DC-EXEC DC-READ CYL head block CCW-LOC 0 DC-ALL-ERROR-BITS ) 
     364    (PRINC " cyl ") 
     365    (PRIN1 CYL) 
     366    (princ "   block ") 
     367    (prin1 block) 
     368    (princ "   head ") 
     369    (prin1 head)) 
     370  
    406371(DEFUN DC-RESET NIL 
    407372  (PHYS-MEM-WRITE DC-CMD-ADR DC-STOP) 
    408373  (PHYS-MEM-WRITE DC-CMD-ADR 0)) 
    409374 
    410 (DEFUN DC-RECALIBRATE NIL 
    411   (DC-EXEC DC-RECAL 0 0 0 0 NIL 0) 
     375(DEFUN DC-RECALIBRATE (&OPTIONAL (UNIT 0)) 
     376  (DC-EXEC DC-RECAL 0 0 0 0 NIL 0 UNIT) 
    412377  (DO () ((NOT (BIT-TEST 1_8 (PHYS-MEM-READ DC-STS-ADR)))) 
    413378    (PROCESS-ALLOW-SCHEDULE))) 
    414379 
    415 (DEFUN DC-FAULT-CLEAR NIL 
    416   (DC-EXEC DC-FAULT-CLEAR 0 0 0 0 NIL 0) 
     380(DEFUN DC-FAULT-CLEAR (&OPTIONAL (UNIT 0)) 
     381  (DC-EXEC DC-FAULT-CLEAR 0 0 0 0 NIL 0 UNIT) 
    417382  (DO () ((NOT (BIT-TEST 1_8 (PHYS-MEM-READ DC-STS-ADR)))) 
    418383    (PROCESS-ALLOW-SCHEDULE))) 
     
    446411#Q 
    447412(DEFUN DCHECK-BLOCK-COUNTER () 
    448   (DO ((DESIRED-VALUES #10R (IF MARKSMAN-P 
    449                                 '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20) 
    450                                 ;; Vandals: Yes, a value of 17. can appear here 
    451                                 '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17))) 
     413  (DO ((DESIRED-VALUES #10R  ;; Vandals: Yes, a value of 17. can appear here 
     414                                '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)) 
    452415       (GOOD-VALUES NIL) 
    453416       (BAD-VALUES NIL) 
     
    473436 
    474437;;; Check address logic, return bits which failed 
    475 (DEFUN DCHECK-CLP-ADR (ADR) 
     438(DEFUN DCHECK-CLP-ADR (ADR &OPTIONAL (UNIT 0)) 
    476439  (LET ((MA 0)) 
    477440    (DECLARE (FIXNUM MA)) 
    478     (DC-EXEC DC-READ 0 0 0 ADR NIL 0) 
     441    (DC-EXEC DC-READ 0 0 0 ADR NIL 0 UNIT) 
    479442    (COND ((NOT (= (LOGAND 14000000 (PHYS-MEM-READ-24 DC-STS-ADR)) 
    480443                   14000000))  ;NXM and CCW CYCLE 
     
    497460   (DC-EXEC DC-READ 0 0 0 CCW-LOC 1000 0))) 
    498461 
    499 (DEFUN DCHECK-CCW-ADR (ADR) 
     462;Tight writing loop.  This is the same as the write in part 6 of DCHECK. 
     463(DEFUN DCHECK-WRITE-LOOP NIL 
     464  (DO I 0 (1+ I) (= I 40)                       ;Loc 0-37 get floating 1's 
     465      (PHYS-MEM-WRITE I (#M LSH #Q ASH 1 I))) 
     466  (DO I 0 (1+ I) (= I 40)                       ;Loc 40-77 get floating 0's 
     467      (PHYS-MEM-WRITE (+ 40 I) (- (#M LSH #Q ASH 1 32.) (#M LSH #Q ASH 1 I)))) 
     468  (DO I 100 (1+ I) (= I 400)                    ;Loc 100-377 get address pattern 
     469      (PHYS-MEM-WRITE I (+ (LSH (LOGXOR 377 I) 8) I))) 
     470  (DO () ((KBD-TYI-NO-HANG)) 
     471    (DC-EXEC DC-WRITE 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS) 
     472    (LET ((MA (DC-READ-MA))) 
     473      (COND ((NOT (= MA 377)) 
     474             (TERPRI) (PRINC '|MA wrong on write of pattern, correct=377, actual=|) 
     475             (PRIN1 MA)))))) 
     476 
     477 
     478(defun dcheck-check-da-block-increments nil 
     479  (dotimes (block  blocks-per-track) 
     480    (cc-disk-xfer dc-read (+ (* 100 blocks-per-cylinder) 
     481                             block) 
     482                1 2))) 
     483 
     484(defun dcheck-check-da-head-increments nil 
     485  (dotimes (head (// blocks-per-cylinder blocks-per-track)) 
     486    (cc-disk-xfer dc-read (+ (* 100 blocks-per-cylinder) 
     487                             (1- blocks-per-track) 
     488                             (* head blocks-per-track)) 
     489                1 2))) 
     490 
     491(defun dcheck-check-da-cylinder-increments nil 
     492  (dotimes (cyl n-cylinders) 
     493    (cc-disk-xfer dc-read (+ (* cyl blocks-per-cylinder) 
     494                             (1- blocks-per-cylinder)) 
     495                  1 2))) 
     496 
     497(defun dcheck-check-da-cylinder-increments-1 nil 
     498  (do ((adr 12 (1+ adr)) 
     499       (core-page 1 (1+ core-page)) 
     500       (n (* 2 blocks-per-cylinder) (1- n))) 
     501      ((= n 0)) 
     502    (phys-mem-write adr (+ (cc-shift adr 8) (cond ((= n 1) 0) (t 1))))) 
     503  (dotimes (cyl (- n-cylinders 2)) 
     504    (dc-exec dc-read cyl 0 0 12 nil dc-all-error-bits))) 
     505 
     506(DEFUN DCHECK-CCW-ADR (ADR &OPTIONAL (UNIT 0)) 
    500507  (LET ((MA 0)) 
    501508    (DECLARE (FIXNUM MA)) 
    502     (DC-EXEC DC-READ 0 0 0 CCW-LOC (SETQ ADR (LOGAND 77777400 ADR)) 0) 
     509    (DC-EXEC DC-READ 0 0 0 CCW-LOC (SETQ ADR (LOGAND 77777400 ADR)) 0 UNIT) 
    503510    (COND ((NOT (= (LOGAND 14000000 (PHYS-MEM-READ-24 DC-STS-ADR)) 
    504511                   04000000))  ;NXM and -CCW CYCLE 
     
    517524 
    518525;;; Alternating seek test 
    519 (DEFUN DCHECK-SEEK (CYL) 
     526(DEFUN DCHECK-SEEK (CYL &OPTIONAL (UNIT 0)) 
    520527  (TERPRI) 
    521528  (PRINC '|Should be seeking between cylinders 0 and |) 
     
    524531  (PRINC '| - type space when OK. |) 
    525532  (DO () (#M (NOT (ZEROP (LISTEN))) #Q (KBD-TYI-NO-HANG)) 
    526     (DC-SEEK 0) 
    527     (DC-SEEK CYL)) 
     533    (DC-SEEK 0 UNIT) 
     534    (DC-SEEK CYL UNIT)) 
    528535  #M (TYI) 
    529536  (TERPRI)) 
     
    547554    (PHYS-MEM-WRITE ADR VAL2) 
    548555    (PHYS-MEM-READ ADR))) 
     556 
     557 
    549558 
    550559;;; ECC Test (in DCFU) error-message printer 
     
    606615;;; Read/Write test 
    607616 
    608 (declare (special dc-write-read-trace)) 
    609 (setq dc-write-read-trace t) 
     617(defvar dc-write-read-trace t) 
     618(defvar dc-test-unit 0) 
    610619 
    611620;;; Low-level routine, does a write and a read and compares 
     
    616625  ;; Trace 
    617626  (and dc-write-read-trace 
    618        (format t '|~%WRITE-READ-TEST: cyl=~O, head=~O, blk=~O, pattern=~A| 
    619                  cyl head blk pattern-func)) 
     627       (format t '|~%WRITE-READ-TEST: unit=~O, cyl=~O, head=~O, blk=~O, pattern=~A| 
     628                 dc-test-unit cyl head blk pattern-func)) 
    620629  ;; Fill memory with pattern 
    621630  (do i 0 (1+ i) (= i 400) 
    622631    (phys-mem-write (+ offset i) (funcall pattern-func i))) 
    623632  ;; Write it out 
    624   (dc-exec dc-write cyl head blk 777 (+ offset 0) dc-all-error-bits) 
     633  (dc-exec dc-write cyl head blk 777 (+ offset 0) dc-all-error-bits dc-test-unit) 
    625634  (do i 0 (1+ i) (= i 400) 
    626635      (phys-mem-write (+ offset i) 0)) 
    627636  ;; Read it back 
    628   (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits 
     637  (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits dc-test-unit) 
    629638  ;; Check pattern 
    630639  (do ((i 0 (1+ i)) 
     
    656665  ;; Trace 
    657666  (and dc-write-read-trace 
    658        (format t "~%READ-TEST: cyl=~O, head=~O, blk=~O" 
    659                  cyl head blk)) 
     667       (format t "~%READ-TEST: unit=~O, cyl=~O, head=~O, blk=~O" 
     668                 dc-test-unit cyl head blk)) 
    660669  ;; Read it 
    661   (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits 
     670  (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits dc-test-unit) 
    662671) 
    663672 
     
    741750;;; This version is kludged up, you should step only one addr at a time! 
    742751(defun dc-write-read-test (&optional response-list 
    743                                      (all-list (if marksman-p 
    744                                                    '( (do 0 210.) 
    745                                                       (do 0 4) 
    746                                                       (do 0 21.)) 
    747                                                    '( (do 0 815.) 
    748                                                       (do 0 5) 
    749                                                       (do 0 17.) )))) 
     752                                     (all-list '( (do 0 815.) 
     753                                                 (do 0 5) 
     754                                                 (do 0 17.) ))) 
    750755  (multiple-value-bind (cyl head blk pattern-func) 
    751756      (dc-get-addr-specs response-list all-list) 
     
    757762  (dc-write-read-test '(all all all all))) 
    758763 
    759 (defun dc-read-test (&optional response-list (all-list (if marksman-p 
    760                                                            '( (do 0 210.) 
    761                                                               (do 0 4) 
    762                                                               (do 0 21.)) 
    763                                                            '( (do 0 815.) 
    764                                                               (do 0 5) 
    765                                                               (do 0 17.) )))) 
     764(defun dc-read-test (&optional response-list (all-list '( (do 0 815.) 
     765                                                         (do 0 5) 
     766                                                         (do 0 17.) ))) 
    766767  (multiple-value-bind (cyl head blk pattern-func) 
    767768      (dc-get-addr-specs response-list all-list T) 
     
    952953;This function reads in a track and types out some approximation of what's on it 
    953954;If cyl is nil, decode what's in core 
    954 (defun decode-track (cyl head &optional (blk 0)) 
     955(defun decode-track (cyl head &optional (blk 0) (unit 0)) 
    955956  (cond ((not (null cyl)) 
    956957         ;; First, read in 20. blocks, which is more than 20160. bytes 
     
    958959           (dbg-write-xbus i (+ (lsh (1+ i) 8) 
    959960                                (cond ((= i 19.) 0) (t 1)))))   
    960          (dc-exec dc-read-all cyl head blk 0 nil dc-some-error-bits) 
     961         (dc-exec dc-read-all cyl head blk 0 nil dc-some-error-bits unit) 
    961962         (get-buffer) ;gobble it down from other machine 
    962963         ))