;;; -*- Mode:midas; base:8 -*-

;;; Explorer PROM microcode for self test, menuboot, & Diagnostic Engine
;;; Contains self test taken from b:>amundsen>expl-promh.lisp.5 dated 7/16/84.
;;; Contains system test taken from a:>kloepper>stm-prom.lisp.36 dated 8/28/84.
;;; +++ System test code commented out for beta test.
;;; +++ Must however wait for the Nupi to clear its self test busy flag
;;; +++ since its probably going to be waiting 40 sec to determine devices.

;;; This code was adapted from new-exprom.lisp.15 dated 10/10/84
;;; For beta test, we will perform processor self test but not system test.
;;; Warm boot events will not be supported.  c-m-c-m-ABORT will bring up an
;;; initial menu that allows selection of default or menu boot.  There will be 
;;; a timeout to automatically select default boot.

(SETQ boot-rom-f '(

(def-data-field %slot-id 4 24.)

(def-data-field %lvl2-map-control-word-rw-access 2 8.)
(def-data-field %lvl1-map-valid-bit 1 11.)

(def-data-field %imod-high-a-source 10. 0)
(def-data-field %imod-low-a-dest 12. 19.)
(def-data-field %imod-low-m-dest 6. 19.)
(def-data-field %imod-low-mrot 5 0)
(def-data-field %imod-low-bytelen 5 5)
(def-data-field %imod-low-dispatch-address 12. 20.)
(def-data-field %imod-low-new-micro-pc 14. 18.)

(def-data-field %multiply-position 12. 12.)

(LOCALITY M-MEM)

M-GARBAGE	(0)
M-HUNOZ		(0)
M-ZERO		(0)
M-ONES		(0)

;; parameter passing registers
;; also used by self test
m-a		(0)
m-b		(0)
m-c		(0)
m-d		(0)
m-e		(0)
m-f		(0)
m-g		(0)
m-h		(0)
m-i		(0)
m-j		(0)
m-k		(0)

;; working registers -- 3 levels
m-1		(0)
m-2		(0)
m-a1		(0)
m-a2		(0)
m-b1		(0)
m-b2		(0)

;; temporary registers
m-tem		(0)

;; temp registers used by self test & system test
m-temp-1	(0)
m-temp-2	(0)

;; multiplication registers
m-mpy-1		(0)
m-mpy-result	(0)

;; convienent variables to have in m-memory
m-main-memory-base-address	(0)
m-draw-row			(0)
m-draw-column			(0)
m-cursor-row			(0)
m-menu-key			(0)
m-boot-type			(0)
m-boot-device-type		(0)
m-mcr-offset			(0)
m-string-low			(0)
m-number-of-devices		(0)
m-nubus-op			(0)

;;; DEI registers
m-stack-1			(0)
m-stack-2			(0)
m-stack-3			(0)
m-stack-4			(0)

m-dei-1				(0)
m-dei-2				(0)
m-dei-3				(0)
m-dei-temp			(0)

m-dei-inst-opcode		(0)
m-dei-inst-opmod		(0)

;;; System test registers
m-boards-tested			(0)
m-boards-failed			(0)
m-crc				(0)

;;; The following are DEI variables that can be saved/restored
;;; to allow recursive invocations of the diagnostic engine.
;;; They must not move from this location as the save/restore code
;;; expects to find them here.
;;; The last 14. locations are used (x32-x3F)
(loc #x+32)

m-ddr-slot			(0)
m-ddr-class			(0)
m-ddr-function			(0)
m-dei-data-space-origin		(0)
m-dei-data-space-size		(0)
m-dei-dstack-origin		(0)
m-dei-dstack-pointer		(0)
m-dei-rstack-origin		(0)
m-dei-rstack-pointer		(0)
m-dei-board-space		(0)
m-dei-inst-space		(0)
m-dei-inst-pointer		(0)
m-dei-inst-increment		(0)
m-dei-erex			(0)


(LOCALITY A-MEM)

A-GARBAGE	(0)
A-HUNOZ		(0)
A-ZERO		(0)
A-ONES		(0)

;; parameter passing registers
a-a		(0)
a-b		(0)
a-c		(0)
a-d		(0)
a-e		(0)
a-f		(0)
a-g		(0)
a-h		(0)
a-i		(0)
a-j		(0)
a-k		(0)

;; working registers -- three levels
a-1		(0)
a-2		(0)
a-a1		(0)
a-a2		(0)
a-b1		(0)
a-b2		(0)

;; temporary registers
a-tem		(0)

;; temp registers used by self test
a-temp-1	(0)
a-temp-2	(0)

;; multiplication registers
a-mpy-1		(0)
a-mpy-result	(0)

;; convienent variables to have in m-memory
a-main-memory-base-address	(0)
a-draw-row			(0)
a-draw-column			(0)
a-cursor-row			(0)
a-menu-key			(0)
a-boot-type			(0)
a-boot-device-type		(0)
a-mcr-offset			(0)
a-string-low			(0)
a-number-of-devices		(0)
a-nubus-op			(0)

;;; DEI registers
a-stack-1			(0)
a-stack-2			(0)
a-stack-3			(0)
a-stack-4			(0)

a-dei-1				(0)
a-dei-2				(0)
a-dei-3				(0)
a-dei-temp			(0)

a-dei-inst-opcode		(0)
a-dei-inst-opmod		(0)

;;; System test registers
a-boards-tested			(0)
a-boards-failed			(0)
a-crc				(0)

;;; The following are DEI variables that can be saved/restored
;;; to allow recursive invocations of the diagnostic engine.
;;; They must not move from this location as the save/restore code
;;; expects to find them here.
;;; The last 14. locations are used (x32-x3F)
(loc #x+32)

a-ddr-slot			(0)
a-ddr-class			(0)
a-ddr-function			(0)
a-dei-data-space-origin		(0)
a-dei-data-space-size		(0)
a-dei-dstack-origin		(0)
a-dei-dstack-pointer		(0)
a-dei-rstack-origin		(0)
a-dei-rstack-pointer		(0)
a-dei-board-space		(0)
a-dei-inst-space		(0)
a-dei-inst-pointer		(0)
a-dei-inst-increment		(0)
a-dei-erex			(0)


(LOC #x+40)
;;; start of non shadowed a-memory

;;; The hex constants MUST start here because numbers 1 to 1F are
;;; generated using an IMOD loop.

a-hex-0				(0)	;not really used
a-hex-1				(0)
a-hex-2				(0)
a-hex-3				(0)
a-hex-4				(0)
a-hex-5				(0)
a-hex-6				(0)
a-hex-7				(0)
a-hex-8				(0)
a-hex-9				(0)
a-hex-A				(0)
a-hex-B				(0)
a-hex-C				(0)
a-hex-D				(0)
a-hex-E				(0)
a-hex-F				(0)
a-hex-10			(0)
a-hex-11			(0)
a-hex-12			(0)
a-hex-13			(0)
a-hex-14			(0)
a-hex-15			(0)
a-hex-16			(0)
a-hex-17			(0)
a-hex-18			(0)
a-hex-19			(0)
a-hex-1A			(0)
a-hex-1B			(0)
a-hex-1C			(0)
a-hex-1D			(0)
a-hex-1E			(0)
a-hex-1F			(0)

;;; these constants are generated using DPB
a-hex-20			(0)
a-hex-30			(0)
a-hex-32			(0)
a-hex-3E			(0)
a-hex-40			(0)
a-hex-41			(0)
a-hex-50			(0)
a-hex-54			(0)
a-hex-74			(0)
a-hex-7F			(0)
a-hex-80			(0)
a-hex-FF			(0)
a-hex-100			(0)
a-hex-200			(0)
a-hex-210			(0)
a-hex-3FB			(0)
a-hex-400			(0)
a-hex-800			(0)
a-hex-2000			(0)
a-hex-5593			(0)
a-hex-F0000000			(0)

;;; Constants used by processor self test
a-100000			(0)	;hex 
a-20000				(0)	;octal
a-400				(0)	;octal
a-constant-2			(0)	;name changed so won't conflict with a-2

;;; NuBus slot id's 
a-processor-slot		(0)
a-monitor-slot			(0)
a-keyboard-slot			(0)
a-boot-device-slot		(0)
a-memory-slot			(0)

;;; Handy addresses of items in Configuration Rom - initialized by SETUP-BOARD-ADDRESSES
a-resource-byte			(0)
a-rom-flags			(0)
a-flag-reg-offset		(0)
a-diagnostic-offset		(0)
a-device-driver-offset		(0)
a-config-reg-offset		(0)
a-rom-size			(0)

;; special NuBus addresses
a-ddr-scratch-area		(0)
a-device-configuration-area	(0)
a-ptable-memory-address		(0)
a-mcr-memory-address		(0)

;;; boot device related variables
a-boot-unit			(0)
a-logical-unit			(0)
a-device-label-address		(0)
a-device-save-address		(0)
a-buffer-pointer		(0)
a-transfer-count		(0)
a-device-address		(0)
a-device-current-position	(0)
a-write-flag			(0)
a-block-size			(0)
a-default-boot-unit		(0)
a-default-unit-type		(0)

;;; microload information
a-mcr-origin			(0)
a-mcr-address			(0)
a-mcr-size			(0)
a-mcr-end			(0)
a-mcr-type			(0)
a-ram-entry-point		(0)

;;; device label variables
a-ptable-length			(0)
a-store-block-address		(0)
a-number-of-partitions		(0)
a-partition-descriptor-size	(0)
a-offset-to-partition-comment	(0)
a-partition-comment-length	(0)
a-default-lod-name		(0)
a-default-mcr-name		(0)
a-number-of-sysloads		(0)

;;; screen & keyboard information
a-rows-per-screen		(0)
a-columns-per-row		(0)
a-first-menu-row		(0)
a-first-menu-column		(0)
a-cursor-char			(0)
a-keyboard-flags		(0)
a-input-timeout			(0)
a-keydoc-flag			(0)
a-default-entry			(0)

;; boot types
a-menu-boot			(0)
a-default-boot			(0)
a-warm-boot			(0)
a-diagnostic-boot		(0)

;;; error code constants
a-error-code			(0)
a-pending-error			(0)
a-no-online-devices		(0)
a-invalid-label			(0)
a-small-save-area		(0)
a-invalid-ptable		(0)
a-no-microloads			(0)
a-microload-not-found		(0)
a-bad-section-type		(0)
a-bad-section-address		(0)
a-end-of-partition		(0)
a-ddr-completion		(0)
a-no-disk-controller		(0)
a-page-fault			(0)
a-ddr-request			(0)
a-dei-instruction-header	(0)

;;; Strings related variables
a-string-address		(0)
a-string-length			(0)
a-char-code			(0)
a-string-space			(0)
a-string-high			(0)	;; Destination for high bits of READ-I-MEM

;;; DEI registers
a-dei-inst-breakpoint		(0)
a-stack-pop			(0)
a-dei-nubus-error-flag		(0)

;;; System test registers
a-boards-crc-failure		(0)
a-boards-self-test-timeout	(0)
a-boards-self-test-failure	(0)
a-boards-subsys-failure		(0)
a-boards-dei-test-failure	(0)
a-boards-nubus-test-timeout	(0)


;;; Registers used to debug NuBus problems
a-nubus-retry-count		(0)
a-nubus-gacbl-failures		(0)
a-nubus-error-latch		(0)
a-nubus-gacbl-count		(0)
a-nubus-timeout			(0)
a-nubus-error			(0)
a-nubus-no-error		(0)
a-no-memory-errors		(0)
a-parity-errors			(0)
a-save-vma			(0)
a-save-md			(0)
a-delay-counter			(0)


;;; The high half of a-memory is used for the DEI stacks (except last 4 locs)
(loc #x+200)
a-dei-stack-space		(0)	;token name, not really used


;;; The last four locations in a-memory are special.
;;; They hold the boot info which is passed between prom and main microcode.

(loc #x+3FC)
a-boot-request			(0)
a-boot-device			(0)
a-boot-mcr-name			(0)
a-boot-lod-name			(0)

;;; Added from b:>amundsen>expl-promh

(Locality T-Mem)
T-Class-0	(00000000)
T-Class-1	(00000000)
T-Class-2	(00000000)
T-Class-3	(00000000)
T-Class-4	(00000000)
T-Class-5	(00000000)
T-Class-6	(00000000)
T-Class-7	(00000000)
T-Class-8	(00000000)
T-Class-9	(00000000)
T-Class-A	(00000000)
T-Class-B	(00000000)
T-Class-C	(00000000)
T-Class-D	(00000000)
T-Class-E	(00000000)
T-Class-F	(00000000)



(LOCALITY I-MEM)
;;; The first part of this file contains processor self test code
;;; taken from the file b:>amundsen>expl-promh.lisp.5 dated 7/16/84.
;;;
;;;
;;; EDIT History
;;;
;;;	6/17/84 Finished coding. Began Debug. Debuged 
;;;		up to memory cycle tests.
;;;     6/20/84 Selftest executes without error.
;;;		Began pulling the boot code in from NUPI-PROMH
;;;     6/23/84 Modified code to initialize the SIB including the 
;;;             keyboard.
;;;             REMOVED ALL OF THE DEBUG-FROM-RAM ONLY CODE
;;;     6/24/84 Found the problem with Q-R shift test. Forget to load
;;;		A-Ones.
;;;	6/27/84 Reworked the SIB initialization to get rid of a time out
;;;		problem when trying to write to the CRT controller. Also
;;;		to try to fix problem with mouse not working with the
;;;		previous version of the PROM. Currently not initializing
;;;		the TV frame interrupt vector on the SIB so that the mouse
;;;		works on the first boot rather than the second boot.
;;;	7/09/84 Found a place where control store parity was supposed to 
;;;		be turned on but it wasn't.
;;;	7/11/84 Fixed the problem with the code that was supposed to 
;;;		initialize the control store with HALTS. EXPL$C.
;;;	7/16/84 Fixed yet another problem with the code that was supposed
;;;		to initialize control store. EXPL$D
;;;
;;; This is first shot at the LCL selftest.
;;; This file also contains a preliminary version of the loader copied
;;; from NUPI-PROMH.
;;;--------------------------------------------------------------------------------
;;; Notes of interest:
;;;
;;; The goal here is to execute code that will detect a failure in the hardware if
;;; one exists and not to execute code that will diagnose the cause of failure.
;;;
;;; The trap on control store parity error enable in MCR must be cleared before
;;; testing the control store. If the data pattern written or read from control
;;; store has even parity and parity error trap is enabled the machine will trap
;;; and then halt if the routine trapped to wants it to.
;;;
;;; The error traps attempt to display an error code in the lights using their 
;;; address divided by two with the 7 MSBs truncated. A Total of 64 combinations 
;;; of codes are possible. Code 0 is unused because that is the reset trap.
;;; Codes 1 through 8. are used by the wired traps. Code 9. is used for most
;;; selftest failures.
;;;
;;; This code tests the loop-on-self test bit in MCR upon completion. If 
;;; loop-on-selftest is active, a jump to location zero is performed. The Test-Sync 
;;; Signal is activated once per loop to support Signature Analysis.
;;; If selftest fails the loop-on-selftest bit is checked. If asserted, selftest
;;; is repeated.
;;;
;;; The And-Call-xxx traps are used with the following convention, if
;;; C-PDL-Buffer-Pointer is equal to A-Ones then the return address on the stack
;;; is incremented by one and a Popj is performed, otherwise the Call
;;; to Internal-Error is performed.
;;;
;;; The M-Tag classifier tests use the routine Write-Tag-Ram which is
;;; also used by the loader.
;;;--------------------------------------------------------------------------------
;;; Things Know not to be tested
;;;
;;; Dispatch, -Advance-Instruction-Stream, -Push-Own-Address,
;;;		Use-MIR, Use-M-Tag, Use-Old-Space-Bit, Use-Gc-Volatility-Bit and
;;;		Dispatch-Mask-Length are not checked.
;;;
;;; Forced memory accesses are not checked. Halfword accesses are not checked.
;;; Interlocked memory cycles are not checked. Abort on bus error is not checked.
;;; Powerfail warning and boot events are not tested.
;;; The configuration PROM and the configuration register are not accessed.
;;;
;;; The instruction stream hardware, CADR style and LCL style are not checked
;;; nor is the NEEDFETCH indicator in MCR. MISC-OP decode is not checked.
;;; Control store parity is not tested.
;;;
;;; Some of the stuff in MCR is not checked.
;;;  PROM disable is not checked 
;;;  NuBus 100 ns RESET is not checked.
;;; 
;;;--------------------------------------------------------------------------------


(Def-Data-Field IMOD-Low-Jump 14. 18.)	;use for control store read/write
(Def-Data-Field IMOD-Rotation-Count 5. 0.)	;use for bit testing
(Def-Data-Field IMOD-A-Src 10. 0.)	;Use For A-Source IMODS
(Def-Data-Field IMOD-M-Src  6. 10.)	;Use For M-Source IMODS
(Def-Data-Field IMOD-A-Dest 10. 19.)	;Use For A-Destination IMODS
(Def-Data-Field IMOD-M-Dest 6. 19.)	;Use For M-Destination IMODS
(Def-Data-Field Condition-Sense-Bit 1. 15.)	;Use for cond. sense IMODS
(DEF-DATA-FIELD %M-MEMORY-DESTINATION 6. 19.)
(DEF-DATA-FIELD %A-MEMORY-DESTINATION 12. 19.)
(DEF-DATA-FIELD %D-MEMORY-ADDRESS 12. 20.)
(DEF-DATA-FIELD %NEW-MICRO-PC 14. 18.)
;;; these two are already defined - JLarson
;;;(DEF-DATA-FIELD %LVL2-MAP-CONTROL-WORD-RW-ACCESS 2 8.)
;;;(DEF-DATA-FIELD %LVL1-MAP-VALID-BIT 1 11.)


;;; +++ Instruction memory origin
(LOC 0)
;;;(loc #x+3700)		;;; for ram debug, the 'prom' will be located at 3700 to 3F00

;;; The following trap table cannot be relocated because the trap addresses
;;; are wired.
;;;--------------------------------------------------------------------------------
;;; LIGHT CODE = 0
;;; Power up trap location, get here from NuBus reset

Reset-Trap
;;;	(Jump-Xct-Next Start-Self-Test)
;;;       ((Test-Synch) SETZ)
;;; >>> modified according to Mike's instructions 10/28/84
	((test-synch) setz)
	(jump START-SELF-TEST)

;;;--------------------------------------------------------------------------------
;;;  The following 3 traps are not expected to be enabled during self-test.
;;;  If they are just replace the code here with something that looks like
;;;  the reset-trap.

;;; LIGHT CODE = 1
;;; power fail warning trap, get here if event enabled by bit 20 in MCR and a
;;; powerfail warning event has been posted.

Power-Fail-Warning-Trap
	(Call Display-Lights)
	(No-op)
;;;--------------------------------------------------------------------------------
;;; LIGHT CODE = 2
;;; Control Store Parity error trap, get here if control store parity error and
;;; abort-on-error is enabled by bit 12 in MCR.

Control-Store-Parity-Error-Trap
	(Call Display-Lights)
	(No-Op)
;;;--------------------------------------------------------------------------------
;;; LIGHT CODE = 3
;;; Warm-Start-Event trap, get here if a warm start event has been posted
;;; and the trap has been enabled by bit 20 in MCR.
;;; ===> this is a temporary trap. Warm start should examine the keyboard to   <===
;;; ===> determine the type of boot. If cold boot then jump to Start-Self-test.<===
;;; ===> If a warm boot then the microcode may get reloaded but main memory    <===
;;; ===> is left untouched.						       <===
;;; ===> In addition it may be desirable to be able to cold boot after         <===
;;; ===> selftest failure so as to perform extended diagnostics. Then again    <===
;;; ===> that may be real losing.
;;; !!! actually this has changed somewhat - JSL 9/19/84
Warm-Start-Event-Trap
;;;	(Jump-Xct-Next Start-Boot-Load)
;;;	(Jump-Xct-Next Start-Self-Test)		;<**** RAM DEBUG ******************
;;;	((MD) SETZ)

	(jump-xct-next WARM-BOOT-EVENT)         ;changed by JSL
       ((m-boot-type) setz)			;warm boot event = boot type 0

;;;--------------------------------------------------------------------------------
;;; LIGHT CODE = 4
;;; Call-to-Illop, get here if a call to illop abbreviated jump is performed
;;; This is used by the selftest to die in some cases. The convention is to
;;; set C-PDL-Buffer-Pointer to -1 if the Call-to-xxx was intentional and the test
;;; should pass.

Call-To-Illop-Trap
	(Call Display-Lights If-Not-Equal A-Ones C-PDL-Buffer-Pointer)
	(Jump Return-Fixup)
;;;--------------------------------------------------------------------------------
;;; LIGHT CODE = 5
;;; Call-to-Trap, get here if a call to trap abbreviated jump is performed

Call-To-Trap
	(Call Display-Lights If-Not-Equal A-Ones C-PDL-Buffer-Pointer)
	(Jump Return-Fixup)
;;;--------------------------------------------------------------------------------
;;; LIGHT CODE = 6
;;; Call-to-Bus-Error-Trap, get here if a call to Bus-Error abbrv jump is performed

Call-To-Bus-Error
	(Call Display-Lights If-Not-Equal A-Ones C-PDL-Buffer-Pointer)
	(Jump Return-Fixup)
;;;--------------------------------------------------------------------------------
;;; LIGHT CODE = 7
;;; Call-to-Unused-Trap, get here if a call to <unused> abbrv jump is performed

Call-To-Unused
	(Call Display-Lights If-Not-Equal A-Ones C-PDL-Buffer-Pointer)
	(Jump Return-Fixup)
;;;--------------------------------------------------------------------------------
;;; LIGHT CODE = 8
;;; Buserr-Abort-Trap, get here if a buserr occurs and the abort if buserr is 
;;; enabled in MCR by bit 13 is enabled.

Buserr-Abort-Trap
	(Call Display-Lights)
	(No-Op)



;;;--------------------------------------------------------------------------------
;;; ERROR halts: This halt is used by all selftest failures. It causes the error
;;; code 9 to be displayed in the lights.

Internal-Error

;;; LIGHT CODE = 9.
	(Call Display-Lights)
	(No-op)

;;; Some kind of boot error, compress to one error code ?
;;; LIGHT CODE = 10. to 19. / A to 13 hex
;;; *** I deleted most of the error halts from >amundsen>expl-promh because
;;; *** I'm going to try to use the monitor to display error messages.
;;; *** The error halts here are for those conditions that for some reason
;;; *** shouldn't depend on the monitor being available. -- JSL

Error-No-Memory			;light code 10.
	(Call Display-Lights)
	(No-op)
Error-No-Monitor		;light code 11.
	(Call Display-Lights)
	(No-op)
Error-DDR-Request		;light code 12.
	(Call Display-Lights)
	(No-op)
Error-DDR-Completion		;light code 13.
	(Call Display-Lights)
	(No-op)
Error-DEI-Instruction-Header	;light code 14.
	(Call Display-Lights)
	(No-op)
Error-DEI-Internal-Error	;light code 15.
	(Call Display-Lights)
	(No-op)

;;; !!! It would be nice if the disk DDR could do something like this -- JSL
;;;ERROR-DISK-ERROR
;;;
;;; Disk operation error.
;;;	;; save status of operation in error.
;;;	((A-Disk-Op-Status) MD)
;;;	;; Try to read some special status words from the NUPI.
;;;	((VMA-Start-Read) DPB M-Ones (Byte-Field 1 9.) A-10) ; 1010
;;;	(Call If-Page-Fault Error-Page-Fault)
;;;	((A-Giles-Word-20) MD)
;;;	((VMA-Start-Read) Add VMA A-1)  ;1011
;;;	(Call If-Page-Fault Error-Page-Fault)
;;;	((A-Giles-Word-24) MD)
;;;
;;;	(Call Read-Disk-Status)
;;;	(Call End-Of-Disk-Error)


;;; *** added by JSL

;;;TEST-BOOT-ENTRY-POINT
;;; Test boot is a special entry point used for cold booting with
;;; a desired set of boot parameters.  The reserved a-memory locations
;;; are set for the desired boot device & partitions and the prom is
;;; entered at this point.  Basically, this is exactly like a warm boot
;;; event except the code in a-boot-request is different.
;;; m-ones & m-zero must be set up correctly.

;;; +++ leave this out until we decide what this should do
;;; 	(jump-xct-next START-BOOT-LOAD)
;;;       ((m-boot-type) dpb m-ones (byte-field 1 2) a-zero)	;boot type 4


WARM-BOOT-EVENT
;;; Jump here from the warm-start trap vector at ROM location 6.
;;; All we do is jump into RAM at WCS location 6.  It is up
;;; to the RAM to do the right thing.  It should at least read
;;; the keyboard to determine boot type (warm or cold) and might
;;; reload lisp accessable processor memories (a/m-memory).

	((m-zero) setz)
	((m-ones) seto)
	((m-hunoz) dpb m-ones (byte-field 2 1) a-zero)	;entry point at location 6 in RAM
	(jump-xct-next ENTER-RAM)
       ((q-r) m-hunoz)



;;;--------------------------------------------------------------------------------
;;; Get here on all selftest errors. The goal here is to display an error code in
;;; the yellow lights. The address of the calling routine divided by two is 
;;; displayed in the lights. The 7 MSBs are discarded. First test the loop on 
;;; selftest bit to see if you should halt or do it again so signature analysis
;;; works. The address of the instruction following the call to Internal-Error is
;;; left in the PC when the machine halts.

Display-Lights
	((Q-R) SETCM Micro-Stack-Data-Pop)
;;;	((M-Hunoz) MCR)		;only here for debug from RAM <*******************
	(Jump If-Bit-Clear (Byte-Field 1. 23.) MCR Reset-Trap)
;;;	(And-Popj Halt (MCR) LDB (Byte-Field 6. 1.) Q-R A-Hunoz) <****************
	(And-Popj Halt (MCR) LDB (Byte-Field 6. 1.) Q-R A-Zero)

;;;--------------------------------------------------------------------------------
;;; Get here if And-Call-xxx is being tested. Return address must be fixed up
;;; so we know we passed. Used in other places to test whether condition
;;; tested was really false.

Return-Fixup
	((Micro-Stack-Data) M+1 Micro-Stack-Data)
	(Popj)


   
;;;--------------------------------------------------------------------------------
Start-Self-Test
;;; First check out tests of If-Bit-Clear, If-Bit-Set, If-Equal, and If-Not-Equal
;;; MD should be clear after reset.
	
;;; +++ FOR RAM DEBUG OF MENUBOOT, DON'T DO SELF TEST -- JSL
;;;	(jump START-BOOT-LOAD)

	(Call If-Bit-Set (Byte-Field 1 0) MD Internal-Error)
	(Call If-Bit-Clear (Byte-Field 1 0) MD Return-Fixup)
	(Call Internal-Error)
	((M-Garbage) MD)	;setup A-Garbage
	(Call If-Not-Equal MD A-Garbage Internal-Error)
	((M-Garbage) MD)	;setup A-Garbage
	(Call If-Equal MD A-Garbage Return-Fixup)
	(Call Internal-Error)
;;;-----------------------------------------------------------------------------
;;; Create M-ZERO and M-ONES, and check the hardware a little.

	((MD M-Zero Q-R) SETZ)  ;Make all zeros,in Q-R, not to depend on M mem
	((MD M-A) SETZ)		;set bit counter to zero
	((MD M-B) SETZ)		;set condition-sense-bit to zero
Q-R-Loop1
;;; Test all 32 bits, from least significant to most according to
;;; bit number.
	((IMOD-Low) DPB IMOD-Rotation-Count M-A A-B)
	(Call If-Bit-Set Rotate-Right (Byte-Field 1 0) Q-R Internal-Error)
;;; increment the bit number to be tested and then see if test is done.
	(And-Skip Always (M-A) M+1 M-A)
	(Call Internal-Error)
	(Jump If-Bit-Clear (Byte-Field 1. 5.) M-A Q-R-Loop1)
;;; set the condition bit for testing the inverse of current sense
	((M-A) M+1 M-A)		;set LSB of M-A so DPB will work
	((M-B) DPB Condition-Sense-Bit M-A A-Zero)
	((M-A) SETZ)		;reset the bit number
;;; Exit condition reached when MD contains ones.
	(Jump-Xct-Next If-Bit-Clear (Byte-Field 1 0) MD Q-R-Loop1)
       ((MD M-Ones Q-R) SETO)
;;;
	((M-Hunoz) MCR)	
	((MCR) DPB (Byte-Field 1. 12.) M-Ones A-Hunoz)	;turn on control store
							;parity checking.
;;;-----------------------------------------------------------------------------
;;; Now, Test M-Memory, A-Memory, and M=A logic
	(Call If-Not-Equal Q-R A-Ones Internal-Error)
	(Call If-Equal Q-R A-Ones Return-Fixup)
	(Call Internal-Error)
	(Call If-Not-Equal M-Ones A-Ones Internal-Error)
	((MD Q-R) ANDCA M-Ones A-Ones)	;clear Q-R
	(Call If-Not-Equal Q-R A-Zero Internal-Error)
	(Call If-Not-Equal M-Zero A-Zero Internal-Error)
;;;-----------------------------------------------------------------------------
;;; See If Carries In Alu Really Carry.
	((MD Q-R) Add M-Ones A-Zero Alu-Carry-In-One)
	(Call If-Not-Equal Q-R A-Zero Internal-Error)
;;;-----------------------------------------------------------------------------
;;; Another simple carry test
	((MD Q-R) Add M-Ones A-Ones ALU-Carry-In-Zero)
	((M-Hunoz) DPB (Byte-Field 31. 1.) M-Ones A-Zero)
	(Call If-Not-Equal Q-R A-Hunoz Internal-Error)
	((MD Q-R) SUB M-Ones A-Ones)
	(Call If-Not-Equal Q-R A-Zero Internal-Error)
;;;-----------------------------------------------------------------------------
;;; Simple test to see if Q-will shift left.
;;; Also tests MD, VMA, PDL, M-Mem a little, A-Mem a little
;;; Tests some jump conditions along the way to reduce the number of
;;; states in the PROM.
;;; M-A contains the bit number that should be set.
;;; M-B contains one less than the current bit count.
;;; M-C contains the test data as it is copied around the machine.
;;; The test simply set a one in the LSB of Q-R and shifts it left. The contents
;;; of Q-R is copied to MD, VMA, C-PDL-Buffer-Pointer, M-Memory and A-Memory
;;; using a number of ALU functions and Output bus control functions and testing
;;; for a number of conditions which should not be true. When Q31 is a one the
;;; test is over.

;;;initialize the Q-Register and the bit count 
	(And-Skip If-Fixnum-Overflow (MD Q-R M-A) SETZ M-Zero A-Zero)
	(Call If-Not-Equal Q-R A-Zero Internal-Error) 
	((MD Q-R) M+1 Q-R A-Zero)	;set the LSB in Q-R
Q-Left-Loop
;;; copy the data from register to register applying ALU and output bus
;;; functions along the way.
	(And-Skip If-Memory-Busy (MD) SETCM Q-R)
	(And-Skip If-NuBus-Error (VMA) XOR MD A-Ones Output-Selector-Mirror)
	(And-Skip Never (C-PDL-Buffer-Pointer) VMA Output-Selector-Mirror)
	(And-Skip If-Tag-Equal (A-B) DPB (Byte-Field 32. 0)
		 C-PDL-Buffer-Pointer A-Zero)
	((MD M-C) SETM M-Zero A-B Output-Selector-A-Bus)
;;; calculate the bit to be tested
	((IMOD-Low) DPB IMOD-Rotation-Count M-A A-Zero) 
	(Call If-Bit-Clear M-C  Rotate-Right (Byte-Field 1. 0.) 
		Internal-Error)	;test the bit
	(Call If-Not-Equal Q-R A-C Internal-Error)
	((MD M-B) ADD M-A A-Ones)
	((MD M-A) M+1 M-A)		;increment the bit number
	((IMOD-Low) DPB IMOD-Rotation-Count MD A-Zero) 
	(Call If-Bit-Set M-C  Rotate-Right (Byte-Field 1. 0.) 
		Internal-Error)	;test the adjacent bit
	((IMOD-Low) DPB IMOD-Rotation-Count M-B A-Zero) 
	(Call If-Bit-Set M-C  Rotate-Right (Byte-Field 1. 0.) 
		Internal-Error)	;test the adjacent bit
;;; are we done with this test yet ?
	(Jump-Xct-Next If-Bit-Clear (Byte-Field 1. 31.) Q-R Q-Left-Loop)
       ((MD M-Garbage) SETCM Q-R Shift-Q-Left)   ;shift the bit over
;;;-----------------------------------------------------------------------------
	((MD M-C) DPB (Byte-Field 1. 31.) M-Ones A-Zero)
;;; At this point A-C and M-C contain #x+80000000
	((MD M-Hunoz) ADD M-C A-C Shift-ALU-Right)
	(Call If-Not-Equal M-C A-Hunoz Internal-Error)
;;; 
	(Call If-Greater-or-Equal M-C A-Zero Internal-Error)
	(Call If-Less-Than M-C A-Zero Return-Fixup)
	(Call Internal-Error)	;should never get here
	(Call If-Greater-or-Equal M-Zero A-Zero Return-Fixup)
	(Call Internal-Error)	;should never get here
	(Call If-Greater-or-Equal M-Zero A-Ones Return-Fixup)
	(Call Internal-Error)	;should never get here
	(Call If-Less-Than M-Zero A-Zero Internal-Error)
	(Call If-Less-Than M-Zero A-Ones Internal-Error)
	
;;;-----------------------------------------------------------------------------
;;; Simple test to see if LC will store individual bits.
;;; Test a few more jump conditions and use the ALU some
;;; This is another left shifting one test. Since LC is less than 32 bits
;;; wide it is tested separately. Also tests another jump condition.

;;;initialize the bit count register to zero
	((MD Q-R) ANDCM M-Ones A-Ones)
	(Call If-Not-Equal Q-R A-Zero Internal-Error)
	((MD Q-R) M+1 Q-R)		;set the LSB in Q-R
LC-Bit-Test
	((Location-Counter M-Garbage) SETZ Q-R 
		Output-Selector-R-Bus ALU-Carry-In-Zero)
	(Call If-Not-Equal Location-Counter A-Garbage Internal-Error)
	(Jump-Xct-Next If-Bit-Clear (Byte-Field 1. 25.) LC-Bit-Test)
       ((MD M-Garbage) SETCM Location-Counter Shift-Q-Left)
;;;-----------------------------------------------------------------------------
;;; Simple test to see if IBUF will store individual bits.
;;; M-A is used to perform a halfword swap
;;; Also checks the Micro-Stack-Pointer and PDL-Address-Counters
;;; Another shift bit left test. The pass/fail test is made by testing bits 
;;; because IBUF is 32 bits wide but is read 16 bits at a time. The halfword 
;;; selected is controlled by LC<00>. The Q-R is used to shift the bit which
;;; is then copied to IBUF (MIB). The bit position to be tested is calculated 
;;; and tested to see if it contains a one.

;;;set LC to odd value so low half of IBUF is selected
	((Location-Counter) IOR M-Ones A-Zero)
;;;initialize the bit count register
	(And-Skip If-Less-Or-Equal (MD Q-R) ORCA M-Zero A-Ones) 
	(Call If-Not-Equal Q-R A-Zero Internal-Error)
	((MD Q-R) M+1 Q-R)		;set the LSB in Q-R
IBUF-Bit-Test-1
	((MIB) Q-R)		;copy the bit to IBUF
	(Jump-Xct-Next If-Bit-Set (Byte-Field 1. 0.) Location-Counter Skip-Halfword-Swap)
       ((M-A) MIB)
;;; calculate the bit number to be tested
	((M-A) DPB (Byte-Field 16. 16.) MIB A-Zero)
	((M-A) LDB (Byte-Field 16. 16.) MIB A-A)
Skip-Halfword-Swap
	(Call If-Not-Equal A-A Q-R Internal-Error)
;;; see if all 32 bits of IBUF have been tested
	(Jump If-Bit-Set (Byte-Field 1. 31.) Q-R IBUF-Bit-Test-2)
;;; After 16 bits checked alter LC to pointer to other halfword
	(Jump-Xct-Next If-Bit-Clear (Byte-Field 1. 15.) Q-R IBUF-Bit-Test-1)
       ((MD) SETO Shift-Q-Left)	;shift the bit over
	(Jump-Xct-Next If-Bit-Set (Byte-Field 1. 0) Location-Counter
		IBUF-Bit-Test-1)
       ((Location-Counter) ORCM M-Ones A-Zero)

;;; Check the Arg-Offset-Field, the Branch-Offset-Field and the PDL address 
;;; counters with a shifting bit. The result is compared to the value in the
;;; Q-Register. The shifting bit is copied to a series of registers. This series
;;; of registers becomes smaller as the register widths are exceeded by the bit
;;; shift count.
IBUF-Bit-Test-2
	((MD Q-R) SETCA A-Ones)	;initialize the bit count register
	(Call If-Not-Equal Q-R A-Zero Internal-Error)
	(And-Skip If-Greater-Than (Location-Counter) SETO)	;set LC to odd 
	((MD Q-R) M+1 Q-R)		;set the LSB in Q-R
IBUF-Bit-Test-3
	((MIB M-A) Q-R)		;put in IBUF
	((PDL-Buffer-Pointer) MIB-Argument-Offset-Field)	;copy
	((PDL-Buffer-Index) PDL-Buffer-Pointer)		;copy the copy
	((Micro-Stack-Pointer) PDL-Buffer-Index)	;copy the copy of the copy
	(Call If-Not-Equal Micro-Stack-Pointer A-A Internal-Error)
	(Jump-Xct-Next If-Bit-Clear (Byte-Field 1. 5.) Q-R IBUF-Bit-Test-3)
       ((MD) ANDCB Shift-Q-Left M-Zero A-Zero)	;shift the bit over

IBUF-Bit-Test-4
	((MIB M-A) Q-R)		;put in IBUF
	((PDL-Buffer-Pointer) MIB-Branch-Offset-Field)	;copy
	((PDL-Buffer-Index) PDL-Buffer-Pointer)		;copy the copy
	(Call If-Not-Equal PDL-Buffer-Index A-A Internal-Error)
	(Jump-Xct-Next If-Bit-Clear (Byte-Field 1. 8.) Q-R IBUF-Bit-Test-4)
       ((MD) SETO Shift-Q-Left)	;shift the bit over

	((PDL-Buffer-Pointer) Q-R)	;put in pointer
	((PDL-Buffer-Index) PDL-Buffer-Pointer)	;copy
	((MD M-Garbage) Q-R)		;setup A-Garbage
	(Call If-Not-Equal PDL-Buffer-Index A-Garbage Internal-Error)
	(Call If-Equal Q-R A-Zero Internal-Error)

;;;-----------------------------------------------------------------------------
;;; At this point in time all of the internal registers not built out of RAM
;;; chips are checked out. Now off to test all of the internal RAMs.
;;;-----------------------------------------------------------------------------
;;; Test M-Memory
;;; M-Hunoz contains the address being tested.
;;; VMA will contain the ending address
;;; Q-R will contain the data pattern
;;; This code doesn't test the pass logic of M-Memory very well, only M-Hunoz
;;; and M-Garbage pass is tested.
;;; Trashes all but the first four locations of M-Memory, tests the
;;; Low part of A-Memory to see if shadow works.
;;; This tests performs a walking ones test on each location of M-Memory, 
;;; starting at the highest location in M-Memory and working down to address 4.

Test-M-Memory
;;; ending location = 4
	((VMA) DPB (Byte-Field 1. 2.) M-Ones A-Zero)
	((Q-R) SETZ)   
;;; Size of M memory + 1 = 64.
	((MD M-Hunoz) DPB (Byte-Field 1. 6. ) M-ONES A-Zero)
M-Memory-Loop1
	((MD M-Hunoz) ADD M-Hunoz A-Ones)		;decrement address
;;;set the msb of the Q register
	((MD) SETO Shift-Q-Right)
	(Call If-Bit-Clear (Byte-Field 1. 31.) Q-R Internal-Error)
M-Bit-Test
	((IMOD-Low) DPB IMOD-M-Dest M-Hunoz A-Zero)
	((MD M-Garbage) Q-R)			;write data to memory
	((IMOD-High) DPB IMOD-M-Src M-Hunoz A-Zero)
	((MD) M-Garbage)			;read data from memory
	(Call If-Not-Equal Q-R A-Garbage Internal-Error)	;test the data
;;; See if the A-Memory shadowed the M-Memory
	((IMOD-High) DPB IMOD-A-Src M-Hunoz A-Zero)
	(Call If-Not-Equal Q-R A-Garbage Internal-Error)	;test the data
	(Jump-Xct-Next If-Bit-Clear (Byte-Field 1. 0.) Q-R M-Bit-Test)
       ((MD)  SETZ Shift-Q-Right)	;shift the bit over
;
	((IMOD-Low) DPB IMOD-M-Dest M-Hunoz A-Zero)
	((MD M-Garbage) M-Hunoz)	;write address to memory on way out
	(Jump If-Not-Equal VMA A-Hunoz M-Memory-Loop1)	   ;stop 
;
	((MD M-Hunoz) DPB (Byte-Field 1. 6.) M-Ones A-Zero)
M-Memory-Loop2
	((MD M-Hunoz) ADD M-Hunoz A-Ones)
	((IMOD-High) DPB IMOD-M-Src M-Hunoz A-Zero)
	(Call If-Not-Equal M-Garbage Internal-Error A-Hunoz)	;test the data
	((IMOD-High) DPB IMOD-A-Src A-Zero M-Hunoz)
	(Call If-Not-Equal M-Hunoz A-Garbage Internal-Error)	;test the data
	(Jump If-Not-Equal VMA A-Hunoz M-Memory-Loop2)
;;;-----------------------------------------------------------------------------
;;; Test A-Memory and PDL memory
;;; M-Hunoz contains the address being tested.
;;; VMA will contain the ending address
;;; Q-R will contain the data pattern
;;; This code doesn't test the pass logic of A-Memory very well, only 
;;; A-Garbage pass is tested.
;;; Tests all but the first four locations of A-Memory, also tests the
;;; PDL memory using both the index and the pointer as address sources.

Test-A-Memory
;;; ending location = 4 was setup in last test

;;; size of A memory and PDL memory + 1 = 1024.
	((PDL-Buffer-Pointer M-Hunoz) DPB (Byte-Field 1. 10. ) M-Ones A-Zero) 
A-Memory-Loop1
	((PDL-Buffer-Pointer M-Hunoz) ADD M-Hunoz A-Ones)		;decrement address
	((Q-R) M+M M-Ones)	;walk a zero
	(And-Skip If-Not-Equal (M-Garbage) M+1 Q-R A-Zero)	;
A-Bit-Test
	((IMOD-Low) DPB IMOD-A-Dest M-Hunoz A-Zero)
	((A-Garbage) Q-R)			;write data to memory
	((IMOD-High) DPB IMOD-A-Src M-Hunoz A-Zero)
	(Call If-Not-Equal A-Garbage Q-R Internal-Error)	;test the Data
;;; set index to address 512 locations away from pointer
	((MD M-Garbage) DPB (Byte-Field 1. 9.) M-Ones A-Zero)
	((PDL-Buffer-Index)  XOR M-Hunoz A-Garbage)
	((C-PDL-Buffer-Pointer) Q-R)	;write the data
	((C-PDL-Buffer-Index M-Garbage) Q-R)	;write the data
	(Call If-Not-Equal C-PDL-Buffer-Pointer A-Garbage Internal-Error)
;
	((MD M-Garbage) Q-R)	;setup A-Garbage
	(Call If-Not-Equal C-PDL-Buffer-Index A-Garbage Internal-Error)
	(Jump-Xct-Next If-Bit-Set (Byte-Field 1. 31.) Q-R A-Bit-Test)
       ((MD) SETZ Shift-Q-Left)	;shift the bit over
;;; write the address to memory on the way out.
	((IMOD-Low) DPB IMOD-A-Dest M-Hunoz A-Zero)
	((A-Garbage) M-Hunoz)
	((C-PDL-Buffer-Pointer) PDL-Buffer-Pointer)
	(Jump-Xct-Next If-Not-Equal VMA A-Hunoz A-Memory-Loop1)	   ;stop at end
       ((C-PDL-Buffer-Index) PDL-Buffer-Index)
;
;;; Check addresses
	((PDL-Buffer-Pointer M-Hunoz) DPB (Byte-Field 1. 10.) M-Ones A-Zero)
A-Memory-Loop2
	((PDL-Buffer-Pointer M-Hunoz) ADD M-Hunoz A-Ones)
	((IMOD-High) DPB IMOD-A-Src M-Hunoz A-Zero)
	(Call If-Not-Equal M-Hunoz A-Garbage Internal-Error)	;test the data
	(Call If-Not-Equal C-PDL-Buffer-Pointer A-Hunoz Internal-Error)
	((MD M-Garbage) DPB (Byte-Field 1. 9.) M-Ones A-Zero)
	((PDL-Buffer-Index M-Garbage)  XOR M-Hunoz A-Garbage)
	(Call If-Not-Equal C-PDL-Buffer-Index A-Garbage Internal-Error)
	(Jump If-Not-Equal VMA A-Hunoz A-Memory-Loop2)
;;;-----------------------------------------------------------------------------
;;; Test Micro-Stack-Memory and Dispatch Memory and Level 1 Memory
;;; M-A contains a flag to indicate when to stop testing D-Mem
;;; M-B contains a copy of Q-R
;;; M-C is used to save the stripped D-Mem read data
;;; M-D contains a flag to indicate when to stop testing LVL1 map
;;; Once again the sliding ones test. Since D-Mem is only 17. bits wide and
;;; the UPCS is 20. bits wide a flag is used to keep from testing D-Mem once
;;; the sliding one has been shifted out of Q<16>. Since the dispatch memory
;;; is 4096. locations deep and the UPCS is but 64. locations deep, the UPCS
;;; memory gets tested 64 times.

	((A-20000) DPB (Byte-Field 1. 13.) M-Ones A-Zero)
	((C-PDL-Buffer-Pointer M-A) SETZ)	;prepare death trap and flag
	((MD M-D) SETZ)
;;; Size of Dispatch Memory +1 = 4096.
	((MD M-Hunoz) DPB (Byte-Field 1. 12.) M-Ones A-Zero)
UPCS-Memory-Loop-1
	((Micro-Stack-Pointer M-Hunoz) ADD M-Hunoz A-Ones)	;decrement add
	((MD Q-R) SETZ)	;initialize 
	(And-Call-Illop If-Q0 (MD Q-R) M+1 Q-R)	;set the LSB in Q-R
	(And-Call-Trap If-Not-Q0)
UPCS-Bit-Test
	((Micro-Stack-Data M-B) Q-R)		;write data to memory
;;; read data from memory, testing the pass logic and then re-read

	(And-Call-Bus-Error If-Tag-Not-Equal (M-Garbage)
		 SETM Micro-Stack-Data A-B)

;;; The following is to get aroung the lack of a AND-CALL-<unused> symbol
;;; in the microassembler. The use of this will produce a warning about using
;;; the LISP environment for the value of this symbol. To date this has been
;;; perfectly acceptable.

	((Field ABJ-Byte-or-ALU %A-Jump-Field-Unused) If-Tag-Not-Equal
		 (M-Garbage) SETM Micro-Stack-Data A-B)
	(Call If-Not-Equal Q-R A-Garbage Internal-Error)

;;; prepare to test LVL1-Mem, first check to see if bit to be tested is > 11.
	(Jump If-Bit-Set (Byte-Field 1 0) M-D Skip-LVL1-Mem)
	((MD) Add MD A-20000)
	((VMA-Write-Map-Level-1) Q-R)
	((M-D) LDB (Byte-Field 1. 11.) Q-R A-Zero)	;if bit 11. then set the flag
	((M-E) DPB (Byte-Field 12. 0.) Memory-Map-Level-1 A-Zero)
	(Call If-Not-Equal M-E A-B Internal-Error)

Skip-LVL1-Mem
;;; prepare to test D-Mem but first check to see if bit to be tested is > 16.
	(Jump If-Bit-Set (Byte-Field 1 0) M-A Skip-D-Mem)
;;; first test the I-Arg-Field
	((IMOD-High) DPB IMOD-A-Src M-Hunoz A-Zero)
	(Dispatch Write-Dispatch-RAM A-Garbage)
	((M-Temp-1) DPB (Byte-Field 10. 0.) M-Hunoz A-Zero)
	(Call Internal-Error If-Not-Equal A-Temp-1 I-Arg)
;;; now test the dispatch RAM
	((IMOD-Low) DPB (Byte-Field 12. 20.) M-Hunoz A-Zero)
	(Write-Dispatch-RAM A-B)
	((M-A) LDB (Byte-Field 1. 16.) Q-R A-Zero)	;set jump around flag.
	((IMOD-Low) DPB (Byte-Field 12. 20.) M-Hunoz A-Zero)
		; Mask off bits from Dispatch Memory
	(Read-Dispatch-RAM)
	((M-C) LDB (Byte-Field 17. 0.) Q-R A-Zero)
	((Q-R) M-B)	;restore Q-R
	(Call If-Not-Equal A-C Q-R Internal-Error)
Skip-D-Mem
;;; now write the address into the memory
	((IMOD-Low) DPB (Byte-Field 12. 20.) M-Hunoz A-Zero)
	(Write-Dispatch-Ram A-Hunoz)
	((Micro-Stack-Data) M-Hunoz)
	((M-E) MD)
	((MD) DPB (Byte-Field 12. 13.) M-Hunoz A-Zero)
	((VMA-Write-Map-Level-1) M-Hunoz)
	((MD) M-E)
;;;
	(Jump-Xct-Next If-Bit-Clear (Byte-Field 1. 19.) Q-R UPCS-Bit-Test)
       (And-Call-Bus-Error If-Not-Equal (M-Garbage) EQV Shift-Q-Left M-Ones A-Ones)
;
	(Jump If-Not-Equal M-Hunoz A-Zero UPCS-Memory-Loop-1)
;;; now check the rams to see if they contain their addresses
	((M-Hunoz) DPB (Byte-Field 1. 10.) M-Ones A-Zero)
D-Mem-Address-Check-Loop
	((M-Hunoz) ADD M-Hunoz A-Ones)
	((IMOD-Low) DPB (Byte-Field 12. 20.) M-Hunoz A-Zero)
	(Read-Dispatch-Ram)
	((MD) DPB (Byte-Field 17. 0) Q-R A-Zero)
	(Call If-Not-Equal MD A-Hunoz Internal-Error)
	((MD) DPB (Byte-Field 12. 13.) M-Hunoz A-Zero)
	((VMA) LDB (Byte-Field 12. 0.) Memory-Map-Level-1 A-Zero)
	(Call If-Not-Equal VMA A-Hunoz Internal-Error)
	(Jump If-Not-Equal M-Hunoz A-Zero D-Mem-Address-Check-Loop)
;;;
	((Micro-Stack-Pointer M-Hunoz) DPB (Byte-Field 6. 0.) M-Ones A-Zero)
UPCS-Address-Check-Loop
	(Call If-Not-Equal Micro-Stack-Data A-Hunoz Internal-Error)
	(Jump-Xct-Next If-Not-Equal M-Hunoz A-Zero UPCS-Address-Check-Loop)
       ((Micro-Stack-Pointer M-Hunoz) ADD M-Hunoz A-Ones)
;;;-----------------------------------------------------------------------------
;;; The following call wires the level 1 map to the level 2 map. This is done in
;;; preparation for testing the level two map along with testing the control 
;;; store. Only the first 128 entries of the level one map are written.
	(Call Wire-Level1-Map)
;;;
;;;-----------------------------------------------------------------------------
;;; Control-Store-Memory-Test
;;; LC contains the ending address
;;; M-Hunoz contains the Address
;;; M-Temp-1 contains the low 32 bits of data to be written
;;; A-Temp-2 contains the high 24 bits of data to be written
;;; M-A contains a flag indicating that all 22. bits of the level 2
;;;     address portion of the map RAM have been tested.
;;; M-B contains a flag indicating that the 8 MSBs are being tested and
;;;     the value read for these bit positions on the A-side of control
;;;     store are of indeterminant value.
;;; M-C contains the low 32 bits read
;;; A-D contains the high 24 bits read
;;; M-E contains a flag indicating that all 13. bits of the level 2
;;;     control portion of the map RAM have been tested.
;;; M-F and M-G are used to read the addresses stored in I-Mem.
;;; A-400 is the constant added to MD to access the next level 2 location
 
Test-I-Memory
;;; first shut off control store parity error traps.
	((M-A) MCR)
	((MCR) DPB (Byte-Field 1. 12.) M-Zero A-A)
	((C-PDL-Buffer-Pointer M-A) SETZ)	;prepare death trap, set flag
	((MD M-E) SETZ)	;Set beginning level 2 address and flag.
	((A-400) DPB (Byte-Field 1. 8.) M-Ones A-Zero)	;set constant

;;;Ending location
	((Location-Counter M-B) DPB (Byte-Field 1. 11.) M-Ones A-Zero)
;;;size of I memory
	((M-Hunoz) DPB (Byte-Field 1. 14. ) M-Ones A-Zero)
I-Memory-Loop1
	((M-Hunoz) ADD M-Hunoz A-Ones)	;decrement address
	((Q-R) M+1 M-Zero)		;set the LSB in Q-R
I-Bit-Test	;;;initialize data to be written
	((VMA-Write-Map-Level-2-Control M-TEMP-2) Q-R)
	((VMA-Write-Map-Level-2-Address M-TEMP-1) Q-R)
	((IMOD-Low) DPB IMOD-LOW-JUMP A-Zero M-Hunoz)
	(Call-Xct-Next 0)
	(Write-I-Mem A-TEMP-2 M-TEMP-1)
;;;
	(Jump If-Bit-Set (Byte-Field 1 0) M-A Test-Low-32)
	((M-A) LDB (Byte-Field 1. 21.) Q-R A-Zero)
	((M-Garbage) DPB (Byte-Field 22. 0) Memory-Map-Level-2-Address)
	(Call If-Not-Equal Q-R A-Garbage Internal-Error)
;
	(Jump If-Bit-Set (Byte-Field 1 0) M-E Test-Low-32)
	((M-E) LDB (Byte-Field 1. 12.) Q-R A-Zero)
	((M-Garbage) DPB (Byte-Field 13. 0) Memory-Map-Level-2-Control)
	(Call If-Not-Equal Q-R A-Garbage Internal-Error)
;
Test-Low-32
	((IMOD-Low) DPB IMOD-LOW-JUMP M-Hunoz A-Zero)
	(Call-Xct-Next 0)
	((M-C) Read-I-Mem)
	((M-C) M-C)
;
	(Call If-Not-Equal Q-R A-C Internal-Error)
	((M-C) Selective-Deposit (Byte-Field 5. 25.) M-C A-Zero)
	(And-Call-Bus-Error If-Tag-Not-Equal (M-C) SETM Q-R A-C)
;
	(Jump2  If-Bit-Set (Byte-Field 1. 0.) M-B Test-Next-Bit)
	((M-B) LDB (Byte-Field 1. 23.) Q-R)	;set the flag
	((IMOD-Low) DPB M-Hunoz IMOD-LOW-JUMP A-Zero)
	(Call-Xct-Next 0)
	((A-D) Read-I-Mem)
	((M-D) DPB (Byte-Field 8. 24.) M-Zero A-D)
	(Call If-Not-Equal Q-R A-D Internal-Error)
;;; write address to memory on the way out
Test-Next-Bit
	((IMOD-Low) DPB IMOD-Low-Jump M-Hunoz A-Zero)
	(Call-Xct-Next 0)
	(Write-I-Mem M-Hunoz A-Hunoz)
	((VMA-Write-Map-Level-2-Address) LDB (Byte-Field 12. 8.) MD A-Zero)
	((VMA-Write-Map-Level-2-Control) LDB (Byte-Field 12. 8.) MD A-Zero)
;;;
	(Jump2-Xct-Next If-Bit-Clear (Byte-Field 1. 31.) Q-R I-Bit-Test)
       ((M-Garbage) SETO Shift-Q-Left)	;shift the bit over
	(Jump-Xct-Next If-Not-Equal Location-Counter A-Hunoz I-Memory-Loop1)
       ((MD) ADD MD A-400)
;;;
	((M-Hunoz) DPB (Byte-Field 1. 14.) M-Ones A-Zero)
	((MD) SETZ)
I-Mem-Address-Loop
	((M-Hunoz) ADD M-Hunoz A-Ones)
	((IMOD-Low) DPB IMOD-Low-Jump M-Hunoz A-Zero)
	(Call-Xct-Next 0)
	((M-F) Read-I-Mem)
	(Call If-Not-Equal M-F A-Hunoz Internal-Error)
	((IMOD-Low) DPB IMOD-Low-Jump M-Hunoz A-Zero)
	(Call-Xct-Next 0)
	((A-G) Read-I-Mem)
	((M-G) DPB (Byte-Field 8. 24.) M-Zero A-G)
	(Call If-Not-Equal M-G A-Hunoz Internal-Error)
	((M-Garbage) DPB (Byte-Field 22. 8.) Memory-Map-Level-2-Address A-Zero)
	(Call If-Not-Equal MD A-Garbage Internal-Error)
	((M-Garbage) DPB (Byte-Field 13. 8.) Memory-Map-Level-2-Control A-Zero)
	(Call If-Not-Equal MD A-Garbage Internal-Error)
	((MD) ADD MD A-400)
	(Jump-Xct-Next If-Not-Equal Location-Counter A-Hunoz I-Mem-Address-Loop)
       ((MD) LDB (Byte-Field 20. 0.) MD A-Zero)
;;; turn on control store parity error traps.
	((M-A) MCR)
	((MCR) DPB (Byte-Field 1. 12.) M-Ones A-A)
;;;------------------------------------------------------------------------------
;;; Test the M-Tag-Classifier RAM.
;;; M-D contains the class number that will contain the sliding bit.

	((MD M-D) DPB (Byte-Field 4. 0.) M-Ones A-Zero)	;number of classes
;;; M-E contains the element number within a class that will contain the
;;; sliding bit.
M-Tag-Loop1
	((MD M-E) DPB (Byte-Field 5. 0.) M-Ones A-Zero)	;number of elements
;;; M-K contains a loop count for writing all classes whenever a bit is
;;; written to memory.
M-Tag-Loop2
	((MD M-K) DPB (Byte-Field 4. 0.) M-Ones A-Zero)	;loop count

M-Tag-Loop3
	((M-G) SETZ)					;initialize the element vector
	(Jump If-Not-Equal M-K A-D Leap-Around)	;only set the bit in one class
	((IMOD-LOW) M-E)				;set the bit
	((MD M-G) DPB (Byte-Field 1. 0.) M-Ones A-Zero)
Leap-Around
	((C-PDL-Buffer-Pointer-Push) M-G)		;push the element vector on PDL
	(Call-Xct-Next Write-Tag-Ram)
	((C-PDL-Buffer-Pointer-Push) M-K)		;push the class number on PDL
;;;do until all classes written
	(Jump-Xct-Next If-Not-Equal M-K A-Zero M-Tag-Loop3)
       ((MD M-K) ADD M-K A-Ones)			;decrement loop count

	(Call Search-Tag-Memory)			;search for first bit found

	(Jump-Xct-Next If-Not-Equal M-E A-Zero M-Tag-Loop2) ;test the next element in class
       ((M-E) ADD M-E A-Ones)

	(Jump-Xct-Next If-Not-Equal M-D A-Zero M-Tag-Loop1) ;test the next class.
       ((M-D) ADD M-D A-Ones)
;;;-----------------------------------------------------------------------------
;;; Now all of the internal registers and memories are tested. Some transfer of 
;;; control stuff gets tested here along with PDL control and some ALU stuff.
;;;-----------------------------------------------------------------------------
;;; Test PDL-Memory Control Logic
;;; This Test check the various pass cases involved and is not a memory test.

PDL-Control-Part-1
	((C-PDL-Buffer-Pointer-Push) M-Hunoz)
	((C-PDL-Buffer-Pointer-Push) SETCM M-Hunoz)
;;;test the pass logic
	(Call If-Equal C-PDL-Buffer-Pointer A-Hunoz Internal-Error)
	(Call If-Equal C-PDL-Buffer-Pointer-Pop A-Hunoz Internal-Error)
	(Call If-Not-Equal C-PDL-Buffer-Pointer-Pop A-Hunoz Internal-Error)

	((C-PDL-Buffer-Index-Increment) M-Hunoz)	;put address into memory
	((C-PDL-Buffer-Index-Increment) SETCM M-Hunoz)	;put address into memory
;;;test the pass logic
	(Call If-Equal C-PDL-Buffer-Index A-Hunoz Internal-Error)
	(Call If-Equal C-PDL-Buffer-Index-Decrement A-Hunoz Internal-Error)
	(Call If-Not-Equal C-PDL-Buffer-Index-Decrement A-Hunoz Internal-Error)

;;; The following test is to insure that the pipeline works properly
PDL-Control-Part-2
	((C-PDL-Buffer-Pointer) M-Hunoz)	;alter data value
	((PDL-Buffer-Pointer) M+1 PDL-Buffer-Pointer)	;alter the address to test pipe
	((PDL-Buffer-Pointer) ADD PDL-Buffer-Pointer A-Ones)	;restore the address
	(Call If-Not-Equal C-PDL-Buffer-Pointer A-Hunoz Internal-Error)
	((C-PDL-Buffer-Index) M-Hunoz)	;alter data value
	((PDL-Buffer-Index) M+1 PDL-Buffer-Index)	;alter the address to test pipe
	((PDL-Buffer-Index) ADD PDL-Buffer-Index A-Ones)	;restore the address
	(Call If-Not-Equal C-PDL-Buffer-Index A-Hunoz Internal-Error)
PDL-Control-Part-3
	((C-PDL-Buffer-Pointer-Push) SETZ)
	((C-PDL-Buffer-Pointer-Push) SETO)
	(Call If-Not-Equal C-PDL-Buffer-Pointer-Pop A-Ones Internal-Error)
	(Call If-Not-Equal C-PDL-Buffer-Pointer A-Zero Internal-Error)
PDL-Control-Part-4
	((C-PDL-Buffer-Index-Increment) SETZ)
	((C-PDL-Buffer-Index-Increment) SETO)
	(Call If-Not-Equal C-PDL-Buffer-Index-Decrement A-Ones Internal-Error)
	(Call If-Not-Equal C-PDL-Buffer-Index A-Zero Internal-Error)
;;;-----------------------------------------------------------------------------
;;; This verifies that -1 + -1 is -2 and also tests the byte hardware a little
ADD-Test
	((Q-R) ADD M-Ones A-Ones)
	((MD) LDB (Byte-Field 31. 1) Q-R A-Ones)
	(Call If-Not-Equal MD A-Ones Internal-Error)
;;;-----------------------------------------------------------------------------
;;; Multiply Step if Q<00>=1 then ADD, else if Q<00>=0 then SETM, ALU-Shift-Right 
;;; Divide-Step   if Q<00>=1 then SUB, else if Q<00>=0 then ADD, ALU-Shift-Left
;;; Divide-First-Step   SUB, ALU-Shift-Left
;;; Divide-Remainder-Correction If Q<00>=1 then SETM else ADD
MPY-Divide-Tests
	((Q-R) SETO)
	((MD M-B) M+1 M-Zero)
	((MD) Multiply-Step M-Zero A-Ones)	;should get all ones
	((MD) Divide-Step MD A-Ones)		;should get a 1
	((MD) Divide-Remainder-Correction-Step MD A-Ones)	;should get a 1
	(Call If-Bit-Clear (Byte-Field 1. 0.) MD Internal-Error)
	((Q-R) SETZ)
	((MD) Multiply-Step MD A-Ones)	;should get all zeros
	((MD) Divide-Step MD A-Ones)	; all ones
	((MD) Divide-Remainder-Correction-Step MD A-B)	;all zeros
	((MD) Divide-First-Step MD A-Ones)	;should get a 2
	(Call If-Bit-Clear (Byte-Field 1. 1.) MD Internal-Error )
;;;-----------------------------------------------------------------------------
	((MD) DPB (Byte-Field 1. 24.) M-Ones A-Zero)
	(And-Call-Illop If-Positive (MD)ADD MD A-Zero)
;;; set the death trap to let 'em live
Illop-Test
	((C-PDL-Buffer-Pointer-Push) M-A-1 M-Ones A-Ones) 
	(And-Call-Illop If-Negative (MD) ADD MD A-Zero)
	(Call Internal-Error)	;should never get here 
Trap-Test
	((C-PDL-Buffer-Pointer-Push) M+A+1 M-Ones A-Ones) 
	(And-Call-Trap (MD) MD)		;try to call Trap
	(Call Internal-Error)	;should never get here
Bus-Error-Test
	((C-PDL-Buffer-Pointer-Push) M-A-1 M-Ones A-Ones) 
	(And-Call-Bus-Error)	;try to call Bus-error
	(Call Internal-Error)	;should never get here
Call-Unused-Test
	((Field ABJ-Byte-or-ALU %A-Jump-Field-Unused))	;call-unused
	(Call Internal-Error)	;should never get here
;;; set the death trap to kill'em
	((C-PDL-Buffer-Pointer-Push) SETZ)
	((M-Hunoz) DPB (Byte-Field 1. 23.) M-Ones A-Zero)
	(And-Call-Illop If-Not-Fixnum-Overflow (MD) ADD M-Hunoz A-Hunoz)
	(And-Call-Illop If-Not-Fixnum-Overflow (MD M-Hunoz) SUB MD A-Hunoz)
Transfer-Control-Test
	(Call Test-Routine)
	(Call Internal-Error If-Equal C-PDL-Buffer-Pointer A-Ones)
	(Call-Xct-Next Test-Routine-2)
       ((C-PDL-Buffer-Pointer-Push) SETZ)
	((C-PDL-Buffer-Pointer) A-A M-Ones SETM Typed-Alu-Op)
	(Call If-Not-Equal A-Ones C-PDL-Buffer-Pointer Internal-Error)
	(Jump Around-Subroutines)
	(Call Internal-Error)	;should never get here
;;;------------------------------------------------------------------------------
Test-Routine
	(And-Popj (C-PDL-Buffer-Pointer-Push) Setz)
	(Call Internal-Error)	;should never get here
;
Test-Routine-2
	(And-Popj-Xct-Next (C-PDL-Buffer-Pointer-Push) 
		DPB (Byte-Field 1. 24.) M-Ones A-Zero)
       ((M-A C-PDL-Buffer-Pointer) Output-Selector-Sign-Extend 
		C-PDL-Buffer-Pointer)
	(Call Internal-Error)

;;;------------------------------------------------------------------------------
Search-Tag-Memory
;;; Searches tag memory for the first occurance of a one starting with class F
;;; and element 1F and working down by element and then class. 
;;;
	((MD M-H) DPB (Byte-Field 4. 0.) M-Ones A-Zero) ; number of classes
M-Tag-Loop4
	((MD M-J) DPB (Byte-Field 5. 0.) M-Ones A-Zero) ; number of elements 
M-Tag-Loop5
	((MD M-F) DPB (Byte-Field 5. 25.) M-J A-Zero)  ; move it over
	((IMOD-LOW) DPB (Byte-Field 4. 10. ) A-Zero M-H)
	(Jump If-In-Class T-Class-0 Search-Done M-F)
	(Jump-Xct-Next If-Not-Equal M-J A-Zero M-Tag-Loop5)
       ((MD M-J) ADD M-J A-Ones)
;;;;
	(Jump-Xct-Next If-Not-Equal M-H A-Zero M-Tag-Loop4)
       ((MD M-H) ADD M-H A-Ones)
	(Call Internal-Error)	;should never get here

Search-Done
	((IMOD-LOW) DPB (Byte-Field 4. 10. ) A-Zero M-H)
	(Call If-Not-In-Class M-F T-Class-0 Internal-Error )
;;; correct element ?
	(Call If-Not-Equal M-J A-E Internal-Error)	
;;; correct class ?
	(Call If-Not-Equal M-H A-D Internal-Error)	
	(Popj)
Write-Tag-Ram
;;;------------------------------------------------------------------------------
;;; The M-Tag-Classifier-Ram is written to by placing the data to be written for
;;; the element of a class in M<30> and the element number in M<29:25>. The ALU
;;; instruction that writes the data must have the class number in IR<13:10>. 
;;; The abbreviated jump field of the ALU instruction must be NIL. 
;;;
;;; M-A will be the M memory word that resides on M bus during tag classifier 
;;; writes Load C-PDL-Pointer with the data to be written to the ram. Bit 0
;;; corresponds to element zero of a class (value of the type field = 0), bit 31
;;; to the 31st element of a class (value of type field = 1F/27, choose your base).
;;; Then load C-PDL-Buffer-Pointer with the class number (0..F)/(0..17)
;;;
;;; Clobbers M-A, M-Temp-1, M-Temp-2, M-Garbage
;;; Pops PDL twice
;;;------------------------------------------------------------------------------
;;;
	((M-Temp-2) C-PDL-Buffer-Pointer-Pop)	;get the class number
	((M-Temp-1) DPB (Byte-Field 1. 5.) M-Ones A-Zero) ; elements in class +1
Load-Tag-RAM
	((IMOD-Low M-Temp-1) ADD M-Temp-1 A-Ones)	;modify for element  to be written
	((M-Garbage) LDB Rotate-Right (Byte-Field 1. 0.) C-PDL-Buffer-Pointer
		A-Zero)
	((M-A) DPB (Byte-Field 1. 30.) A-Zero M-Garbage)	;move it over
	((M-A) DPB (Byte-Field 5. 25.) M-Temp-1 A-A)	;insert element no.
	((IMOD-LOW) DPB (Byte-Field 4. 10.) M-Temp-2 A-Zero)	;insert class no.
	(Write-M-Tag-Classifier M-A T-Class-0)		;do it
	(Jump If-Not-Equal M-Temp-1 A-Zero Load-Tag-RAM)
        (And-POPJ (M-Garbage) C-PDL-Buffer-Pointer-Pop)
;;;-----------------------------------------------------------------------------
;;; The following code wires the level 1 map to the level 2 map. This is done in
;;; preparation for testing the level two map along with testing the control 
;;; store. Only the first 128 entries of the level one map are written.
Wire-Level1-Map
	((MD) SETZ)	;initialize the address
;;; set to one minus the valid bit so first add produces valid-lvl1-entry
	((VMA) DPB (Byte-Field 10. 0.) M-Ones A-Zero)
;;; increment by region size 
	((M-Hunoz) DPB (Byte-Field 1. 13.) M-Ones A-Zero)
Wire-Level1-Map-Loop
	((VMA-Write-Map-Level-1) M+1 VMA)	;Wire level-1 map
	((MD) ADD MD A-Hunoz)		;increment the address
	(Jump If-Bit-Clear (Byte-Field 1 20.) MD Wire-Level1-Map-Loop)
	(POPJ)
;;;------------------------------------------------------------------------------
Around-Subroutines
	
;;;-----------------------------------------------------------------------------
;;; Here we attempt an unmapped memory cycle to clear the page fault status 
;;; latch. With MCR<08> clear, memory cycles are disabled. PF will get cleared
;;; on unmapped attempts. Sequence break is tested.
;;; M-A contains an image of MCR
;;; M-B contains the constant 4
;;; M-C contains FsC00000 
;;; M-D contains FsD00000
;;; M-E contains FsE00000
;;; M-F contains FsFFFFA0	;an address within the config prom
;;; M-G contains the two's complement of 4
;;; M-H contains the interrupt (event) level being tested
;;; M-J contains a microstack pointer value to test micro-stack push/pop
;;; operations
;;; A-2 contains the constant 2 *** changed to a-constant-2 by JLarson
;;; A-100000 contains the constant used for building NuBus Addresses
;;;
;;; The configuration prom is at FsFFFFFF and is 256 locations deep.
;;;				 FsFFFC00
;;; The event logic starts at    FsE00000 and is  16 locations deep.
;;; The configuration reg is at  FsD00000 and is   1 location deep.
;;; The flag register is at      FsC00000 and is   1 location deep.
;;;
;;; Going to set address to the flag register because that will remain constant.
;;; The value in the flag register should be 00000007. The subsystem fail indicator
;;; MCR<07> will be set which should alter this value to 00000003. Note that the
;;; contents of MD after the read may be FsC000vv where s is the slot ID and v is the
;;; contents of the flag register. This is because the NuBus tends to retain the address
;;; on the bus during the data transfer for those byte positions not used. Since 
;;; this is a side affect it will not be used as part of the test.
;;;

;;;	((A-2) DPB (Byte-Field 1. 1.) M-Ones A-Zero)	;build a 2
	((A-constant-2) DPB (Byte-Field 1. 1.) M-Ones A-Zero)	;build a 2
	((A-100000) DPB (Byte-Field 1. 20.) M-Ones A-Zero)	;build a big const
;;; build NuBus addresses
	((MD M-C) LDB (Byte-Field 4. 28.) MCR A-Ones)	;get own slot ID
	((MD M-C) SETCM M-C)				;was in complement form
	((MD M-C) DPB (Byte-Field 4. 24.) M-C A-Zero)	;put it in right place
	((MD M-C) DPB (Byte-Field 4. 28.) M-Ones A-C)	;build leading F, Fs
	((MD M-C) DPB (Byte-Field 2. 22.) M-Ones A-C)	;FsC00000
	((MD M-D) ADD M-C A-100000)			;FsD00000
	((MD M-E) ADD M-D A-100000)			;FsE00000
;;;	((MD M-F) ADD M-E A-100000)			;FsF00000
;;;	((MD M-F) DPB (Byte-Field 13. 7.) M-Ones A-F)	;FsFFFF80
;;;	((MD M-F) DPB (Byte-Field 1. 5.) M-Ones A-F)	;FsFFFFA0

;;; setup level 1 map to valid
	((VMA) DPB (Byte-Field 1. 11.) M-Ones A-Zero)
	((MD-Write-Map-Level-1) M-C)
	((VMA) LDB (Byte-Field 22. 10.) M-C A-Zero)	;
	((MD-Write-Map-Level-2-Address) LDB (Byte-Field 30. 2.) A-Zero M-C)
	((VMA) SETZ)
	((MD-Write-Map-Level-2-Control) LDB (Byte-Field 30. 2.) A-Zero M-C)
	((M-B) DPB (Byte-Field 1. 2.) M-Ones A-Zero)	;build a four

;;; not supposed to do a memory cycle because MCR<08> is not set. 
	((MD-Start-Read) LDB (Byte-Field 30. 2.) A-Zero  M-C)
	(Call If-Not-Page-Fault Internal-Error)
	((MD-Start-Write) LDB (Byte-Field 30. 2.) A-Zero  M-C)
	(Call If-Not-Page-Fault Internal-Error)
	((VMA) DPB (Byte-Field 1. 9.) M-Ones A-Zero)	;set to read only
	((MD-Write-Map-Level-2-Control) LDB (Byte-Field 30. 2.) A-Zero  M-C)
	((M-G) SETCM M-B)
	((VMA-Start-Read) LDB (Byte-Field 30. 2.) A-Zero  M-C)
	(Call If-Page-Fault Internal-Error)
	((MD-Start-Write) LDB (Byte-Field 30. 2.) A-Zero  M-C)
	(Call If-Not-Page-Fault Internal-Error)
	((VMA) DPB (Byte-Field 2. 8.) M-Ones A-Zero)	;set to r/w status
;;; now write the data
	((MD-Write-Map-Level-2-Control) LDB (Byte-Field 30. 2.) A-Zero  M-C)
	((M-G) M+1 M-G)				;build the twos complement of four
	((VMA-Start-Write) LDB (Byte-Field 30. 2.) A-Zero  M-C)
	(Call If-Page-Fault Internal-Error)
;;; not supposed to do a memory cycle because MCR<08> is not set.
	((C-PDL-Buffer-Pointer) SETZ)	;set death trap
	((VMA-Start-Unmapped-Read) LDB (Byte-Field 30. 2.) A-Zero  M-C)
	(And-Call-Illop If-Memory-Busy (M-J) Micro-Stack-Pointer)
	(And-Call-Trap If-Page-Fault (Micro-Stack-Data-Push) SETZ)
	(And-Call-Trap If-Page-Fault-or-Interrupt-Pending
		(Micro-Stack-Data-Push) SETO)
	(And-Call-Trap If-Page-Fault-or-Interrupt-Pending-or-Sequence-Break
		(M-Hunoz) MCR)
;;; set the sequence break signal in MCR, does this get reset anywhere ???
	(And-Call-Trap If-Interrupt-Pending (MCR)
		 DPB (Byte-Field 1. 14.) M-Ones A-Hunoz)
	(And-Call-Trap If-Not-Page-Fault-or-Interrupt-Pending-or-Sequence-Break)
	((M-K) LDB (Byte-Field 20. 0.) Micro-Stack-Data-Pop A-Ones)
	(Call Internal-Error If-Not-Equal M-K A-Ones)
	(Call Internal-Error If-Not-Equal Micro-Stack-Data-Pop A-Zero)
	(Call Internal-Error If-Not-Equal Micro-Stack-Pointer A-J)
;;;---------------------------------------------------------------------------
;;; enable memory cycles and read the flag register
;;;---------------------------------------------------------------------------
	((M-A) MCR)
	((MCR M-A) DPB (Byte-Field 1. 8.) M-Ones A-A)
;;; build expected data
	((M-A) DPB (Byte-Field 3. 0.) M-Ones A-Zero)
	((VMA-Start-Unmapped-Read) M-C)
	(Call Flag-Read-Check)
;;; set the subsystem pass indicator
	((M-Hunoz) MCR)
	((MCR) DPB (Byte-Field 1. 7.) M-Ones A-Hunoz)
	((M-A) DPB (Byte-Field 2. 0.) M-Ones A-Zero)
;;;
	((MD-Start-Unmapped-Read) SETZ)
	(Call Flag-Read-Check)
;;;
	((MD-Start-Unmapped-Byte-Read) SETZ)
	(Call Flag-Read-Check)
;;;
	((VMA-Start-Unmapped-Read) M-C)
	(Call Flag-Read-Check)
;;;
	((VMA-Start-Unmapped-Byte-Read) M-C)
	(Call Flag-Read-Check)
	(Jump Interrupt-Test)

FLAG-Read-Check
	(Call If-Not-Memory-Busy Internal-Error)
	((MD) DPB (Byte-Field 8. 0.) MD A-Zero)
	(Call If-Not-Equal MD A-A Internal-Error)
	(Call If-NuBus-Error Internal-Error)
	(Call If-Not-NuBus-Error Return-Fixup)
	(Call Internal-Error)
	(Popj)
;;;-----------------------------------------------------------------------------
;;;
Interrupt-Test
	((M-Hunoz) MCR)		;enable interrupts.
	((MCR) DPB (Byte-Field 1. 15.) M-Ones A-Hunoz)
	((MD M-H) DPB (Byte-Field 4. 0.) M-Ones A-Zero)
Int-Loop1
	((M-Hunoz) DPB (Byte-Field 4. 2.) M-H A-Zero)
	((MD) SETO)
	((VMA-Start-Unmapped-Write) ADD M-E A-Hunoz)
	(No-Op)		;cosmic no-op
	((MD) MD)	;wait for cycle to finish
	(No-op)		;wait for interrupt to trickle through
	(No-op)		;wait for interrupt
	(Call If-No-Interrupt-Pending Internal-Error)
	((MD) LDB (Byte-Field 4. 16.) MCR A-Zero)
	(Call If-Not-Equal MD A-H Internal-Error)
;;;	(Jump-Xct-Next If-Not-Equal M-H A-2 Int-Loop1)
	(Jump-Xct-Next If-Not-Equal M-H A-constant-2 Int-Loop1)
       ((M-H) ADD M-H A-Ones)
;;;
	((MD M-H) DPB (Byte-Field 4. 0.) M-Ones A-Zero)
Int-Loop2
	((M-Hunoz) DPB (Byte-Field 4. 2.) M-H A-Zero)
	((MD) SETZ)
	((VMA-Start-Unmapped-Write) ADD M-E A-Hunoz)
	(No-op)		;cosmic no-op
	((MD) MD)
;;;	(Jump-Xct-Next If-Not-Equal M-H A-2 Int-Loop2)
	(Jump-Xct-Next If-Not-Equal M-H A-constant-2 Int-Loop2)
       ((M-H) ADD M-H A-Ones)
	(No-op)		;wait for interrupt to trickle through
	(No-op)		;wait for interrupt
	(Call If-Interrupt-Pending Internal-Error)	

;;;
	

;;;-----------------------------------------------------------------------------
;;; At this point all of the testing is done and now all of the RAM in the 
;;; machine and some of the registers will be initialized.
;;;-----------------------------------------------------------------------------

;;;-----------------------------------------------------------------------------
;;; The following code wires the first 128 entries of the level 1 map to the
;;; level 2 map. The level 2 map is cleared. The first 128 level 1 entries
;;; are set to valid. All other level one entries are set to invalid and are 
;;; cleared, all level two are set to invalid.
;;; MD contains the address of the map RAM to be written.
;;; VMA contains the data to be written to the map RAM.
;;; M-Hunoz contains the constant to add to VMA to access the next level 1
;;; map RAM location.
Init-Map
	(Call Wire-Level1-Map)
;;;
Clear-Level-1-Map
	((VMA-Write-Map-Level-1) SETZ)
	((MD) ADD MD A-Hunoz)
	(Jump If-Bit-Clear (Byte-Field 1 25.) MD Clear-Level-1-Map)
;;;
	((MD) SETZ)	;initialize the address
;;; increment by the page size
	((M-Hunoz) DPB (Byte-Field 1. 8.) M-Ones A-Zero)
Clear-Level-2-Map
	((VMA-Write-Map-Level-2-Control) SETZ)	;Clear level-2 map
	((VMA-Write-Map-Level-2-Address) SETZ)
	((MD) ADD MD A-Hunoz)		;increment the address
	(Jump If-Bit-Clear (Byte-Field 1 20.) MD Clear-Level-2-Map)

;;;-----------------------------------------------------------------------------
;;; This loop clears the M-Tag classifier RAM. Use Write-Tag-Ram which 
;;; may be used by the loader (so the code is free).
;;; M-Hunoz contains the class number being cleared.

	((MD M-Hunoz) DPB (Byte-Field 4. 0.) M-Ones A-Zero) ; number of classes
Clear-M-Tag-RAM
	((C-PDL-Buffer-Pointer-Push) M-Zero)		;clear the tag ram
	((C-PDL-Buffer-Pointer-Push) M-Hunoz)		;push the class number
	(Call Write-Tag-Ram)				;write the class
	(Jump-Xct-Next If-Not-Equal M-Hunoz A-Zero Clear-M-Tag-RAM)
       ((MD M-Hunoz) ADD M-Hunoz A-Ones)		;decrement class number
;;;-----------------------------------------------------------------------------
;;; The following code clears A, PDL, Dispatch, Micro-Stack and Control store
;;; memories.
;;; M-Hunoz contains the address of the memory to be cleared (except PDL).
;;; Since Control store is 16K entries all other memories get cleared a number
;;; of times.
;;;					
;;; Use this instruction for debug out of RAM so code doesn't clear itself
;;;	((M-Hunoz PDL-Buffer-Pointer) DPB (Byte-Field 1. 11.) M-Ones A-Zero)
;;; use this statement for ROM version	<***************************
	((M-A) MCR)
	((MCR) DPB (Byte-Field 1. 12.) M-Zero A-A)
	((M-Hunoz PDL-Buffer-Pointer) SETZ)
;;; write the halt bit
	((M-A) DPB (Byte-Field 1. 17.) M-Ones A-Zero)
Clear-A-Memory
	((IMOD-LOW) DPB IMOD-A-Dest M-Hunoz A-Zero)	;A destination
	((A-Garbage) SETZ)
	((M-A) M-A)			;restore A-A
	((C-PDL-Buffer-Pointer-Push) SETZ)
	((Micro-Stack-Data-Push) SETZ)
	((IMOD-Low) DPB IMOD-Low-JUMP M-Hunoz A-Zero)  ;IMOD selects I-mem address
	(Call-Xct-Next 0)		;generate address for write
	(Write-I-Mem M-Zero A-A)	;write selected I-Mem location
	((IMOD-Low) DPB (Byte-Field 12. 20.) M-Hunoz A-Zero)
	(Write-Dispatch-RAM A-Zero)
	((M-Hunoz) M+1 M-Hunoz)
	(Jump If-Bit-Clear (Byte-Field 1. 14.) M-Hunoz Clear-A-Memory)
;;;-----------------------------------------------------------------------------
;;; Clear M memory to make sure it contains known data.
;;; But don't bash the M-ZERO and M-ONES constants.
	((M-Hunoz) DPB (Byte-Field 1 6.) M-Ones A-Zero)	;64., size of M memory
	((MD) DPB M-Ones (Byte-Field 1 2) A-Zero)	;4, lowest location 
Clear-M-Memory
	((M-Hunoz) M-A-1 M-Hunoz A-Zero)	
	((IMOD-LOW) DPB IMOD-M-Dest M-Hunoz A-Zero)	;M destination
	((M-Garbage) M-Zero)
	(Jump If-Not-Equal MD A-Hunoz Clear-M-Memory)
;;;-----------------------------------------------------------------------------
;;; Clear the internal registers. MD is required to be clear if self-test is
;;; to be repeated. Shut off all LEDs only if booting. Does the 
;;; Micro-Stack-Pointer need to be 0 or -1 ?
	((M-Ones Micro-Stack-Pointer) SETO)
	((PDL-Buffer-Index) SETZ)
	((PDL-Buffer-Pointer) SETZ)
	((Location-Counter) SETZ)
	((VMA) SETZ)
;;;	((MCR M-Hunoz) DPB (Byte-Field 1. 11.) M-Ones A-Zero) <**** RAM DEBUG ONLY 
	((MCR) SETZ)
	(Jump-Xct-Next If-Bit-Clear (Byte-Field 1. 23.) MCR Reset-Trap)
       ((MD M-Zero) SETZ) 
;;;
;;; Shut off all LEDs, set the system pass indicator, set the sub-system
;;; (which we don't have) pass indicator. 
;;; Turn all other bits in MCR off.
	((M-Hunoz) MCR)
	((MCR M-Hunoz) DPB (Byte-Field 8. 0.) M-Ones A-Hunoz)
;;; Indicate to NuBus interface that selftest is complete.
	((MCR M-Hunoz) DPB (Byte-Field 1. 27.) M-Ones A-Hunoz)



;;;-----------------------------------------------------------------------------
;;; And now its time to deal with reality. Setup Constants and stuff.
;;;
Start-Boot-Load

;;; +++ the following five lines are temporary since we have bypassed self test	-- JSL
;;;	((M-ONES) SETO)
;;;	((M-ZERO) SETZ)
;;;	((M-Hunoz) MCR)
;;;	((MCR M-Hunoz) DPB (Byte-Field 8. 0.) M-Ones A-Hunoz)
;;;	((MCR M-Hunoz) DPB (Byte-Field 1. 27.) M-Ones A-Hunoz)


;;; First enable power fail warning event and boot event traps.
;;; Note that should either of these events happen the machine
;;; will crash because this ROM contains no code to handle these events.
	((M-Hunoz) MCR)
	((MCR) DPB M-Ones (Byte-Field 1 20.) A-Hunoz)
;;; setup so AND-CALL-ILLOP will be a death trap.
	((M-Zero C-PDL-Buffer-Pointer) SETZ)
	((M-Ones) SETO)

;;; >>> here ends the insertion from B:>amundsen>expl-promh

	;; this is probably already clear but just to be safe . . .
	((MCR) dpb m-zero (byte-field 1 13.) a-hunoz)	;clear busserr trap enable

CONSTRUCT-CONSTANTS
;;; create the general purpose numbers and various other
;;; constants that don't change based on system configuration
;;; Hex constants 1 to 1F are generated using an IMOD loop.  Their a-memory
;;; definitions MUST start at x41.

	((m-a md) dpb m-ones (byte-field 1 6) a-zero)	;x40
CONSTRUCTOR-LOOP
	((imod-low) dpb md %imod-low-a-dest)
	((a-garbage) sub md a-a)			;address - x40 = value
	(jump-xct-next if-bit-clear (byte-field 1 5) md CONSTRUCTOR-LOOP)
       ((md) m+1 md)

	((a-hex-20)	  dpb m-ones (byte-field 1 5)    a-zero)
	((a-hex-30)       dpb m-ones (byte-field 2 4)    a-zero)
	((a-hex-32)       dpb m-ones (byte-field 2 4)    a-hex-2)
	((a-hex-3E)       dpb m-ones (byte-field 5 1)    a-zero)
        ((a-hex-40)       dpb m-ones (byte-field 1 6)    a-zero)
	((a-hex-41)	  m+a+1 m-zero a-hex-40)
	((a-hex-50)       dpb m-ones (byte-field 1 4)    a-hex-40)
	((a-hex-54)       dpb m-ones (byte-field 1 2)    a-hex-50)
	((a-hex-74)       dpb m-ones (byte-field 1 5)    a-hex-54)
	((a-hex-7F)       dpb m-ones (byte-field 7 0)    a-zero)
	((a-hex-80)       dpb m-ones (byte-field 1 7)    a-zero)
        ((a-hex-FF)       dpb m-ones (byte-field 8. 0)   a-zero)
	((a-hex-100)      dpb m-ones (byte-field 1 8)    a-zero)
	((a-hex-200) 	  dpb m-ones (byte-field 1 9.)   a-zero)
	((a-hex-210)      dpb m-ones (byte-field 1 4)    a-hex-200)
	((a-hex-3FB)      dpb m-ones (byte-field 6 4)    a-hex-B)
	((a-hex-400)      dpb m-ones (byte-field 1 10.)  a-zero)
	((a-hex-800)      dpb m-ones (byte-field 1 11.)  a-zero)
	((a-hex-2000) 	  dpb m-ones (byte-field 1 13.)  a-zero)
	((a-hex-F0000000) dpb m-ones (byte-field 4 28.)  a-zero)

	((m-tem) a-hex-15)
	((a-hex-5593) dpb m-ones (byte-field 2 7) a-hex-13)
	((a-hex-5593) dpb m-tem  (byte-field 5 10.) a-hex-5593)

	;; +++ string space occupies the last 48. locations of memory
	;; for prom this starts at x7D0 
	;; for ram this is at x3ED0 (assuming origin at x3700)
	((a-string-space) dpb m-ones (byte-field 5 6) a-hex-10)	;x7D0
;;;	((m-tem) dpb m-ones (byte-field 2 6) a-hex-10)		;xD0
;;;	((a-string-space) dpb m-ones (byte-field 5 9) a-tem)	;x3ED0

	;; +++ boot types 
	;; 0 is reserved for warm boot events 
	;; test boot is 4 but we don't need to check for it anywhere
	((a-warm-boot)       setz)	;shouldn't actually be using this anywhere
	((a-default-boot)    a-hex-1)
	((a-menu-boot)       a-hex-2)
	((a-diagnostic-boot) seto)	;disable diagnostic boot

	;; error codes 
	((a-pending-error) setz)	;no pending errors initially

	;; non fatal errors
	((a-no-online-devices) 		M+A+1 m-zero a-zero)
	((a-invalid-label)              M+A+1 m-zero a-no-online-devices)
	((a-small-save-area)		M+A+1 m-zero a-invalid-label)
	((a-invalid-ptable)             M+A+1 m-zero a-small-save-area)
	((a-no-microloads)              M+A+1 m-zero a-invalid-ptable)
 	((a-microload-not-found)        M+A+1 m-zero a-no-microloads)
	((a-bad-section-type)           M+A+1 m-zero a-microload-not-found)
	((a-bad-section-address)        M+A+1 m-zero a-bad-section-type)
	((a-end-of-partition)           M+A+1 m-zero a-bad-section-address)
	((a-ddr-completion)		M+A+1 m-zero a-end-of-partition)

	;; fatal errors
	((a-no-disk-controller)         M+A+1 m-zero a-ddr-completion)
	((a-page-fault)			M+A+1 m-zero a-no-disk-controller)
	((a-ddr-request)		M+A+1 m-zero a-page-fault)
	((a-dei-instruction-header)	M+A+1 m-zero a-ddr-request)

	;; this stuff needs to be initialized if used
	((a-nubus-timeout)        setz)
	((a-nubus-gacbl-count)    setz)
	((a-no-memory-errors)     setz)
	((a-parity-errors)        setz)
	((a-nubus-no-error)       setz)
;;;	((a-nubus-gacbl-failures) setz)
;;;	((a-nubus-error)          setz)



SYSTEM-TEST
;;; For this version of the ROM's, the Explorer is assumed to be
;;; system test master.  DEI self test will be run for all
;;; boards that require it.  

	((mcr) ior mcr a-hex-100)		;turn on memory cycle enable
	((mcr) andca mcr a-hex-1)		;turn on led0, starting system test
	((m-tem) (byte-field 4 28.) mcr)	;get processor slot from MCR
	((a-processor-slot) xor m-tem a-hex-F)	;invert active low bits
	(call DEI-INITIALIZE)			;get ready . . . 

;;; >>> begin insertion of system test code from a:>kloepper>stm-prom.lisp.36 dated 8/28/84
;;; >>> MODIFICATION HISTORY:
;;; 10/8/84 -- JSL
;;; I changed m-boards-subsys-failed to a-boards-subsys-failure.
;;; I changed m-boards-failed to a-boards-self-test-failure.
;;; I now used m-boards-failed as a "global" status that may be set if any
;;; of the various tests failed.  m-boards-failed is used by locate-tested-resource.
;;; I also added the following test flags & put in code to set them.
;;;   a-boards-nubus-test-timeout
;;;   a-boards-crc-failure
;;;   a-boards-self-test-timeout
;;;   a-boards-dei-test-failure


LOCATE-TEST-RESOURCES
;;; We must locate resources required for performing system tests.
;;; A monitor is necessary for the display of periodic status messages.
;;; Memory is required for NuBus DMA tests.

	;; initialize flag word of boards tested 
	;; one bit per slot number - 0 is not tested, 1 is tested
	((m-boards-tested)             setz)		; set to all untested
	((m-boards-failed)             setz)		; set to all passed
	((a-boards-crc-failure)        setz)
	((a-boards-self-test-timeout)  setz)
	((a-boards-self-test-failure)  setz)
	((a-boards-subsys-failure)     setz)
	((a-boards-dei-test-failure)   setz)
	((a-boards-nubus-test-timeout) setz)

	;; search all slots in the NuBus for resources
;;; +++ Ethernet board has FF in resource byte. Until this is fixed, 
;;; +++ we must start board searches from slot 1.
;;;	((m-a) setz)
	((m-a) a-hex-1)
FIND-SYSTEST-MONITOR
	(call-xct-next LOCATE-RESOURCE)
       ((m-b) a-hex-8)					;monitor resource bit = 3
        ((a-monitor-slot) m-c)				;-1 means no monitor available

	;; look for memory underneath the processor
;;; +++ Ethernet board has FF in resource byte. Until this is fixed, 
;;; +++ we must start board searches from slot 1.
;;;	((m-a) setz)
	((m-a) a-hex-1)
FIND-SYSTEST-MEMORY
	(call-xct-next LOCATE-RESOURCE)			; find Memory board in lower slot
       ((m-b) a-hex-1)					; memory resource bit = 0
	((m-c) a-hex-4)
	((a-memory-slot) m-c)				; remember where it is

;;; Set up some memory specific constants used later.
;;; m-main-memory-base-address  = first byte of main memory, Fs000000
;;; a-ddr-scratch-area          = used to build nupi command blocks, Fs000780 (syscom area)
;;; a-device-configuration-area = same as scratch area, info returned by DDR call
;;; a-ptable-memory-address     = memory for reading ptable, Fs000800 (page 2)
;;; a-mcr-memory-address        = memory for reading the microload, Fs020000

	((m-main-memory-base-address) dpb m-c (byte-field 4 24.) a-hex-F0000000)
	((m-tem) add m-main-memory-base-address a-hex-400)
	((a-ddr-scratch-area) dpb m-ones (byte-field 3 7) a-tem)
	((a-device-configuration-area) a-ddr-scratch-area)
	((a-ptable-memory-address) add m-main-memory-base-address a-hex-800)

	;; memory to store the microload starts at Fs020000
	;; note that this means the main mem section should fall within the first 
	;; 128K bytes of main memory
	((a-mcr-memory-address) dpb m-ones (byte-field 1 17.) a-zero)
	((a-mcr-memory-address) add m-main-memory-base-address a-mcr-memory-address)

;;; +++ Is this necessary at all ?
;;; Here we should initialize main memory since it probably has bad parity.
;;;	((MD) SETZ)
;;;	((M-A) a-main-memory-base-address)
;;;	((M-B) DPB (Byte-Field 1. 21.) M-Ones a-main-memory-base-address)
;;;Clear-Main-Memory ; page 0
;;;	((VMA-Start-Unmapped-Write) M-A)
;;;	((M-A) ADD M-A A-hex-4)
;;;	(Jump If-Less M-A A-B Clear-Main-Memory)



;;; Now test the Monitor & Memory just found.  
;;; If there was no monitor found, we won't crash but we will ignore any 
;;; monitor access operations.  If either memory or monitor fails self
;;; test, try to find another.  If no useable memory board is found, crash.

;	(jump if-equal m-ones a-monitor-slot TEST-MEMORY)   
;
;	( call-xct-next TEST-A-BOARD ) 
;       ( (m-c) a-monitor-slot )
;	;; m-tem < 0 if self test failed
;	(jump-xct-next if-bit-set (byte-field 1 31.) m-tem FIND-SYSTEST-MONITOR)
;       ((m-a) add m-ones a-monitor-slot)
;

	;; initialize the monitor for display and get its row/column size
	(call INITIALIZE-MONITOR)		


;TEST-MEMORY
;	( call-xct-next TEST-A-BOARD )
;       ( (m-c) a-memory-slot )
;	(jump-xct-next if-bit-set (byte-field 1 31.) m-tem FIND-SYSTEST-MEMORY)
;       ((m-a) add m-ones a-memory-slot)
;


;;; Now perform self test on all boards in the systesm.
;;; +++ For beta test, all we do is wait for boards with self test to complete.
;;; +++ The Nupi is going to take a long time (40 sec) to complete self test
;;; +++ so print some kind of message before starting.

	;; Delay to allow boards to respond to the reset before we touch them.
	;; This seems especially necessary for the Ethernet board.
	(call-xct-next DELAY)
       ((a-delay-counter) dpb m-ones (byte-field 1 21.) a-zero)	;x200000

	;; temporary hack to display a "waiting" message
	(call-xct-next DRAW-STRING)
       ((m-b) dpb m-ones (byte-field 1 5) a-hex-8)	;x28 = "SYSTEM TEST IN PROGRESS "

;;; +++ Ethernet boards cannot be depended upon to have valid config roms yet.
;;;	( (m-c) setz )					; test from 0 to 15.
	((m-c) a-hex-1)
BOARD-TEST-LOOP
	( call FIND-NEXT-BOARD )			; locate next non-empty slot
	( jump if-bit-set (byte-field 1 31.) m-c BEGIN-NUBUS-TEST )	;done ?
	( call TEST-A-BOARD )
	( jump-xct-next if-less m-c a-hex-F BOARD-TEST-LOOP )
       ( (m-c) m+1 m-c )				; next slot up


BEGIN-NUBUS-TEST
;;; Now perform NuBus tests for all boards.
;;; +++ Nubus testing is not included for beta test.

	(jump SYSTEM-TEST-COMPLETE)

;	( (m-c) seta a-hex-f )				; find all NuBus testers
;
;START-NUBUS-TEST-LOOP
;	( call FIND-NEXT-BOARD )			; find next non-empty slot
;	( jump if-bit-set (byte-field 1 31.) m-c BEGIN-END-NUBUS-TEST )		; all able boards now initiated
;	( call-xct-next NUBUS-BYTE-READ )
;       ( (vma) a-rom-flags )
;	( jump if-bit-clear (byte-field 1 1) md START-NEXT-NUBUS )
;
;	;; NuBus testor has been found 
;	;; set up test address of F(memory-board)00(test-board)000 - and initiate
;	( call-xct-next GET-AN-OFFSET )
;       ( (m-tem) a-config-reg-offset )
;
;	( (md) a-memory-slot )
;	( (md) dpb (byte-field 4 4) md a-c )	; upper-nibble is memory board slot number, lower is test slot number
;	( call-xct-next NUBUS-BYTE-WRITE )
;       ( (vma) add m-tem a-hex-4 )		; specifies area to use for test, config reg + 4
;	( (md) a-hex-c )			; turn on test led, and begin NuBus test
;	( call-xct-next NUBUS-BYTE-WRITE )	; write to config reg + 8
;       ( (vma) m-tem )				; write to config reg + 0
;
;START-NEXT-NUBUS
;	( jump-xct-next if-greater m-c a-zero START-NUBUS-TEST-LOOP )
;       ( (m-c) add m-c a-ones )		; next board down
;
;
;BEGIN-END-NUBUS-TEST
;	( (m-c) seta a-hex-f )
;
;END-NUBUS-TEST-LOOP
;	( call FIND-NEXT-BOARD )
;	( jump if-bit-set (byte-field 1 31.) SYSTEM-TEST-COMPLETE )	;;; DONE - Begin Boot procedure
;	( (m-temp-1) dpb (byte-field 1 15.) m-ones a-zero )	; set up "time-out" count   (>8000)
;
;END-NUBUS-TIMEOUT-LOOP
;	( call-xct-next NUBUS-BYTE-READ )
;       ( (vma) a-rom-flags )
;	( jump if-bit-clear (byte-field 1 1) md END-NEXT-NUBUS )
;
;	;; NuBus testor found - has it finished ??
;	( call-xct-next GET-AN-OFFSET )
;       ( (m-tem) a-config-reg-offset )
;
;	( call-xct-next NUBUS-BYTE-READ )
;       ( (vma) m-tem )
;
;	( jump if-bit-clear (byte-field 1 2) md END-NEXT-NUBUS )
;	( (m-temp-1) add m-tem a-ones )		; count down timeout
;	( jump if-equal m-temp-1 a-zero END-NUBUS-TIMEOUT-LOOP )
;
;	;; nubus test timeout flag added by JSL
;	;; +++ NOTE: nubus test timeout is not considered fatal at this time
;	;; +++ so it doesn't call DECLARE-BOARD-A-FAILURE
;	((imod-low) dpb m-c %imod-low-mrot a-zero)
;	((a-boards-nubus-test-timeout)
;	  dpb m-ones (byte-field 1 0) a-boards-nubus-test-timeout)
;
;END-NEXT-NUBUS	
;	( jump-xct-next if-greater m-c a-zero END-NUBUS-TEST-LOOP )
;       ( (m-c) add m-c a-ones )				; next board down
;
;


;;; This page has the routines needed to support the STM process

;;; Here begins the "TEST-A-BOARD" Function
;;; TEST-A-BOARD expects to find:
;;;	m-c containing the board number to be tested
;;;     M-TEM returns with test status: < 0 if failure
;;;
;;; TEST-A-BOARD will first do a CRC check on each board's configuration ROM.  If
;;; the board fails CRC, the test aborts.  Following CRC check, we wait for the
;;; board to finish its self test if it has one.  Finally, we perform DEI self test
;;; on all boards that have DEI code.
;;; Bits in the following registers may be set:
;;;  m-boards-tested	(always)
;;;  m-boards-failed    (only on fatal error -- currently all of them)
;;;  a-boards-crc-failure
;;;  a-boards-self-test-timeout
;;;  a-boards-self-test-failure
;;;  a-boards-subsys-failure
;;;  a-boards-dei-test-failure

TEST-A-BOARD
	( (m-tem) setcm m-c )		; jump likes its rotate fields as 32-mrot
	( (imod-low) dpb %imod-low-mrot m-tem )		; convert board number into bit number
	( jump if-bit-clear (byte-field 1 0) m-boards-tested STM-BOARD-BEGIN )
	;** - Board is already tested - just return
	(and-popj (m-tem) setz)

STM-BOARD-BEGIN
	;;  Now begin check of boards configuration rom - do the CRC calculations and test
	;; >>> this call not really necessary -- already done from board-test-loop
	( call SETUP-BOARD-ADDRESSES )		; build handy set of config rom addresses

;;; +++ until CRC works correctly
;;; +++ fall into STM-CRC-OK
;
;	;;   now calculate size and starting address
;	( call-xct-next NUBUS-BYTE-READ )		; read NuBus for rom size byte
;       ( (vma) a-rom-size)
;
;	;; now calculate rom size 
;	;; m-a2 is number of bytes to CRC - m-j is address of byte to CRC
;	;; rom size is 2 ** (contents of ROM-SIZE in Config Rom)
;	( (imod-low) %imod-low-mrot md )
;	( (m-a2) dpb (byte-field 1 0) m-ones a-zero )
;
;	( (m-hunoz) dpb (byte-field 30 2) m-a2 a-zero )	; size times four
;	( (m-j) sub m-zero a-hunoz )			; negate to get first byte address
;	( (m-a2) sub m-a2 a-hex-12 )			; skip over last 18. entries of ROM
;	( (m-d) setz )					; initial crc value is zero
;
;	;;; Now do the CRC calculations
;
;	( (m-crc) setz )				; initialize the crc value to zero
;
;STM-CRC-NEXT-BYTE               
;	( call-xct-next NUBUS-BYTE-READ )
;       ( (vma) dpb %slot-id m-c a-j )
;
;	( call CRC-CALCULATE-NEXT )
;
;	( (m-j) add m-j a-hex-4 )				; advance to next byte
;	( (m-a2) m-a-1 m-a2 a-zero )				; one more down - some to go ?
;	( jump if-not-equal m-a2 a-zero STM-CRC-NEXT-BYTE )	; go do next byte 
;
;	;;; Now check if the CRC (in a-crc) is correct
;
;	( call-xct-next NUBUS-BYTE-READ )
;       ( (vma) dpb %slot-id m-c a-j )
;
;	;; first byte of crc ;; ??? which byte is first ???
;	( (m-k) dpb (byte-field 8 0) md a-zero )
;	( call-xct-next NUBUS-BYTE-READ)
;       ( (vma) add vma a-hex-4)			; >>> chg this to a-hex-4 for "real" roms
;	( (m-k) dpb (byte-field 8. 8.) md a-k)			; second byte of crc
;
;	;; CRC error handling changed by JSL	
;	(jump if-equal m-k a-crc STM-CRC-OK)
;
;	((imod-low) dpb %imod-low-mrot m-c)
;	((a-boards-crc-failure) dpb (byte-field 1 0) m-ones a-boards-crc-failure)
;	(call DECLARE-BOARD-A-FAILURE)	;returns -1 in m-tem
;	(jump STM-DE-TEST-FINISHED)	;abort testing


STM-CRC-OK
;;; board has now passed the crc check - config rom is valid
;;; next - check if board has own self-test, and then check if it has passed its self-test.
;;; wait-on-self-test returns status in m-tem -- negative if failed self test

	( call WAIT-ON-SELF-TEST )
;;;	( jump if-bit-clear (byte-field 1 31.) m-tem STM-BEGIN-TESTING )

	;;; Now - report self-test failed - How is a good question
	;;;   Thus i'm leaving this be filled in later
	;;;     (actually - just fall into DE testing 
	;;;      'cause WAIT-ON-SELF-TEST set the fail flag)

;;; Now begin checking and set up for DEI - the Diagnostic Engine Interpreter
;;; This is used to run self-tests on "dumb" boards - and perhaps complement 
;;; smart board's self-tests

STM-BEGIN-TESTING
;;; +++ No DEI testing for beta test.
;;; +++ Fall into STM-DE-TEST-FINISHED
;
;	;; first, initialize the DEI stack pointers -- added 10/8 jsl
;	(call DEI-INITIALIZE)
;
;;;;	( call FIND-SELF-TEST-INST-SPACE )
;;;; >>> the above routine is now coded in line -- JSL
;
;	((m-dei-board-space) dpb m-c (byte-field 4 24.) a-hex-F0000000)
;
;	;; setup-board-addresses has been called
;	(call-xct-next GET-AN-OFFSET)	
;       ((m-tem) a-diagnostic-offset)
;
;	;; if instruction space pointer is invalid, ignore dei self test
;	((m-temp-1) ldb (byte-field 24. 0) m-tem a-ones)		; is address >FidFFFFFF ?
;	(jump if-equal m-ones a-temp-1 STM-DE-TEST-PASSED)
;;;; +++ must currently also check for an offset of zeros being invalid for the NUPI
;	((m-temp-1) ldb (byte-field 24. 0 ) m-tem a-zero)
;	(jump if-equal m-zero a-temp-1 STM-DE-TEST-PASSED)
;
;	;; valid pointer so go hack instruction header 
;	(call-xct-next PROCESS-DIAGNOSTIC-INST-HEADER )
;       ((m-dei-inst-space) m-tem)
;
;	;; don't perform DEI self test if the instruction space was invalid
;	;; m-tem returned with zero for valid header or -1 for invalid header
;	(jump if-equal m-tem a-ones STM-DE-TEST-PASSED)
;
;	( call DIAGNOSTIC-ENGINE )					; run it
;
; 	;; check test completion status
;	( (imod-high) dpb %imod-high-a-source m-dei-data-space-origin )
;	( (m-hunoz) seta )
;	(jump if-equal m-hunoz a-zero STM-DE-TEST-PASSED)
;
;	;; DEI failure flag added by JSL
;	((imod-low) dpb m-c %imod-low-mrot a-zero)
;	((a-boards-dei-test-failure) dpb m-ones (byte-field 1 0) a-boards-dei-test-failure)
;	(jump-xct-next STM-DE-TEST-FINISHED)
;       ((m-tem) seto)	;negative completion status
;
;
;STM-DE-TEST-PASSED
;;;; de test passed, return 0
;	((m-tem) setz)
;
STM-DE-TEST-FINISHED
;;; test has either passed or failed -- status in m-tem (< 0 if faulire)

	( (imod-low) dpb %imod-low-mrot m-c )
	( (m-boards-tested) dpb (byte-field 1 0) m-ones a-boards-tested )
	( popj )		; DONE - RETURN



;;;; The next is a 3rd level function that computes Roger Vest's CRC function
;;;; upon the Configuration Rom
;
;CRC-CALCULATE-NEXT
;
;;;; md contains the byte to be included in the current CRC value to make the next value
;
;	( (m-b1) and m-crc a-hex-5593 )			; only bits of interrest
;	( (m-b2) setz )					; init parity to even (seto for odd)
;
;;;; calculate parity on bits selected by the >5593
;
;CRC-PARITY-LOOP
;	( jump-xct-next if-bit-clear (byte-field 1 0) m-b1 CRC-NO-TOGGLE )
;       ( (m-b1) setm shift-alu-right m-b1 )		; shift to next bit
;
;	;;; now toggle the parity bit
;
;	( (m-b2) setcm m-b2 )				; toggle it
;
;CRC-NO-TOGGLE
;	( jump if-not-equal m-b1 a-zero CRC-PARITY-LOOP )	; fall-thru when no one's left
;
;	( (m-crc) setm shift-alu-right m-crc )		; shift old crc value
;	( (m-crc) dpb (byte-field 1 15.) m-b2 a-crc)	; put parity bit on top
;
;	;;; now expand the input byte so that it may be xored into the next crc value
;
;CRC-BUILD-5593						; entry so 5593 constant may be built
;	( (m-b1) ldb (byte-field 2 0.) md a-zero )	; 1> set md to a-ones, then
;	( (md)   ldb (byte-field 6 2) md a-zero )	; 2> call CRC-BUILD-5593
;	( (m-b1) dpb (byte-field 1 4.) md a-b1   )	; 3> upon return m-b1 contains #x+5593
;	( (md)   ldb (byte-field 5 1) md a-zero )
;	( (m-b1) dpb (byte-field 2 7.) md a-b1   )
;	( (md)   ldb (byte-field 3 2) md a-zero )
;	( (m-b1) dpb (byte-field 1 10.) md a-b1  )
;	( (md)   ldb (byte-field 2 1) md a-zero )
;	( (m-b1) dpb (byte-field 1 12.) md a-b1  )
;	( (md)   ldb (byte-field 1 1) md a-zero )
;	( and-popj-xct-next
;	  (m-b1) dpb (byte-field 1 14.) md a-b1  )
;       ( (m-crc) xor m-crc a-b1 )			; calculation is done
;


WAIT-ON-SELF-TEST
;;; This has the slot number in m-c, and setup-board-addresses has been run
;;;					 (as part of "resource-bit-slot-search")
;;; May set bits in :
;;;   a-boards-failed
;;;   a-boards-self-test-failure
;;;   a-boards-self-test-timeout
;;;   a-boards-subsys-failure

;;;	( call SETUP-BOARD-ADDRESSES )		;  call explicitly so find-keyboard may use it

	;; can board do self-test ??
	( call-xct-next NUBUS-BYTE-READ )
       ( (vma) a-rom-flags )			; read the rom flags

	;; if board can't do its own self test, return 
	(jump if-bit-clear (byte-field 1 0) md SELF-TEST-PASSED)


;;; +++ EARLY VERSIONS OF THE BOOT ROM HAD A x200000 TIMEOUT VALUE FOR THE NUPI
;;; +++ WE MAY CONSIDER MAKING THE TIMEOUT LARGER ?? -- JSL

	;; can do self-test - is it done ??
	;; init "time-out" counter to 4k tries - is this long enough ??
	( (m-temp-1) dpb (byte-field 1 16.) m-ones a-zero )
						

IS-SELF-TEST-DONE
	;; get the flag register address - returned in m-tem
	( call-xct-next GET-AN-OFFSET )				
	( (m-tem) a-flag-reg-offset )

	( call-xct-next NUBUS-BYTE-READ )			; read flag register's value
       ( (vma) m-tem )

	;; is it still busy ??
	( jump if-bit-clear (byte-field 1 0) md SELF-TEST-IS-DONE )

	;; self-test is still busy - time out stuff next
	( (m-temp-1) add m-ones a-temp-1 )			; one less count to wait
	( jump if-not-equal m-temp-1 a-zero IS-SELF-TEST-DONE )

	;; +++ The Nupi is going to take around 40 seconds to complete self test
	;; +++ instead of timing out, just wait indefinately and hope it completes.
	;; +++ This will all go away eventually.
	;; +++ Use this timeout period to draw a character on the screen so the user
	;; +++ knows something is going on.

	(call-xct-next DRAW-CHAR)
       ((a-char-code) dpb m-ones (byte-field 1 5) a-hex-E)	;x2E = "."

	(jump-xct-next IS-SELF-TEST-DONE)
       ((m-temp-1) dpb m-ones (byte-field 1 16.) a-zero)	;reinitialize timeout counter

;	;; self test timeout flag added by JSL
;	((imod-low) dpb m-c %imod-low-mrot a-zero)
;	((a-boards-self-test-timeout) dpb m-ones (byte-field 1 0) a-boards-self-test-timeout)
;	(jump DECLARE-BOARD-A-FAILURE)	;returns -1 in m-tem


SELF-TEST-IS-DONE
	( jump if-bit-set (byte-field 1 1) md SELF-TEST-FAILED )
	( jump if-bit-set (byte-field 1 2) md SELF-TEST-SUBSYS-FAILED )

;;; +++ EARLY VERSIONS OF THE BOOT ROM HAD A x180000 DELAY HERE FOR THE NUPI
;;; +++ I DON'T SEE WHY THIS WOULD BE NECESSARY BUT WE MAY CONSIDER PUTTING IT IN
;;; 	(call-xct-next DELAY)
;;;       ((a-delay-counter) dpb m-ones (byte-field 2 19.) a-zero)

SELF-TEST-PASSED
	( and-popj (m-tem) m-c )	; success - return positive slot number

SELF-TEST-FAILED
;;;	( (m-tem) sub m-zero a-hex-2 )	    	   ; completed but failed == -2
	((imod-low) dpb %imod-low-mrot m-c)	   ; set slot # bit to one
	((a-boards-self-test-failure) dpb m-ones (byte-field 1 0) a-boards-self-test-failure)
	(jump DECLARE-BOARD-A-FAILURE)

SELF-TEST-SUBSYS-FAILED
;;;	( (m-tem) sub m-zero a-hex-4 )		; completed but failed == -4
	((imod-low) dpb %imod-low-mrot m-c)    ; set slot # bit to one
	((a-boards-subsys-failure) dpb (byte-field 1 0) m-ones a-boards-subsys-failure)
	;; fall in

DECLARE-BOARD-A-FAILURE
;;; We come here whenever a board has failed some piece of self test.
;;; Bits in this register can be used as a general "health" status for a board.
;;; Don't call this if the failed test is not considered fatal.
;;; This register is used by LOCATE-RESOURCE
;;; Always returns -1 in m-tem.

	((imod-low) dpb m-c %imod-low-mrot a-zero)
	((m-boards-failed) dpb m-ones (byte-field 1 0) a-boards-failed)
	(and-popj (m-tem) seto)


;;; Miscellaneous routines used by system test.


;;; GET-AN-OFFSET takes the value in m-tem, which is the first byte address 
;;; of the offset desired, and includes the Fid and returns it in m-tem
;;; This routine used to assume that the bytes were MSB, middle, LSB
;;; I changed it so it uses the correct ordering of LSB, middle, MSB. -- JSL

GET-AN-OFFSET
	( call-xct-next NUBUS-BYTE-READ )
       ( (vma) m-tem )						; read low order byte
	( (m-tem) dpb (byte-field 8. 0) md a-tem )
	( call-xct-next NUBUS-BYTE-READ )
       ( (vma) add vma a-hex-4 )				; read middle byte
	( (m-tem) dpb (byte-field 8. 8.) md a-tem)
	( call-xct-next NUBUS-BYTE-READ )
       ( (vma) add vma a-hex-4 )				; read high byte
	( and-popj (m-tem) dpb (byte-field 8. 16.) md a-tem )	; offset is complete - return


LOCATE-RESOURCE
;;; Look for a board of desired type by examining resource bits in the 
;;; configuration rom.  The board must have passed self test.
;;; Begin at the slot number in m-a and count up until found.
;;; m-b contains a byte with the appropriate resource bit set
;;; return slot number of first board found in m-c 
;;; return -1 in m-c if the board was not found

	((m-c) m-a)

SLOT-SEARCH-LOOP	
	(call FIND-NEXT-BOARD)			; begin search at m-c
	(popj if-equal m-c a-ones)		; return -1 if board not found

	;; md returned with contents of resource byte
	((m-tem) and md a-b)
	(jump if-equal m-tem a-zero NEXT-SLOT)

	;; check self test status for this board
	((m-tem) setcm m-c)		; 32 - mrot for LDB,JUMP
	((imod-low) dpb m-tem %imod-low-mrot)	
	(popj if-bit-clear (byte-field 1 0) m-boards-failed)

NEXT-SLOT
	(jump-xct-next if-less m-c a-hex-F SLOT-SEARCH-LOOP)
       ((m-c) m+1 m-c)

	;; not found, return -1
	(and-popj (m-c) seto)


;;; FIND-NEXT-BOARD searches upward for non-empty slots 
;;; Empty slots are detected by checking for NuBus timeout on memory references.
;;; M-C has starting slot number.

FIND-NEXT-BOARD
	;; some range checking added by JSL
	(jump if-greater m-c a-hex-F NO-NEXT-BOARD)	;just to be safe
	(jump if-less m-c a-zero NO-NEXT-BOARD)

	( call SETUP-BOARD-ADDRESSES )
	( call-xct-next NUBUS-BYTE-READ )
       ( (vma) a-resource-byte )		; Seymour returns 0 for un-implemented address
	(jump if-nubus-error FIND-NEXT-BOARD-1)	; Buserr generated on empty slots
	(popj)					; Return on non-empty slot

FIND-NEXT-BOARD-1
	( jump-xct-next if-less m-c a-hex-F FIND-NEXT-BOARD )	
       ( (m-c) m+1 m-c )			; next slot up

NO-NEXT-BOARD
	(and-popj (m-c) seto)			; off the end - return a -1


;;; This function SETUP-BOARD-ADDRESSES
;;;    takes the slot number in m-c and builds the following handy addresses
;;;
;;;	a-resource-byte
;;;	a-rom-flags
;;;	a-flag-reg-offset
;;;	a-diagnostic-offset
;;;	a-config-reg-offset
;;;	a-rom-size

SETUP-BOARD-ADDRESSES
	( (a-resource-byte) setca a-hex-ff )				; >FFFFFF00
	( (a-resource-byte) dpb %slot-id m-c a-resource-byte )		; >FidFFFF00
	( (m-tem) a-resource-byte )
	( (a-rom-flags) add m-tem a-hex-10 )				; >FidFFFF10
	( (a-flag-reg-offset) add m-tem a-hex-14)			; >FidFFFF14
	( (a-diagnostic-offset) add m-tem a-hex-20 )			; >FidFFFF20
	( (m-tem) a-diagnostic-offset )
;;;	((a-device-driver-offset) add m-tem a-hex-C)			; >FidFFFF2C -- JSL
	( (a-config-reg-offset) add m-tem a-hex-18 )			; >FidFFFF38
	( and-popj-xct-next
	  (m-tem) add m-tem a-hex-80 )					; (>FidFFFFA0)
	( (a-rom-size) add m-tem a-hex-14) 		; Return and	; >FidFFFFB4




SYSTEM-TEST-COMPLETE
;;; Jump here when Chassis tests have completed.
;;; At this point, all boards may be assumed to have completed self test
;;; and posted their completion status. 
;;; A monitor & memory board have been found.
;;; This is the way we boot for beta test.  Actually we will probably
;;; use this method in the released product as well.
;;; Attempt to present the boot menu but allow a timeout for auto boot.
;;; If monitor or keyboard could not be found, do a default boot.

	;; turn on led1, finished system test
	((mcr) andca mcr a-hex-2)

	(call DEI-INITIALIZE)		;just in case . . . 

	;; monitor already initialized
	;; leave blank line between the diagnostic messages and the initial menu
	((m-draw-row) add m-draw-row a-hex-2)
	((m-draw-column) setz)

	(jump if-equal m-ones a-monitor-slot MONITOR-PROBLEMS)

	;; find the system keyboard
;;; +++ Ethernet board has FF in resource byte. Until this is fixed, 
;;; +++ we must start board searches from slot 1.
;;;	((m-a) setz)
	((m-a) a-hex-1)
	(call-xct-next LOCATE-RESOURCE)
       ((m-b) a-hex-20)			;keyboard resource bit = 5
	((a-keyboard-slot) m-c)
	(jump if-equal m-ones a-keyboard-slot KEYBOARD-PROBLEMS)

	(call INITIALIZE-KEYBOARD)
	
	;; set up an input timeout of around 15. seconds for the initial menu
	((a-input-timeout) dpb m-ones (byte-field 1 15.) a-zero)

;;;	(jump SELECT-BOOT-TYPE)
;;; +++ For beta test, clear the screen to get rid of "SYSTEM TEST IN PROGRESS"
	(jump SELECT-BOOT-TYPE-AGAIN)


MONITOR-PROBLEMS
KEYBOARD-PROBLEMS
;;; Here if for some reason the monitor or keyboard is not available.
;;; Do a default boot.

	((m-boot-type) a-default-boot)
	;; fall in

BETA-DEFAULT-BOOT
DEFAULT-COLD-BOOT
;;; Here if a default boot requested or if timeout on initial menu or if 
;;; monitor or keyboard are not available.

	(call LOCATE-BOOT-DEVICE)
	(call INITIALIZE-BOOT-DEVICE)
	(call READ-LABEL)

	;; set up the boot parameters passed to RAM
	((a-boot-request) m-boot-type)
	((md) a-boot-device-slot)
	((a-boot-device) dpb md (byte-field 8. 8.) a-boot-unit)
	((a-boot-mcr-name) a-default-mcr-name)		;use label defaults
	((a-boot-lod-name) a-default-lod-name)		;for mcr & lod names
	(jump START-MICROCODE-LOAD)



LOCATE-BOOT-DEVICE
;;; Look for a disk controller board.
;;; Default boot device is zero on the first controller we find.
;;; NOTE: This routine calls FATAL-ERROR if a disk controller is not found.
;;; +++ The default unit is actually 1 for now.
;;;
;;; +++ THERE ARE SOME UNRESOLVED PROBLEMS RELATING TO THE WAY THE 
;;; +++ NUPI DOES A READ-CONFIGURATION.
;;; +++ FOR NOW WE MUST ASSUME THAT THERE ARE WORKING UNITS ON THE
;;; +++ BOARD WE FIND.  FOR BETA TEST THIS IS FINE BUT MUST BE
;;; +++ FIXED IN THE FINAL ROMS.

;;; +++ Ethernet board has FF in resource byte. Until this is fixed, 
;;; +++ we must start board searches from slot 1.
;;;	((m-a) setz)
	((m-a) a-hex-1)

CONTROLLER-SEARCH-LOOP

	;; find a board with the disk resource bit set
	(call-xct-next LOCATE-RESOURCE)
       ((m-b) a-hex-2)				;disk resource bit = 1
	(jump-xct-next if-equal m-c a-ones FATAL-ERROR)
       ((a-error-code) a-no-disk-controller)

	;; see if there is an available unit on this controller
	(call-xct-next INITIALIZE-DEVICE-CONTROLLER)
       ((a-boot-device-slot) m-c)

;;; +++ Don't do this yet.
;;; +++ Pretend we are reading the default unit from nvram.
;;;	(call GET-DEVICE-CONFIGURATION)
;;;	(call-xct-next LOCATE-AVAILABLE-DEVICE-INFO)
;;;       ((m-a) setz)
	((a-default-boot-unit) a-hex-1)
	((a-boot-unit) a-hex-1)
	((m-boot-device-type) setz)	;disk

	;; return if an available unit was found
	(popj if-not-equal m-ones a-boot-unit)

	;; resume search from the last board found
	(jump-xct-next CONTROLLER-SEARCH-LOOP)
       ((m-a) m+1 m-a)


LOCATE-AVAILABLE-DEVICE-INFO
;;; search a controller status block for information on a given available device
;;; a-device-configuration-area has physical address of status block
;;; m-a has index of device to find 
;;;    (0 = first available device, 1 = second available device...)
;;; uses level 3 registers
;;; returns :
;;;   a-boot-unit        = NUPI style unit number of device (-1 if not found)
;;;   m-boot-device-type = DDR style device type (0 = disk, 1 = tape)
;;;   a-logical-unit     = index of the unit in the configuration table

	((m-b1) a-device-configuration-area)		;initial address
	((m-b2) m-a)					;save device index
	((a-logical-unit) setz)				
	
CHECK-DEVICE-STATUS
	((vma-start-unmapped-read) m-b1)
	(call if-page-fault error-page-fault)

	;; if at end of list and coundn't find device, return -1
	(popj-xct-next if-equal md a-ones)
       ((a-boot-unit) seto)			

	;; check status bits 
	((m-tem) ldb (byte-field 8 0) md)
	(jump if-not-equal m-tem a-zero NEXT-DEVICE)

	;; we found an available device - set return paramaters
	((a-boot-unit) ldb (byte-field 16. 16.) md)
	((m-boot-device-type) ldb (byte-field 8. 8.) md)

	;; return if this is the device we were looking for
	(popj if-equal m-b2 a-zero)
	((m-b2) sub m-b2 a-hex-1)

NEXT-DEVICE
	((a-logical-unit) m+a+1 m-zero a-logical-unit)
	(jump-xct-next CHECK-DEVICE-STATUS)
       ((m-b1) add m-b1 a-hex-4)
	


SELECT-BOOT-TYPE-AGAIN
;;; Here if the user uses the ABORT key to get back to the initial menu.
;;; When the initial menu is first displayed, the screen is not cleared.
;;; This allows the user to see any messages that diagnostics have left on the screen.
;;; Subsequent redisplays of the initial menu will need to clear the screen.

	(call INIT-DISPLAY)	;clear screen, home cursor
	;; fall in

SELECT-BOOT-TYPE
;;; Create a menu containing the various boot types.
;;; Attempt to display the names of the default partitions next to the
;;; Default boot menu entry.
;;; It is best not to trust the a-memory variable containing the boot unit here 
;;; since menu-boot can be requested when the default device isn't set up.
;;; For now, always look for the default device like power up boot does.

;;;	(call LOCATE-BOOT-DEVICE)			;look for default boot device

	;; this won't clear the screen so diagnostic messages will be left intact
	(call-xct-next DISPLAY-INITIAL-MENU-HEADER)	;returns a-first-menu-row
       ((m-a) a-hex-2)					;(SELECT) BOOT TYPE

	(call-xct-next DISPLAY-BOOT-TYPE)
       ((m-a) a-hex-E)					;DEFAULT
;;;	(call DISPLAY-BOOT-DEFAULTS)			;display a-memory boot defaults
	(call NEW-LINE)	

	(call-xct-next DISPLAY-BOOT-TYPE)
       ((m-a) a-hex-10)					;MENU
	(call NEW-LINE)

	;; this flag will inhibit printing of the "ABORT = PREVIOUS MENU" string
	((a-keydoc-flag) setz)

	((m-a) a-hex-2)
	(call-xct-next MAKE-SELECTION)
       ((m-cursor-row) a-first-menu-row)

	;; can't abort out of this menu
	(jump if-equal m-menu-key a-hex-1B SELECT-BOOT-TYPE-AGAIN)	

	;; subsequent menus need the ABORT key documentation
	((a-keydoc-flag) seto)

	;; boot types must be the same as their menu locations + 1
	;; boot type zero is reserved for warm boot events
	;; M-A is returned with the menu selection.
	;; setup reserved a-mem loc that passes boot type to RAM

	((m-boot-type) M+1 m-a)
	((a-boot-request) m-boot-type)		;RAM boot parameter
	(jump if-equal m-boot-type a-default-boot DEFAULT-COLD-BOOT)
	
	;; menu or diagnostic boot, fall in & select device


SELECT-BOOT-DEVICE
;;; Allow the user to select a boot device from a menu of available devices.
;;; Default disk controller board has been located and initialized.
;;; *** Eventually this must allow selection from several different boards.

	(call LOCATE-BOOT-DEVICE)			;look for default boot device

	(call-xct-next DISPLAY-MENU-HEADER)		;sets a-first-menu-row
       ((m-a) a-hex-4)					;DEVICE
	((m-cursor-row) a-first-menu-row)		;initial cursor

	(call GET-DEVICE-CONFIGURATION)			;get unit info for current board
	((m-number-of-devices) setz)			;available device count

BUILD-DEVICE-MENU
	(call-xct-next LOCATE-AVAILABLE-DEVICE-INFO)
       ((m-a) m-number-of-devices)
	(jump if-equal m-ones a-boot-unit NO-MORE-DEVICES)
	
	;; check for default unit
	((m-tem) a-default-boot-unit)
	(call if-equal m-tem a-boot-unit SET-MENU-DEFAULT)

	;; determine appropriate string for boot device type
        ((m-b) a-hex-16)
	(jump if-equal m-boot-device-type a-zero DISPLAY-DEVICE-TYPE)	;disk type = 0

	;; If this isn't a disk assume its a tape (device type 1)
	((m-b) a-hex-17)

DISPLAY-DEVICE-TYPE
	;; draw the device type string determined above (m-a has id)
	(call DRAW-STRING)

	;; display the unit number of the device & return
	((m-draw-column) m+1 m-draw-column)     ;leave a space
	(call-xct-next DRAW-8-BIT-NUMBER)
       ((m-b) a-logical-unit)			;logical unit number
;;;       ((m-b) a-boot-unit)			;physical unit number

	(call NEW-LINE)
	(jump-xct-next BUILD-DEVICE-MENU)
       ((m-number-of-devices) m+1 m-number-of-devices)	

NO-MORE-DEVICES

	;; If no devices have been found, we must assume that they haven't
	;; come online yet.  Abort back to the initial menu and display an error message. 
	(jump-xct-next if-less-or-equal m-number-of-devices a-zero NON-FATAL-ERROR)
       ((a-error-code) a-no-online-devices)

	;; allow user to choose device - m-cursor-row set on default device
	(call MAKE-SELECTION)			;m-a has number of devices

	;; if abort requested, go back to the boot type menu 
	(jump if-equal m-menu-key a-hex-1B SELECT-BOOT-TYPE-AGAIN)

	;; get the information for the selected device
	(call LOCATE-AVAILABLE-DEVICE-INFO)			;m-a has index 

	;; setup boot device parameter passed to RAM
	((md) a-boot-device-slot)
	((a-boot-device) dpb md (byte-field 8. 8.) a-boot-unit)

	;; go initialize the device & read the label
	(call INITIALIZE-BOOT-DEVICE)
        (call READ-LABEL)

	;; fall in to select partitions


SELECT-SYSTEM-LOAD
;;; Allow the user to select a system load partition.
;;; If this is a diagnostic boot, jump to the microload selection menu
;;; since diagnostics must be microcoded.

	((a-number-of-sysloads) setz)			;assume there aren't any now
	(jump if-equal m-boot-type a-diagnostic-boot SELECT-MICROLOAD)

	(call-xct-next DISPLAY-MENU-HEADER)
       ((m-a) a-hex-6)					;SYSTEM

	((m-a) a-default-lod-name)	
	(call-xct-next BUILD-MENU-FROM-LABEL)
       ((m-b) setz)					;type code for system load bands

	;; m-a returned with number of menu choices
	;; m-cursor-row has menu row with default partition as per the disk label

	;; go directly to microload menu if no system loads available
	((a-number-of-sysloads) m-a)			;save the number of system loads
	(jump if-equal m-a a-zero SELECT-MICROLOAD)
	
	(call MAKE-SELECTION)

	;; check for abort request
	;; if auto selection of boot device has occurred, this will
	;; abort back to the device menu that wasn't seen previously
	;; I think this is a feature actually.
	(jump if-equal m-menu-key a-hex-1B SELECT-BOOT-DEVICE)

	;; >>> special hack to remove '*' from microcode menu if the 
	;; >>> default load band is not selected
	(jump if-equal m-a a-default-entry DEFAULT-LOD-SELECTED)
	((a-default-mcr-name) setz)				;clear name so won't find in menu
	(jump FIND-PARTITION-INFO)

DEFAULT-LOD-SELECTED
	;; get name of default system load and microload
	((vma) add m-main-memory-base-address a-hex-40)
	((vma-start-unmapped-read) add vma a-hex-4)
	(call if-page-fault error-page-fault)
	((a-default-mcr-name) md)

FIND-PARTITION-INFO
	;; find address of ptable entry for selected partition
	;; m-a has index, m-b gets partition type, m-c returned with address
	(call-xct-next LOCATE-PARTITION-INFO)
       ((m-b) setz)					

	;; read the name of the selected partition
	((vma-start-unmapped-read) m-c)
	(call if-page-fault error-page-fault)
	((a-boot-lod-name) md)

	;; NOTE: It is desired that the desired microload for a selected system
	;;       be determined and used as the default menu entry.
	;;       This can be determined by reading a field from the system 
	;;       communication area.  This does however permanently wire
	;;       that location in sys com for this use.

	;; *** If we don't do what is described above, why don't we
	;; *** present the microload menu first.  This would allow us to
	;; *** display/select diagnostic microloads instead of having
	;; *** a "diagnostic boot" entry on the initial menu.

	;; fall in to select microload


SELECT-MICROLOAD
;;; Allow the user to select a microcode partition.
;;; Display a menu of Explorer microloads or diagnostic microloads depending
;;; on the boot request.

	((a-mcr-type) a-hex-1)			;explorer microcode partition type
	((m-a) a-hex-8)				;MICROCODE menu string
	(jump if-not-equal m-boot-type a-diagnostic-boot DISPLAY-MICROLOAD-MENU)
	((a-mcr-type) a-hex-8)			;diagnostic microcode partition type
	((m-a) a-hex-A)				;DIAGNOSTIC menu string

DISPLAY-MICROLOAD-MENU
	(call DISPLAY-MENU-HEADER)		;m-a has string id

	((m-a) a-default-mcr-name)
	(call-xct-next BUILD-MENU-FROM-LABEL)
       ((m-b) a-mcr-type)			;partition type (explorer or diagnostic)

	;; error if no microloads are available
	(jump-xct-next if-less-or-equal m-a a-zero NON-FATAL-ERROR)
       ((a-error-code) a-no-microloads)

	;; m-a has number of menu entries, m-cursor-row is on default partition
	(call MAKE-SELECTION)
	(jump if-not-equal m-menu-key a-hex-1B MICROLOAD-SELECTED)

	;; abort back to sysload selection menu if there were any
	(jump if-less m-zero a-number-of-sysloads SELECT-SYSTEM-LOAD)
	(jump SELECT-BOOT-DEVICE)


MICROLOAD-SELECTED
	;; find address of ptable entry for selected partition
	;; m-a has index, m-b gets partition type, m-c returned with address
	(call-xct-next LOCATE-PARTITION-INFO)
       ((m-b) a-mcr-type)					

	;; get the name of the selected partition
	((vma-start-unmapped-read) m-c)			;read partition name
	(call if-page-fault error-page-fault)
	((a-boot-mcr-name) md)

	;; m-c already contains the ptable address of selected microload
	;; we don't have to search for it again, so bypass the first part
	;; of get-microload-information
	;; !!! this doesn't work anymore because I want to display boot parameters
	;; !!! in all boot cases 
;;;	(jump READ-MICROLOAD-INFO)


START-MICROCODE-LOAD
;;; Merge here for all boot types.  A microload name has been defaulted or selected.
;;; Clear the screen and display the current boot parameters before attempting
;;; to boot.  If we get errors, this allows us to see what it was trying to do.

	(call INIT-DISPLAY)			;clear screen

	(call-xct-next DRAW-STRING)
       ((m-b) a-hex-12)				;"BOOTING FROM DEVICE "

	(call-xct-next DRAW-16-BIT-NUMBER)
       ((m-b) a-boot-device)

	((m-draw-column) m+1 m-draw-column)
	(call-xct-next DRAW-STRING-WORD-4)
       ((m-c) a-boot-mcr-name)


;;;GET-MICROLOAD-INFORMATION
;;; merge here for all boot types (actually, menu boot uses read-microload-info)
;;; a microload name has been defaulted or selected
;;; find its ptable entry and extract required information
;;; a-boot-mcr-name has the name of the microload we want

	(call-xct-next LOCATE-NAMED-PARTITION-INFO)
       ((m-a) a-boot-mcr-name)

	(jump-xct-next if-equal m-c a-ones NON-FATAL-ERROR)
       ((a-error-code) a-microload-not-found)

READ-MICROLOAD-INFO
	((vma-start-unmapped-read) add m-c a-hex-4)	;starting block address
	(call if-page-fault error-page-fault)
	((a-mcr-origin) md)
	((a-mcr-address) a-mcr-origin)

	((vma-start-unmapped-read) add m-c a-hex-8)	;length in blocks
	(call if-page-fault error-page-fault)
	((a-mcr-size) md)

	;; fall into load-microcode


LOAD-MICROCODE
;;; Read microcode partition into memory if not warm boot.
;;; For warm boot, set things up to read one page at a time.

	;;  set this just in case we don't have the special main-mem section
	((a-ram-entry-point) setz)

	;; set things up for warm boot
;;;	((a-mcr-end) add m-main-memory-base-address a-hex-400)
;;;	(jump-xct-next if-equal m-boot-type a-warm-boot PROCESS-SECTION)
       ((m-mcr-offset) a-mcr-memory-address)

	;; not a warm boot so read in the whole partition
	((a-buffer-pointer) a-mcr-memory-address)
	((a-device-address) a-mcr-origin)
	((a-transfer-count) a-mcr-size)
	(call READ-N-BLOCKS)
	
	;; set a-mcr-end to point to the word following the last word of the partition
	((m-tem) a-mcr-size)
	((m-tem) dpb m-tem (byte-field 22. 10.) a-zero)		;blocks to bytes
	((a-mcr-end) add m-tem a-mcr-memory-address)	


PROCESS-SECTION
;;; Each section starts with three words:
;;; The section type, the initial address, and the number of locations.
;;; These are placed in M-B, M-C, and M-D and the section type is 'dispatched' on
;;; Section codes are:
;;;   1 = I-MEM, 2 = D-MEM, 3 = MAIN-MEM, 4 = A&M-MEM, 5 = T-MEM

	;; Mike says to disable control store parity checking when loading i-memory
	((m-hunoz) mcr)
	((mcr) dpb m-zero (byte-field 1 12.) a-hunoz)

	(call GET-NEXT-WORD)
	(call-xct-next GET-NEXT-WORD)
       ((m-b) m-a)
	(call-xct-next GET-NEXT-WORD)
       ((m-c) m-a)
	((m-d) m-a)

	(jump if-equal m-b a-hex-1 PROCESS-I-MEM-SECTION)
	(jump if-equal m-b a-hex-2 PROCESS-D-MEM-SECTION)
	(jump if-equal m-b a-hex-3 PROCESS-MAIN-MEM-SECTION)
	(jump if-equal m-b a-hex-4 PROCESS-A-MEM-SECTION)
        (jump if-equal m-b a-hex-5 PROCESS-T-MEM-SECTION)
	(jump-xct-next NON-FATAL-ERROR)
       ((a-error-code) a-bad-section-type)

PROCESS-I-MEM-SECTION
	(jump if-equal m-d a-zero PROCESS-SECTION)

	((m-a) (byte-field 18. 14.) m-c)
	(jump-xct-next if-not-equal m-a a-zero NON-FATAL-ERROR)
       ((a-error-code) a-bad-section-address)

	(call-xct-next GET-NEXT-WORD)
       ((m-d) sub m-d a-hex-1)
	(call-xct-next GET-NEXT-WORD)
       ((m-b) m-a)

	;; M-B has first word of instruction, M-A has second word
	;; M-C has i-memory address

	((imod-low) dpb m-c %imod-low-new-micro-pc a-zero)
        (ACCESS-I-MEM)
	(WRITE-I-MEM m-a a-b)
	(jump-xct-next PROCESS-I-MEM-SECTION)
       ((m-c) add m-c a-hex-1)


PROCESS-D-MEM-SECTION
	(jump if-equal m-d a-zero PROCESS-SECTION)

	((m-a) (byte-field 20. 12.) m-c)
	(jump-xct-next if-not-equal m-a a-zero NON-FATAL-ERROR)
       ((a-error-code) a-bad-section-address)

	(call-xct-next GET-NEXT-WORD)
       ((m-d) sub m-d a-hex-1)

	;; Now M-A has the contents and M-C has the address.
	((imod-low) dpb m-c %imod-low-dispatch-address a-zero)
	(dispatch WRITE-DISPATCH-RAM (byte-field 0 0) (I-ARG (A-MEM-LOC A-A)))
	(jump-xct-next PROCESS-D-MEM-SECTION)
       ((m-c) add m-c a-hex-1)


PROCESS-T-MEM-SECTION
;;; this code was taken from a:>amundsen>expl-promh.lisp.5
        (Jump If-Equal M-D A-Zero Process-Section)
        (Call Get-Next-Word)
	((C-PDL-Buffer-Pointer-Push) M-C)
	((C-PDL-Buffer-Pointer-Push) M-A)
	(Call-Xct-Next Write-Tag-RAM)
       ((M-C) M+1 M-C)
        (Jump-Xct-Next Process-T-Mem-Section)
       ((M-D) SUB M-D A-hex-1)			; had to change from A-1

PROCESS-MAIN-MEM-SECTION
	(call GET-NEXT-WORD)

	;; M-C has Number of blocks.
	;; M-D has Address of first block, relative to beginning of partition.
	;; M-A has Physical memory address of first word.
	;; physical memory address is a zero based contiguous word address 

	(jump if-equal m-c a-zero SPECIAL-MAIN-MEM-SECTION)

;;; >>> We can't do this for tapes and shouldn't be doing this anyway.
;;; >>> Assume for now we aren't warm booting & that the partition has been
;;; >>> completely read in.  That way all we have to do is a memory copy.
;;;
;;;	((m-b) add m-d a-mcr-origin)      ;absolute disk block number
;;;
;;;	;; convert m-a into a nubus byte address
;;;	((a-buffer-pointer) dpb m-a (byte-field 22. 2) a-main-memory-base-address)
;;;	((a-device-address) m-b) 
;;;	((a-transfer-count) m-c)
;;;	(call READ-N-BLOCKS)
;;;	(jump PROCESS-SECTION)

	;; a-ptable-memory-address points to the first byte of the partition in memory
	;; m-d gets converted to a byte offset and added to the start of the partition
	;; m-c is converted to a word count
	;; m-a is converted from a virtual to a physical memory address 

	((m-d) dpb m-d (byte-field 14. 10.) a-zero)
	((m-d) add m-d a-mcr-memory-address)
	((m-a) dpb m-a (byte-field 22. 2.) a-zero)
	((m-a) add m-a a-main-memory-base-address)
	((m-c) dpb m-c (byte-field 24. 8.) a-zero)

COPY-MAIN-MEMORY-LOOP
	((vma-start-unmapped-read) m-d)
	(no-op)
	((vma-start-unmapped-write) m-a)
	(no-op)
	((m-d) add m-d a-hex-4)
	((m-a) add m-a a-hex-4)
	(jump-xct-next if-greater m-c a-hex-1 COPY-MAIN-MEMORY-LOOP)
       ((m-c) add m-c a-ones)

	(jump PROCESS-SECTION)


SPECIAL-MAIN-MEM-SECTION
	(call GET-NEXT-WORD)		;remove extra word 
	(jump-xct-next PROCESS-SECTION)
       ((a-ram-entry-point) m-a)

PROCESS-A-MEM-SECTION
	((pdl-buffer-pointer) sub m-c a-hex-1)

A-MEM-LOOP
	(jump if-equal m-d a-zero DONE-LOADING)			;finished loading microcode
	((m-a) (byte-field 22. 10.) m-c)
	(jump-xct-next if-not-equal m-a a-zero NON-FATAL-ERROR)
       ((a-error-code) a-bad-section-address)
	(call-xct-next GET-NEXT-WORD)
       ((m-d) sub m-d a-hex-1)
	(jump-xct-next A-MEM-LOOP)
       ((c-pdl-buffer-pointer-push) m-a)



GET-NEXT-WORD
;;; Subroutine used by load-microcode.
;;; Get the next word of the MCR partition into M-A.  
;;; On cold boot, the partition has been read entirely into memory
;;; starting at a-ptable-memory-address and ending ad a-mcr-end.
;;; On warm boot, the partition is read in one page at a time into
;;; page zero (m-main-memory-base-address).  On warm boot, a-mcr-end
;;; has the address of main memory page one.
;;; m-mcr-offset  has the physical address of the next word
;;; a-mcr-size    has the number of pages remaining (warm boot)
;;; a-mcr-address has address of next partition page on disk (warm boot)

;;;	(jump if-greater-or-equal m-mcr-offset a-mcr-end END-OF-MCR-BUFFER)

	(jump-xct-next if-greater-or-equal m-mcr-offset a-mcr-end NON-FATAL-ERROR)
       ((a-error-code) a-end-of-partition)

	((vma-start-unmapped-read) m-mcr-offset)
	(call if-page-fault ERROR-PAGE-FAULT)
	(and-popj-xct-next (m-mcr-offset) add m-mcr-offset a-hex-4)
       ((m-a) md)


;;;END-OF-MCR-BUFFER
;;; If this is a warm boot, read in the next page of the partition.
;;; If this is not a warm boot, we have attempted to read too far.
;;;
;;;	(jump-xct-next if-not-equal m-boot-type a-warm-boot NON-FATAL-ERROR)
;;;       ((a-error-code) a-end-of-partition)
;;;
;;;	;; any pages left ?
;;;	(jump if-greater-or-equal m-zero a-mcr-size NON-FATAL-ERROR)
;;;
;;;	((m-mcr-offset) m-main-memory-base-address)	;reset read pointer
;;;	((a-mcr-size) add m-ones a-mcr-size)		;Subtract 1
;;;
;;;	((a-device-address) a-mcr-address)
;;;	((a-buffer-pointer) m-main-memory-base-address)		;page zero
;;;	(call READ-ONE-BLOCK)
;;;
;;;	(jump-xct-next GET-NEXT-WORD)
;;;       ((a-mcr-address) m+a+1 m-zero a-mcr-address)


DONE-LOADING
;;; clean up and jump into main microcode
;;; if menu boot, save selected mcr & lod names in the label (only for disks)
;;; if warm boot, restore memory used for label and partition table
;;; finally, copy pdl buffer into a/m memories

	;; turn on control store parity checking that was disabled during load
	((m-hunoz) mcr)
	((mcr) dpb m-ones (byte-field 1 12.) a-hunoz)

	(jump if-not-equal m-boot-type a-menu-boot RESTORE-MEMORY)
	(jump if-not-equal m-boot-device-type a-zero RESTORE-MEMORY)	;disk type = 0

	;; update default partition names in label
;;; +++ we may not want to do this but currently the RAM isn't looking at the
;;; +++ a-memory boot info so this is the only way to pass selections
;;; +++ NOTE: this means that we can only select from the default disk 
	((md) a-boot-lod-name)
	((vma-start-unmapped-write) add m-main-memory-base-address a-hex-40)
	(call if-page-fault error-page-fault)
	((md) a-boot-mcr-name)
	((vma-start-unmapped-write) add vma a-hex-4)		
	(call if-page-fault error-page-fault)

	;; now write the updated label
	((a-buffer-pointer) m-main-memory-base-address)
	((a-device-address) a-device-label-address)
	(call WRITE-ONE-BLOCK)

RESTORE-MEMORY
;;;	(jump if-not-equal m-boot-type a-warm-boot COPY-PDL-BUFFER)
;;;
;;;	;; Read back page 0 of physical memory, which we saved on block 1.
;;;	((a-buffer-pointer) m-main-memory-base-address)		;page zero
;;;	((a-device-address) a-device-save-address)
;;;	(call READ-ONE-BLOCK)
;;;
;;;	;; Read back the pages that were overwritten by the partition table
;;;	;; partition table in memory starting at page 2
;;;	((a-buffer-pointer) a-ptable-memory-address)
;;;	((a-device-address) a-store-block-address)
;;;	((a-transfer-count) a-ptable-length)
;;;	(call READ-N-BLOCKS)
	

COPY-PDL-BUFFER
;;; copy pdl buffer into a/m memory and jump into i-memory
;;; a-ram-entry-point was set by SPECIAL-MAIN-MEM-SECTION - store it
;;; in q-r before we fill a memory.
;;; !!! don't touch the last four locations of a-memory
;;; !!! they are reserved to contain boot info passed to main microcode

	((q-r) a-ram-entry-point)	;destroyed soon so save here
	((pdl-buffer-index) setz)

FILL-M-LOOP
	((imod-low) dpb pdl-buffer-index %imod-low-m-dest a-zero)
	((m-garbage) c-pdl-buffer-index)
	((pdl-buffer-index) m+1 pdl-buffer-index)
	(jump if-bit-clear (byte-field 1 6) pdl-buffer-index FILL-M-LOOP)

	;; we are now ready to dump a-memory but only dump up to location #x3FC
	;; >>> NOTE: Since we use m-hunoz, this trashes whatever is in location 1 
	;; >>> of m-memory.  I believe this doesn't matter.

	((m-hunoz) dpb m-ones (byte-field 8. 2) a-zero)

FILL-A-LOOP
	((imod-low) dpb pdl-buffer-index %imod-low-a-dest a-zero)
	((a-garbage) c-pdl-buffer-index)
	((pdl-buffer-index) m+1 pdl-buffer-index)
;	(jump if-not-equal pdl-buffer-index a-zero FILL-A-LOOP)
	(jump if-less pdl-buffer-index a-hunoz FILL-A-LOOP)


ENTER-RAM
;;; transfer to cold boot routines loaded from the mcr partition
;;; q-r has ram entry point from SPECIAL-MAIN-MEM-SECTION
;;; NOTE: It is up to the system microcode to examine the keyboard and/or 
;;; the a-boot-request variable to determine what kind of boot has
;;; occurred.

	((M-Zero) Setz)
	((M-Ones) Seto)
	;; Transfer to RAM.  Entry address in Q-R.
	((MD) M-A-1 Q-R A-Zero)	
	((M-Hunoz) MCR)
	((IMOD-Low) DPB %imod-low-new-micro-pc MD)
	(Jump-Xct-Next 0)
       (And-Skip
	  (MCR) DPB (Byte-Field 1. 11.) M-Ones A-Hunoz) ; prom disable.
	(No-Op)                 ; This may not be needed 3/6/84 mja
	(No-Op)


READ-LABEL
;;; Read the boot device label into physical memory page zero and extract useful parameters
;;; a-boot-unit must be set up 
;;; the label is currently assumed to be at block zero on the boot device

	;; we may want to make these soft someday 
	((a-device-label-address) setz)
	((a-device-save-address) a-hex-1)

;;;	(jump if-not-equal m-boot-type a-warm-boot READ-FIRST-PAGE)
;;;
;;;	;; on a warm boot, save page zero
;;;	((a-buffer-pointer) m-main-memory-base-address)
;;;	((a-device-address) a-device-save-address)  
;;;	(call WRITE-ONE-BLOCK)

READ-FIRST-PAGE
	((a-buffer-pointer) m-main-memory-base-address)
	((a-device-address) a-device-label-address)
	(call READ-ONE-BLOCK)

DECODE-LABEL
	;; First word must be ascii 'LABL'
	(call-xct-next READ-I-MEMORY-STRING)
       ((m-b) a-hex-1A)					;LABL
	((vma-start-unmapped-read) m-main-memory-base-address)	
	(call if-page-fault error-page-fault)
	(jump-xct-next if-not-equal md a-string-low NON-FATAL-ERROR)
       ((a-error-code) a-invalid-label)

	;; ??? we could check version number and make sure the 
	;; ??? label device matches the nupi device type 

	;; get name of default system load and microload
	((vma-start-unmapped-read) add m-main-memory-base-address a-hex-40)
	(call if-page-fault error-page-fault)
	((a-default-lod-name) md)
	((vma-start-unmapped-read) add vma a-hex-4)
	(call if-page-fault error-page-fault)
	((a-default-mcr-name) md)

	;; get the name of the partition table partition
	;; currently 'PTBL'
	((vma-start-unmapped-read) add m-main-memory-base-address a-hex-50)  ; byte 80.
	(call if-page-fault error-page-fault)
	((m-1) md)

	;; Get the address of the save store and its length
	;; currently at block 3 & 1 block long
	((vma-start-unmapped-read) add m-main-memory-base-address a-hex-74)  ; byte 116.
	(call if-page-fault error-page-fault)
	((a-store-block-address) md)
	((vma-start-unmapped-read) add vma a-hex-4)
	(call if-page-fault error-page-fault)
	((m-tem) md)

	;; Get the address of the partition table and its length
	;; currently at block 2 & 1 block long
	((vma-start-unmapped-read) add m-main-memory-base-address a-hex-54)  ; byte 84.
	(call if-page-fault error-page-fault)
	((m-2) md)
	((vma-start-unmapped-read) add vma a-hex-4)			   ; byte 88.
	(call if-page-fault error-page-fault)
	((a-ptable-length) md)
	
	;; the save store must be at least as large as the partition table	
	(jump-xct-next if-greater-than md a-tem NON-FATAL-ERROR)
       ((a-error-code) a-small-save-area)

;;;	(jump if-not-equal m-boot-type a-warm-boot READ-PARTITION-TABLE)
;;;
;;;	;; On warm boot, save the pages used by the partition table
;;;	((a-buffer-pointer) a-ptable-memory-address)
;;;	((a-device-address) a-store-block-address)
;;;	((a-transfer-count) a-ptable-length)
;;;	(call WRITE-N-BLOCKS)
	
READ-PARTITION-TABLE
	;; Read the partition table
	((a-buffer-pointer) a-ptable-memory-address)
	((a-device-address) m-2)
	((a-transfer-count) a-ptable-length)
	(call READ-N-BLOCKS)

	;; make sure this is a valid partition table
	;; First word must contain the partition table name read from the label
	((vma-start-unmapped-read) a-ptable-memory-address)
	(call if-page-fault error-page-fault)
;;;+++ This currently contains 'PRTN' which doesen't match the string 'PTBL'
;;;+++ found in the label.  Until this is corrected, don't check.
;;;	(jump-xct-next if-not-equal md a-1 NON-FATAL-ERROR)
;;;       ((a-error-code) a-invalid-ptable)
	
	;; Get the number of partition descriptors (currently 7)
	((vma-start-unmapped-read) add vma a-hex-8)	;byte 8. of ptable	
	(call if-page-fault error-page-fault)
	((a-number-of-partitions) md)

	;; Get the number of bytes per partition descriptor (currently 8)
;;;+++ This is currently stored as length in words instead of bytes.
;;;+++ Convert it to bytes.
	((vma-start-unmapped-read) add vma a-hex-4)	;byte 12. of ptable
	(call if-page-fault error-page-fault)
;;;	((a-partition-descriptor-size) md)
	((a-partition-descriptor-size) dpb md (byte-field 30. 2) a-zero) ;times 4

	;; Get the byte offset to partition comment (currently 4)
;;;+++ This also seems to be stored in words instead of bytes.
	((vma-start-unmapped-read) add vma a-hex-4)	;byte 16. of ptable
	(call if-page-fault error-page-fault)
;;;	((a-offset-to-partition-comment) md)
	((a-offset-to-partition-comment) dpb md (byte-field 30. 2) a-zero) ;times 4

	;; Calculate partition comment size
	((m-tem) a-partition-descriptor-size)
	((a-partition-comment-length) sub m-tem a-offset-to-partition-comment)

	;; The first partition entry should start at word 16. of the ptable.
	(popj)



;;; Routines used to build menus

;;;DISPLAY-DEVICE-INFORMATION
;;;;;; This routine will print the device type string and the unit number
;;;;;; for the device currently specified in a-boot-unit & m-boot-device-type
;;;;;; Draw position must be set up before calling.
;;;;;; m-b is used
;;;
;;;	;; determine appropriate string for boot device type
;;;        ((m-b) a-hex-16)
;;;	(jump if-equal m-boot-device-type a-zero DISPLAY-DEVICE-TYPE)	;disk type = 0
;;;
;;;	;; If this isn't a disk assume its a tape (device type 2)
;;;	((m-b) a-hex-17)
;;;;;;	(jump if-equal m-boot-device-type a-hex-1 DISPLAY-DEVICE-TYPE)
;;;;;;
;;;;;;	;; this is an unknown device type so print its numeric type 
;;;;;;	;; followed by some question marks
;;;;;;	(call-xct-next DRAW-16-BIT-NUMBER)
;;;;;;       ((m-b) m-boot-device-type)
;;;;;;
;;;;;;	((m-draw-column) add m-draw-column a-hex-1)	;leave a space
;;;;;;	((m-b) a-hex-18)				;string containing q marks
;;;
;;;DISPLAY-DEVICE-TYPE
;;;	;; draw the device type string determined above (m-a has id)
;;;	(call DRAW-STRING)
;;;
;;;	;; display the unit number of the device & return
;;;	((m-draw-column) m+1 m-draw-column)			;leave a space
;;;	(jump-xct-next DRAW-8-BIT-NUMBER)			
;;;       ((m-b) a-boot-unit)


DISPLAY-PARTITION-INFORMATION
;;; Display the name and comment for a partition in the ptable.
;;; M-C has start of partition entry in memory.

	((a-string-address) m-c)
        ((a-string-length) a-hex-4)
	(call DRAW-MAIN-MEMORY-STRING)				;draw the partition name

;;;	;; draw a colon
;;;	(call-xct-next DRAW-CHAR)
;;;       ((a-char-code) dpb m-ones (byte-field 2 4) a-hex-A)	;x3A = ':'

	((m-draw-column) add m-draw-column a-hex-2)		;leave two spaces
	((a-string-address) add m-c a-offset-to-partition-comment)
	((a-string-length) a-partition-comment-length)
	(jump DRAW-MAIN-MEMORY-STRING)				;jump & return


BUILD-MENU-FROM-LABEL
;;; m-a has the name of the default partition
;;; m-b contains a partition type code
;;; scan the device label for partitions of this type and print information about them
;;; uses level 2 registers
;;; returns :
;;;   m-a = number of menu entries generated
;;;   m-cursor-row = row containing default partition 
;;;   a-default-entry = same as m-cursor-row

	((m-a1) m-a)				;save default partition name
	((m-cursor-row) a-first-menu-row)	;initial cursor row
	((m-a) setz)				;initial partition index

BUILD-MENU-LOOP
	(call LOCATE-PARTITION-INFO)
	(popj if-equal m-c a-ones)		;no more partitions ?

	;; if this is the default partition, set the initial cursor to this row
	;; also print a '*' in the preceeding column
	((vma-start-unmapped-read) m-c)
	(no-op)
	(call if-equal md a-a1 SET-MENU-DEFAULT)
	(call DISPLAY-PARTITION-INFORMATION)
	(call NEW-LINE)

	(jump-xct-next BUILD-MENU-LOOP)
       ((m-a) m+1 m-a)


SET-MENU-DEFAULT
;;; Here to place an asterisk next to the default selection on
;;; a menu.  Also set the initial cursor row to the current row.
;;; a-default-entry gets the menu entry number of the default selection.

	((m-draw-column) m-a-1 m-draw-column a-zero)		;back up one space
	(call-xct-next DRAW-CHAR)
       ((a-char-code) dpb m-ones (byte-field 1 5) a-hex-A)	;x2A = '*'

	(and-popj-xct-next (m-cursor-row) m-draw-row)
       ((a-default-entry) sub m-draw-row a-first-menu-row)


LOCATE-NAMED-PARTITION-INFO
;;; Find information for a partition of a given name.
;;; M-A has the name of the partition to find.

	((m-b) seto)
	;; fall in

LOCATE-PARTITION-INFO
;;; find information for a partition in the disk partition table
;;; partition table must be in memory at a-ptable-memory-address
;;; uses level 3 registers
;;; this routine can be used in two ways (I know its bad but it saves code . . . )
;;; WAY 1 : find the Nth a partition of a given type
;;;           m-a = partition number
;;;           m-b = partition type
;;;
;;; WAY 2 : find a partition with a given name
;;;           m-a = partition name
;;;           m-b = -1 (indicates a name search)
;;; RETURNS :
;;;   m-c = address of ptable entry for desired partition (-1 if not found)

	((m-c) a-ptable-memory-address)
	((m-c) add m-c a-hex-40)				;offset to first ptable entry
	((m-b1) m-a)						;save partition index
	((m-b2) setz)						;total partition count

CHECK-PARTITION-LOOP
	(jump if-not-equal m-b a-ones CHECK-PARTITION-TYPE)

	;; compare partition names
	((vma-start-unmapped-read) m-c)				;read name
	(call if-page-fault error-page-fault)
	(popj if-equal md a-a)
	(jump NEXT-PARTITION)

CHECK-PARTITION-TYPE
	((vma-start-unmapped-read) add m-c a-hex-C)		;attribute word (byte 12.)
	(call if-page-fault error-page-fault)
	((m-tem) (byte-field 4 0) md)
	(jump if-not-equal m-tem a-b NEXT-PARTITION)

	;; a partition of the desired type has been found 
	;; return if this is the one we are looking for
	(popj if-equal m-b1 a-zero)
	((m-b1) add m-b1 a-ones)

NEXT-PARTITION
	((m-c) add m-c a-partition-descriptor-size)
	((m-b2) m+1 m-b2)
	(jump if-less-than m-b2 a-number-of-partitions CHECK-PARTITION-LOOP)

	;; couldn't find the desired partition -- return -1
	(and-popj (m-c) seto)




MAKE-SELECTION
;;; make a selection from the menu choices currently displayed
;;; m-a has the number of choices displayed
;;; m-cursor-row has initial cursor position 
;;; return the selection number in m-a (relative to first menu row)
;;; return -1 if abort key pressed
;;; terminating key is returned in m-menu-key (return, enter, or abort)
;;; a-input-timeout has a positive timeout counter, < 0 to disable timeout
;;; uses level 2 registers

	;; display documentation line below menu
	((m-draw-row) add m-draw-row a-hex-1)		;leave one empty line
	((m-draw-column) a-hex-0)			;start in column 0
	(call-xct-next DRAW-STRING)
       ((m-b) a-hex-1C)

	(jump if-equal m-zero a-keydoc-flag DISPLAY-PENDING-ERRORS) 
	((m-draw-column) m+1 m-draw-column)
	(call-xct-next DRAW-STRING)
       ((m-b) dpb m-ones (byte-field 1 2) a-hex-20)	;x24 "ABORT = PREVIOUS MENU"

DISPLAY-PENDING-ERRORS
	;; If any error messages are pending, display them
	((m-draw-row) add m-draw-row a-hex-2)
	((m-draw-column) setz)
	(call-xct-next if-not-equal m-zero a-pending-error DISPLAY-ERROR-MESSAGE)
       ((a-error-code) a-pending-error)

MAKE-SELECTION-INIT
	;; this will give about a 15. sec timeout period
;;;	((a-input-timeout) dpb m-ones (byte-field 1 15.) a-zero)

	((m-a1) add m-a a-first-menu-row)
	((m-a1) sub m-a1 a-hex-1)	;highest allowable cursor row number
	((m-a) m-cursor-row)		;set new cursor row to current row
	((a-cursor-char) a-hex-20)	;set up for space cursor initially
	((m-a2) setz)			;zero blink counter so we draw immediately
	
INPUT-LOOP
;;; Get a keystroke and process it.
;;; Check for user input timeout.  If timeout, automatically select the item
;;; the cursor is on.  Also check for cursor blink timeout and redraw cursor
;;; if necessary.

	(jump if-greater m-zero a-input-timeout CHECK-CURSOR-BLINK)	;timeout disabled ?

	;; decrement timeout counter
	((a-input-timeout) add m-ones a-input-timeout)
	(jump if-not-equal m-zero a-input-timeout CHECK-CURSOR-BLINK)

	;; user input has timed out
	((m-a) sub m-cursor-row a-first-menu-row)		;return selection
	(popj)

CHECK-CURSOR-BLINK
	((m-a2) add m-a2 a-ones)		;decrement blink counter
	(jump if-greater m-a2 a-zero CHECK-CURSOR-MOVEMENT)
	;; blink timer has counted down, change cursor character
	((m-tem) a-cursor-char)
	((a-cursor-char) xor m-tem a-hex-20)	;toggle between zero and x20
	(call MOVE-CURSOR)			;draw the new cursor
	((m-a2) a-hex-200)			;reset counter
	
CHECK-CURSOR-MOVEMENT
	;; only redraw the cursor if it has moved
	(jump if-equal m-a a-cursor-row READ-USER-INPUT)
	(call MOVE-CURSOR)		;m-a has new row
	((m-cursor-row) m-a)		;update cursor position

READ-USER-INPUT
	(call GET-KEYBOARD-CHARACTER)	;key code returned in md
	((m-menu-key) md)
	(jump if-equal md a-hex-FF INPUT-LOOP)	;no key available

	;; a key has been pressed, disable timeout (or reset it ??)
	((a-input-timeout) seto)					;disable timeout
;;;	((a-input-timeout) dpb m-ones (byte-field 1 15.) a-zero)	;reset timeout

	;; check for the return key (x0D)
	(jump if-not-equal md a-hex-D CHECK-UP-ARROW)
	((m-a) sub m-cursor-row a-first-menu-row)			;return selection
	(popj)

CHECK-UP-ARROW
	;; the up arrow key is mapped into control P (x10)
	(jump if-not-equal md a-hex-10 CHECK-DOWN-ARROW)
	(jump if-less-or-equal m-cursor-row a-first-menu-row INPUT-LOOP)
	((m-a) sub m-cursor-row a-hex-1)
	(jump INPUT-LOOP)

CHECK-DOWN-ARROW
	;; the down arrow key is mapped into control N (x0E)
	(jump if-not-equal md a-hex-E CHECK-ABORT)
	(jump if-greater-or-equal m-cursor-row a-a1 INPUT-LOOP)	
	((m-a) add m-cursor-row a-hex-1)
	(jump INPUT-LOOP)
	
CHECK-ABORT
	;; the abort key is mapped into escape (x1B)
	(jump if-not-equal md a-hex-1B UNKNOWN-KEY)
	((m-a) m-ones)
	(popj)

UNKNOWN-KEY
	;; this label is really only for testing purposes
	;; it should eventually go away
	(jump INPUT-LOOP)



;;; Display related routines

MOVE-CURSOR
;;; move the cursor to a new location
;;; m-a contains the new cursor row, m-cursor-row has the old one
;;; the cursor will always appear in the same column to the left of the menu
;;; destroys m-draw-row & m-draw-column
;;; !!! note this does not update m-cursor-row

	;; first erase the current cursor
	((m-draw-row) m-cursor-row)
	((m-draw-column) a-hex-2)		;draw cursor in column two
	(call-xct-next DRAW-CHAR)
       ((a-char-code) a-hex-20)			;ascii code for space	

	;; now draw the new cursor
	((m-draw-row) m-a)
	((m-draw-column) a-hex-2)

	(jump if-equal m-zero a-cursor-char DRAW-CURSOR)
	(jump-xct-next DRAW-CHAR)
       ((a-char-code) a-cursor-char)


NEW-LINE
;;; set the current draw position to the start of the next line
;;; a-rows-per-screen has the maximum number of rows supported

	((m-draw-column) a-first-menu-column)
	(popj if-greater-or-equal m-draw-row a-rows-per-screen)
	(and-popj (m-draw-row) m+1 m-draw-row)


DRAW-MAIN-MEMORY-STRING
;;; draw a string stored in main memory
;;; a-string-address has nubus address
;;; a-string-length  has number of bytes

DRAW-MAIN-MEMORY-STRING-LOOP
	(call-xct-next NUBUS-BYTE-READ)
       ((vma) a-string-address)
	(call if-page-fault error-page-fault)
	(call-xct-next DRAW-CHAR)
       ((a-char-code) md)
	((a-string-address) m+a+1 m-zero a-string-address)
	((a-string-length) add m-ones a-string-length)
	(jump if-less m-zero a-string-length DRAW-MAIN-MEMORY-STRING-LOOP)
	(popj)


DRAW-STRING
;;; Draw a string that is stored in the string space of i-memory ROM.
;;; Strings are stored little endian and have a maximum of 6 characters
;;; per i-memory word.  Strings are terminated by a byte containing zero.

	(call READ-I-MEMORY-STRING)		;m-b has address
	(call-xct-next DRAW-STRING-WORD-4)
       ((m-c) m-string-low)
	(popj if-equal m-zero a-char-code)
	(call-xct-next DRAW-STRING-WORD-2)
       ((m-c) a-string-high)
	(jump-xct-next if-not-equal m-zero a-char-code DRAW-STRING)
       ((m-b) m+1 m-b)
	(popj)


READ-I-MEMORY-STRING
;;; m-b has i-mem address
;;; m-string-low & a-string-high are loaded from memory

	((m-tem) add m-b a-string-space)

	;; read high bits <55:32>
	((imod-low) dpb m-tem %imod-low-new-micro-pc a-zero)
        (ACCESS-I-MEM)
	(READ-I-MEM (A-STRING-HIGH))	;garbage is left in the high 5 bytes!

	;; read low bits <31:00>
	((imod-low) dpb m-tem %imod-low-new-micro-pc a-zero)
        (ACCESS-I-MEM)
	(READ-I-MEM (M-STRING-LOW))
	
	;; The hardware does not store into a-string-low with the above
	;; instruction.  The next instruction should put it there.
	((m-string-low) m-string-low)

	(popj)


DRAW-STRING-WORD-4
;;; m-c has a string with up to 4 characters
;;; draw characters until byte of zeros is encountered

	((m-b2) a-hex-8)
	(jump DRAW-STRING-START)

DRAW-STRING-WORD-2
;;; m-b has a string with up to 2 characters
	((m-b2) a-hex-18)
	;; fall in

DRAW-STRING-START
	((m-b1) a-hex-20)

DRAW-STRING-WORD-LOOP
	((imod-low) dpb m-b1 %imod-low-mrot a-zero)				
	((a-char-code) ldb (byte-field 8 0) m-c)
	(popj if-equal m-zero a-char-code)
	(call DRAW-CHAR)
;;;	(jump-xct-next if-greater m-b1 a-hex-8 DRAW-STRING-WORD-LOOP)
	(jump-xct-next if-greater m-b1 a-b2 DRAW-STRING-WORD-LOOP)
       ((m-b1) sub m-b1 a-hex-8)
	(popj)


;;; Number Drawing Routines:
;;; m-b contains a number that is printed in hexadicamal form
;;; In order to eleminate unecessary leading zeros, numbers can
;;; be drawn with either 16 bits of precesion (4 hex digits) as well as
;;; 32 bits of precision (8 hex digits).


;;;DRAW-32-BIT-NUMBER
;;;;;; m-b1 gets the mrot field to LDB the digit at (byte-field 4 28.)
;;;
;;;	((m-b1) a-hex-4)
;;;	(jump DRAW-NUMBER)

DRAW-16-BIT-NUMBER
;;; m-b1 gets mrot field to LDB the digit at (byte-field 4 12.)

	((m-b1) a-hex-14)
	(jump DRAW-NUMBER)

DRAW-8-BIT-NUMBER
;;; m-b1 get mrot field to LDB the digit at (byte-field 4 4)
 	((m-b1) a-hex-1C)
	;; fall in

DRAW-NUMBER
;;; m-b contains a number
;;; m-b1 has mrot field to start extracting digits

	;; extract a digit
	((imod-low) dpb m-b1 %imod-low-mrot a-zero)
	((m-b2) ldb (byte-field 4 0) m-b)
	
	((m-tem) add m-b2 a-hex-30)	;ascii code for '0'
	(jump if-less-than m-b2 A-HEX-A DRAW-CONVERTED-DIGIT)
	((m-b2) sub m-b2 a-hex-A)
	((m-tem) add m-b2 a-hex-41)	;ascii code for 'A'
DRAW-CONVERTED-DIGIT
	(call-xct-next DRAW-CHAR)
       ((a-char-code) m-tem)

	;; do next digit
	((m-b1) add m-b1 a-hex-4)
	(jump if-less-or-equal m-b1 a-hex-20 DRAW-NUMBER)

	(popj)


DISPLAY-MENU-HEADER
;;; Print the title line for a given menu.
;;; Menu type code in m-a.
;;; Leave m-draw-row two line after the last line of the header and
;;; Set a-first-menu-row.
;;; If a-pending-error has a non zero value, print an error message
;;; at the top of the screen.

	(call INIT-DISPLAY)

DISPLAY-INITIAL-MENU-HEADER
;;; special entry point for the initial menu that avoids clearing the screen

	(call-xct-next DRAW-STRING)
       ((m-b) setz)			;SELECT
	(call-xct-next DRAW-STRING)     ;menu type passed in
       ((m-b) m-a)
	(jump if-less m-a a-hex-6 DISPLAY-MENU-HEADER-RETURN)
	;; system, microcode, or diagnostic menu
	(call-xct-next DRAW-STRING)
       ((m-b) a-hex-C)			;PARTITION

DISPLAY-MENU-HEADER-RETURN
	((m-draw-row) add m-draw-row a-hex-2)
	(and-popj-xct-next (a-first-menu-row) m-draw-row)
       ((m-draw-column) a-first-menu-column)


DISPLAY-BOOT-TYPE
;;; used by the first menu 
;;; m-a has string code for boot type
;;; draw specified string followed by the string "BOOT"

	(call-xct-next DRAW-STRING)
       ((m-b) m-a)
	(jump-xct-next DRAW-STRING)	;jump & return
       ((m-b) a-hex-11)



DISPLAY-BOOT-DEFAULTS
;;; Print the names of the default unit, mcr & lod partitions.
;;; This is much less fancy than the original version which
;;; displayed the partition comments.  This however required
;;; that the default device be initialized and that the label be read.
;;; This presents numerous problems at this stage of the boot.
;;; *** NOTE: currently this prints the device number as the physical 
;;; *** slot/unit encoding.

	;; The string "BOOT " already has a trailing space
;;;;;;	((m-draw-column) m+1 m-draw-column)			;leave a space
;;;	(call-xct-next DRAW-CHAR)
;;;       ((a-char-code) dpb m-ones (byte-field 1 5) a-hex-8)	;x28 = '('
;;;	(call-xct-next DRAW-STRING)
;;;       ((m-b) a-hex-4)						;"DEVICE "
;;;	(call-xct-next DRAW-16-BIT-NUMBER)
;;;       ((m-b) a-boot-device)
;;;;;;	(call-xct-next DRAW-CHAR)
;;;;;;       ((a-char-code) dpb m-ones (byte-field 1 5) a-hex-C)	;x2C = ','
;;;;;;	((m-draw-column) m+1 m-draw-column)			;leave a space
;;;;;;	(call-xct-next DRAW-STRING-WORD-4)			;mcr partition name
;;;;;;       ((m-c) a-boot-mcr-name)
;;;;;;	(call-xct-next DRAW-CHAR)
;;;;;;       ((a-char-code) dpb m-ones (byte-field 1 5) a-hex-C)	;x2C = ','
;;;;;;	((m-draw-column) m+1 m-draw-column)			;leave a space
;;;;;;	(call-xct-next DRAW-STRING-WORD-4)			;lod partition name
;;;;;;       ((m-c) a-boot-lod-name)
;;;	(jump-xct-next DRAW-CHAR)				;jump & return
;;;       ((a-char-code) dpb m-ones (byte-field 1 5) a-hex-9)	;x29 = ')'
	


;;; miscellaneous stuff

ERROR-PAGE-FAULT
;;; called whenever an illegal page fault is detected
;;; calls fatal-error with page fault error code

	((a-error-code) a-page-fault)
	;; fall in

FATAL-ERROR
;;; a-error-code has an error number
;;; Display an error message on the monitor

;;;	;; invert sence of bits to turn on leds
;;;	((m-1) dpb m-ones (byte-field 6 0) a-zero)			;x3F
;;;	((m-1) xor a-error-code a-1)					;invert bits
;;;	((m-1) ldb (byte-field 6 0) m-1)				;extract field
;;;	((mcr) selective-deposit mcr (byte-field 25. 7) a-1)		;turn them on
	
	;; display an error message in the upper left hand corner
	((m-draw-row) setz)
	((m-draw-column) setz)
	(call DISPLAY-ERROR-MESSAGE)

DEATH	(jump HALT DEATH)


NON-FATAL-ERROR
;;; Here for problems encountered during loading or displaying menus.
;;; Jump back to the initial menu and display an error message at the top.
;;; This is only for errors that occurr after the initial menu has been displayed.

	(jump-xct-next SELECT-BOOT-TYPE-AGAIN)
       ((a-pending-error) a-error-code)


DISPLAY-ERROR-MESSAGE
;;; Display an error message on the top row of the screen.
;;; a-error-code is set, m-draw-row & m-draw-column are set
;;; clears a-pending-error

	;; Crash if the monitor has problems
	(jump if-equal m-ones a-monitor-slot ERROR-NO-MONITOR)

	(call-xct-next DRAW-STRING)
       ((m-b) a-hex-1B)				;ERROR
	((m-draw-column) m+1 m-draw-column) 	;leave a space
	(call-xct-next DRAW-8-BIT-NUMBER)	;error code
       ((m-b) a-error-code)

	(and-popj (a-pending-error) setz)


DELAY
;;; Used by various routines to delay for awhile
;;; a-delay-count has a count down value (should be > 0)

	(jump-xct-next if-less m-zero a-delay-counter DELAY)
       ((a-delay-counter) add m-ones a-delay-counter)
	(popj)


MULTIPLY
;;; multiply two numbers
;;; m-mpy-1<31:12> contains one number
;;; q-r<11:0> contains the other
;;; result returned in m-mpy-result

	((m-mpy-result) multiply-step a-mpy-1 m-zero)
	((m-tem) a-hex-8)
MULTIPLY-LOOP
        ((m-mpy-result) multiply-step m-mpy-result a-mpy-1)
	(jump-xct-next if-greater m-tem a-zero MULTIPLY-LOOP)
       ((m-tem) m-a-1 m-tem a-zero)

;;;(repeat 9 ((m-mpy-result) multiply-step m-mpy-result a-mpy-1))
	(and-popj-xct-next (m-mpy-result) multiply-step m-mpy-result a-mpy-1)
       ((m-mpy-result) multiply-step m-mpy-result a-mpy-1)



;;;READ-4BYTE-WORD
;;;;;; read a word split up over 4 NuBus words into MD
;;;;;; certain areas of NuBus memory such as the configuration ROM and NVRAM
;;;;;; contain 4-byte fields that are segmented over 4 words of NuBus address space
;;;;;; the low order byte of each word contains the corresponding byte
;;;;;; for the segmented field
;;;;;; vma contains the NuBus address of the word containing the first byte
;;;
;;;	((m-temp-1) setz)
;;;	((vma) sub vma a-hex-4)
;;;READ-WORD-LOOP
;;;	((vma-start-unmapped-read) add vma a-hex-4)
;;;	(call if-page-fault error-page-fault)
;;;	((imod-low) dpb m-temp-1 %imod-low-mrot a-zero)
;;;	((m-temp-2) dpb md (byte-field 8 0) a-temp-2)
;;;	(jump-xct-next if-less-than m-temp-1 a-hex-18 READ-WORD-LOOP)
;;;       ((m-temp-1) add m-temp-1 a-hex-8)
;;;
;;;	;; restore vma to its original value, set md and return
;;;	((vma) sub vma a-hex-10) 
;;;	(and-popj (md) m-temp-2)
;;;
;;;
;;;CONVERT-WEIGHTED-LOG2
;;;;;; some numbers in the configuration rom are stored in weighted log2 format
;;;;;; the most significant 4 bits of the byte hold the mantissa 
;;;;;; the least significant 4 bits hold the 2's exponent
;;;;;; m-a has the encoded byte; return number in m-a
;;;;;; uses temporaries
;;;;;; currently used only to find the number of bytes on memory boards
;;;;;;! CAUTION - NOT SIMULATED
;;;
;;;	((m-temp-1) ldb (byte-field 4 4) m-a)	;mantissa
;;;	((m-temp-2) ldb (byte-field 4 0) m-a)	;exponent
;;;	((imod-low) dpb m-temp-2 %imod-low-mrot)
;;;	((m-a) dpb m-temp-1 (byte-field 4 0))	;mantissa LSH by exponent
;;;	(popj)



;;; *************************************************************************
;;;
;;; Device Driver support routines & routines that use DDR calls
;;;
;;; *************************************************************************

KEYBOARD-DDR
;;; set up a call to the keyboard device driver
;;; m-ddr-function has desired function index

	((m-ddr-slot)     a-keyboard-slot)
	((m-ddr-class)    a-hex-20)		;keyboard resource bit = 5
	(jump PERFORM-DDR-OPERATION)

MONITOR-DDR
;;; set up a call to the monitor device driver
;;; m-ddr-function has desired function index

	((m-ddr-slot)     a-monitor-slot)
	((m-ddr-class)    a-hex-8)		;monitor resource bit = 3
	(jump PERFORM-DDR-OPERATION)

BOOT-DEVICE-DDR
;;; set up a call to the disk controller device driver
;;; m-ddr-function has desired function index
;;; If we get DDR completion errors, display a message.

	((m-ddr-slot)     a-boot-device-slot)
	((m-ddr-class)    a-hex-2)		;disk resource bit = 1
	;; fall in

PERFORM-DDR-OPERATION
;;; Run a device driver routine with the diagnostic engine
;;; First find the address of the DDR code in the board's config rom.
;;; The first bytes in this code space contain a function table.
;;;
;;; m-ddr-slot     = slot of board to use
;;; m-ddr-class    = function class
;;; m-ddr-function = function index 
;;;
;;; sets up :
;;;  m-dei-board-space
;;;  m-dei-inst-space
;;;  m-dei-inst-pointer
;;;

	;; find instruction space for the DDR's on this board
 	((m-dei-board-space) dpb m-ddr-slot (byte-field 4 24.) a-hex-F0000000)

	;; ddr inst pointer at FsFFFF2C
	((m-tem) dpb m-ones (byte-field 16. 8.) a-hex-20)
	((m-tem) add m-tem a-hex-C)
	(call-xct-next GET-AN-OFFSET)
       ((m-tem) add m-dei-board-space a-tem)
	((m-dei-inst-space) m-tem)		;returned by get-an-offset

	(call PROCESS-DDR-INST-HEADER)

	;; scan function table (m-dei-inst-pointer left after inst header)

SCAN-FUNCTION-TABLE
	(call DEI-READ-INSTRUCTION)
	(jump if-not-equal md a-hex-FF CHECK-FUNCTION-CLASS)

	;; here if the end of the table was reached
	;; die if this is a monitor request, otherwise display a message
	(jump-xct-next if-not-equal m-ddr-slot a-monitor-slot FATAL-ERROR)
       ((a-error-code) a-ddr-request)
	(jump ERROR-DDR-REQUEST)

CHECK-FUNCTION-CLASS
	(jump if-equal md a-ddr-class FOUND-FUNCTION-CLASS)

	;; get the length of the vector area for this class
	(call DEI-READ-INSTRUCTION)
	(jump-xct-next SCAN-FUNCTION-TABLE)
       ((m-dei-inst-pointer) add md a-dei-inst-pointer)

FOUND-FUNCTION-CLASS
;;; We have located the vectors for a given class of functions
;;; Set the instruction pointer to the desired entry in the vector.
;;; The instruction pointer currently points at the vector length byte.

        ((m-dei-inst-pointer) m+a+1 m-dei-inst-pointer a-ddr-function)	
	(call-xct-next DIAGNOSTIC-ENGINE)
       ((m-dei-erex) seto)				;ignore bus errors

	;; check completion status -- die if non zero and halt enabled
	(call POP-DSTACK)
	(popj if-equal m-stack-1 a-zero)		;return if good completion

	;; completion error, do some magic
	;; +++ contains special hack to ignore completion errors 
	;; +++ on boot device ops that cause "media change" errors
	(jump if-not-equal m-ddr-slot a-boot-device-slot DDR-COMPLETION-ERROR)
	(popj if-equal m-ddr-function a-hex-2)
	
DDR-COMPLETION-ERROR
	(jump-xct-next if-not-equal m-ddr-slot a-monitor-slot NON-FATAL-ERROR)
       ((a-error-code) a-ddr-completion)
	(jump ERROR-DDR-COMPLETION)		;monitor error, die


;;; Disk related routines.

INITIALIZE-DEVICE-CONTROLLER
;;; perform any initializations required prior to using a controller
;;; Currently this sets the nubus master enable bit in the nupi
;;; configuration register.

	(jump-xct-next BOOT-DEVICE-DDR)
       ((m-ddr-function) setz)  	;initialize-BD-controller vector

;;;	;; config register address = FsE00008
;;;	((m-tem) a-boot-device-slot)
;;;	((m-tem) dpb m-tem (byte-field 4 24.) a-hex-F0000000)
;;;	((m-tem) dpb m-ones (byte-field 3 21.) a-tem)
;;;	((m-tem) dpb m-ones (byte-field 1 3)   a-tem)
;;;
;;;	;; Enable NUPI as a bus master.
;;;	((MD) dpb m-ones (byte-field 1 25.)) ; (Byte-Mask %%NUPI-CR-Bus-Master-Enable) => 02
;;;	((VMA-Start-Unmapped-Write) m-tem)
;;;	(No-Op)
;;;	(popj)


INITIALIZE-BOOT-DEVICE
;;; Initialize a given device on a controller
;;; For disk this usually means recalibration; for tapes, rewind
;;; pass unit number and scratch area address
;;; +++ We are having problems with the NUPI returning "Media Change" errors
;;; +++ when first attempting to access the tape.  If this occurrs, retry the
;;; +++ operation.  This problem should go away eventually.

	((a-device-current-position) setz)	;used for tapes only

	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) a-ddr-scratch-area)
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) a-boot-unit)

;;;	(jump-xct-next BOOT-DEVICE-DDR)
;;;       ((m-ddr-function) a-hex-2)		;initialize boot device vector

	;; +++ special hack in perform-ddr-operation to ignore completion
	;; +++ errors on this operation -- take out eventually
	(call-xct-next BOOT-DEVICE-DDR)
       ((m-ddr-function) a-hex-2)		;initialize boot device vector

	(popj if-equal m-stack-1 a-zero)	;return if no errors

	;; try the operation agai
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) a-ddr-scratch-area)
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) a-boot-unit)

	(jump-xct-next BOOT-DEVICE-DDR)
       ((m-ddr-function) a-hex-2)		;initialize boot device vector


GET-DEVICE-CONFIGURATION
;;; Find status of all devices attached to a controller
;;; a-boot-device-slot has controller slot id
;;; pass scratch area address
;;; returns address of configuration block

	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) a-ddr-scratch-area)

	(call-xct-next BOOT-DEVICE-DDR)
       ((m-ddr-function) a-hex-4)			;read configuration vector

	(call POP-DSTACK)
	(and-popj (a-device-configuration-area) m-stack-1)


