Changeset 271


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

Update from System 78.

Location:
trunk/lisp/lmcons
Files:
17 deleted
4 edited

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  
    297297(IF-FOR-LISPM
    298298(DEFUN CC-SELECT-SYMBOL-TABLE (FILENAME)
    299   (LET ((TEM (ASSOC FILENAME CC-SYMBOL-TABLES-LOADED)))
     299  (LET ((TEM (ASSQ FILENAME CC-SYMBOL-TABLES-LOADED)))
    300300    (COND (TEM (SETQ CC-FILE-SYMBOLS-LOADED-FROM (CAR TEM)
    301301                     CC-SYMBOLS-SIZE (CADR TEM)
     
    334334
    335335(DEFUN CC-END-ADDING-SYMBOLS ()
    336    (SETQ CC-SYMBOLS-ARRAY-SIZE CC-SYMBOLS-SIZE)
     336   ;(SETQ CC-SYMBOLS-ARRAY-SIZE CC-SYMBOLS-SIZE)  ;Don't do this, it just causes wastage later
    337337   #M (*REARRAY CC-SYMBOLS-NAME T CC-SYMBOLS-SIZE)
    338338   #Q (ADJUST-ARRAY-SIZE CC-SYMBOLS-NAME CC-SYMBOLS-SIZE)
     
    420420                      (COND ((ZEROP DELTA) NAME)
    421421                            ((AND (> DELTA 0)
    422                                   (< DELTA 20))
     422                                  (< DELTA 100))
    423423                             (LIST NAME DELTA))
    424424                            (T NIL))))))))
     
    472472;DEFINITIONS OF VARIOUS WORD FORMATS, FOR BOTH TYPE-OUT AND TYPE-IN
    473473
    474 (DECLARE (SPECIAL CC-Q-DESC CC-A-DESC CC-HWD-DESC CC-BYTE-DESC CC-INST-DESC
     474(DECLARE (SPECIAL CC-Q-DESC CC-A-DESC CC-HWD-DESC CC-BYTE-DESC CC-INST-DESC CC-ASCII-BYTE-DESC
    475475                  CC-I-DEST-DESC CC-I-ADDR-DESC CC-I-BR-DESC
    476476                  CC-I-11-DESC CC-I-12-DESC CC-I-13-DESC CC-I-15-DESC
     
    481481                  CC-SEXP-DESC))
    482482
    483 (SETQ CC-MODE-DESC-TABLE '(
    484         (H . CC-HWD-DESC) (B . CC-BYTE-DESC)
    485         (Q . CC-Q-DESC) (A . CC-A-DESC) (/_ . CC-REG-ADDR-DESC)
    486         (I . CC-INST-DESC) (U . CC-UINST-DESC) (V . CC-O-UINST-DESC) (S . CC-SEXP-DESC)
    487         (/# . CC-BITS-DESC)
    488 ))
     483(DEFCONST CC-MODE-DESC-TABLE '((H . CC-HWD-DESC) (B . CC-BYTE-DESC)
     484                               (Q . CC-Q-DESC) (A . CC-A-DESC) (/_ . CC-REG-ADDR-DESC)
     485                               (I . CC-INST-DESC) (T . CC-ASCII-BYTE-DESC)
     486                              (U . CC-UINST-DESC) (V . CC-O-UINST-DESC) (S . CC-SEXP-DESC)
     487                               (/# . CC-BITS-DESC)
     488                               (N . CC-SIGNED-WORD-DESC)))
    489489
    490490
     
    510510; (NUM <FIELD-POSITION>)
    511511;       pure numeric field, prompting with "#: ".
     512; (SIGNED-NUM <FIELD-POSITION>) by special hack, it allows fields bigger than fixnum size.
    512513; (SUB-FIELD <DESCRIPTION-NAME>)
    513514;       call sub-description.
     
    540541; (BITS)  typeout only, type bit numbers of set bits.
    541542
    542 (SETQ CC-REG-ADDR-DESC '( (CALL CC-PRINT-ADDRESS-1 0030) ))
    543 
    544 (SETQ CC-BITS-DESC '( (BITS)))
    545 
    546 (SETQ CC-HWD-DESC '( (NUM 2020) (CTYPE /,/,) (NUM 0020)
    547 ))
    548 
    549 (SETQ CC-BYTE-DESC '( (NUM 0010) (CTYPE /,) (NUM 1010) (CTYPE /,)
    550                       (NUM 2010) (CTYPE /,) (NUM 3010)
    551 ))
    552 
    553 (SETQ CC-SEXP-DESC '( (CALL CC-Q-PRINT-TOPLEV-1 0035) ))
    554 
    555 
    556 
    557 (SETQ CC-Q-DESC '( (SELECT-FIELD CDR 3602 (NIL CDR-TRAP CDR-NIL CDR-NEXT))
    558                    (SELECT-FIELD FLAG-BIT 3501 (NIL FLAG-BIT))
    559                    (SELECT-FIELD DATA-TYPE 3005
     543(DEFCONST CC-REG-ADDR-DESC '( (CALL CC-PRINT-ADDRESS-1 0030) ))
     544
     545(DEFCONST CC-BITS-DESC '( (BITS)))
     546
     547(DEFCONST CC-SIGNED-WORD-DESC '( (SIGNED-NUM 0040)))
     548
     549(DEFCONST CC-HWD-DESC '( (NUM 2020) (CTYPE /,/,) (NUM 0020)))
     550
     551(DEFCONST CC-BYTE-DESC '( (NUM 0010) (CTYPE /,) (NUM 1010) (CTYPE /,)
     552                         (NUM 2010) (CTYPE /,) (NUM 3010)))
     553
     554(DEFCONST CC-ASCII-BYTE-DESC '( (CHAR 0010) (CHAR 1010)
     555                               (CHAR 2010) (CHAR 3010)))
     556
     557(DEFCONST CC-SEXP-DESC '( (CALL CC-Q-PRINT-TOPLEV-1 0035) ))
     558
     559
     560
     561(DEFCONST CC-Q-DESC '( (SELECT-FIELD CDR 3602 (NIL CDR-TRAP CDR-NIL CDR-NEXT))
     562                      (SELECT-FIELD FLAG-BIT 3501 (NIL FLAG-BIT))
     563                      (SELECT-FIELD DATA-TYPE 3005
    560564                       (NIL NULL FREE SYMBOL SYMBOL-HEADER FIX EXTENDED-NUMBER HEADER
    561565                        GC-FORWARD EXTERNAL-VALUE-CELL-POINTER ONE-Q-FORWARD
     
    565569                            SELECT-METHOD INSTANCE INSTANCE-HEADER
    566570                        ENTITY T T T T T T T))
    567                    (NUM 0030)
    568 ))
    569 
    570 (SETQ CC-A-DESC '( (CONSTANT 3005 2)    ;ARRAY-HEADER DATA-TYPE
    571                    (SELECT-FIELD ARRAY-TYPE 2305
     571                      (NUM 0030)))
     572
     573(DEFCONST CC-A-DESC '( (CONSTANT 3005 2)        ;ARRAY-HEADER DATA-TYPE
     574                      (SELECT-FIELD ARRAY-TYPE 2305
    572575                       (T ART-1B ART-2B ART-4B ART-8B ART-16B ART-32B ART-Q
    573576                        ART-Q-LIST ART-STRING ART-STACK-GROUP-HEAD ART-SPECIAL-PDL
     
    580583                   (SELECT-FIELD LONG 1301 (NIL LONG))
    581584                   (SELECT-FIELD SPARE-BIT 1201 (NIL SPARE-BIT))
    582                    (TYPE-FIELD INDEX-LENGTH 0012 NIL)
    583 ))
    584 
    585 
    586 (SETQ CC-INST-DESC '( (SELECT-FIELD OP-CODE 1104
     585                   (TYPE-FIELD INDEX-LENGTH 0012 NIL)))
     586
     587
     588(DEFCONST CC-INST-DESC '( (SELECT-FIELD OP-CODE 1104
    587589                       (CALL CALL0 MOVE CAR
    588590                        CDR CADR CDDR CDAR
     
    598600                        CC-I-ADDR-DESC CC-I-ADDR-DESC CC-I-ADDR-DESC
    599601                        CC-I-ADDR-DESC CC-I-ADDR-DESC CC-I-ADDR-DESC
    600                         NIL CC-I-15-DESC NIL NIL))
    601 ))
    602 
    603 (SETQ CC-I-DEST-DESC '( (SELECT-FIELD DEST 1503
     602                        NIL CC-I-15-DESC NIL NIL))))
     603
     604(DEFCONST CC-I-DEST-DESC '( (SELECT-FIELD DEST 1503
    604605                          (IGNORE STACK NEXT LAST
    605606                           RETURN NEXTQ LASTQ NEXT-LIST))
    606607))
    607608
    608 (SETQ CC-I-ADDR-DESC '( (COND ADR-TYPE 1001 (CC-I-ADDR-F-DESC CC-I-ADDR-R-DESC))
     609(DEFCONST CC-I-ADDR-DESC '( (COND ADR-TYPE 1001 (CC-I-ADDR-F-DESC CC-I-ADDR-R-DESC))
    609610))
    610611
    611 (SETQ CC-I-ADDR-F-DESC '( (TYPE FEF) (NUM 0010) ))
    612 
    613 (SETQ CC-I-ADDR-R-DESC '( (SELECT-FIELD ADR 0602 (QTPG LCL ARG PDL))
    614                           (NUM 0006)
    615 ))
    616 
    617 (SETQ CC-I-BR-DESC '( (SELECT-FIELD BRANCH 1503
     612(DEFCONST CC-I-ADDR-F-DESC '( (TYPE FEF) (NUM 0010) ))
     613
     614(DEFCONST CC-I-ADDR-R-DESC '( (SELECT-FIELD ADR 0602 (QTPG LCL ARG PDL))
     615                             (NUM 0006)))
     616
     617(DEFCONST CC-I-BR-DESC '( (SELECT-FIELD BRANCH 1503
    618618                       (BR BR-NIL BR-NOT-NIL BR-NIL-OR-POP
    619619                        BR-NOT-NIL-OR-POP BR-ATOM BR-NOT-ATOM T))
     
    621621))
    622622
    623 (SETQ CC-I-11-DESC '( (SELECT-FIELD OP 1503
     623(DEFCONST CC-I-11-DESC '( (SELECT-FIELD OP 1503
    624624                        (T + - * // LOGAND LOGXOR LOGIOR))
    625625))
    626626
    627 (SETQ CC-I-12-DESC '( (SELECT-FIELD OP 1503
     627(DEFCONST CC-I-12-DESC '( (SELECT-FIELD OP 1503
    628628                        (= > < EQ SCDR SCDDR 1+ 1-))
    629629))
    630630
    631 (SETQ CC-I-13-DESC '( (SELECT-FIELD OP 1503
     631(DEFCONST CC-I-13-DESC '( (SELECT-FIELD OP 1503
    632632                        (BIND BINDNIL BINDPOP SETNIL SETZERO PUSH-E MOVEM POP))
    633633))
    634634
    635 (SETQ CC-I-15-DESC '( (TYPE-FIELD MISC-OP 0011 NIL)
     635(DEFCONST CC-I-15-DESC '( (TYPE-FIELD MISC-OP 0011 NIL)
    636636                      (OUTPUT (CALL CC-I-MISC-NAME 0011)) ))   
    637637
     
    868868;;; Print a string.  Note that it is truncated to at most 200 characters to
    869869;;; avoid printing infinite garbage
     870(DEFVAR CC-Q-PRINT-STRING-MAXL 200)
     871
    870872(DEFUN CC-Q-PRINT-STRING (ADR)
    871873  (QF-ARRAY-SETUP (QF-MAKE-Q (QF-POINTER ADR) DTP-ARRAY-POINTER))
     
    877879       (CH)
    878880       (WD))
    879       ((OR (>= I LEN) (= I 200))
     881      ((OR (>= I LEN) (= I CC-Q-PRINT-STRING-MAXL))
    880882       (AND (< I LEN) (PRINC '/././.) CC-OUTPUT-STREAM)
    881883       NIL)
     
    979981              ((EQ (CAR ITEM) 'NUM)
    980982                (PRIN1-THEN-SPACE (LOGLDB (CADR ITEM) WD)))
     983              ((EQ (CAR ITEM) 'SIGNED-NUM)
     984               (PRIN1-THEN-SPACE (CC-UNSIGNED-TO-SIGNED (CADR ITEM)
     985                                                        (LOGLDB-BIG (CADR ITEM) WD))))
     986              ((EQ (CAR ITEM) 'CHAR)
     987                (TYO (LOGLDB (CADR ITEM) WD)))
    981988              ((EQ (CAR ITEM) 'CONSTANT))
    982989              ((EQ (CAR ITEM) 'INPUT))
     
    10101017        (GO L1)
    10111018))
     1019
     1020;like LDB, but can load fields bigger than fixnum size.
     1021(DEFUN LOGLDB-BIG (FLD WD)
     1022  (PROG (ANS BITS BITS-OVER SHIFT)
     1023        (SETQ SHIFT 0 ANS 0 BITS (LOGLDB 0006 FLD) BITS-OVER (LOGLDB 0620 FLD))
     1024    L   (SETQ ANS (LOGIOR ANS (ASH (LOGLDB (LOGDPB BITS-OVER 0620 (MIN BITS 23.)) WD) SHIFT)))
     1025        (IF (
     1026 (SETQ BITS (- BITS 23.)) 0) (RETURN ANS))
     1027        (SETQ SHIFT (+ SHIFT 23.)
     1028              BITS-OVER (+ BITS-OVER 23.))
     1029        (GO L)))
     1030
     1031(DEFUN CC-UNSIGNED-TO-SIGNED (FLD WD)
     1032  (LET ((SIGN-BIT (ASH 1 (1- (LDB 0006 FLD)))))
     1033    (IF (NOT (ZEROP (LOGAND SIGN-BIT WD)))
     1034        (MINUS (1+ (LOGXOR WD (1- (ASH SIGN-BIT 1)))))
     1035        WD)))
    10121036
    10131037(DEFUN CC-C-OR-D-ADR-OUT (TYPE VAL SYM-BASE)
     
    13581382  (CC-UCODE-LOADER 'LOAD-WITHOUT-SYMBOLS FILE NIL))
    13591383
    1360 (DEFUN CC-LOAD-UCODE-SYMBOLS (FILE &OPTIONAL MERGEP)
    1361   (COND ((EQUAL FILE CC-FILE-SYMBOLS-LOADED-FROM))
     1384(DEFUN CC-LOAD-UCODE-SYMBOLS-FOR-VERSION (VERSION)
     1385  (CC-LOAD-UCODE-SYMBOLS (FUNCALL (FS:PARSE-PATHNAME "SYS: UBIN; UCADR")
     1386                                  ':NEW-TYPE-AND-VERSION "SYM" VERSION)))
     1387
     1388(DEFUN CC-LOAD-UCODE-SYMBOLS (FILE &OPTIONAL MERGEP &AUX TRUENAME)
     1389  (SETQ FILE (FS:MERGE-PATHNAME-DEFAULTS FILE)
     1390        TRUENAME (FUNCALL FILE ':TRUENAME))
     1391  (COND ((EQ TRUENAME CC-FILE-SYMBOLS-LOADED-FROM))
    13621392        ((AND (NULL MERGEP)
    1363               (CC-SELECT-SYMBOL-TABLE FILE)))
     1393              (CC-SELECT-SYMBOL-TABLE TRUENAME)))
    13641394        (T
    1365          (CC-UCODE-LOADER 'LOAD-SYMBOLS FILE MERGEP)
    1366          (CC-RECORD-SYMBOL-TABLE (SETQ CC-FILE-SYMBOLS-LOADED-FROM FILE)))))
     1395         (CC-UCODE-LOADER 'LOAD-SYMBOLS TRUENAME MERGEP)
     1396         (CC-RECORD-SYMBOL-TABLE TRUENAME))))
    13671397
    13681398(DEFUN CC-COMPARE-UCODE (FILE)
     
    14011431
    14021432
     1433
    14031434(DEFUN CC NIL                   ;MAIN LOOP OF CONS CONSOLE PROGRAM
    1404   (PROG (CC-ARG CC-SYL CC-VAL CC-UPDATE-DISPLAY-FLAG CC-OPEN-REGISTER
     1435  (PROG ((BASE 8.) (IBASE 8.) (PACKAGE (PKG-FIND-PACKAGE "CADR"))
     1436         CC-ARG CC-SYL CC-VAL CC-UPDATE-DISPLAY-FLAG CC-OPEN-REGISTER
    14051437          CC-LAST-OPEN-REGISTER CC-LAST-VALUE-TYPED COM-CH TEM)
    14061438        (SETQ QF-SWAP-IN-LOOP-CHECK NIL)
     
    19561988                   (PRINC '| |)
    19571989                   (PRINC (NTH (LOGLDB %%REGION-SPACE-TYPE BITS)
    1958                                '(FREE OLD NEW STATIC FIXED EXITED EXIT EXTRA-PDL
    1959                                  WIRED USER-PAGED COPY 13 14 15 16 17))))
     1990                               '(FREE OLD NEW NEW1 NEW2 NEW3 NEW4 NEW5 NEW6
     1991                                 STATIC FIXED EXTRA-PDL COPY 15 16 17))))
    19601992                (TERPRI))))))
    19611993
    19621994
    19631995
    1964 (DEFPROP ATOM CC-DESCRIBE-ATOM CC-COLON-CMD)
    1965 
    1966 (DEFUN CC-DESCRIBE-ATOM (TEM)
     1996(DEFUN (ATOM CC-COLON-CMD) (TEM)
    19671997  (SETQ CC-GETSYL-UNRCH NIL CC-GETSYL-UNRCH-TOKEN NIL) ;FLUSH DELIMITER
    19681998  (SETQ TEM (READ))     ;GET NAME OF ATOM USING LISP SYNTAX
     
    24112441(DECLARE (SPECIAL %%PHT2-PHYSICAL-PAGE-NUMBER %%PHT2-META-BITS %%PHT2-MAP-ACCESS-CODE))
    24122442
     2443(DECLARE (SPECIAL A-MEMORY-VIRTUAL-BASE-ADDRESS))
     2444
     2445(SETQ A-MEMORY-VIRTUAL-BASE-ADDRESS (DPB (LSH A-MEMORY-VIRTUAL-ADDRESS -27)
     2446                                         2701
     2447                                         (DPB A-MEMORY-VIRTUAL-ADDRESS 0027 0)))
     2448
    24132449(DEFUN CC-CHECK-LEVEL-2-BLOCK (VIRTUAL-BASE LEVEL-2-BLOCK-NUMBER)
    24142450 (PROG (L2M PHT-ADR PHT-VALUE VIR-ADR NUM-CHECKED-OK L2MAP-SA)
     
    24222458                             (SETQ VIR-ADR (+ VIRTUAL-BASE (LSH ADR-IN-BLOCK 8)))))
    24232459              (COND ((< PHT-ADR 0)
    2424                      (COND ((< VIR-ADR A-MEMORY-VIRTUAL-ADDRESS)
     2460                     (COND ((< VIR-ADR A-MEMORY-VIRTUAL-BASE-ADDRESS)
    24252461                            (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS
    24262462                                         VIR-ADR 'NOT-FOUND-IN-PHT))
     
    24332469                                     (SETQ PHT-VALUE (PHYS-MEM-READ (1+ PHT-ADR))))))
    24342470                     (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS VIR-ADR 'DIFFERS-FROM-PHT))
     2471                     (PRINT (LIST 'MAP-VALUE L2M
     2472                                  'PHT-VALUE PHT-VALUE
     2473                                  'PHT-ADR PHT-ADR
     2474                                  'LEVEL-2-MAP-ADR (+ (LSH LEVEL-2-BLOCK-NUMBER
     2475                                                           5)
     2476                                                      ADR-IN-BLOCK))))
     2477                    ((NOT (= (LOGLDB %%PHT2-META-BITS L2M)
     2478                             (LOGLDB %%PHT2-META-BITS PHT-VALUE)))
     2479                     (PRINT (LIST 'MAP-ENTRY-AT-VIRTUAL-ADDRESS VIR-ADR 'META-BITS-DIFFER))
    24352480                     (PRINT (LIST 'MAP-VALUE L2M
    24362481                                  'PHT-VALUE PHT-VALUE
     
    26672712(DEFUN (CODE CC-COLON-CMD) (ARG)
    26682713   (TERPRI)
    2669    (LET ((PC (QF-POINTER (CC-SHIFT (CC-SYMBOLIC-EXAMINE-REGISTER 'LC) -1)))
    2670          (FEF (CC-REGISTER-EXAMINE (+ (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
    2671                                       RAPBO))))
     2714   (LET ((PC (COND (CC-OPEN-REGISTER 0)
     2715                   (T (QF-POINTER (CC-SHIFT (CC-SYMBOLIC-EXAMINE-REGISTER 'LC) -1)))))
     2716         (FEF (COND (CC-OPEN-REGISTER (CC-REGISTER-EXAMINE CC-OPEN-REGISTER))
     2717                    (T (CC-REGISTER-EXAMINE (+ (CC-SYMBOLIC-EXAMINE-REGISTER 'M-AP)
     2718                                               RAPBO))))))
    26722719     (DECLARE (FIXNUM PC FEF))
    26732720     (COND ((NOT (= (QF-DATA-TYPE FEF) DTP-FEF-POINTER))
    26742721            (PRINC '|The current function is not a FEF.|) (TERPRI))
    26752722           (T (SETQ FEF (QF-POINTER FEF))
    2676               (PRINC '|Current FEF is |)
     2723              (PRINC (COND (CC-OPEN-REGISTER '|FEF is |)
     2724                           (T '|Current FEF is |)))
    26772725              (CC-Q-PRINT-TOPLEV (CC-MEM-READ (+ %FEFHI-FCTN-NAME FEF)))
    26782726              (TERPRI)
    26792727              (LET ((RELPC (- PC (* 2 FEF))))
    26802728                (DECLARE (FIXNUM RELPC))
    2681                 (COND ((OR (< RELPC 10) (> RELPC 10000))
     2729                (COND ((AND (NULL CC-OPEN-REGISTER) (OR (< RELPC 10) (> RELPC 10000)))
    26822730                       (PRINC '|The PC does not seem to be pointer to the running FEF.|)
    26832731                       (TERPRI))
    2684                       (T (CC-DISASSEMBLE-FEF FEF (COND ((EQ ARG 1) NIL)
     2732                      (T (CC-DISASSEMBLE-FEF FEF (COND ((OR CC-OPEN-REGISTER (EQ ARG 1)) NIL)
    26852733                                                       (T RELPC))))))))))
    26862734
     
    29603008    (SELECT-FIELD DEFERRED-SEQUENCE-BREAK 2201 (NIL DEFERRED-SEQUENCE-BREAK)) ))
    29613009
     3010(declare (special cc-ilong-range cc-ilong-set cc-ilong-list cc-ilong-high-half))
     3011
     3012(defun ilong-initialize-search ()
     3013  (setq cc-ilong-range '(0 30000))
     3014  (setq cc-ilong-set nil)
     3015  (setq cc-ilong-list nil)
     3016  (setq cc-ilong-high-half t))
     3017
     3018(defun ilong-setup nil
     3019  (if cc-ilong-set (ilong-clear))
     3020  (setq cc-ilong-list nil)
     3021  (let ((last (+ (car cc-ilong-range) (cadr cc-ilong-range))))
     3022    (do ((adr (car cc-ilong-range) (1+ adr))
     3023         wd
     3024         (ilong (dpb 1 cons-ir-ilong 0)))
     3025        ((>= adr last)
     3026          t)
     3027      (cond ((zerop (logand ilong (setq wd (cc-read-c-mem adr))))
     3028             (cc-write-c-mem adr (logior ilong wd)))
     3029            (t (push adr cc-ilong-list)))))
     3030  (setq cc-ilong-set t))
     3031
     3032(defun ilong-clear nil
     3033  (let ((last (+ (car cc-ilong-range) (cadr cc-ilong-range))))
     3034    (do ((adr (car cc-ilong-range) (1+ adr))
     3035         (ilong-mask (logxor -1 (dpb 1 cons-ir-ilong 0))))
     3036        ((>= adr last))
     3037      (cond ((memq adr cc-ilong-list))
     3038            (t (cc-write-c-mem adr (logand ilong-mask (cc-read-c-mem adr)))))))
     3039  (setq cc-ilong-set nil))
     3040
     3041;if last trial won, subdivide interval
     3042;if lost,try other half of interval.
     3043(defun ilong-trial (win)
     3044  (if cc-ilong-set (ilong-clear))
     3045  (cond (win (setq cc-ilong-range (list (car cc-ilong-range)
     3046                                        (// (cadr cc-ilong-range) 2)))
     3047             (setq cc-ilong-high-half nil))
     3048        (cc-ilong-high-half
     3049         (format t "~%lost on both halves of range ~s ~s"
     3050                 (- (car cc-ilong-range) (cadr cc-ilong-range))
     3051                 (+ (car cc-ilong-range) (cadr cc-ilong-range)))
     3052         (break foo t))
     3053        (t   (setq cc-ilong-range (list (+ (car cc-ilong-range) (cadr cc-ilong-range))
     3054                                        (cadr cc-ilong-range)))
     3055             (setq cc-ilong-high-half t)))
     3056  (format t "~% range now ~s" cc-ilong-range)
     3057  (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
     
    122122                                  MEM-PARITY-ERROR NXM-ERROR CCW-CYCLE READ-COMPARE-DIFFERENCE
    123123                                  INTERNAL-PARITY-ERROR ))
     124     
    124125     #M (PROGN (PRINC '| SEL-UNIT-BLOCK-CTR=|) (PRIN1 (LSH STATUS -24.))))
    125126
    126 (defun dc-print-marksman-status ()
    127   (let ((sts))
    128     (dc-print-status)
    129     (terpri)
    130     (let ((da (phys-mem-read dc-da-adr)))
    131       (format t "~%Disk address: cylinder ~o, head ~o, block ~o (octal)~%"
    132                 (ldb 2020 da) (ldb 1010 da) (ldb 0010 da)))
    133     (princ "Current status: ")
    134     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
    135     (cc-print-set-bits sts '( track-zero landing-zone ill-cmd ready
    136                               spin-out-of-limit end-of-cyl diag-error track-zero-error ))
    137     (princ ", Re-read status: ")
    138     (dc-exec-1 5)
    139     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
    140     (cc-print-set-bits sts '( track-zero landing-zone ill-cmd ready
    141                               spin-out-of-limit end-of-cyl diag-error track-zero-error ))
    142 
    143     (dc-exec-1 200005)
    144     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
    145     (princ '|sector-length=|)
    146     (prin1 (logldb 0002 sts))
    147     (tyo 40)
    148     (cc-print-set-bits sts '( nil nil illegal-set-sector sector-switches-overridden
    149                               illegal-rezero-or-illegal-seek illegal-cylinder illegal-command
    150                               write-protect-violation ))
    151     (terpri)
    152     (dc-exec-1 400005)
    153     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
    154     (princ '|last cmd byte 1=|)
    155     (prin1 sts)
    156     (dc-exec-1 600005)
    157     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
    158     (princ '|, byte 2=|)
    159     (prin1 sts)
    160     (dc-exec-1 1000005)
    161     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
    162     (princ '|, cur cyl=|)
    163     (prin1 sts)
    164     (dc-exec-1 1200005)
    165     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
    166     (princ '|, sec//trk-1=|)
    167     (prin1 sts)
    168     (dc-exec-1 1400005)
    169     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
    170     (princ '|, diag sts 1=|)
    171     (prin1 sts)
    172     (dc-exec-1 1600005)
    173     (setq sts (logldb 3010 (phys-mem-read dc-ma-adr)))
    174     (princ '|, diag sts 2=|)
    175     (prin1 sts)))
    176 
    177127;;; Seek, print status if error
    178 (DEFUN DC-SEEK (CYL)
     128(DEFUN DC-SEEK (CYL &OPTIONAL (UNIT 0))
     129  (PHYS-MEM-WRITE DC-DA-ADR (ASH UNIT 28.))
    179130  (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE)
    180131  (PHYS-MEM-WRITE DC-START-ADR 0)
    181132  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
    182   (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 0))
    183   (PHYS-MEM-WRITE DC-CMD-ADR (logdpb cyl 3010 (logdpb 100 2010 DC-SEEK)))
     133  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 (ASH UNIT 28.)))
     134  (PHYS-MEM-WRITE DC-CMD-ADR (LOGDPB CYL 3010 (LOGDPB 100 2010 DC-SEEK)))
    184135  (PHYS-MEM-WRITE DC-START-ADR 0)
    185136  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
    186   (OR MARKSMAN-P
    187       (DO () ((LDB-TEST 0201 (PHYS-MEM-READ DC-STS-ADR))) ;Await attention
    188         #M (SLEEP 0.03)
    189         #Q (PROCESS-ALLOW-SCHEDULE)
    190         ))
     137  (DO () ((LDB-TEST 0201 (PHYS-MEM-READ DC-STS-ADR))) ;Await attention
     138    #M (SLEEP 0.03)
     139    #Q (PROCESS-ALLOW-SCHEDULE)
     140    )
    191141  (DC-CHECK-STATUS DC-SOME-ERROR-BITS))
    192142
    193 (defun dc-recal-marksman ()
    194   (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
    195   (dc-exec 10000005 0 0 0 0 nil 0)
    196   (dc-print-marksman-status))
    197 
    198 ;;; Run internal marksman diagnostics (this doesn't work, maybe we don't have the firmware)
    199 (defun dc-diag-marksman (test-number)
    200   (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
    201   (PHYS-MEM-WRITE DC-CMD-ADR (logdpb (+ 200 test-number) 2010 5))
    202   (PHYS-MEM-WRITE DC-START-ADR 0)
    203   (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
    204   (dc-print-marksman-status))
    205 
    206143;;; Perform a read or write, check specified status bits.
    207 (DEFUN DC-EXEC (CMD CYL HEAD BLOCK CLP CCW ERR-BITS)
     144(DEFUN DC-EXEC (CMD CYL HEAD BLOCK CLP CCW ERR-BITS &OPTIONAL (UNIT 0))
     145  (PHYS-MEM-WRITE DC-DA-ADR (ASH UNIT 28.))
    208146  (PHYS-MEM-WRITE DC-CMD-ADR DC-AT-EASE)
    209147  (PHYS-MEM-WRITE DC-START-ADR 0)
    210148  (DO () ((LDB-TEST 0001 (PHYS-MEM-READ DC-STS-ADR)))) ;Await Idle
    211   (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB CYL 2014 (+ (LSH HEAD 8) BLOCK)))
     149  (PHYS-MEM-WRITE DC-DA-ADR (LOGDPB UNIT 3404 (LOGDPB CYL 2014 (+ (LSH HEAD 8) BLOCK))))
    212150  (PHYS-MEM-WRITE DC-CLP-ADR CLP)
    213151  (AND CCW (PHYS-MEM-WRITE CLP CCW))
     
    235173  (LET ((VAL (PHYS-MEM-READ-24 DC-STS-ADR)))
    236174    (COND ((NOT (ZEROP (LOGAND MASK VAL)))
    237            (DC-PRINT-STATUS1 VAL)))))
     175           (DC-PRINT-STATUS1 VAL)
     176           (let ((ecc (phys-mem-read dc-ecc-adr))
     177                 (da  (phys-mem-read dc-da-adr))
     178                 (ma  (phys-mem-read dc-ma-adr)))
     179             (format t "CYL ~O, HEAD ~O, SEC ~O, MA ~O, ECC pat ~O, ECC pos ~O"
     180                     (ldb 2014 da) (ldb 1010 da) (ldb 0010 da)
     181                     (dpb (ldb 2010 ma) 2010 (ldb 0020 ma))
     182                     (ldb 2020 ecc) (ldb 0020 ecc)))
     183           T))))
    238184
    239185;;; This function provides a scope loop for debugging problems starting up
     
    263209;;; Test function
    264210
    265 (DEFUN DCHECK (&AUX CONTROLLER-TYPE)
     211(DEFUN DCHECK (&OPTIONAL (UNIT 0) &AUX CONTROLLER-TYPE)
    266212  (SETQ CONTROLLER-TYPE (LDB (BITS 2 22.) (PHYS-MEM-READ DC-MA-ADR)))
    267213  (FORMAT T
     
    269215      CONTROLLER-TYPE)
    270216  ;Don't do this, the hardware isn't necessarily right.  This IS a diagnostic, after all.
    271   ;(SETQ MARKSMAN-P (= CONTROLLER-TYPE 1))
    272   (FORMAT T "~&Operating as if ~:[Trident~;Marksman~]~%" MARKSMAN-P)
     217  ;(SETQ FOO-P (= CONTROLLER-TYPE 1))
     218  ;(FORMAT T "~&Operating as if ~:[Trident~;Marksman~]~%" MARKSMAN-P)
    273219  ;; Part 1 - verify bus response to reading and writing disk-address register
    274220  (PHYS-MEM-WRITE DC-DA-ADR 1777777777) ;28 bits
     
    321267  ;; Part 3.5 - check that the block counter is counting.  This checks
    322268  ;; that the disk is rotating and that the index/sector pulse logic works.
     269  (PHYS-MEM-WRITE DC-DA-ADR (ASH UNIT 28.))
    323270  #Q (DCHECK-BLOCK-COUNTER)
    324   ;; Part 3.6 - recalibrate.  Marksman needs this if I/O reset has been done.
     271  ;; Part 3.6 - recalibrate. 
    325272  (FORMAT T "~&Recalibrate...")
    326   (DC-RECALIBRATE)
     273  (DC-RECALIBRATE UNIT)
    327274  ;; Part 4 - Test disk bus bits and basic command logic by seeking
    328275  (COND ((NOT BYPASS-SEEKS)
    329          (DCHECK-SEEK (if marksman-p 209. 814.))
    330          (DO I (if marksman-p 128. 512.) (LSH I -1) (ZEROP I)
    331            (DCHECK-SEEK I))))
     276         (DCHECK-SEEK 814. UNIT)
     277         (DO I 512. (LSH I -1) (ZEROP I)
     278           (DCHECK-SEEK I UNIT))))
    332279  (and local-disk-p (break the-rest-of-this-aint-gonna-work))
    333280  ;; Part 5 - Check address logic by reading with a CLP that points at NXM
     
    336283  ;;   MA is naturally going to be wrong also since no memory cycles at all will happen.
    337284  (LET ((MASK   ;Bits which are suspect (this stuff is only 22 bits, fits in fixnum)
    338          (LOGIOR (DCHECK-CLP-ADR NXM-LOC1) (DCHECK-CLP-ADR NXM-LOC2) (DCHECK-CLP-ADR NXM-LOC3)
    339                  (DCHECK-CCW-ADR NXM-LOC3) (DCHECK-CCW-ADR NXM-LOC2) (DCHECK-CCW-ADR NXM-LOC1)
     285         (LOGIOR (DCHECK-CLP-ADR NXM-LOC1 UNIT)
     286                 (DCHECK-CLP-ADR NXM-LOC2 UNIT)
     287                 (DCHECK-CLP-ADR NXM-LOC3 UNIT)
     288                 (DCHECK-CCW-ADR NXM-LOC3 UNIT)
     289                 (DCHECK-CCW-ADR NXM-LOC2 UNIT)
     290                 (DCHECK-CCW-ADR NXM-LOC1 UNIT)
    340291                 )))
    341292    (COND ((NOT (ZEROP MASK))
     
    354305    (PHYS-MEM-WRITE I (+ (LSH (LOGXOR 377 I) 8) I)))
    355306  (PRINT 'WRITE)
    356   (DC-EXEC DC-WRITE 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS)
     307  (DC-EXEC DC-WRITE 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT)
    357308  (LET ((MA (DC-READ-MA)))
    358309    #M (DECLARE (FIXNUM MA))
     
    363314    (PHYS-MEM-WRITE I 0))
    364315  (PRINT 'READ)
    365   (DC-EXEC DC-READ 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS)
     316  (DC-EXEC DC-READ 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT)
    366317  (LET ((MA (DC-READ-MA)))
    367318    #M (DECLARE (FIXNUM MA))
     
    394345  (PRINC "Trying reads of various blocks; will get HEADER-COMPARE if disk bus bits bad")
    395346  (TERPRI)
    396   (DC-EXEC DC-READ 0 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS)
     347  (DC-EXEC DC-READ 0 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT)
    397348  (PRINC " cyl 0 ")
    398349  (DO CYL 1 (LSH CYL 1) (= CYL 2000)
    399     (DC-EXEC DC-READ CYL 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS)
     350    (DC-EXEC DC-READ CYL 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS UNIT)
    400351    (PRINC " cyl ")
    401352    (PRIN1 CYL))
     
    406357  (PRINC '|End of DCHECK.  Now run the format program and the ECC test program.|))
    407358
     359(defun dc-read-cyl (cyl)
     360    (DC-EXEC DC-READ CYL 0 0 CCW-LOC 0 DC-ALL-ERROR-BITS )
     361    (PRINC " cyl ")
     362    (PRIN1 CYL))
     363
     364(defun dc-read-block (cyl head block)
     365    (DC-EXEC DC-READ CYL head block CCW-LOC 0 DC-ALL-ERROR-BITS )
     366    (PRINC " cyl ")
     367    (PRIN1 CYL)
     368    (princ "   block ")
     369    (prin1 block)
     370    (princ "   head ")
     371    (prin1 head))
     372 
    408373(DEFUN DC-RESET NIL
    409374  (PHYS-MEM-WRITE DC-CMD-ADR DC-STOP)
    410375  (PHYS-MEM-WRITE DC-CMD-ADR 0))
    411376
    412 (DEFUN DC-RECALIBRATE NIL
    413   (DC-EXEC DC-RECAL 0 0 0 0 NIL 0)
     377(DEFUN DC-RECALIBRATE (&OPTIONAL (UNIT 0))
     378  (DC-EXEC DC-RECAL 0 0 0 0 NIL 0 UNIT)
    414379  (DO () ((NOT (BIT-TEST 1_8 (PHYS-MEM-READ DC-STS-ADR))))
    415380    (PROCESS-ALLOW-SCHEDULE)))
    416381
    417 (DEFUN DC-FAULT-CLEAR NIL
    418   (DC-EXEC DC-FAULT-CLEAR 0 0 0 0 NIL 0)
     382(DEFUN DC-FAULT-CLEAR (&OPTIONAL (UNIT 0))
     383  (DC-EXEC DC-FAULT-CLEAR 0 0 0 0 NIL 0 UNIT)
    419384  (DO () ((NOT (BIT-TEST 1_8 (PHYS-MEM-READ DC-STS-ADR))))
    420385    (PROCESS-ALLOW-SCHEDULE)))
     
    449414#Q
    450415(DEFUN DCHECK-BLOCK-COUNTER ()
    451   (DO ((DESIRED-VALUES #10R (IF MARKSMAN-P
    452                                 '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)
    453                                 ;; Vandals: Yes, a value of 17. can appear here
    454                                 '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)))
     416  (DO ((DESIRED-VALUES #10R  ;; Vandals: Yes, a value of 17. can appear here
     417                                '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17))
    455418       (GOOD-VALUES NIL)
    456419       (BAD-VALUES NIL)
     
    477440
    478441;;; Check address logic, return bits which failed
    479 (DEFUN DCHECK-CLP-ADR (ADR)
     442(DEFUN DCHECK-CLP-ADR (ADR &OPTIONAL (UNIT 0))
    480443  (LET ((MA 0))
    481444    (DECLARE (FIXNUM MA))
    482     (DC-EXEC DC-READ 0 0 0 ADR NIL 0)
     445    (DC-EXEC DC-READ 0 0 0 ADR NIL 0 UNIT)
    483446    (COND ((NOT (= (LOGAND 14000000 (PHYS-MEM-READ-24 DC-STS-ADR))
    484447                   14000000))  ;NXM and CCW CYCLE
     
    501464   (DC-EXEC DC-READ 0 0 0 CCW-LOC 1000 0)))
    502465
    503 (DEFUN DCHECK-CCW-ADR (ADR)
     466;Tight writing loop.  This is the same as the write in part 6 of DCHECK.
     467(DEFUN DCHECK-WRITE-LOOP NIL
     468  (DO I 0 (1+ I) (= I 40)                       ;Loc 0-37 get floating 1's
     469      (PHYS-MEM-WRITE I (#M LSH #Q ASH 1 I)))
     470  (DO I 0 (1+ I) (= I 40)                       ;Loc 40-77 get floating 0's
     471      (PHYS-MEM-WRITE (+ 40 I) (- (#M LSH #Q ASH 1 32.) (#M LSH #Q ASH 1 I))))
     472  (DO I 100 (1+ I) (= I 400)                    ;Loc 100-377 get address pattern
     473      (PHYS-MEM-WRITE I (+ (LSH (LOGXOR 377 I) 8) I)))
     474  (DO () ((KBD-TYI-NO-HANG))
     475    (DC-EXEC DC-WRITE 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS)
     476    (LET ((MA (DC-READ-MA)))
     477      (COND ((NOT (= MA 377))
     478             (TERPRI) (PRINC '|MA wrong on write of pattern, correct=377, actual=|)
     479             (PRIN1 MA))))))
     480
     481
     482(defun dcheck-check-da-block-increments nil
     483  (dotimes (block  blocks-per-track)
     484    (cc-disk-xfer dc-read (+ (* 100 blocks-per-cylinder)
     485                             block)
     486                1 2)))
     487
     488(defun dcheck-check-da-head-increments nil
     489  (dotimes (head (// blocks-per-cylinder blocks-per-track))
     490    (cc-disk-xfer dc-read (+ (* 100 blocks-per-cylinder)
     491                             (1- blocks-per-track)
     492                             (* head blocks-per-track))
     493                1 2)))
     494
     495(defun dcheck-check-da-cylinder-increments nil
     496  (dotimes (cyl n-cylinders)
     497    (cc-disk-xfer dc-read (+ (* cyl blocks-per-cylinder)
     498                             (1- blocks-per-cylinder))
     499                  1 2)))
     500
     501(defun dcheck-check-da-cylinder-increments-1 nil
     502  (do ((adr 12 (1+ adr))
     503       (core-page 1 (1+ core-page))
     504       (n (* 2 blocks-per-cylinder) (1- n)))
     505      ((= n 0))
     506    (phys-mem-write adr (+ (cc-shift adr 8) (cond ((= n 1) 0) (t 1)))))
     507  (dotimes (cyl (- n-cylinders 2))
     508    (dc-exec dc-read cyl 0 0 12 nil dc-all-error-bits)))
     509
     510(DEFUN DCHECK-CCW-ADR (ADR &OPTIONAL (UNIT 0))
    504511  (LET ((MA 0))
    505512    (DECLARE (FIXNUM MA))
    506     (DC-EXEC DC-READ 0 0 0 CCW-LOC (SETQ ADR (LOGAND 77777400 ADR)) 0)
     513    (DC-EXEC DC-READ 0 0 0 CCW-LOC (SETQ ADR (LOGAND 77777400 ADR)) 0 UNIT)
    507514    (COND ((NOT (= (LOGAND 14000000 (PHYS-MEM-READ-24 DC-STS-ADR))
    508515                   04000000))  ;NXM and -CCW CYCLE
     
    522529
    523530;;; Alternating seek test
    524 (DEFUN DCHECK-SEEK (CYL)
     531(DEFUN DCHECK-SEEK (CYL &OPTIONAL (UNIT 0))
    525532  (TERPRI)
    526533  (PRINC '|Should be seeking between cylinders 0 and |)
     
    529536  (PRINC '| - type space when OK. |)
    530537  (DO () (#M (NOT (ZEROP (LISTEN))) #Q (KBD-TYI-NO-HANG))
    531     (DC-SEEK 0)
    532     (DC-SEEK CYL))
     538    (DC-SEEK 0 UNIT)
     539    (DC-SEEK CYL UNIT))
    533540  #M (TYI)
    534541  (TERPRI))
     
    552559    (PHYS-MEM-WRITE ADR VAL2)
    553560    (PHYS-MEM-READ ADR)))
     561
     562
    554563
    555564
     
    613622;;; Read/Write test
    614623
    615 (declare (special dc-write-read-trace))
    616 (setq dc-write-read-trace t)
     624(defvar dc-write-read-trace t)
     625(defvar dc-test-unit 0)
    617626
    618627;;; Low-level routine, does a write and a read and compares
     
    623632  ;; Trace
    624633  (and dc-write-read-trace
    625        (format t '|~%WRITE-READ-TEST: cyl=~O, head=~O, blk=~O, pattern=~A|
    626                  cyl head blk pattern-func))
     634       (format t '|~%WRITE-READ-TEST: unit=~O, cyl=~O, head=~O, blk=~O, pattern=~A|
     635                 dc-test-unit cyl head blk pattern-func))
    627636  ;; Fill memory with pattern
    628637  (do i 0 (1+ i) (= i 400)
    629638    (phys-mem-write (+ offset i) (funcall pattern-func i)))
    630639  ;; Write it out
    631   (dc-exec dc-write cyl head blk 777 (+ offset 0) dc-all-error-bits)
     640  (dc-exec dc-write cyl head blk 777 (+ offset 0) dc-all-error-bits dc-test-unit)
    632641  (do i 0 (1+ i) (= i 400)
    633642      (phys-mem-write (+ offset i) 0))
    634643  ;; Read it back
    635   (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits
     644  (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits dc-test-unit)
    636645  ;; Check pattern
    637646  (do ((i 0 (1+ i))
     
    663672  ;; Trace
    664673  (and dc-write-read-trace
    665        (format t "~%READ-TEST: cyl=~O, head=~O, blk=~O"
    666                  cyl head blk))
     674       (format t "~%READ-TEST: unit=~O, cyl=~O, head=~O, blk=~O"
     675                 dc-test-unit cyl head blk))
    667676  ;; Read it
    668   (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits
     677  (dc-exec dc-read cyl head blk 777 (+ offset 0) dc-all-error-bits dc-test-unit)
    669678)
    670679
     
    748757;;; This version is kludged up, you should step only one addr at a time!
    749758(defun dc-write-read-test (&optional response-list
    750                                      (all-list (if marksman-p
    751                                                    '( (do 0 210.)
    752                                                       (do 0 4)
    753                                                       (do 0 21.))
    754                                                    '( (do 0 815.)
    755                                                       (do 0 5)
    756                                                       (do 0 17.) ))))
     759                                     (all-list '( (do 0 815.)
     760                                                 (do 0 5)
     761                                                 (do 0 17.) )))
    757762  (multiple-value-bind (cyl head blk pattern-func)
    758763      (dc-get-addr-specs response-list all-list)
     
    764769  (dc-write-read-test '(all all all all)))
    765770
    766 (defun dc-read-test (&optional response-list (all-list (if marksman-p
    767                                                            '( (do 0 210.)
    768                                                               (do 0 4)
    769                                                               (do 0 21.))
    770                                                            '( (do 0 815.)
    771                                                               (do 0 5)
    772                                                               (do 0 17.) ))))
     771(defun dc-read-test (&optional response-list (all-list '( (do 0 815.)
     772                                                         (do 0 5)
     773                                                         (do 0 17.) )))
    773774  (multiple-value-bind (cyl head blk pattern-func)
    774775      (dc-get-addr-specs response-list all-list T)
     
    961962;This function reads in a track and types out some approximation of what's on it
    962963;If cyl is nil, decode what's in core
    963 (defun decode-track (cyl head &optional (blk 0))
     964(defun decode-track (cyl head &optional (blk 0) (unit 0))
    964965  (cond ((not (null cyl))
    965966         ;; First, read in 20. blocks, which is more than 20160. bytes
     
    967968           (dbg-write-xbus i (+ (lsh (1+ i) 8)
    968969                                (cond ((= i 19.) 0) (t 1))))) 
    969          (dc-exec dc-read-all cyl head blk 0 nil dc-some-error-bits)
     970         (dc-exec dc-read-all cyl head blk 0 nil dc-some-error-bits unit)
    970971         (get-buffer) ;gobble it down from other machine
    971972         ))
Note: See TracChangeset for help on using the changeset viewer.