;;; -*- Mode:LISP; Package:LAMBDA; Readtable:ZL; Base:10; Lowercase:T; Fonts:(CPTFONTB) -*- ;;; ;;; (c) Copyright 1986 - Lisp Machine, Inc. ;;; ;;; Youcef. 01/06/86. ;;; ;;; This will provide an window interface for the hardware diagnostics. ;;; (defun start-test (tests) (new-ltest tests) ) (defun new-initialize-diag () (cond ((null (access-path-lmi-serial-protocol *proc*)) (funcall *current-test* :new-message "ND MODE") (test-nd-mode-data-path) (nd-setup-1))) (setup-nubus-configuration) (funcall *current-test* :new-message "CON-REG") (TEST-CON-REG-DATA-PATH) (FUNCALL *CURRENT-TEST* :NEW-MESSAGE "PMR") (TEST-PMR-DATA-PATH) (RESET early-pmr-list) (funcall *current-test* :new-message "TRAM ADDRESS") (TEST-TRAM-ADR-DATA-PATH) (funcall *current-test* :new-message "TRAM") (TEST-TRAM-DATA-PATH) (funcall *current-test* :new-message "Fast address test of TRAM") (FAST-ADDRESS-TEST-TRAM) ;does an (init-tram nil t) afterwards. ) (defun NEW-LTEST (test-list &OPTIONAL &KEY (INIT NIL) &aux message) (AND INIT (NEW-INITIALIZE-DIAG)) (cond ((>= (send *proc* :major-version) 100.) (LET ((PMR (READ-PMR))) (CHANGE-PMR '(SPY-ADDRESS-TRAM-L 0 ALLOW-UINST-CLOCKS 0)) (WRITE-TRAM-ADR 3007) (SM-TICK) (SM-TICK) (WRITE-PMR PMR)) (sm-tick) (sm-tick) )) (dolist (test test-list) (if (listp test) (if (member 'ltest test) (new-ltest (eval (second test))) (funcall *current-test* :new-message (second test)) (eval test)) (setq message (format nil "~A" test)) (let ((index0 (string-search "Test-" message)) (index1 (string-search "-data-path" message))) (setq index0 (if index0 (+ index0 5) 0)) (setq message (if (string-search "Fast-address-test" message) (format nil "Fast address test of ~A" (substring message index0 index1)) (substring message index0 index1)))) (funcall *current-test* :new-message message) (cond ((stringp test) (format lambda-diag-stream test)) ((and (not (stringp test)) (atom test)) (funcall test)) ))) ) (DEFUN NEW-CM-TEST (&optional (clear-screen t) (load-tram t)) (and clear-screen (send *interaction-pane* :clear-screen)) (NEW-LTEST CM-TEST-LIST ':INIT load-tram)) (DEFUN NEW-DP-TEST (&optional (clear-screen t) (init t)) (and clear-screen (send *interaction-pane* :clear-screen)) (NEW-LTEST DP-TEST-LIST ':INIT init)) (DEFUN NEW-MI-TEST (&optional (clear-screen t) (init t)) (and clear-screen (send *interaction-pane* :clear-screen)) (NEW-LTEST MI-TEST-LIST ':INIT init)) (DEFUN NEW-RG-TEST (&OPTIONAL (USE-OTHER-BOARDS NIL)) (send *interaction-pane* :clear-screen) (NEW-LTEST RG-STAnd-ALONE-TEST-LIST ':INIT T) (IF USE-OTHER-BOARDS (NEW-LTEST RG-DEPENDENT-TEST-LIST))) (DEFUN NEW-BASIC-UTEST () (NEW-LTEST BASIC-UTEST-LIST)) (DEFUN NEW-LAM-TEST-FAST-ADDRESS-TESTS () (NEW-LTEST RG-ADDRESS-TEST-LIST) (NEW-LTEST CM-ADDRESS-TEST-LIST) (NEW-LTEST DP-ADDRESS-TEST-LIST) (NEW-LTEST MI-ADDRESS-TEST-LIST)) (defun new-lam-test-machine () (funcall *interaction-pane* :clear-screen) (new-rg-test t) (new-cm-test nil nil) (new-dp-test nil nil) (new-mi-test nil nil) (new-lam-test-fast-address-tests) ) (defun select-tests (&aux test) (setq test (second (assoc (send *proc* :proc-type) *tests-for-boards*))) (tv:menu-choose test '(:string "Choose test to run" :font fonts:tr12bi :centered)) t ) (defun new-select-test () (funcall *current-test* :clear-screen) (force-string-in "(select-tests)") ) (DEFUN LAM-ON-FRAME (&OPTIONAL flush-state) ;MAIN LOOP OF LAMBDA CONSOLE PROGRAM (if flush-state (flush-state)) (ERROR-RESTART (dbg:debugger-condition "Restart LAM from top level") (PROG ((*READ-BASE* 8.) (*PRINT-BASE* 8.) (*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA")) LAM-ARG LAM-SYL LAM-VAL LAM-UPDATE-DISPLAY-FLAG LAM-OPEN-REGISTER LAM-LAST-OPEN-REGISTER LAM-LAST-VALUE-TYPED COM-CH TEM) (SETQ QF-SWAP-IN-LOOP-CHECK NIL) (LAM-CONSOLE-INIT) (format *terminal-io* "~&~:[Getting fresh state from machine~;~ LAM contains saved state, use (LAM T) to flush it~].~%" lam-full-save-valid) (if (typep *terminal-io* 'tv:window) (LAM-CONSOLE-STATUS-DISPLAY-INTO-WINDOW T)) ;dont touch machine since saved state may ;not be valid (cond ((null *his-version*) (format t "~%Setting up for his version ..") (qf-initial-area-list) (format t " = ~d" *his-version*))) L0 (SETQ LAM-ARG NIL) (IF (and (typep *terminal-io* 'tv:window) (>= (- (CAR (CURSORPOS)) LAM-FIRST-STATUS-LINE) 0)) (PROGN (CURSORPOS 'Z) (TERPRI))) L (SETQ LAM-SYL (LAM-GETSYL-READ-TOKEN)) (COND ((NUMBERP LAM-SYL) (GO L1)) ((EQ LAM-SYL '*RUB*) ;OVER RUB-OUT (GO ERR1)) ((EQ LAM-SYL '|#@|) ;VARIOUS REG ADDR SPACES + MISC COMMANDS (GO COM)) ((EQ LAM-SYL '|#ALTMODE|) ;EXIT TO LISP (GO X)) ((EQ LAM-SYL '|#_|) ;VARIOUS TYPE-OUT MODES (GO UND)) ((EQ LAM-SYL '|#`|) ;VARIOUS TYPE-IN MODES (GO IND)) ((EQ LAM-SYL '|#'|) ;TYPE-IN OVER EXISTING FIELDS (GO INDOV)) ((EQ LAM-SYL '|.|) ;"POINT" (SETQ LAM-SYL LAM-LAST-OPEN-REGISTER) (GO L1)) ((EQ LAM-SYL '|#:|) ;VARIOUS SYMBOLIC COMMANDS (GO CLN)) ((SETQ TEM (LAM-LOOKUP-NAME LAM-SYL)) (SETQ LAM-SYL TEM) (GO L1))) L2 (COND ((SETQ TEM (GET LAM-SYL 'LAM-COMMAND)) (GO COM1))) ERR (PRIN1 LAM-SYL) ERR1 (PRINC "?? ") (GO L0) L1 (COND ((NUMBERP LAM-ARG) (SETQ LAM-ARG (PLUS LAM-ARG LAM-SYL))) (T (SETQ LAM-ARG LAM-SYL))) (GO L) COM (SETQ COM-CH (LAM-GETSYL-READ-TOKEN T)) ; (ASCII (LAM-CHAR-UPCASE (LAM-GETSYL-RCH))) (COND ((SETQ TEM (GET COM-CH 'LAM-LOWEST-ADR)) (COND ((NULL LAM-ARG) (SETQ LAM-ARG 0))) (SETQ LAM-ARG (+ LAM-ARG (SYMEVAL TEM))) (GO L))) (SETQ LAM-SYL COM-CH) (GO L2) COM1 (SETQ LAM-VAL (FUNCALL TEM LAM-ARG)) (COND (LAM-UPDATE-DISPLAY-FLAG (LAM-CONSOLE-STATUS-DISPLAY-INTO-WINDOW NIL) (SETQ LAM-UPDATE-DISPLAY-FLAG NIL))) (COND ((NUMBERP LAM-VAL) (SETQ LAM-ARG LAM-VAL) (GO L)) (T (GO L0))) UND (SETQ LAM-SYL (CHAR-UPCASE (LAM-GETSYL-RCH))) ;VARIOUS TYPEOUT COMMANDS (OR LAM-ARG (SETQ LAM-ARG LAM-LAST-VALUE-TYPED)) (COND ((OR (AND (>= LAM-SYL #/0) (<= LAM-SYL #/9)) (= LAM-SYL #/-)) (SETQ LAM-GETSYL-UNRCH LAM-SYL ;IF DIGIT OR MINUS, LAM-SYL (LAM-GETSYL-READ-TOKEN)) ;READ WHOLE NUMBER (SETQ LAM-SYL (LOGAND 37 LAM-SYL)) ;AND LEFT-ROTATE BY THAT (SETQ LAM-ARG (LOGIOR (LOGLDB (+ LAM-SYL (ASH (- 40 LAM-SYL) 6)) LAM-ARG) (ASH (LOGLDB (- 40 LAM-SYL) LAM-ARG) LAM-SYL))) (AND (EQ LAM-GETSYL-UNRCH-TOKEN #\SPACE) (SETQ LAM-GETSYL-UNRCH-TOKEN '=)) (GO L))) ;N_N TYPES OUT, OTHERWISE IS TYPE-IN! (tyo #/space) (OR (SETQ COM-CH (ASSQ (SETQ LAM-SYL (ASCII LAM-SYL)) LAM-MODE-DESC-TABLE)) (GO ERR)) (LAM-TYPE-OUT LAM-ARG (CDR COM-CH) T NIL) (SETQ LAM-LAST-VALUE-TYPED LAM-ARG) (PRINC " ") (GO L0) IND (SETQ LAM-SYL (ASCII (CHAR-UPCASE (LAM-GETSYL-RCH)))) ;VARIOUS TYPEIN COMMANDS (PRINC " ") (OR (SETQ COM-CH (ASSQ LAM-SYL LAM-MODE-DESC-TABLE)) (GO ERR)) (SETQ LAM-SYL (LAM-TYPE-IN (CDR COM-CH) 0 NIL)) (GO L1) INDOV (SETQ LAM-SYL (ASCII (CHAR-UPCASE (LAM-GETSYL-RCH)))) (FORMAT T "~%[Edit] ") (OR (SETQ COM-CH (ASSQ LAM-SYL LAM-MODE-DESC-TABLE)) (GO ERR)) (SETQ LAM-SYL (LAM-TYPE-IN (CDR COM-CH) LAM-LAST-VALUE-TYPED T)) (GO L1) X (RETURN LAM-LAST-VALUE-TYPED) CLN (SETQ LAM-SYL (LAM-GETSYL-READ-TOKEN)) ;:FOOBAR ETC. (OR (SETQ TEM (GET LAM-SYL 'LAM-COLON-CMD)) (GO ERR1)) (GO COM1)))) (DEFUN LAM-CONSOLE-STATUS-DISPLAY-INTO-WINDOW (DONT-TOUCH-MACHINE &AUX PC IR (*standard-output* *current-instruction-pane*)) (SEND *current-instruction-pane* :CLEAR-SCREEN) (LAM-ENTER) (FORMAT *current-instruction-pane* "~%~10TPC=~O " (SETQ PC (LAM-REGISTER-EXAMINE RAPC))) (SETQ IR (LAM-REGISTER-EXAMINE RASIR)) (FORMAT *current-instruction-pane* "~10TMFO=~O ~A~%~10TIR=" (LAM-REGISTER-EXAMINE RAMFO) (LAM-FIND-CLOSEST-SYM (+ PC RACMO))) ;PRINT SYMBOLIC PC ;if coming in at top level, dont print contents of M or A mem location that does ;not have symbolic name. Problem is that examining does LAM-NOOP-CLOCK which results ;in loss of state, increments PC, etc etc. (LAM-TYPE-OUT IR LAM-UINST-DESC T DONT-TOUCH-MACHINE) (FORMAT *current-instruction-pane* "~%~10T~:[~;NOOP ~]~:[~;LAST-INST-HAD-HALT-BIT~]~%" LAM-NOOP-FLAG lam-last-inst-had-halt-bit) (LAM-RAID) ;print cache state machine state (if (eq current-processor-type :lambda) (let ((tem (read-csm-adr))) (format *current-instruction-pane* "~%~10Tcsmadr: ~o ~s" TEM (CSM-SYMBOLIC-LOCATION (LOGAND 3777 TEM))))) )