;;; Routines to read and write from the boot device.

READ-ONE-BLOCK
	((a-transfer-count) a-hex-1)
READ-N-BLOCKS
	(jump-xct-next READ-WRITE-BOOT-DEVICE)
       ((a-write-flag) setz)


WRITE-ONE-BLOCK
	((a-transfer-count) a-hex-1)
WRITE-N-BLOCKS
	((a-write-flag) a-hex-1)
;;;	(jump if-equal m-boot-device-type a-hex-1 NON-FATAL-ERROR)
;;;      ((a-error-code) a-cant-write-to-tape)
	;; fall in

READ-WRITE-BOOT-DEVICE
;;; perform a read or write operation to the boot device
;;; parameters passed in a-memory variables
;;; If boot device is  tape, we must check to see if the
;;; tape must be forwarded before we read.  a-device-current-position
;;; has the block address to which the tape is currently positioned.
;;; +++ a-block-size should be set up to contain the number
;;; +++ of bytes per block -- read from disk label ??
;;; +++ hard code for now

	(jump if-not-equal m-boot-device-type a-hex-1 ISSUE-IO-REQUEST)

	;; Here if booting from tape -- check current tape position
	((m-stack-2) a-device-address)			;safe to use this ?
	((m-stack-2) sub m-stack-2 a-device-current-position)
;;;	(jump-xct-next if-less m-stack-2 a-zero NON-FATAL-ERROR)
;;;      ((a-error-code) a-cant-reverse-tape)
	(jump if-equal m-stack-2 a-zero ISSUE-IO-REQUEST)

	;; Here if we must forward the tape to the desired block
	(call-xct-next PUSH-DSTACK)  
       ((m-stack-1) a-ddr-scratch-area)         ; Address of scratch area
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) m-stack-2)			; Number of blocks to skip
	(call-xct-next PUSH-DSTACK)
;;;       ((m-stack-1) a-block-size)        	; Number of bytes per block
       ((m-stack-1) a-hex-400) 			; 1024. bytes per block
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) a-boot-unit)		; Device unit number

	((m-tem) a-device-current-position)
	((a-device-current-position) add m-tem a-stack-2)

	(call-xct-next BOOT-DEVICE-DDR)
       ((m-ddr-function) a-hex-8)		; Skip forward vector

ISSUE-IO-REQUEST
	(call-xct-next PUSH-DSTACK)  
       ((m-stack-1) a-ddr-scratch-area)         ; Address of scratch area
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) a-device-address)           ; Block number
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) a-transfer-count)           ; Number of blocks
	(call-xct-next PUSH-DSTACK)
;;;       ((m-stack-1) a-block-size)        	; Number of bytes per block
       ((m-stack-1) a-hex-400) 			; 1024. bytes per block
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) a-buffer-pointer)		; Memory address
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) a-boot-unit)		; Device unit number
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) a-write-flag)		; Read/Write flag

	;; advance block pointer before performing operation
	((m-tem) a-device-address)
	((a-device-current-position) add m-tem a-transfer-count)

	(jump-xct-next BOOT-DEVICE-DDR)
       ((m-ddr-function) a-hex-6)		; Read/Write vector



;;; Routines requiring monitor & keyboard DDR calls

INITIALIZE-MONITOR
;;; sets up the monitor board for use
;;; initializes video registers, resets interrupts etc. . . 
;;; Also determines the size of the screen and clears the screen.

	(call-xct-next MONITOR-DDR)
       ((m-ddr-function) setz)			;initialize-monitor vector

	(call-xct-next MONITOR-DDR)
       ((m-ddr-function) a-hex-4)		;get-display-size vector

	((a-first-menu-column) a-hex-5)		;seems like a good place to put this

	(call POP-DSTACK-2)
	((a-rows-per-screen) m-stack-1)
	((a-columns-per-row) m-stack-2)
	;; fall in

INIT-DISPLAY
;;; perform various display initializations prior to displaying a menu
;;; including clearing the screen

	((m-draw-row)    a-hex-1)		;leave a line for error messages 
	((m-draw-column) a-hex-0)
	((m-cursor-row)  a-hex-0)

CLEAR-SCREEN
	;; clear the screen
	(jump-xct-next MONITOR-DDR)
       ((m-ddr-function) a-hex-2)		;clear-display vector


DRAW-CHAR
;;; draw a character on the display
;;; a-char-code contains the character code to draw
;;; m-draw-row, m-draw-column have screen position
;;; DDR draws character and returns updated screen position
;;; Input  TOS = line number, column number, ascii code
;;; Output TOS = completion code, new line number, new column number
	
 	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) a-char-code)
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) m-draw-column)
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) m-draw-row)

 	(call-xct-next MONITOR-DDR)
       ((m-ddr-function) a-hex-6)			;draw-character vector

	(call POP-DSTACK-2)
	(and-popj-xct-next (m-draw-row) m-stack-1)
       ((m-draw-column) m-stack-2)


DRAW-CURSOR
;;; Draw the cursor character at the current draw position.
;;; Currently the DDR defines the cursor to be a block with all pixel set.
;;; Inputs  TOS = line number, column number
;;; Outputs TOS = completion code, line number, column number


 	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) m-draw-column)
 	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) m-draw-row)

	(call-xct-next MONITOR-DDR)
       ((m-ddr-function) a-hex-8)			;draw-cursor vector

	(call POP-DSTACK-2)
	(and-popj-xct-next (m-draw-row) m-stack-1)
       ((m-draw-column) m-stack-2)



INITIALIZE-KEYBOARD
;;; prepare the keyboard usart for use
;;; Returns keyboard flags in addition to a completion code.

	(call-xct-next KEYBOARD-DDR)
       ((m-ddr-function) setz)			;initialize-keyboard vector

	(call POP-DSTACK)
	(and-popj (a-keyboard-flags) m-stack-1)


GET-KEYBOARD-CHARACTER
;;; read a key from the keyboard
;;; return key in MD (-1 if no key available)
;;; DDR wants TOS = keyboard flags
;;; returns   TOS = completion code, keyboard flags, ascii code (-1 if none read)

	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) a-keyboard-flags)

	(call-xct-next KEYBOARD-DDR)
       ((m-ddr-function) a-hex-2)			;get-character vector

	(call POP-DSTACK-2)
	(and-popj-xct-next (a-keyboard-flags) m-stack-1)
       ((md) m-stack-2)



;;; ***************************************************************************
;;;
;;; Diagnostic Engine Interpretter & Associated Routines
;;;
;;; ***************************************************************************
;;; @@@

DEI-INITIALIZE
;;; Set up the initial DEI stack pointers.
;;; This routine must be called once before any DEI use is made.
;;; The high half of a-memory is used for the stacks.  
;;; The data stack begins at x200 and grows down.
;;; The rstack begins at x3FB and grows up.
;;; The heap space is allocated underneath the rstack.  The rstack origin
;;; is moved once the required amount of heap space is determined.
;;; Note the last 4 locations of a-memory are not used as these are reserved 
;;; for communication with the main microcode.

	((m-dei-dstack-origin) a-hex-200)
	((m-dei-dstack-pointer) m-dei-dstack-origin)

	((m-dei-data-space-origin) a-hex-3FB)

	((m-dei-rstack-origin)  m-dei-data-space-origin)
	((m-dei-rstack-pointer) m-dei-rstack-origin)

	((m-dei-erex)	          setz) ;bus error trap disabled
	((a-dei-nubus-error-flag) setz)	;haven't had any bus errors yet

	((a-dei-inst-breakpoint) seto)	;so we won't hit any breakpoints 

	(popj)


PROCESS-DIAGNOSTIC-INST-HEADER
;;; Here to decode the instruction space pointed to by the diagnostic offset.
;;; If the instruction space is invalid, don't crash, return ones in m-tem.

	(jump-xct-next PROCESS-DEI-INST-HEADER)
       ((m-dei-temp) setz)

PROCESS-DDR-INST-HEADER
;;; Here to decode the instruction space pointed to by the device driver offset.
;;; If the instruction space is invalid, we must crash.

	((m-dei-temp) seto)
	;; fall in

PROCESS-DEI-INST-HEADER
;;; The instruction space for self test or device driver has been found.
;;; Examine the instruction space header and make sure it is valid.
;;; The first word must contain the number 1 (indicates diagnostic engine).
;;; The second word contains information on how the instruction space is to 
;;; be accessed.  The above two words of header are always stored one byte per
;;; word.  The rest of the inst space may be stored differently.  The second byte
;;; of the header contains the instruction increment for the remainder of the 
;;; instruction space (eg. increment of 1 = 4 bytes per byte, 2 = byte per halfword,
;;; 4 = byte per word).
;;;
;;; The byte following the two header words make up the instruction space.
;;; m-dei-inst-space is set to address this location.  All references to this space
;;; are made using a-dei-inst-pointer which is modified with m-dei-inst-increment.
;;;
;;; The instruction space is formatted as follows:
;;; The first byte contains the version number (currently an ascii code)
;;; The next two bytes have the required data space size.
;;; 
;;; Following this are one or more resource vectors as follows:
;;;   First byte   - resource type 
;;;   Second byte  - vector length (offset to next resource vector)
;;;   Next n bytes - ddr vectors for the current resource
;;;
;;; The last resource vector is followed by a word of ones.
;;; Code for dei routines follows the resource vectors.
;;;
;;; Allocate the data space under the Rstack and set up the special 
;;; dspace locations required by the self test routines.
;;; Word 0 - self test completion status (set to -1)
;;; Word 1 - Fs000000 for board under test
;;; Word 2 - NuBus address of some memory (m-main-memory-base-address for now)

	;; check instruction space validity
	;; m-dei-temp has ones for DDR, zero for diagnostics
	;; nubus-byte-read must not clobber m-dei-temp !!

	;; m-dei-inst-space currently points to the instruction space header.
	;; the first 'word' better contain a one.
	(call-xct-next NUBUS-BYTE-READ)
       ((vma) m-dei-inst-space)
	(jump if-equal md a-hex-1 INSTRUCTION-SPACE-OK)

	;; if this is a diagnostic request, return -1 in m-tem
	(popj-xct-next if-equal m-zero a-dei-temp)
       ((m-tem) seto)

	;; if this is a monitor request die, otherwise display a message and die
	((m-tem) ldb (byte-field 4 24.) m-dei-board-space)
	(jump-xct-next if-not-equal m-tem a-monitor-slot FATAL-ERROR)
       ((a-error-code) a-dei-instruction-header)
	(jump ERROR-DEI-INSTRUCTION-HEADER)		;crash with light code

INSTRUCTION-SPACE-OK
	;; get the instruction space access increment
	(call-xct-next NUBUS-BYTE-READ)
       ((vma) add vma a-hex-4)
 
	;; now we are ready to access the instruction space in the normal way
	((m-dei-inst-space)     add vma a-hex-4)
	((m-dei-inst-increment) md)
	((m-dei-inst-pointer)   setz)

	;; skip over the version code
	(call DEI-READ-INSTRUCTION)
	
	;; get the data space requirement
	(call DEI-READ-INSTRUCTION)
	((m-dei-data-space-size) dpb md (byte-field 8. 8.) a-zero)
	(call DEI-READ-INSTRUCTION)
	((m-dei-data-space-size) dpb md (byte-field 8. 0.) a-dei-data-space-size)

	;; allocate the data space under the rstack
	((m-dei-rstack-origin) sub m-dei-data-space-origin a-dei-data-space-size)
	((m-dei-rstack-pointer) m-dei-rstack-origin)

	;; set up data space reserved words
	((m-tem) m-dei-data-space-origin)

	;; set word zero to -1 (test completion status)
	((imod-low) dpb m-tem %imod-low-a-dest a-zero)
	((a-garbage) seto)

	;; set word one to address space of board under test
	((m-tem) m-a-1 m-tem a-zero)
	((imod-low) dpb m-tem %imod-low-a-dest a-zero)
	((a-garbage) m-dei-board-space)
	
	;; set word two to the address of some available memory
	;; This is only used by system test.  If the DDR's use this, then
	;; warm boot could be a problem.
	((m-tem) m-a-1 m-tem a-zero)
	((imod-low) dpb m-tem %imod-low-a-dest a-zero)
	((a-garbage) m-main-memory-base-address)

	(and-popj (m-tem) setz)		;return 0 in m-tem for diagnostics



DIAGNOSTIC-ENGINE
;;; The following variables must be initialized:
;;;
;;; m-dei-board-space       =  Fs000000 for board under test
;;; m-dei-inst-space        =  NuBus address to start of instruction space
;;; m-dei-inst-pointer      =  offset to first instruction relative to inst-space
;;; m-dei-inst-increment    =  physical increment between subsequent dei instructions
;;;
;;; m-dei-data-space-origin = start of data space in a-mem
;;; m-dei-data-space-size   = number of a-mem locs used for data space
;;;
;;; m-dei-dstack-origin     = start of dstack in a-mem
;;; m-dei-dstack-pointer    = may be greater than origin if parameters are passed
;;;
;;; m-dei-rstack-origin     = directly above data space in a-mem
;;; m-dei-rstack-pointer    = should be the same as origin at first
;;;
;;; If this is a self test, the data space must have -1 at location zero,
;;; m-dei-board-space at location one, and m-main-memory-base-address at location two
	
	;; stuff used to go here but it went away
	;; keep the label for historical reasons


DEI-FETCH-INSTRUCTION
;;; start interrpreting dei instructions
;;; read the next instruction from the current boards config rom

	(call DEI-READ-INSTRUCTION)
	(jump if-bit-set (byte-field 1 7) md DEI-DECODE-INSTRUCTION)

	;; this instruction is a user function call
	;; push the current instruction offset + 1 and transfer control to 
	;; the offset specified in the current and next instruction bytes
	
	(call-xct-next PUSH-RSTACK)
       ((m-stack-1) m+a+1 m-dei-inst-pointer a-zero)

	((m-dei-1) dpb md (byte-field 7 8) a-zero)		;shift into place
	(call DEI-READ-INSTRUCTION)				;get next 8 bits
	((m-dei-inst-pointer) dpb md (byte-field 8 0) a-dei-1)	;build offset
	(jump DEI-FETCH-INSTRUCTION)


DEI-DECODE-INSTRUCTION
;;; dei instruction branch table, md has instruction

	((m-dei-inst-opcode) ldb (byte-field 5 0) md)
	((m-dei-inst-opmod)  ldb (byte-field 2 5) md)

	(jump if-equal m-dei-inst-opcode a-zero 	DEI-CONTROL-OPS)
	(jump if-equal m-dei-inst-opcode a-hex-1	DEI-JUMP-OPS )
	(jump if-equal m-dei-inst-opcode a-hex-2	DEI-ARITHMETIC-OPS)
	(jump if-equal m-dei-inst-opcode a-hex-3	DEI-BOOLEAN-OPS)
	(jump if-equal m-dei-inst-opcode a-hex-4	DEI-SHIFT-OPS)
	(jump if-equal m-dei-inst-opcode a-hex-5	DEI-COMPARISON-OPS)
	(jump if-equal m-dei-inst-opcode a-hex-6	DEI-NOVER-OPS)	
	(jump if-equal m-dei-inst-opcode a-hex-7	DEI-PICK-OPS)
	(jump if-equal m-dei-inst-opcode a-hex-8	DEI-VAL-OPS)
	(jump if-equal m-dei-inst-opcode a-hex-9	DEI-FROMR)
	(jump if-equal m-dei-inst-opcode a-hex-A	DEI-TOR)
	(jump if-equal m-dei-inst-opcode a-hex-B	DEI-RGET-OPS)
	(jump if-equal m-dei-inst-opcode a-hex-C	DEI-OUTPUT-OPS)
	(jump if-equal m-dei-inst-opcode a-hex-D        DEI-ILOOP)
	(jump if-equal m-dei-inst-opcode a-hex-10	DEI-DPUT)
	(jump if-equal m-dei-inst-opcode a-hex-11	DEI-NPUT)
	(jump if-equal m-dei-inst-opcode a-hex-12	DEI-BPUT)
	(jump if-equal m-dei-inst-opcode a-hex-14	DEI-DGET)
	(jump if-equal m-dei-inst-opcode a-hex-15	DEI-NGET)
	(jump if-equal m-dei-inst-opcode a-hex-16	DEI-BGET)
	(jump if-equal m-dei-inst-opcode a-hex-17	DEI-IGET)
	(jump if-equal m-dei-inst-opcode a-hex-18	DEI-MEMORY-OPS)
	(jump if-equal m-dei-inst-opcode a-hex-19	DEI-MEMORY-OPS)
	(jump if-equal m-dei-inst-opcode a-hex-1A	DEI-MEMORY-OPS)
	(jump if-equal m-dei-inst-opcode a-hex-1E       DEI-EREX)

	;; unsupported operation code
        (call DEI-ILLEGAL-OPERATION)


DEI-PUSHD-FETCH-INSTRUCTION
;;; a type of return used in alot of places -- m-stack-1 has something in it

	(call PUSH-DSTACK)
	(jump DEI-FETCH-INSTRUCTION)


DEI-EREX
;;; This instruction is provided so that the DEI system tests can expect
;;; bus errors and handle them.  When the EREX flag is clear, bus errors
;;; are considered fatal.  On buserr with EREX clear, the Diagnostic Engine
;;; will stop whatever it is doing and begin executing instructions at
;;; location 5 of instruction space.  Location 5 is assumed to contain some
;;; kind of buserr handling routine, probably an error message printer.  If
;;; EREX is set, normal operation will continue but the nubus-error-flag
;;; will be set.  This flag is tested by the JNBE operation.  
;;; Upon execution of a JNBE operation, both the nubus-error-flag and the EREX
;;; flag will be cleared.

	(jump-xct-next DEI-FETCH-INSTRUCTION)
       ((m-dei-erex) seto)



;;; control operations and jump operations

DEI-CONTROL-OPS
	(jump if-equal m-dei-inst-opmod a-zero  DEI-EXIT)
	(jump if-equal m-dei-inst-opmod a-hex-1	DEI-FETCH-INSTRUCTION)	;NOP
	(jump if-equal m-dei-inst-opmod a-hex-2	DEI-RETURN)
;	(jump if-equal m-dei-inst-opmod a-hex-3	DEI-WAIT)

DEI-WAIT
;;; wait in multiples of 100 micro second periods
;;; +++ Ok, this is how I figure it . . . 
;;; I am assuming an alu instruction takes 4 clocks (125 ns) and 
;;; a jump takes 5 clocks (156.2 ns).
;;; Given that there are 1000 ns per usec, we must wait 100000 ns
;;; for each wait period passed to this routine. 
;;; Calculating the inner loop at 406.2 ns, xF6 interations of this
;;; will expend 99925.2 ns.  Calculating the outer loop at 406.2 ns
;;; plus the inner loop waists 100331.4 ns which should be enough.
;;; NOTE: THIS IS NOT INTENDED TO BE A VERY ACURATE WAIT CLOCK.

	(call POP-DSTACK)			;get number of wait periods

;;;	(jump if-equal m-stack-1 a-zero DEI-FETCH-INSTRUCTION)
	((m-stack-1) add m-stack-1 a-ones)	;adjust for loop termination

DEI-WAIT-LOOP-1
	((m-tem) dpb m-ones (byte-field 4 4) a-hex-6)	;xF6
DEI-WAIT-LOOP-2
	((m-garbage) setz)
	(jump-xct-next if-not-equal m-zero a-tem DEI-WAIT-LOOP-2)
       ((m-tem) add m-tem a-ones)

        (jump-xct-next if-not-equal m-zero a-stack-1 DEI-WAIT-LOOP-1)
       ((m-stack-1) add m-stack-1 a-ones)

	(jump DEI-FETCH-INSTRUCTION)


DEI-RETURN
;;; pop rstack and resume execution from there
;;; if we are at the top of the rstack, exit from DEI

	(jump if-equal m-dei-rstack-pointer a-dei-rstack-origin DEI-EXIT)

	(call POP-RSTACK)
	(jump-xct-next DEI-FETCH-INSTRUCTION)
       ((m-dei-inst-pointer) m-stack-1)


DEI-EXIT
;;; return from this invocation of the DEI
;;; initialize the return stack before returning

	(and-popj (m-dei-rstack-pointer) m-dei-rstack-origin)


DEI-JUMP-OPS
	(jump if-equal m-dei-inst-opmod a-zero	DEI-GOTO)
	(jump if-equal m-dei-inst-opmod a-hex-1	DEI-JIFZ)
	(jump if-equal m-dei-inst-opmod a-hex-2 DEI-JNBE)
	(jump if-equal m-dei-inst-opmod a-hex-3 DEI-ILOOP)
	(call DEI-ILLEGAL-OPERATION)

DEI-JIFZ
;;; goto if dstack has zero

	(call POP-DSTACK)
	(jump if-equal m-stack-1 a-zero DEI-GOTO)

	;; skip next two instruction bytes
	(jump-xct-next DEI-FETCH-INSTRUCTION)
       ((m-dei-inst-pointer) add m-dei-inst-pointer a-hex-2)

DEI-GOTO
;;; next two bytes of instruction memory contain jump destination

	(call DEI-READ-INSTRUCTION)
	((m-dei-1) dpb md (byte-field 7 8) a-zero)		;shift into place
	(call DEI-READ-INSTRUCTION)				;get next 8 bits
	((m-dei-inst-pointer) dpb md (byte-field 8 0) a-dei-1)	;build offset
	(jump DEI-FETCH-INSTRUCTION)

DEI-JNBE
;;; jump if no NuBus error has occurred
;;; executing this instruction also clears the EREX 
;;; and the nubus-eror flags.

	((m-dei-erex) setz)

	(jump-xct-next if-equal m-zero a-dei-nubus-error-flag DEI-GOTO)
       ((a-dei-nubus-error-flag) setz)

	;; skip next two instruction bytes
	(jump-xct-next DEI-FETCH-INSTRUCTION)
       ((m-dei-inst-pointer) add m-dei-inst-pointer a-hex-2)


DEI-ILOOP
;;; loop termination handler for 'do' style loops
;;; Rstack has loop index, limit, & loop address; Dstack has loop increment

	(call POP-DSTACK)		;get loop increment

	(call-xct-next POP-RSTACK)	;get loop index
       ((m-stack-2) m-stack-1)		;save increment
	(call-xct-next POP-RSTACK)	;get loop limit
       ((m-stack-3) m-stack-1)		;save index
	(call-xct-next POP-RSTACK)	;get loop address
       ((m-stack-4) m-stack-1)		;save limit

	((m-dei-1) add m-stack-3 a-stack-2)	;index + increment

	;; calculate limit check value by subtracting new index from limit
        ((m-dei-2) sub m-stack-4 a-dei-1)		
	(jump if-greater-or-equal m-stack-2 a-zero DEI-ILOOP-CHECK)

	;; index is negative, switch sign of limit check
	((m-dei-2) sub m-zero a-dei-2)

DEI-ILOOP-CHECK
	;; stop the loop if the limit check is less than or equal to zero
	(jump if-less-or-equal m-dei-2 a-zero DEI-ILOOP-RETURN)

	;; execute the loop again
	;; set instruction fetch pointer to loop address and 'push'
	;; the loop parameters back on the rstack

	((m-dei-inst-pointer) m-stack-1)

	;; restore rstack pointer
	((m-dei-rstack-pointer) sub m-dei-rstack-pointer a-hex-2)

	;; push the new loop index
	(call-xct-next PUSH-RSTACK)
       ((m-stack-1) m-dei-1)

	;; the rstack now looks as it did before but with a new index

DEI-ILOOP-RETURN

	(jump DEI-FETCH-INSTRUCTION)




;;; arithmetic operations

DEI-ARITHMETIC-OPS
;;; pop two elements from dstack and perform requested operation

	(call POP-DSTACK-2)

	(jump if-equal m-dei-inst-opmod a-zero	DEI-PLUS)
	(jump if-equal m-dei-inst-opmod a-hex-1	DEI-MINUS)
	(jump if-equal m-dei-inst-opmod a-hex-2	DEI-TIMES)
;	(jump if-equal m-dei-inst-opmod a-hex-3	DEI-DIV)

DEI-DIV
;;; divide second stack element by the first stack element
;;; signed divide subourine taken from uc-arith
;;; M-1 = Dividend (now m-stack-2)
;;; M-2 = Divisor  (now m-stack-1)
;;; Q-R = Result (Quotient)
;;; M-1 = Result (Remainder) (now m-stack-2)

DIV
	((m-dei-1) m-stack-2)
	(JUMP-Xct-Next If-Greater-Or-Equal M-STACK-2 A-ZERO DIV1)
		; Q GETS MAGNITUDE OF DIVIDEND, M-DEI-1 SAVES ORIGINAL
       ((Q-R) M-STACK-2)
	((Q-R) SUB M-ZERO A-dei-1)
DIV1		; Divisor must also be positive
	(Jump-Xct-Next If-Greater-Or-Equal M-STACK-1 DIV3)
		; m-dei-2 saves original
       ((m-dei-2) M-STACK-1)
	((M-STACK-1) SUB M-ZERO A-STACK-1)
DIV3
	((M-STACK-2) DIVIDE-FIRST-STEP M-ZERO A-STACK-1)
;;;(REPEAT 31. ((M-STACK-2) DIVIDE-STEP M-STACK-2 A-STACK-1))
	
	((m-hunoz) a-hex-20)
DIV-LOOP
	((m-stack-2) divide-step m-stack-2 a-stack-1)
	(jump-xct-next if-greater-than m-hunoz a-hex-2 DIV-LOOP) 
       ((m-hunoz) m-a-1 m-hunoz a-zero)

	((M-STACK-2) DIVIDE-LAST-STEP M-STACK-2 A-STACK-1)
		 ; JUMP IF POSITIVE DIVIDEND
	(JUMP-Xct-Next If-Less-Or-Equal M-ZERO A-dei-1 DIV2)
		; M-STACK-2 GETS MAGNITUDE OF REMAINDER
       ((M-STACK-2) DIVIDE-REMAINDER-CORRECTION-STEP M-STACK-2 A-STACK-1)
		; NEGATIVE DIVIDEND => NEGATIVE REMAINDER
	((M-STACK-2) SUB M-ZERO A-STACK-2)
DIV2		; IF SIGNS OF DIVIDEND AND DIVISOR ARE DIFFERENT,
	((M-STACK-1) m-dei-2)
	((m-dei-1) XOR M-STACK-1 A-dei-1)
	(JUMP If-Less-Or-Equal M-ZERO A-dei-1 DIV-RETURN)
	((m-dei-1) Q-R)
        ((Q-R) SUB M-ZERO A-dei-1)	;THEN QUOTIENT IS NEGATIVE

DIV-RETURN
	;; push remainder (m-stack-2), and quotient (q-r)
	((m-dei-1) q-r)	;save
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) m-stack-2)

	(jump-xct-next DEI-PUSHD-FETCH-INSTRUCTION)
       ((m-stack-1) m-dei-1)


DEI-TIMES
;;; signed 32. bit multiply adapted from code in uc-arith
;;;

	((q-r) m-stack-2)
	((m-stack-2) multiply-step a-stack-1 m-zero)

;;;(REPEAT 30. ((M-STACK-2) MULTIPLY-STEP M-STACK-2 A-stack-1))

	((m-hunoz) a-hex-20)
MPY-LOOP
	((m-stack-2) multiply-step m-stack-2 a-stack-1)
	(jump-xct-next if-greater-than m-hunoz a-hex-3 MPY-LOOP)
       ((m-hunoz) m-a-1 m-hunoz a-zero)

	(jump-Xct-Next If-Bit-Clear (BYTE-FIELD 1 0) Q-R MPY-RETURN)
       ((M-STACK-2) MULTIPLY-STEP M-STACK-2 A-STACK-1)
		; FINAGLE IF NEGATIVE VALUE INITIALLY IN Q-R
	((M-STACK-2) M-STACK-2 SUB A-STACK-1)

MPY-RETURN
	;; push low 32. bits of product (q-r) and return
	(jump-xct-next DEI-PUSHD-FETCH-INSTRUCTION)
       ((m-stack-1) q-r)



DEI-PLUS
	(jump-xct-next DEI-PUSHD-FETCH-INSTRUCTION)
       ((m-stack-1) add m-stack-1 a-stack-2)

DEI-MINUS
	(jump-xct-next DEI-PUSHD-FETCH-INSTRUCTION)
       ((m-stack-1) sub m-stack-2 a-stack-1)



;;; boolean operations and shift operations


DEI-BOOLEAN-OPS

	(jump if-equal m-dei-inst-opmod a-zero	DEI-NOT)

	;; we will always need two arguments if this isn't a NOT operation
	(call POP-DSTACK-2)

	(jump if-equal m-dei-inst-opmod a-hex-1	DEI-AND)
	(jump if-equal m-dei-inst-opmod a-hex-2	DEI-OR)
;	(jump if-equal m-dei-inst-opmod a-hex-3	DEI-XOR)

DEI-XOR
	(jump-xct-next DEI-PUSHD-FETCH-INSTRUCTION)
       ((m-stack-1) xor m-stack-1 a-stack-2)


DEI-AND
	(jump-xct-next DEI-PUSHD-FETCH-INSTRUCTION)
       ((m-stack-1) and m-stack-1 a-stack-2)

DEI-OR
	(jump-xct-next DEI-PUSHD-FETCH-INSTRUCTION)
       ((m-stack-1) ior m-stack-1 a-stack-2)

DEI-NOT
	(call POP-DSTACK)			;get only one argument
	(jump-xct-next DEI-PUSHD-FETCH-INSTRUCTION)
       ((m-stack-1) setcm m-stack-1)		;complement m-source




DEI-SHIFT-OPS
	;; get arguments from the stack
	(call POP-DSTACK-2)

	(jump if-equal m-dei-inst-opmod a-zero	DEI-ROTATE)
	(jump if-equal m-dei-inst-opmod a-hex-1	DEI-SHIFT)
	(call DEI-ILLEGAL-OPERATION)

DEI-ROTATE
;;; rotate routine adapted from code in Uc-Logical
;;; m-stack-1 = rotation count, m-stack-2 = data
;;; NOTE: no error conditions are checked -- instruction must be normal!
;;; positive count = left shift, negative count = right shift
;;; General Idea: 1) LDB an N bit piece from 32. - N bits over
;;;		  2) deposit a 32. - N bit piece N places to the left
;;;		     into the result of operation 1
;;; note how it is not necessary to treat a negative count (right rotate) 
;;; as a special case since only the lower 5 bits are used for imods

	;; First compute byte length of piece to be shifted (32. - N)
        ((m-dei-1) a-hex-20)
  	((m-dei-1) sub m-dei-1 a-stack-1)

	((m-dei-2) ldb (byte-field 5 0) m-stack-1)	;save count

	;; LDB wants (32. - mrot) internally which equals the count
	((imod-low) dpb m-dei-2 %imod-low-bytelen a-dei-2)
	((m-stack-1) ldb (byte-field 0 0) m-stack-2 a-zero)

	((imod-low) dpb m-dei-1 %imod-low-bytelen a-dei-2)
	((m-stack-1) dpb m-stack-2 (byte-field 0 0) a-stack-1)

	(jump DEI-PUSHD-FETCH-INSTRUCTION)


DEI-SHIFT
;;; m-stack-1 = shift count, m-stack-2 = data
;;; positive count = left shift, negative count = right shift
;;; sign extend
;;; shift count better not be greater than 32.

	((m-dei-1) a-hex-20)

	(jump if-bit-set (byte-field 1 31.) m-stack-1 DEI-SHIFT-RIGHT)

	;; left shift, byte length = (32. - N), m-rot = N
	((m-dei-1) sub m-dei-1 a-stack-1)
	((imod-low) dpb m-dei-1 %imod-low-bytelen a-stack-1)
	((m-stack-1) dpb m-stack-2 (byte-field 0 0) a-zero)

	(jump DEI-PUSHD-FETCH-INSTRUCTION)


DEI-SHIFT-RIGHT
;;; make right shift count positive
;;; perform shift with LDB, sign extend

	;; make shift length positive
	((m-stack-1) sub m-zero a-stack-1)

	;; set ldb background to bits of appropriate sign
	((m-dei-2) setz)
	(jump if-bit-clear (byte-field 1 31.) m-stack-2 DEI-SHIFT-RIGHT-1)
	((m-dei-2) seto)

DEI-SHIFT-RIGHT-1

	;; m-rot field for LDB = (32. - shiftlen), so is bytelen
	((m-dei-1) sub m-dei-1 a-stack-1)
	((imod-low) dpb m-dei-1 %imod-low-bytelen a-dei-1)
	((m-stack-1) ldb (byte-field 0 0) m-stack-2 a-dei-2)
	
	(jump DEI-PUSHD-FETCH-INSTRUCTION)




DEI-COMPARISON-OPS
;;; all operations leave false (zero) or true (-1) on dstack

	;; get arguments from stack
	(call POP-DSTACK-2)
	;; set default conditition to false
	((m-dei-1) setz)

	(jump if-equal m-dei-inst-opmod a-zero	DEI-EQUALS)
	(jump if-equal m-dei-inst-opmod a-hex-1	DEI-LESS)
	(jump if-equal m-dei-inst-opmod a-hex-2	DEI-ULESS)
	(call DEI-ILLEGAL-OPERATION)

DEI-EQUALS
	(jump if-equal m-stack-1 a-stack-2 DEI-PUSH-TRUE)
	(jump DEI-PUSH-FALSE)
	
DEI-LESS
;;; push true if second element less than first element
	(jump if-less m-stack-2 a-stack-1 DEI-PUSH-TRUE)
	(jump DEI-PUSH-FALSE)

DEI-ULESS
;;; push true if second element less than first (unsigned)
;;; if both sign bits are the same, dei-less will do the correct comparison
;;; if the sign bits are not the same, push true if m-stack-2 has sign bit set

	((m-dei-2) xor m-stack-1 a-stack-2)
	(jump if-bit-clear (byte-field 1 31.) m-dei-2 DEI-LESS)
	(jump if-bit-set (byte-field 1 31.) m-stack-2 DEI-PUSH-FALSE)
	;; else fall into push-true

DEI-PUSH-TRUE
	((m-dei-1) seto)

DEI-PUSH-FALSE
	(jump-xct-next DEI-PUSHD-FETCH-INSTRUCTION)
       ((m-stack-1) m-dei-1)



DEI-NOVER-OPS
	(jump if-equal m-dei-inst-opmod a-zero	DEI-NOVER)
	(jump if-equal m-dei-inst-opmod a-hex-1	DEI-SWAP)
	(call DEI-ILLEGAL-OPERATION)

DEI-NOVER
;;; remove an element from the dstack and put it on top
;;; element number to be moved is on stack and is relative to the top of the stack
;;; element number is 1 based after the parameter is removed

	(call POP-DSTACK)

	;; set m-dei-1 to stack element to move
	((m-dei-1) sub m-dei-dstack-pointer a-stack-1)
	((m-dei-1) m+1 m-dei-1)

	(call if-less-or-equal m-dei-1 a-dei-dstack-origin DEI-FATAL-ERROR)

	;; adjust the stack pointer to make the loop work better
	((m-dei-dstack-pointer) m-a-1 m-dei-dstack-pointer a-zero)

	;; save the stack element to move
	((imod-high) dpb m-dei-1 %imod-high-a-source a-zero)
	((m-stack-1) a-garbage)

DEI-NOVER-LOOP
	((m-dei-2) m+1 m-dei-1)
	((imod-high) dpb m-dei-2 %imod-high-a-source a-zero)
	((m-dei-3) a-garbage)	;get current element + 1	

	((imod-low) dpb m-dei-1 %imod-low-a-dest a-zero)
	((a-garbage) m-dei-3)	;store in current element

	(jump-xct-next if-less m-dei-1 a-dei-dstack-pointer DEI-NOVER-LOOP)
       ((m-dei-1) m+1 m-dei-1)

	(jump DEI-PUSHD-FETCH-INSTRUCTION)


DEI-SWAP
;;; swap the top two elements of dstack

	(call POP-DSTACK-2)
	(call PUSH-DSTACK)	
	(jump-xct-next DEI-PUSHD-FETCH-INSTRUCTION)
       ((m-stack-1) m-stack-2)	


DEI-PICK-OPS
	;; always want to remove one stack argument
	(call POP-DSTACK)

	(jump if-equal m-dei-inst-opmod a-zero	DEI-PICK)
	(jump if-equal m-dei-inst-opmod a-hex-1	DEI-DUP)
	(jump if-equal m-dei-inst-opmod a-hex-2	DEI-DROP)
	(call DEI-ILLEGAL-OPERATION)

DEI-PICK
;;; copy an element from the dstack to the top of dstack
;;; element number to copy is on dstack and is relative to the top of stack
;;; element number is 1 based after the parameter is removed

	((m-dei-1) sub m-dei-dstack-pointer a-stack-1)
	((m-dei-1) m+1 m-dei-1)		;find desired element

	(call if-less-or-equal m-dei-1 a-dei-dstack-origin DEI-FATAL-ERROR)

	((imod-high) dpb m-dei-1 %imod-high-a-source a-zero)
	((m-stack-1) a-garbage)		;read element

	(jump DEI-PUSHD-FETCH-INSTRUCTION)


DEI-DUP
;;; duplicate top element of stack

	(call PUSH-DSTACK)
	(jump DEI-PUSHD-FETCH-INSTRUCTION)


DEI-DROP
;;; remove top element of stack
;;; already removed so just return

	(jump DEI-FETCH-INSTRUCTION)



DEI-VAL-OPS
;;; store data word on the dstack
;;; one to four bytes of immediate date are present
;;; sign extend to full 32. bits
;;; successive bytes are of descending significance
;;; opmod has number of bytes present (0 = 1 byte, 1 = 2 bytes . . )

	(call DEI-READ-INSTRUCTION)

	;; setup background for proper sign extension
	(jump-xct-next if-bit-clear (byte-field 1 7) md DEI-VAL-LOOP)
       ((m-stack-1) setz)
	((m-stack-1) seto)

DEI-VAL-LOOP
;;; note how (byte field 2 3) is used to do a * 8 calculation on byte number 
;;; to compute the byte position (mrot) -- credit goes to Pete Kloepper

	((imod-low) dpb m-dei-inst-opmod (byte-field 2 3) a-zero)
	((m-stack-1) dpb md (byte-field 8 0) a-stack-1)

	;; done?
	(jump if-equal m-dei-inst-opmod a-zero DEI-PUSHD-FETCH-INSTRUCTION)

	(call DEI-READ-INSTRUCTION)
	(jump-xct-next DEI-VAL-LOOP)
       ((m-dei-inst-opmod) m-a-1 m-dei-inst-opmod a-zero)



DEI-FROMR
;;; pop top of rstack, push on dstack

        (call POP-RSTACK)
	(jump DEI-PUSHD-FETCH-INSTRUCTION)


DEI-TOR
;;; pop top of dstach, push on rstack

	(call POP-DSTACK)
	(call PUSH-RSTACK)
	(jump DEI-FETCH-INSTRUCTION)



DEI-RGET-OPS
;;; copy an element from the rstack onto the dstack
;;; for RGET, element number is on dstack
;;; for others, opmod field has element number
;;; assumes top of stack is the '1' element

	(jump if-equal m-dei-inst-opmod a-zero	DEI-RGET)
;	(jump if-equal m-dei-inst-opmod a-hex-1	DEI-INDEX)
;	(jump if-equal m-dei-inst-opmod a-hex-2	DEI-LIMIT)
;	(jump if-equal m-dei-inst-opmod a-hex-3	DEI-DOTOP)

	;; m-dei-inst-opmod has rstack element number to copy to dstack
	((m-stack-1) m-a-1 m-dei-inst-opmod a-zero)

DEI-DO-RGET
	((m-stack-1) add m-dei-rstack-pointer a-stack-1)

	(call if-greater-or-equal m-stack-1 a-dei-rstack-origin DEI-FATAL-ERROR)

	((imod-high) dpb m-stack-1 %imod-high-a-source a-zero)
	((m-stack-1) a-garbage)

	(jump DEI-PUSHD-FETCH-INSTRUCTION)

DEI-RGET
;;; pop dstack
;;; push indicated rstack element onto dstack

	(call POP-DSTACK)
	(jump-xct-next DEI-DO-RGET)
       ((m-stack-1) m-a-1 m-stack-1 a-zero)	;adjust for correct stack indexing




DEI-OUTPUT-OPS
;;; These routines will call the DDR for the boot monitor
;;; in order to display messages.  Since this involves a recursive
;;; call of the diagnostic engine, it is necessary to completely
;;; save & restore states around calls.

	(jump if-equal m-dei-inst-opmod a-zero	DEI-EMIT)
	(jump if-equal m-dei-inst-opmod a-hex-1	DEI-CLRSCR)
	(call DEI-ILLEGAL-OPERATION)

DEI-EMIT
;;; Draw 1 character on the screen at the current cursor position.
;;; Character is in the low order byte.

	(call POP-DSTACK)
	(call DEI-SAVE-STATE)
	(call-xct-next DRAW-CHAR)
       ((a-char-code) m-stack-1)
	(jump DEI-RESTORE-STATE)

DEI-CLRSCR
;;; clear the screen
;;; position the cursor at the bottom left corner

	(call DEI-SAVE-STATE)
	(call INIT-DISPLAY)
	(jump DEI-RESTORE-STATE)


DEI-SAVE-STATE
;;; We need to make a recursive call to the DEI.
;;; Save all m-memory variables that contain the DEI
;;; state on the data stack then reinitialize stack
;;; pointers.
;;; >>> currently set up to handle 14. locations at x32

	((m-dei-1) setz)					;index
DEI-SAVE-LOOP
	((m-dei-2) add m-dei-1 a-hex-32)			;index + offset to variables
	((imod-high) dpb m-dei-2 %imod-high-a-source)		;read variable
	((m-dei-3) a-garbage)			
	((m-dei-2) m+a+1 m-dei-1 a-dei-dstack-pointer)		;index + stack offset + 1
	((imod-low) dpb m-dei-2 %imod-low-a-dest)		;store variable on stack
	((a-garbage) m-dei-3)
	(jump-xct-next if-less m-dei-1 a-hex-D DEI-SAVE-LOOP)	;currently 14. variables
       ((m-dei-1) m+1 m-dei-1)					;do the next one

	;; now, reinitialize the stack parameters
	((m-dei-dstack-origin) m+a+1 m-dei-dstack-pointer a-hex-E)
	((m-dei-dstack-pointer) m-dei-dstack-origin)
	((m-dei-data-space-origin) add m-dei-rstack-pointer a-ones)
	((m-dei-rstack-origin) m-dei-data-space-origin)
	((m-dei-rstack-pointer) m-dei-rstack-origin)
	(popj)

DEI-RESTORE-STATE
;;; We have finished a recursive DEI call.
;;; Restore previous state from the data stack.

	((m-dei-1) setz)				
	((m-dei-2) sub m-dei-dstack-origin a-hex-E)		;point to start of saved vars
DEI-RESTORE-LOOP
	((m-dei-3) add m-dei-1 a-dei-2)				;index saved variable
	((imod-high) dpb m-dei-3 %imod-high-a-source)		;read variable
	((m-dei-temp) a-garbage)			
	((m-dei-3) add m-dei-1 a-hex-32)			;index variable address
	((imod-low) dpb m-dei-3 %imod-low-m-dest)		;restore variable
	((m-garbage) m-dei-temp)
	(jump-xct-next if-less m-dei-1 a-hex-D DEI-RESTORE-LOOP)
       ((m-dei-1) m+1 m-dei-1)					

	(jump DEI-FETCH-INSTRUCTION)



;;; memory referencing

DEI-DPUT
;;; store a value into data space
;;; first element of dstack has address, second has data
;;; check for illegal address

	(call POP-DSTACK-2)
	(call if-greater-or-equal m-stack-1 a-dei-data-space-size DEI-FATAL-ERROR)

	((m-stack-1) sub m-dei-data-space-origin a-stack-1)

	((imod-low) dpb m-stack-1 %imod-low-a-dest a-zero)
	((a-garbage) m-stack-2)

	(jump DEI-FETCH-INSTRUCTION)


DEI-DGET
;;; push contents of an address in data space on dstack
;;; address popped from dstack
;;; check for illegal address

	(call POP-DSTACK)
	(call if-greater-or-equal m-stack-1 a-dei-data-space-size DEI-FATAL-ERROR)

	((m-stack-1) sub m-dei-data-space-origin a-stack-1)

	((imod-high) dpb m-stack-1 %imod-high-a-source a-zero)
	((m-stack-1) a-garbage)
	(jump DEI-PUSHD-FETCH-INSTRUCTION)


DEI-IGET
;;; push contents of instruction memory (one byte) on dstack
;;; address is popped from dstack

	(call POP-DSTACK)
	((m-dei-1) m-dei-inst-pointer)		;save current instruction pointer
	((m-dei-inst-pointer) m-stack-1)	;set to address of data

	(call DEI-READ-INSTRUCTION)
        ((m-dei-inst-pointer) m-dei-1)		;restore

	(jump-xct-next DEI-PUSHD-FETCH-INSTRUCTION)
       ((m-stack-1) md)


;;; NPUT,NGET & BPUT,BGET now check to see if a nubus error occurrs
;;; after memory references.  The bus error status is placed in the
;;; a-memory variable a-dei-nubus-error-flag.  Unexpected bus errors
;;; (EREX = 0) will cause the special bus error routine to be 
;;; executed (presumed to be at location 5 in instruction space). 


DEI-NPUT
DEI-BPUT
;;; store into NuBus space
;;; first element of dstack has address, second has data
;;; opmod has element size (0 = byte, 1 = halfword, 2 = fullword)
;;; for bput, first element has offset into slot space of current board

	(call POP-DSTACK-2)
	((vma) m-stack-1)
	((md) m-stack-2)

	(jump if-equal m-dei-inst-opcode a-hex-11 DEI-NPUT-WRITE)
	
	((vma) add vma a-dei-board-space)	;add slot space address for bput

DEI-NPUT-WRITE
	(call DEI-NUBUS-WRITE)
	(jump DEI-BUSERR-CHECK)

;;; >>> The problems below should go away now that GACBL handling 
;;; >>> is provided.
;;;
;;;	(jump if-equal m-dei-inst-opcode a-hex-11 DEI-BUSERR-CHECK)
;;;	(jump if-not-equal m-ddr-slot a-hex-2 DEI-BUSERR-CHECK)
;;;
;;;	;; >>> If you thought that was funny . . . 
;;;	;; There is a problem with writing to the configuration register 
;;;	;; on the Nupi.  If you set the NuBus master enable bit and don't
;;;	;; wait awhile, the next memory access will return zero.  Since
;;;	;; this next memory access is presumably a DEI instruction fetch, 
;;;	;; it is important that we get the real stuff.
;;;
;;;	;; We must check for a Bput within the word at E00008 (config register)
;;;	;; extract the address & mask off the low two bits (byte offset)
;;;
;;;	((md) selective-deposit m-stack-1 (byte-field 22. 2) a-zero)
;;;	((m-tem) dpb m-ones (byte-field 3 21.) a-hex-8)			;E00008
;;;	(jump if-not-equal md a-tem DEI-BUSERR-CHECK)
;;;
;;;	((m-tem) dpb m-ones (byte-field 1 16.) a-zero)
;;;DEI-BPUT-DELAY
;;;	(jump-xct-next if-greater m-tem a-zero DEI-BPUT-DELAY)
;;;       ((m-tem) add m-tem a-ones)
;;;
;;;	(jump DEI-BUSERR-CHECK)


DEI-NGET
DEI-BGET
;;; push contents of NuBus address on dstack
;;; address popped from dstack
;;; for bget, address is offset into slot space of current board
;;; opmod has element size (0 = byte, 1 = halfword, 2 = fullword)

	(call POP-DSTACK)
	((vma) m-stack-1)

	(jump if-equal m-dei-inst-opcode a-hex-15 DEI-NGET-READ)
	((vma) add vma a-dei-board-space)

DEI-NGET-READ
	(call DEI-NUBUS-READ)
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) md)

	(jump DEI-BUSERR-CHECK)




;;; special functions for memory testing

DEI-MEMORY-OPS
;;; perform setmem, checkmem, or walkmem
;;; first dstack element has starting address
;;; second has value to store (setmem, walkmem) or value to check (checkmem)
;;; third has number of memory elements to interate on
;;;  (positive count is forward walk, negative count is backward walk)
;;; fourth has value to check (only for walkmem)
;;; opmod field has element size (0 = byte, 1 = halfword, 2 = fullword)
;;; setmem opcode = x18, checkmem = x19, walkmem = x1A

	(call POP-DSTACK)
	(call-xct-next POP-DSTACK-2)	;get data, count
       ((m-dei-1) m-stack-1) 		;starting address

	;; if this is a checkmem, the parameters are in the correct registers
	(jump if-equal m-dei-inst-opcode a-hex-19 DEI-MEMORY-TEST)
	
	;; move value to store on setmem & walkmem
	((m-dei-2) m-stack-1)

	;; if this is a walkmem, get the check value
	(jump if-not-equal m-dei-inst-opcode a-hex-1A DEI-MEMORY-TEST)
	(call POP-DSTACK)

DEI-MEMORY-TEST
;;; this is the main memory access loop for setmem, checkmem, & walkmem
;;;   m-dei-1   has memory address
;;;   m-dei-2   has value to store (setmem & walkmem)
;;;   m-stack-1 has value to check (checkmem & walkmem)
;;;   m-stack-2 has count (positive = forward walk, negative = backward)

	;; set memory increment/decrement value
	((m-dei-3) m+a+1 m-dei-inst-opmod a-zero)
	(jump if-not-equal m-dei-inst-opmod a-hex-2 DEI-CHECK-DECREMENT)
	((m-dei-3) m+1 m-dei-3)

DEI-CHECK-DECREMENT
;;; see if a backward walk is requested, otherwise do a forward walk
	(jump if-bit-clear (byte-field 1 31.) m-stack-2 DEI-START-MEMORY-TEST)
	((m-stack-2) sub m-zero a-stack-2)	;make count positive
	((m-dei-3) sub m-zero a-dei-3)		;make increment negative

DEI-START-MEMORY-TEST
	((m-stack-2) m-a-1 m-stack-2 a-zero)	;adjust loop count

DEI-MEMLOOP
	;; don't compare if setmem
	(jump if-equal m-dei-inst-opcode a-hex-18 DEI-MEMLOOP-2)

	;; read memory element of requested size
	(call-xct-next DEI-NUBUS-READ)
       ((vma) m-dei-1)

	;; abort if comparison fails or if bus error detected
	(jump if-nubus-error DEI-MEMORY-TEST-COMPLETE)
	(jump if-not-equal md a-stack-1 DEI-MEMORY-TEST-COMPLETE)

	;; don't store data if checkmem
	(jump if-not-equal m-dei-inst-opcode a-hex-1A DEI-MEMLOOP-3)

DEI-MEMLOOP-2
	;; store data for setmem & walkmem
	((md) m-dei-2)
	(call-xct-next DEI-NUBUS-WRITE)
       ((vma) m-dei-1)

	;; abort if bus error detected
	(jump if-nubus-error DEI-MEMORY-TEST-COMPLETE)

DEI-MEMLOOP-3
	((m-dei-1) add m-dei-1 a-dei-3)		;increment/decrement memory address
	(jump-xct-next if-greater m-stack-2 a-zero DEI-MEMLOOP)
       ((m-stack-2) m-a-1 m-stack-2 a-zero)


DEI-MEMORY-TEST-COMPLETE	
;;; return if this is a setmem, otherwise check for errors

	(jump if-equal m-dei-inst-opcode a-hex-18 DEI-BUSERR-CHECK)
	(jump if-greater-or-equal m-stack-2 a-zero DEI-CHECKMEM-ERROR)

	;; everything was Ok, so push return status of false (no errors)
	(jump-xct-next DEI-MEMORY-OP-STATUS)
       ((m-stack-1) setz)

DEI-CHECKMEM-ERROR
;;; push address of error, data read, data expected, error flag

	((m-dei-2) m-stack-1)		;save expected value

	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) m-dei-1)		;address
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) md)			;data read
	(call-xct-next PUSH-DSTACK)
       ((m-stack-1) m-dei-2)		;expcted value

       ((m-stack-1) seto)		;error flag

DEI-MEMORY-OP-STATUS
;; m-stack-1 has zero or ones 
	(call PUSH-DSTACK)
	;; fall in


DEI-BUSERR-CHECK
;;; here from either the memory ops or nget, nput
;;; check for bus errors before going to execute the next instruction

	(jump if-nubus-error DEI-BUSERR-DETECTED)

	(jump-xct-next DEI-FETCH-INSTRUCTION)
       ((a-dei-nubus-error-flag) setz)

DEI-BUSERR-DETECTED
	(jump-xct-next if-equal m-dei-erex a-ones DEI-FETCH-INSTRUCTION) 
       ((a-dei-nubus-error-flag) seto)
	;; fall in

DEI-BUSERR-UNEXPECTED
;;; Here if a bus error has occurred and was unexpected (EREX = 0)
;;; We must jump to location 5 in instruction space where presumably
;;; there is an error handler.  Make this a 'call' type of jump so 
;;; that the error handler can return if it wants to.

	(call-xct-next PUSH-RSTACK)
       ((m-stack-1) m-dei-inst-pointer)

	;; invoke the buserr handler passing it the bad address
        ((m-dei-inst-pointer) a-hex-5)
	(jump-xct-next DEI-PUSHD-FETCH-INSTRUCTION)
       ((m-stack-1) vma)


;;; stack routines for the dei
;;; elements from the dstack are popped into m/a-memory locations
;;; m-stack-1, m-stack-2, m-stack-3, m-stack-4

POP-DSTACK
;;; pop the data stack, return in m-stack-1

	(call POP-DSTACK-PRIMITIVE)
	(and-popj (m-stack-1) a-stack-pop)


POP-DSTACK-2
;;; pop two elements from the data stack

	(call POP-DSTACK-PRIMITIVE)
	((m-stack-1) a-stack-pop)
	(call POP-DSTACK-PRIMITIVE)
	(and-popj (m-stack-2) a-stack-pop)

;;;POP-DSTACK-4
;;;;;; pop four elements from the data stack
;;;
;;;	(call POP-DSTACK-2)
;;;	(call POP-DSTACK-PRIMITIVE)
;;;	((m-stack-3) a-stack-pop)
;;;	(call POP-DSTACK-PRIMITIVE)
;;;	(and-popj (m-stack-4) a-stack-pop)	


POP-DSTACK-PRIMITIVE
;;; remove top of dstack
;;; check for stack pointer already at top of stack space
;;; return top of stack in a-stack-pop

	(call if-equal m-dei-dstack-pointer a-dei-dstack-origin DEI-FATAL-ERROR)

	((imod-high) dpb m-dei-dstack-pointer %imod-high-a-source a-zero)
	(and-popj-xct-next (a-stack-pop) a-garbage)
       ((m-dei-dstack-pointer) m-a-1 m-dei-dstack-pointer a-zero)



PUSH-DSTACK
;;; push the contents of m-stack-1 onto the data stack
;;; check for overflow into rstack

	((m-dei-dstack-pointer) m+1 m-dei-dstack-pointer)
	(call if-greater-or-equal m-dei-dstack-pointer a-dei-rstack-pointer
	 DEI-FATAL-ERROR)

	(and-popj-xct-next 
	 (imod-low) dpb m-dei-dstack-pointer %imod-low-a-dest a-zero)
       ((a-garbage) m-stack-1)

PUSH-RSTACK
;;; push the contents of m-stack-1 onto the return stack
;;; check for overflow into dstack

	((m-dei-rstack-pointer) m-a-1 m-dei-rstack-pointer a-zero)
	(call if-less-or-equal m-dei-rstack-pointer a-dei-dstack-pointer
	 DEI-FATAL-ERROR)

	(and-popj-xct-next
	 (imod-low) dpb m-dei-rstack-pointer %imod-low-a-dest a-zero)
       ((a-garbage) m-stack-1)


POP-RSTACK
;;; pop top of return stack into m-stack-1
;;; check for stack pointer already at top of stack space
;;; normally this error condition signals a return to the DEI caller
;;; but this case should be handled seperately
	
	(call if-greater-or-equal m-dei-rstack-pointer a-dei-rstack-origin
	 DEI-FATAL-ERROR)

	((imod-high) dpb m-dei-rstack-pointer %imod-high-a-source a-zero)
	(and-popj-xct-next (m-stack-1) a-garbage)
       ((m-dei-rstack-pointer) m+1 m-dei-rstack-pointer a-zero)



DEI-ILLEGAL-OPERATION
DEI-FATAL-ERROR
;;; entered if an unsupported opcode or opcode modifier was encountered
;;; also used to halt on fatal errors such as stack overflow
;;; these should be called so the errant PC will be on micro-pc stack
;;; Can't display error message on monitor from here so halt with
;;; error trap address in the lights

;;;	((m-tem) ldb (byte-field 4 24.) m-dei-board-space)
;;;	(jump-xct-next if-not-equal m-tem a-monitor-slot FATAL-ERROR)
;;;       ((a-error-code) a-dei-internal-error)

	(jump ERROR-DEI-INTERNAL-ERROR)



DEI-READ-INSTRUCTION
;;; Read a DEI instruction byte from instruction space.
;;; Increment the instruction pointer after read.
;;; Primitive breakpointing is supported here.
;;; This routine currently handles two types of instruction storage :
;;;   - instructions stored 4 per word (as in main memory)
;;;   - instructions stored 1 per word (as in configuration rom)
;;; Eventually want to handle other types of increment.

	(call if-equal m-dei-inst-pointer a-dei-inst-breakpoint DEI-BREAKPOINT)

	((vma) m-dei-inst-pointer)
	(jump if-equal m-dei-inst-increment a-hex-1 DEI-READ-INST-1)
	;; +++ for now, assume increment of 4 (1 instruction per word)
	;; +++ we will need to fix this since the NUPI has increment of 2
	((vma) dpb vma (byte-field 30. 2) a-zero)	;times 4

DEI-READ-INST-1
	((vma) add vma a-dei-inst-space)
	(jump-xct-next NUBUS-BYTE-READ)
       ((m-dei-inst-pointer) m+1 m-dei-inst-pointer)


DEI-BREAKPOINT
;;; Dei breakpoint hit, halt the machine.

	(jump HALT DEI-BREAKPOINT)


;;; The following two routines are used by the DEI memory test operations.

DEI-NUBUS-READ
;;; Read from NuBus address space.
;;; Opmod field has element size (0 = byte, 1 = halfword, 2 = fullword)
;;; VMA has address.

	(jump-xct-next if-equal m-dei-inst-opmod a-hex-2 NUBUS-OPERATION-WITH-GACBL)
       ((m-nubus-op) a-hex-2)				;set for full-word read
	
	(jump if-equal m-dei-inst-opmod a-zero NUBUS-BYTE-READ)

	;; here on halfword read operations
	(call NUBUS-BYTE-READ)
	((m-dei-temp) md)
	(call-xct-next NUBUS-BYTE-READ)
       ((vma) m+1 vma)	
        (and-popj (md) dpb md (byte-field 8. 8.) a-dei-temp)


DEI-NUBUS-WRITE
;;; Write into nubus address space.  Opmod has element size.
;;; VMA & MD are passed in.
;;; Uses primitave nubus routines so gacbl handling can be done.

	(jump-xct-next if-equal m-dei-inst-opmod a-hex-2 NUBUS-OPERATION-WITH-GACBL)
       ((m-nubus-op) a-hex-3)				;set for full-word write

	(jump if-equal m-dei-inst-opmod a-zero NUBUS-BYTE-WRITE)

	;; here on halfword write operations
	((m-dei-temp) md)
	(call-xct-next NUBUS-BYTE-WRITE)
       ((md) ldb (byte-field 8. 0.) m-dei-temp a-zero)
	((vma) m+1 vma)					;write next byte
	(jump-xct-next NUBUS-BYTE-WRITE)
       ((md) ldb (byte-field 8. 8.) m-dei-temp a-zero)



;;; The following are the NuBus byte access routines
;;; They should be used whenever an unmapped byte access is to be done

NUBUS-BYTE-READ
;;; Read a byte from NuBus address space.  VMA has address.
;;; A full word is returned with the byte in its relative position.
;;; Return the byte right justified in MD with zeros everywhere else.
;;; WARNING: this smashes m-hunoz!

	(call-xct-next NUBUS-OPERATION-WITH-GACBL)
       ((m-nubus-op) setz)				;set for byte read
	
	;; if on word boundary, don't attempt to right justify
	((m-hunoz) dpb vma (byte-field 2 3) a-zero)
	(jump if-equal m-hunoz a-zero NUBUS-BYTE-READ-RETURN)

	;; create mrot using bottom 2 bits of vma
	;; need 32. - mrot for LDB, make this 32. + (- mrot)
	((m-hunoz) sub m-zero a-hunoz)
	((m-hunoz) add m-hunoz a-hex-20)
	((imod-low) dpb m-hunoz %imod-low-mrot)

NUBUS-BYTE-READ-RETURN
	(and-popj (md) ldb (byte-field 8. 0) md)


NUBUS-BYTE-WRITE
;;; Write a byte into NuBus address space.
;;; If the byte is not on a word boundary, it must be
;;; shifted in MD to its proper place.

	;; create mrot using bottom 2 bits of vma
	((imod-low) dpb vma (byte-field 2 3) a-zero)
	((md) dpb md (byte-field 8. 0) a-zero)

	((m-nubus-op) a-hex-1)			;set for byte write
	;; fall in


NUBUS-OPERATION-WITH-GACBL
;;; Perform a nubus operation.
;;; Check nubus error status and attempt a gacbl if
;;; error occurred.  
;;; m-nubus-op must be set as follows:
;;;  bit 0 : 0 = read, 1 = write
;;;  bit 1 : 0 = byte  1 = full word

	;; >>> first clear any existing NuBus error latches
	(call if-nubus-error RESET-NUBUS-ERRORS)

	((a-nubus-retry-count) a-hex-4)

NUBUS-OPERATION-LOOP
	(jump if-bit-set (byte-field 1 0) m-nubus-op NUBUS-WRITE-OPERATIONS)
	(jump if-bit-set (byte-field 1 1) m-nubus-op NUBUS-WORD-READ)
	((vma-start-unmapped-byte-read) vma)
	(jump NUBUS-OPERATION-FINISHED)
NUBUS-WORD-READ
	((vma-start-unmapped-read) vma)
	(jump NUBUS-OPERATION-FINISHED)
NUBUS-WRITE-OPERATIONS
	(jump if-bit-set (byte-field 1 1) m-nubus-op NUBUS-WORD-WRITE)
	((vma-start-unmapped-byte-write) vma)
	(jump NUBUS-OPERATION-FINISHED)
NUBUS-WORD-WRITE
	((vma-start-unmapped-write) vma)
	;; fall in

NUBUS-OPERATION-FINISHED
	(no-op) 
	(jump if-nubus-error NUBUS-OPERATION-ERROR)
	(popj)

;;; >>> simple nubus error handler that assumes a gacbl 

NUBUS-OPERATION-ERROR
	((a-nubus-gacbl-count) m+a+1 m-zero a-nubus-gacbl-count)
	(jump if-greater-or-equal m-zero a-nubus-retry-count GACBL-RETRIES-EXHAUSTED)

	(call-xct-next DELAY)			;pause . . .
       ((a-delay-counter) a-hex-400)

	(jump-xct-next NUBUS-OPERATION-LOOP)	;retry . . . 
       ((a-nubus-retry-count) add m-ones a-nubus-retry-count)

GACBL-RETRIES-EXHAUSTED
	(and-popj (a-nubus-gacbl-failures) m+a+1 m-zero a-nubus-gacbl-failures)


;;; >>> Here is a better NuBus error handler that uses the NuBus registers on the 
;;; >>> memory board.  It should only be used for testing since it has device dependencies.

;NUBUS-OPERATION-ERROR
;	((a-save-vma) vma)
;	((a-save-md) md)
;
;	;; Read the Bus Status Error Latch at FsFFC014
;	((m-tem) dpb m-ones (byte-field 10. 14.) a-hex-14)	;FFC014
;	((m-tem) add m-tem a-main-memory-base-address)		;F4FFC014
;	((vma-start-unmapped-read) m-tem)
;	(no-op)
;	((a-nubus-error-latch) md)
;
;	((vma) a-save-vma)
;	((md) a-save-md)
;
;	((m-tem) a-nubus-error-latch)
;	((m-tem) ldb (byte-field 2 14.) m-tem)	;get error type
;	(jump if-equal m-tem a-zero NUBUS-ERROR)
;	(jump if-equal m-tem a-hex-1 NO-MEMORY-ERROR)
;	(jump if-equal m-tem a-hex-2 PARITY-ERROR)
;
;WEIRD-ERROR
;	(jump HALT WEIRD-ERROR)		;shouldn't ever see this
;NO-MEMORY-ERROR
;;;;	(jump HALT NO-MEMORY-ERROR)
;	(and-popj (a-no-memory-errors) m+a+1 m-zero a-no-memory-errors)
;PARITY-ERROR
;;;;	(jump HALT PARITY-ERROR)
;	(and-popj (a-parity-errors) m+a+1 m-zero a-parity-errors)
;NUBUS-ERROR
;	((m-tem) a-nubus-error-latch)
;	((m-tem) ldb (byte-field 2 6) m-tem)	;get error TMs
;	(jump if-equal m-tem a-hex-1 NUBUS-ERROR-ERROR)
;	(jump if-equal m-tem a-hex-2 NUBUS-ERROR-TIMEOUT)
;	(jump if-equal m-tem a-hex-3 NUBUS-ERROR-GACBL)
;NUBUS-NO-ERROR
;;;;	(jump HALT NUBUS-NO-ERROR)
;	(and-popj (a-nubus-no-error) m+a+1 m-zero a-nubus-no-error)
;NUBUS-ERROR-ERROR
;	(jump HALT NUBUS-ERROR-ERROR)
;;;;	(and-popj (a-nubus-error) m+a+1 m-zero a-nubus-error)
;NUBUS-ERROR-TIMEOUT
;	((a-nubus-timeout) m+a+1 m-zero a-nubus-timeout)
;	(popj)
;NUBUS-ERROR-GACBL
;	((a-nubus-gacbl-count) m+a+1 m-zero a-nubus-gacbl-count)
;	(jump if-greater-or-equal m-zero a-nubus-retry-count GACBL-RETRIES-EXHAUSTED)
;
;	(call-xct-next DELAY)			;pause . . .
;       ((a-delay-counter) a-hex-400)
;
;	(jump-xct-next NUBUS-OPERATION-LOOP)
;       ((a-nubus-retry-count) add m-ones a-nubus-retry-count)
;
;
;GACBL-RETRIES-EXHAUSTED
;	(jump HALT GACBL-RETRIES-EXHAUSTED)


RESET-NUBUS-ERRORS
;;; Here at the start of a memory operation if a nubus error
;;; was previously detected.  
;;; We need to clear the error by accessing a memory location
;;; known to be good.  Use the last byte of the processor's
;;; config rom at FsFFFFFC.

	((a-save-vma) vma)
	((a-save-md) md)

	;; read high byte of processor config rom at FsFFFFFC
	((m-tem) dpb m-ones (byte-field 30. 2) a-zero)		;FFFFFFFC
	((vma) a-processor-slot)
	((vma-start-unmapped-byte-read) dpb vma (byte-field 4 24.) a-tem)
	(no-op)

	(and-popj-xct-next (vma) a-save-vma)
       ((md) a-save-md)


;;; 


;;; +++ string space
(loc #x+7D0)
;;;(loc #x+3ED0)

STRING-SPACE
;;; In order to save space yet still allow usefull messages for the boot menus,
;;; ASCII strings are stored in i-memory instead of being built dynamically.
;;; Strings are stored 6 characters per i-memory word instead of 7 since the 
;;; upper byte of i-memory words contain parity information.
;;; The uppermost byte is set to 2 so the halt bit will be on in these words.
;;; This space must be at a known location.  It is currently set up to reside
;;; in the last 48. locations of PROM memory (starting at x7D0). 
;;; +++ For ram debug, it will start at x3ED0 assuming a code origin of x3700
;;; +++ This is currently more that is needed.

	(ABSOLUTE-DATA #x+025443454C4553)	;SELECT		0
        (ABSOLUTE-DATA #x+02000000000020)       ;<SP>		1
  	(ABSOLUTE-DATA #x+025420544F4F42)       ;BOOT T		2
  	(ABSOLUTE-DATA #x+02000000455059)       ;YPE		3
  	(ABSOLUTE-DATA #x+02454349564544)       ;DEVICE		4
  	(ABSOLUTE-DATA #x+02000000000020)       ;<SP>		5
  	(ABSOLUTE-DATA #x+024D4554535953)       ;SYSTEM		6
  	(ABSOLUTE-DATA #x+02000000000020)       ;<SP>		7
  	(ABSOLUTE-DATA #x+02434F5243494D)       ;MICROC		8
  	(ABSOLUTE-DATA #x+0200002045444F)       ;ODE<SP>	9
  	(ABSOLUTE-DATA #x+024F4E47414944)       ;DIAGNO		A
  	(ABSOLUTE-DATA #x+02002043495453)       ;STIC<SP>	B
  	(ABSOLUTE-DATA #x+02544954524150)       ;PARTIT		C
  	(ABSOLUTE-DATA #x+020000004E4F49)       ;ION		D
  	(ABSOLUTE-DATA #x+024C5541464544)       ;DEFAUL		E
  	(ABSOLUTE-DATA #x+02000000002054)       ;T<SP>		F
  	(ABSOLUTE-DATA #x+020020554E454D)       ;MENU<SP>	10
  	(ABSOLUTE-DATA #x+020020544F4F42)       ;BOOT<SP>	11

	(ABSOLUTE-DATA #x+024E49544F4F42)	;BOOTIN		12
  	(ABSOLUTE-DATA #x+024D4F52462047)       ;G FROM		13
	(ABSOLUTE-DATA #X+02434956454420)	; DEVIC		14
	(ABSOLUTE-DATA #X+02000000002045)	;E<SP>		15

  	(ABSOLUTE-DATA #x+0200004B534944)       ;DISK		16
  	(ABSOLUTE-DATA #x+02000045504154)       ;TAPE		17
  	(ABSOLUTE-DATA #x+0200003F3F3F3F)       ;????		18  ;no longer used ?
;;;  	(ABSOLUTE-DATA #x+0200004C4C554E)       ;NULL		19  ;no longer used
	(ABSOLUTE-DATA #x+0200204D524157)       ;WARM<SP>       19  ;new
  	(ABSOLUTE-DATA #x+0200004C42414C)       ;LABL		1A
  	(ABSOLUTE-DATA #x+0200524F525245)       ;ERROR		1B

  	(ABSOLUTE-DATA #x+02574F442F5055)       ;UP/DOW		1C
  	(ABSOLUTE-DATA #x+024F525241204E)       ;N ARRO		1D
  	(ABSOLUTE-DATA #x+024F4D203D2057)       ;W = MO		1E
  	(ABSOLUTE-DATA #x+02525543204556)       ;VE CUR		1F
  	(ABSOLUTE-DATA #x+02202020524F53)       ;SOR<SP,SP,SP>	20
	(ABSOLUTE-DATA #X+024E5255544552)	;RETURN		21
	(ABSOLUTE-DATA #X+024C4553203D20)	; = SEL		22
	(ABSOLUTE-DATA #X+02002020544345)	;ECT<SP,SP>	23
  	(ABSOLUTE-DATA #x+022054524F4241)       ;ABORT<SP>	24
  	(ABSOLUTE-DATA #x+0256455250203D)       ;= PREV		25
  	(ABSOLUTE-DATA #x+024D2053554F49)       ;IOUS<SP>M	26
;;;	(ABSOLUTE-DATA #x+02000000554E45)       ;ENU		27

	;; the reader won't accept the above line because it interpretes the E45
        ;; as an exponentiation
	(assign DATA (plus #x+02000000554045 #x+E00))
	(ABSOLUTE-DATA DATA)			;		27

	;; This is a temporary message to warm the user of the Nupi delay.
  	(ABSOLUTE-DATA #x+024D4554535953)       ;= SYSTEM	28
  	(ABSOLUTE-DATA #x+02205453455420)       ;= <SP>TEST<SP> 29
  	(ABSOLUTE-DATA #x+024F5250204E49)       ;= IN<SP>PRO	2A
  	(ABSOLUTE-DATA #x+02205353455247)       ;= GRESS<sp>	2B
  	(ABSOLUTE-DATA #x+02000000000000)       ;= 		2C
	

)) ;end of exprom