;;;;;-*- Mode:LISP; Package:LAMBDA; Base:8; readtable: ZL -*-
;;;
;;; (c) Copyright 1984,1985,1986 - Lisp Machine, Inc.
;;;


(DEFCONST *PARANOID-MODE* NIL)  ;if T, enable various read-back checks, etc, to
	;be sure you're winning.  NIL is faster.

(DEFCONST *EXECUTE-SINGLE-UINST-MODE* NIL) ;T causes LAM-EXECUTE-UINST-CLOCK
		;to use single uinst mode at full speed instead of SM-STEPping.

;;-NOTE--  before compiling this, make sure debug-uinst is compiled and loaded 
;;         also NU-DEBUG

;;this file contains the functions for hacking the directly accessible locations of the
;;processor, starting with the RG board

;; not special any more guys!!!!!
;;(defvar RG-slot nil)


;RG MOD OF 11/13/83.  Idea is to make T.A.CLOCK and T.M.CLOCK earlier so as to allow
; for reasonable buffering, etc.  Means is to anticipate them one minor cycle in
; TRAM.  These clocks want to actually occur "logically" simultaneously with
; source.cycle to execute.cycle transition.  Thus, T.A.CLOCK.NEXT, for example, wants
; to be asserted in the codeword for the LAST source cycle.  For now, we are
; clocking T.A.clock and T.M.clock always at the same time and always at the
; source to execute transition.  The only reason we might not want to do this is that
; on a dispatch instruction, this will parity check the useless A-address instead
; of the referenced dispatch location.  Eventually, we probably want a timing ram option
; to take 4 minor cycles for DISPATCH to fix this.  (it is necessary to take 4 to get
; T.A.clock back down, then up, then back down so as to be able to come up again at
; source-execute boundary of next uinst).

;TRAM fields:

(eval-when (compile load eval)
(defconst tram.state (byte 8 0))
(defconst tram.next.select (byte 2 8))
(defconst tram.hold.control (byte 2 10.))	;these are unused now.
(defconst tram.M.control (byte 4 12.))
 (defconst tram.M.address.control (byte 2 12.))  ;0 nothing
			;1 PDL index, 2 PDL pointer, 3 write address
 (defconst tram.M.CS (byte 1 14.))
 (defconst tram.M.WE-L (byte 1 15.))
(defconst tram.A.control (byte 4 16.))
 (defconst tram.A.address.control (byte 2 16.))
   (defconst tram.A.address.from.dispatch (byte 1 16.))	;otherwise from AM
   (defconst tram.AM.from.write.address (byte 1 17.)) 	;otherwise from A.source
 (defconst tram.A.WE-L (byte 1 18.))
 (defconst tram.a.clock (byte 1 19.))		;OLD RG BOARD
 (defconst tram.a.clock.next (byte 1 19.))      ;MODDED RG BOARD
(defconst tram.L.to.A-L (byte 1 20.))
(defconst tram.L.to.M-L (byte 1 21.))
(defconst tram.source.cycle (byte 1 22.))
(defconst tram.first.source.cycle.next (byte 1 22.))
(defconst tram.first.source.cycle.next-l (byte 1 22.))

(defconst tram.data.paths.to.MFO (byte 1 23.))  ;also controls T.M.clock in old RG boards
;  (defconst tram.latch.multiplicands (byte 1 24.)) ;old - not used in (at least) v2.2
(defconst tram.m.clock.next (byte 1 24.))
(defconst tram.slow.dest.write (byte 1 25.))   ;set this on the minor cycle before last
			;of a slow.destination.write.  Causes destination prom output to
			;get clocked into register and be asserted during last minor cycle.
 ; (defconst tram.m.clock.next (byte 1 26.))
(defconst tram.new.uinst (byte 1 27.))

;half-half
(defconst tram.next.cycle.number (byte 2 28.))
(defconst tram.parity (byte 4 28.))
);end of eval-when


; super duper new runtime update value.  tries to do all of the computation at
; compile time in the common cases.  As far as I know, this function is only
; used with tram stuff, but if it is used for other fields, they too will
; need an (eval-when ...) like the above to make the field definitions available
; at compile time.

;first a helper function
(eval-when (compile load eval)
(defun update-value-compute-changes (change-list)
  (do ((mask #xffffffff)
       (new-bits 0)
       (things-to-do-at-run-time nil)
       (item change-list (cddr item)))
      ((null item) (values mask new-bits things-to-do-at-run-time))
    (cond ((numberp (cadr item))
	   (setq mask (dpb 0 (symeval (car item)) mask))
	   (setq new-bits (dpb (cadr item)
			       (symeval (car item))
			       new-bits)))
	  (t
	   (setq things-to-do-at-run-time
		 (append (list (car item) (cadr item))
			 things-to-do-at-run-time))))))
);end of eval-when

(defmacro update-value (change-list &optional (old-state 0))
  (cond ((null change-list) old-state)
	((and (listp change-list)
	      (eq (car change-list) 'quote))
	 (multiple-value-bind (mask new-bits things-to-do-at-run-time)
	     (update-value-compute-changes (cadr change-list))
	   (cond ((null things-to-do-at-run-time)
		  (cond ((numberp old-state)
			 (logior new-bits (logand mask old-state)))
			(t
			 `(logior ,new-bits (logand ,mask ,old-state)))))
		 (t
		  (cond ((numberp old-state)
			 `(old-update-value ,things-to-do-at-run-time
					    ,(logior new-bits (logand mask old-state))))
			(t
			 `(run-time-update-value
			    ,things-to-do-at-run-time
			    (logior ,new-bits (logand ,mask ,old-state)))))))))
	(t
	 `(run-time-update-value ,change-list ,old-state))))

(DEFUN RUN-TIME-UPDATE-VALUE (CHANGE-LIST &OPTIONAL (OLD-STATE 0))
  (COND ((NULL CHANGE-LIST) OLD-STATE)
	(T (DPB (cond ((numberp (SECOND CHANGE-LIST))(second change-list))
		      (t (symeval (second change-list))))
		(SYMEVAL (FIRST CHANGE-LIST))
		(UPDATE-VALUE (CDDR CHANGE-LIST)
			      OLD-STATE)))))

;(DEFUN CHANGE-CON-REG-AND-CHECK (CHANGE-LIST &OPTIONAL (OLD-STATE (READ-CON-REG)))
;  (LET ((NEW-STATE (UPDATE-VALUE CHANGE-LIST OLD-STATE))
;	(TEM1)
;	(TEM2))
;    (WRITE-CON-REG NEW-STATE)
;    (IF ( (setq tem1 (LOGAND  17 NEW-STATE))
;	   (SETQ TEM2 (LOGAND 17  (READ-CON-REG))))	;mask out read only bits
;	(FERROR NIL "CONFIGURATION REG FAILS, WROTE ~O  READ ~O"
;		TEM1 TEM2))))

;this is a macro so when change-list is a constant, that information can be
;passed along to update-value, who will then do as much computation as possible
;at compile time
(defmacro change-con-reg-and-check (change-list &optional (old-state '(read-con-reg)))
  `(let ((new-state (update-value ,change-list ,old-state))
	 (tem1)
	 (tem2))
     (write-con-reg new-state)
     (if (not (= (setq tem1 (logand 17 new-state))
		 (logand 17 (setq tem2 (read-con-reg 17)))))
	 (ferror nil "CONFIGURATION REG FAILS, WROTE ~O READ ~O (only lo 4 bits writeable)"
		 tem1 tem2))))

;(DEFUN CHANGE-CON-REG (CHANGE-LIST &OPTIONAL (OLD-STATE (READ-CON-REG)))
;  (WRITE-CON-REG (UPDATE-VALUE CHANGE-LIST OLD-STATE)))

(defmacro change-con-reg (change-list &optional (old-state '(read-con-reg)))
  `(write-con-reg (update-value ,change-list ,old-state)))

;spy-read moved to diag-system

(defun spy-read-byte (byte-number spy-address)
  (logand 377 (ash (spy-read spy-address) (* byte-number -8.))))

;(defun spy-write (adr data)
;  (nd-slot-write rg-slot (logand 37 adr) data))

;spy-write moved to diag-system

(defun spy-write-byte (byte-number spy-address data)
 ; nd-slot-write-byte does enable-nd-byte-mode
 ;(enable-nd-byte-mode)
 ;  (nd-slot-write-byte rg-slot
 ;		      (dpb byte-number 0002 (ash spy-address 2))
 ;		      data)
  (send *proc* :bus-slot-write-byte (send *proc* :rg-slot) (dpb byte-number 0002 (ash spy-address 2)) data)
 ;(disable-nd-byte-mode)
 )

;(DEFUN CHANGE-PMR (CHANGE-LIST)
;  (WRITE-PMR
;    (UPDATE-VALUE CHANGE-LIST (READ-PMR))))
(defmacro change-pmr (change-list)
  `(write-pmr (update-value ,change-list (read-pmr))))

;(DEFUN CHANGE-PMR-AND-CHECK (CHANGE-LIST)
;  (LET ((NEW-VALUE (UPDATE-VALUE CHANGE-LIST (READ-PMR))))
;    (WRITE-PMR NEW-VALUE)
;    (COND (( NEW-VALUE (READ-PMR))
;	   (FERROR NIL "~%PMR DID NOT LOAD PROPERLY, WROTE ~O , NOW READS ~O"
;		   NEW-VALUE (READ-PMR))))))
(defmacro change-pmr-and-check (change-list)
  `(let ((new-value (update-value ,change-list (read-pmr))))
     (write-pmr new-value)
     (cond ((not (= new-value (read-pmr)))
	    (ferror nil "PMR DID NOT LOAD PROPERLY, WROTE ~O, NOW READS ~O"
		    new-value (read-pmr))))))

(DEFUN SETUP-PMR (&OPTIONAL (SETUP-LIST STANDARD-PMR-LIST))
  (declare (special standard-pmr-list))
  (LET ((NEW-VALUE (UPDATE-VALUE SETUP-LIST)))
    (WRITE-PMR NEW-VALUE)
    (COND (( NEW-VALUE (READ-PMR))
	   (FERROR NIL "~%PMR DID NOT LOAD PROPERLY, WROTE ~O , NOW READS ~O"
		   NEW-VALUE (READ-PMR))))))


;handling of clocks:
;  SM clock is the most basic clock of the machine.  It drives the Timing state machine
;and cache state machine.  If lambda is not ENABLED, SM clock is driven directly
;from the PMR.
;  UINST-CLOCK is the microinstruction level clock.  It is driven by latches which are
;in turn clocked by SM clock.  The input to the latches comes from the AND of
;the PMR bit ALLOW-UINST-CLOCK and the TREG bit T.req.next.uinst.clock .  Thus, if this
;TREG bit is present, UINST-CLOCK will go high on the next SM clock if ALLOW-UINST-CLOCK
;is true.  SM clocks are either source cycles or execute cycles.  The first SM clock
;of a UINST is a source cycle.  The reset of the SM clocks associated with a UINST are
;execute cycles, of which there can be one or more.
;  All source cycles are exactly identical from the point of view of the TREG.
;There is a single codeword which appears in the TREG during a source cycle.  It
;is conventionally stored in TRAM location 3000.  The T.req.next.uinst.clock
;is associated with the last execute cycle of a UINST.  Thus, the same sm clock which
;causes the source codeword to appear in the TREG also causes UINST-CLOCK 
;(provided ALLOW-UINST-CLOCK is true).
; A primary concern is the appropriate preservation of state.  It must be true
;that, as the machine is running along, it can be stopped, various registers examined, etc,
;and later the machine proceeded as if nothing had happened.  Microinstruction
;boundaries are defined to be the intervals at which such preservation of state
;is possible.
; The machine can be stopped at any SM clock.  Thus the state saving sequence has
;the following parts:
;  (1)	Advance the machine to the next uinst boundary, doing zero or more SM clocks.
;A machine state now exists which can potentially be saved.  Uinst boundaries are defined
;by the appearance of the SOURCE codeword in the TREG, which in turn, can be detected
;by the T.source.cycle bit being on.
;  (2)  Complete pipelined operations which are in progress.  This is accomplished
;by completing a NO-OP uinst, which gives pipelined writes to the A and M memories
;an opportunity to complete.  During this clocking process, undesired state alterations must
;be avoided.
;  The machine is now "clean" and various registers can be examined, etc, as desired.

;  Even when the machine is in a clean state, various conventions are necessary.
;One reason for this is that on Lambda, it is necessary to clock the machine even
;to examine registers.  Another is that, for hardware reasons, it is possible to
;write the IREG only when the UINST-CLOCK is low.  A third source of complications is
;the NO.OP flipflop.  If set, NO.OP will no-op microinstructions, which could cause
;microinstructions intended to examine or write memories not to function as desired.
;It is not possible to directly clear the NO-OP flipflop.
;However, one can zero the IREG and cause a UINST-CLOCK, which will clear NO-OP.

;  Note that with the machine at a uinst boundary, (ie SOURCE codeword in TREG),
;normally the UINST-CLOCK will be high.  This is unfortunate, since that prevents
;loading IREG.  Thus, it may be necessary to do a FORCE-UINST-CLOCK-LOW.

;  The transition of UINST-CLOCK low to high clocks all microcode level
;edge-triggered registers in the machine, such as the instruction register.
;The hardware provides the ALLOW-UINST-CLOCKS low bit in the control register
;which allows the SM clocks to be generated without causing UINST-CLOCKS and
;possible loss of state in edge-triggered registers.
;  One must also consider the write-pulse memories, notably the A and M memories.
;The write enable lines of these are controlled directly by the TREG.
;THERE NEEDS TO BE ADDED AN AM.WRITE.PULSE ENABLE BIT TO THE CONTROL REGISTER TO
;ALLOW SUPPRESSION OF WRITE.PULSES TO AM AS VARIOUS CLOCKING IS DONE.

; Once the machine is in a clean state, there are three kinds of operations possible.
;Some operations are provided directly in the spy hardware, and cause no problems
;with respect to clocking, some involve executing microinstructions for purposes of
;reading and some involve executing them for purposes of writing.
;  Even a read involves clocking the machine.  After the uinst is in the IREG,
;we need to cause the fetch codeword to appear in the TREG, then do a SM clock.
;This will cause the machine to advance to the first execute cycle, and
;drive the desired data onto the MFO.bus where it can be read.  Note, that at
;this point T.req.new.uinst will normally be high, so another SM-TICk will
;cause a UINST-CLOCK.
;  The proceedure on a write is identical to a read, followed more SM-TICKs
;until a microinstruction boundary is reached.  The last of these SM-TICKs will
;cause a UINST-CLOCK.  If the write destination is edge triggered the UINST-CLOCK
;will accomplish the write.  If an write-pulse memory has been written, the instruction
;register should be zeroed and the machine clocked to the next microinstruction boundary.

(DEFCONST SOURCE-CYCLE-DOUBLED-IN-TRAM nil)	;t if tram doubles source and execute cycles
(DEFCONST SOURCE-CYCLE-TRIPLED-IN-TRAM nil)
(DEFCONST EXECUTE-CYCLE-DOUBLED-IN-TRAM nil)
(DEFCONST EXECUTE-CYCLE-TRIPLED-IN-TRAM nil)	;if doubled true, then this triples it.
(DEFVAR TRAM-LOCATION-3000 NIL)  ;CONTENTS OF TRAM LOCATION 3000.  AT UINST BOUNDARY WHEN
				 ; THIS IN TREG.  Dont reference this directly! Instead
				 ; call (TRAM-LOCATION-3000).

(defun tram-triple-triple nil
  (setq source-cycle-doubled-in-tram t)
  (setq source-cycle-tripled-in-tram t)
  (setq execute-cycle-doubled-in-tram t)
  (setq execute-cycle-tripled-in-tram t)
  (init-tram))

;write con reg does a byte op to write only the writeable part. (unfortunately, byte writes
; to the read-only part are not ignored, so the SDU loses if a 32 bit op is attempted).
; only 8 bits are writable anyway.
(DEFUN WRITE-CON-REG (DATA)
                                           ;the bits in the con reg are inverted

  (cond ((access-path-lmi-serial-protocol *proc*)
	 (funcall *proc* ':prin1 data)
	 (funcall *proc* ':tyo-cr #/L)
	 (funcall *proc* ':string-out "77Y
"))
	(t 
	 (funcall *proc* :bus-slot-write-byte (SEND *PROC* :RG-SLOT)
		       77773774
		       (LOGAND 377 DATA))))	;when they come off the bus and in the
						;con reg

)




;read con reg reads the whole thing, including the read-only part, with a 32 bit operation.
(DEFUN READ-CON-REG (&optional (compare-mask 17))
                                                   ;as a default, compare only bits really 
						   ; writable.
  (cond ((access-path-lmi-serial-protocol *proc*)
	 (funcall *proc* ':string-out "77X ")
	 (funcall *proc* ':read-32 compare-mask))
	(t
	 (funcall *proc* :bus-slot-read (SEND *PROC* :RG-SLOT) 77773774))))



(eval-when (compile load eval)
(DEFCONST INIT-BIT 0001)

(DEFCONST ENABLE-NU-MASTER-BIT 0101)
	  
(DEFCONST LED-BIT 0201)

(DEFCONST ENABLE-SM-CLOCK-BIT 0301)			;same as -debug.clock.mode

(DEFCONST NOOP-BIT 0401)	;THE NEXT 4 ARE READ ONLY.  They are read back thru
						;a non-inverting buffer, so the net
(DEFCONST NOOP-NEXT-BIT 0501)			;result is they seem inverted from the
						;actual signal used on the board
(DEFCONST T-HOLD-L-BIT 0601)

(DEFCONST UINST-CLOCK-L-BIT 0701)

(DEFCONST STAT-HALT-L-BIT 1001)			;The next 24 bits of the con-reg are also
						;read-only, but are read back thru an
(DEFCONST HALT-REQUEST-BIT 1101)		;inverting register - thus, they seem the
						;same sense as they are on the board

(defconst any-parity-error-bit 1201)    

(defconst hbus-present-l-bit 1301)    

  ;*** OLD BOARDS MAY HAVE THIS ON BIT 12 INSTEAD, BUT THEY AREN'T EXPECTED TO 
  ;    TO DO PARITY RIGHT ANYWAY

(DEFCONST DEBUG-CLOCK-MODE-SYNCED 1401)	;** ?? **

(defconst any-parity-error-synced-l-bit 1501)
  ;this is actually what stops SM.clock.
  ;when a parity error is detected, one more sm.clock happens before machine really
  ;stops completely (t.hold is asserted during this clock, however).
  ;if the parity error goes away this last sm.clock, the machine will stop with 
  ;the any-parity-error-synced bit set, but any-parity-error no longer set.

;; The other 20 bits of the con-reg are not currently used ... if you think of something...

);end eval-when

;This can be called with machine running
(defun print-regs ()
 (print-con-reg)
 (print-pmr)
  )

(DEFUN PRINT-CON-REG ()
  (print-con-reg-data (read-con-reg)))

(defun print-con-reg-data (con-reg)
  (format t "~%..................................")
  (format t "~%     CONFIGURATION REGISTER ")
  (format t "~%..................................")
  (FORMAT T "~%~[SM-CLOCK disabled~;SM-CLOCK enabled~]"
	  (ldb enable-sm-clock-bit con-reg))
  (FORMAT T "~[~;~%Lambda INIT bit ON~]"
	  (ldb init-bit con-reg))
  (FORMAT T "~%~[NUBUS mastership disabled~;NUBUS mastership enabled~]"
	  (ldb enable-nu-master-bit con-reg))
  (FORMAT T "~%~[LED OFF~;LED ON~]"
	  (ldb led-bit con-reg))
  (FORMAT T "~%~[NOT NOOP~;NOOP~]"
	  (ldb NOOP-BIT con-reg))
  (FORMAT T "~%~[NOT NOOP-NEXT-UINST~;NOOP-NEXT-UINST~]"
	  (ldb NOOP-NEXT-BIT con-reg))
  (FORMAT T "~[~%T-HOLD~;~]"
	  (LDB T-HOLD-L-BIT CON-REG))
  (FORMAT T "~%~[UINST-CLOCK HIGH~;UINST-CLOCK LOW~]"
	  (LDB UINST-CLOCK-L-BIT CON-REG))
  (FORMAT T "~[~%STAT-HALT~;~]"
	  (ldb stat-halt-l-bit con-reg))
  (FORMAT T "~[~;~%HALT-REQUEST~]"
	  (ldb halt-request-bit con-reg))
  (format t "~[~;~%Parity Error~]"
	  (ldb any-parity-error-bit con-reg))
  (format t "~[~%Parity Error last SM CLOCK~;~]"
	  (ldb any-parity-error-synced-l-bit con-reg))
  (format t "~[~;~%HBUS NOT PRESENT~]"
	  (ldb hbus-present-l-bit con-reg))
  (format t "~%..................................~%"))

(defconst check-parity NIL)			;parity off by default

(DEFUN PRINT-CON-REG-ONE-LINE (&optional (con-reg (read-con-reg)))
    (FORMAT T "~%~%~[NOT-NOOP~;NOOP~]  ~[NOT-NOOP-NEXT-UINST~;NOOP-NEXT~] ~[SM-CLOCK-DISABLED~;SM-CLOCK-ENABLED~]
~[NOT RESET~;RESET~] ~[NUBUS MASTERSHIP DISABLED~;NUBUS MASTERSHIP ENABLED~] ~[**T-HOLD**~;NOT-T-HOLD~]
~[UINST-CLOCK-HIGH~;UINST-CLOCK-LOW~] ~[STAT-HALT~;NO-STAT-HALTED~] ~[NO-HALT-REQUEST~;HALT-REQUEST~] ~[no-parity-error~;parity-error~]~%"
	    (ldb NOOP-BIT con-reg)
	    (ldb NOOP-NEXT-BIT con-REG)
	    (ldb enable-sm-clock-bit con-reg)
	    (ldb init-bit con-reg)
	    (ldb enable-nu-master-bit con-reg)
	    (LDB T-HOLD-L-BIT CON-REG)
	    (LDB UINST-CLOCK-L-BIT CON-REG)
	    (ldb stat-halt-l-bit con-reg)
	    (ldb halt-request-bit con-reg)
	    (ldb any-parity-error-bit con-reg)))

(DEFUN PRINT-TICK-DATA NIL
  (format t "~%TRAM adr: ~o, treg: ~o, pc: ~o, ireg: ~o"
	  (read-tram-adr) (read-treg) (read-pc) (read-ireg)))

(DEFUN UINST-CLOCK-LOW-P ()
  (= 1 (LDB UINST-CLOCK-L-BIT (READ-CON-REG))))

;this is set in (setup)
(defvar izero-good-parity)

(DEFUN ZERO-IREG-IF-POSSIBLE ()
  (IF (UINST-CLOCK-LOW-P) (WRITE-IREG izero-good-parity)))

(DEFUN ZERO-IREG ()
  (IF (NOT (UINST-CLOCK-LOW-P))
;     (progn (FORCE-UINST-CLOCK-LOW)(format t "~A~%" (uinst-clock-low-p)))
      (FORCE-UINST-CLOCK-LOW))
 (WRITE-IREG-AND-CHECK izero-good-parity))

(DEFUN ZERO-IREG-IF-POSSIBLE-THEN-SM-TICK ()
  (ZERO-IREG-IF-POSSIBLE)
  (SM-TICK))

(DEFUN ZERO-IREG-THEN-SM-TICK ()
  (ZERO-IREG)
  (SM-TICK))

(DEFUN TEST-CON-REG NIL
  (INIT-LAMBDA)
  (COND ((EQUAL 4 (LOGAND 17 (READ-CON-REG)))
	 (FORMAT T "~% CON-REG"))
	(T NIL)))

(DEFUN INIT-LAMBDA ()
  (WRITE-CON-REG 1))				;WRITES 1 TO THE INIT-BIT, WHICH DOES A
						;RESET AND THEN SETS THE LOW CONREG BITS TO
						;40

(defun led-on ()
  (change-con-reg-and-check '(led-bit 1)))

(defun led-off ()
  (change-con-reg-and-check '(led-bit 0)))

(DEFUN ENABLE-LAMBDA ()
  (if check-parity
      (enable-parity))
    (CHANGE-CON-REG-AND-CHECK
    '(ENABLE-SM-CLOCK-BIT 1)))

(defvar *last-parity-vector* nil)

(defvar *last-pmr* nil)

(DEFUN ENABLE-LAMBDA-AND-NU-MASTER (&OPTIONAL &KEY (AND-DONT-TOUCH NIL))
  (if check-parity
      (enable-parity))
  (IF AND-DONT-TOUCH
      (CHANGE-CON-REG
	'(ENABLE-NU-MASTER-BIT 1 ENABLE-SM-CLOCK-BIT 1))
    (CHANGE-CON-REG-AND-CHECK
      '(ENABLE-NU-MASTER-BIT 1 ENABLE-SM-CLOCK-BIT 1))))

(DEFUN DISABLE-LAMBDA-AND-NU-MASTER ()		;if parity is enabled, store enable
						;vector and error-vector and then
						;disable parity
    (CHANGE-CON-REG-AND-CHECK
    '(ENABLE-NU-MASTER-BIT 0 ENABLE-SM-CLOCK-BIT 0))
    (setq *last-pmr* (read-pmr)
	  *last-parity-vector* (read-parity))
    (disable-parity)
)

(DEFUN ENABLE-CACHE NIL
  (CHANGE-PMR '(DEBUG-CACHE-PERMIT 1)))

(DEFUN DISABLE-CACHE NIL
  (CHANGE-PMR '(DEBUG-CACHE-PERMIT 0)))

(eval-when (compile load eval)
;; bits in the register:
;;
;;	23-22	:unused, but can be read back with the rest

;       21 prevents T.req.next.uinst from clocking into uinst.clock.

(DEFCONST ALLOW-UINST-CLOCKS 2501)

;;	20  force.csm.use.spy.address

(DEFCONST FORCE-CSM-USE-SPY-ADDRESS-L 2401)

;;	19  force.mi.reset L

(DEFCONST FORCE-MI-RESET-L 2301)

;;	18  force t.hold

(DEFCONST FORCE-T-HOLD 2201)

;;	17  forces tram to get address from tram.adr.reg

(DEFCONST SPY-ADDRESS-TRAM-L 2101)

;;	16-15	:unused.

;;	14	:clear.noop.low ; 1 = clear any current noop; 0 = allow noops

(DEFCONST CLEAR-NOOP-L 1601)

;;	13    :unused.

;;	12-8  parity-enable-field

(DEFCONST PARITY-ENABLE-FIELD 1005)

(DEFCONST ENABLE-TREG-PARITY 1401)
(DEFCONST ENABLE-MID-PARITY 1301)
(DEFCONST ENABLE-DP-PARITY 1201)
(DEFCONST ENABLE-CM-PARITY 1101)
(DEFCONST ENABLE-MI-PARITY 1001)


;;	7	:parity stop enable ; 1 = stop on parity errors

(DEFCONST PARITY-STOP-ENABLE 0701)

;; ** not used in v3.0 or later; individual parity controls  provided above

;;	6	:debug cache permit ; 1 = lambda uses cache; 0 = always take cache fault

(DEFCONST DEBUG-CACHE-PERMIT 0601)

;;	5	:advance uinst request; a transition from 0 to 1 causes a single uinst

;;		 step, or tries to restart the lambda if it is in a halted state
;;		used to be called advance-restart-request.

(DEFCONST ADVANCE-UINST-REQUEST 0501)

;;	4	:debug clock ; this bit directly controls the sm clock if the lambda
;;		 is in debug clock mode (set with a 0 in bit 3 of the configuration reg)

(DEFCONST DEBUG-CLOCK 0401)

;;	3	:reset interrupt counter L ; sets the pointer to the interrupt location
;;		:to zero

(DEFCONST RESET-INTERRUPT-COUNTER-L 0301)

;;	2	:clock speed ; 0 = sm clock is double the speed of the bus clock
;;			       1 = sm clock is the same speed as the bus clock

(DEFCONST FAST-CLOCK-ENABLE-L 0201)

;;  ** not used by v3.0 and later boards **
;;
;;	1	:single step mode ; 1 = halt request all the time...this needs the
;;		 right TRAM program to work, where halt request inhibits uinst clocks,
;;		 but doesn't otherwise gum up the works.  The machine can be stepped
;;		 by temporarilly releasing halt request, getting the clock, and then
;;		 asserting halt request again

(DEFCONST SINGLE-STEP-MODE 0101)

;;;     0   : stat.halt.enable L -- if enabled, halts the machine when the stat counter gets
;;;         to zero (useful for many debugging functions and metering); 0 = enabled
;;;									1 = disabled

(DEFCONST STAT-HALT-ENABLE-L 0001)

);end eval-when

(DEFUN ENABLE-LAMBDA-SINGLE-STEPPING (&OPTIONAL (AND-NU-MASTER NIL))
   ;it takes a couple of SM.clocks for the HALT.REQUEST to appear due to syncronizers.
   ;  Forcing T.hold prevents the machine from advancing during those.
  (CHANGE-PMR '(SINGLE-STEP-MODE 1 FORCE-T-HOLD 1 ALLOW-UINST-CLOCKS 0))
  (IF AND-NU-MASTER (ENABLE-LAMBDA-AND-NU-MASTER)
    (ENABLE-LAMBDA))
  (CHANGE-PMR '(FORCE-T-HOLD 0 ALLOW-UINST-CLOCKS 1)))

(DEFUN DISABLE-LAMBDA-AND-CLEAR-SINGLE-STEP ()
  (DISABLE-LAMBDA-AND-NU-MASTER)
  (CHANGE-PMR '(SINGLE-STEP-MODE 0)))

(DEFUN SET-SINGLE-STEP-MODE ()
  (CHANGE-PMR '(SINGLE-STEP-MODE 1)))

(DEFUN CLEAR-SINGLE-STEP-MODE ()
  (CHANGE-PMR '(SINGLE-STEP-MODE 0)))

(DEFUN ADVANCE-UINST ()
  (CHANGE-PMR '(ADVANCE-UINST-REQUEST 0))
  (CHANGE-PMR '(ADVANCE-UINST-REQUEST 1))
  (CHANGE-PMR '(ADVANCE-UINST-REQUEST 0)))

(defun fast-advance-uinst-loop ()
  (let ((pmr-0 (ash (update-value '(advance-uinst-request 0) (read-pmr)) 8.))
	(pmr-1 (ash (update-value '(advance-uinst-request 1) (read-pmr)) 8.))
	(pmr-adr (+ (dpb (send *proc* :rg-slot) (byte 4 24.) #xf0000000) 20_2)))
    (bb-nd-bus-write pmr-adr pmr-0)
    (do-forever
      (bb-nd-bus-write pmr-adr pmr-1)
      (bb-nd-bus-write pmr-adr pmr-0))))

(DEFUN DISABLE-LAMBDA ()	;switch to debug clock mode
  (CHANGE-CON-REG-AND-CHECK
    '(ENABLE-SM-CLOCK-BIT 0)))

;;the processor mode register has bits which control the clock speed, the width and
;;timing of the write pulse, single-step mode, parity-stop-enable, clearing of the
;;csm reg,reseting the interrupt counter, and ticking the debug clock.
;;
;;the pmr is offset to the high 24 bits of the data word - - the low bits are read from
;;the configuration prom...just to prevent any undriven lines on reads.

(defvar pmr-last-written nil)

(defun read-pmr ()
  (let ((tem (logand 77777777 (ash (spy-read 20) -10))))
    (if (zerop (ldb fast-clock-enable-l tem))
	(format t "WARNING: fast-clock-enable is on"))
    tem))

(defun write-pmr (data)
  (spy-write 20 (ash (setq pmr-last-written data) 10)))

;for use only by test-pmr-data-path, which doesnt want above testing.
(defun write-pmr-direct (data)
  (spy-write 20 (ash (setq pmr-last-written data) 10)))
  

(defun read-pmr-direct ()
  (logand 77777777 (ash (spy-read 20) -10)))

;write pmr one byte at a time, to imitate sdu, check the transfer mode decode logic

(defun write-pmr-byte (byte-number data)
    (spy-write-byte byte-number 20 data)
  )


(defun read-pmr-byte (byte-number)
  (spy-read-byte byte-number 20))


(defun read-pmr-in-loop ()
  (let ((data (read-pmr-direct)))
    (do () (())
      (cond ((not (= (read-pmr-direct) data))
	     (tv:beep))))))

(defun write-pmr-in-loop (data)
  (do () (())
    (write-pmr-direct data)
    (cond ((not (= (read-pmr-direct) data))
	   (tv:beep)))))

(DEFUN PRINT-PMR NIL
  (PRINT-PMR-DATA (READ-PMR)))

(DEFUN PRINT-PMR-DATA (PMR)
  (format t "~%~%________________________________________")
  (format t "~%  PROCESSOR MODE REGISTER = ~o  " pmr)
  (format t "~%----------------------------------------")
  (FORMAT T "~[~;~%Single step microinstruction mode~]"
	  (LDB SINGLE-STEP-MODE PMR))
  (FORMAT T "~[~%Interrupt counter forced to zero~;~]"
	  (LDB RESET-INTERRUPT-COUNTER-L PMR))
  (FORMAT T "~%~[Manual clock bit LOW~;Manual clock bit HIGH~]"
	  (LDB DEBUG-CLOCK PMR))
  (FORMAT T "~%~[ADVANCE-UINST-REQUEST bit LOW~;ADVANCE-UINST-REQUEST bit HIGH~]"
	  (LDB ADVANCE-UINST-REQUEST PMR))
  (FORMAT T "~%~[CACHE disabled~;CACHE enabled~]"
	  (LDB DEBUG-CACHE-PERMIT PMR))
  (FORMAT T "~%~[NOOPS cleared~;NOOPS enabled~]"
	  (LDB CLEAR-NOOP-L PMR))
  (FORMAT T "~[~%TRAM address comes from TRAM.ADR.REG~;~]"
	  (LDB SPY-ADDRESS-TRAM-L PMR))
  (FORMAT T "~[~;~%T-HOLD is forced~]"
	  (LDB FORCE-T-HOLD PMR))
  (FORMAT T "~%~[MI board is RESET~;MI board is ENABLED~]"
	  (LDB FORCE-MI-RESET-L PMR))
  (FORMAT T "~[~%CSM address comes from CSM.ADR.REG~;~]"
	  (LDB FORCE-CSM-USE-SPY-ADDRESS-L PMR))
  (FORMAT T "~%~[NEXT UINST-CLOCK is inhibited~;ALLOW-UINST-CLOCKS~]"
	  (LDB ALLOW-UINST-CLOCKS PMR))
  (FORMAT T "~%~[Halt on STAT-COUNTER ~;STAT-COUNTER halts disabled~]"
	  (LDB STAT-HALT-ENABLE-L PMR))
  (FORMAT T "~%Parity ~[NOT enabled~:;enabled for~]~
			     ~[~; Treg ~]~
			     ~[~; MID ~]~
			     ~[~; DP ~]~
			     ~[~; CM ~]~
			     ~[~; MI ~]"
	  (LDB PARITY-ENABLE-FIELD PMR)		;PRINTS "NOT enabled" if 0,
						;defaults to "enabled for"
						;otherwise
	  (LDB ENABLE-TREG-PARITY PMR)
	  (LDB ENABLE-MID-PARITY PMR)
	  (LDB ENABLE-DP-PARITY PMR)
	  (LDB ENABLE-CM-PARITY PMR)
	  (LDB ENABLE-MI-PARITY PMR))

  (format t "~%---------------------------------------~%"))

(DEFUN DEBUG-SM-CLOCK ()
  (LET ((PMR (READ-PMR)))
    (WRITE-PMR (DPB 1 DEBUG-CLOCK PMR))		;makes it LOW?
    (WRITE-PMR (DPB 0 DEBUG-CLOCK PMR))))	;makes it HIGH?




(DEFCONST STANDARD-PMR-LIST
        '(FAST-CLOCK-ENABLE-L 1
	  RESET-INTERRUPT-COUNTER-L 1
	  SINGLE-STEP-MODE 0
	  CLEAR-NOOP-L 1
	  ADVANCE-UINST-REQUEST 0
	  PARITY-STOP-ENABLE 0			;while we are checking things out
	  SPY-ADDRESS-TRAM-L 1
	  DEBUG-CACHE-PERMIT 0
	  FORCE-CSM-USE-SPY-ADDRESS-L 1
	  ALLOW-UINST-CLOCKS 1
	  FORCE-MI-RESET-L 1
	  STAT-HALT-ENABLE-L 1
	  ))

(DEFCONST early-PMR-LIST
        '(FAST-CLOCK-ENABLE-L 1
	  RESET-INTERRUPT-COUNTER-L 1
	  SINGLE-STEP-MODE 0
	  CLEAR-NOOP-L 1
	  ADVANCE-UINST-REQUEST 0
	  PARITY-STOP-ENABLE 0			;while we are checking things out
	  SPY-ADDRESS-TRAM-L 1
	  DEBUG-CACHE-PERMIT 0
	  FORCE-CSM-USE-SPY-ADDRESS-L 1
	  ALLOW-UINST-CLOCKS 1
	  FORCE-MI-RESET-L 0
	  STAT-HALT-ENABLE-L 1
	  ))


(DEFCONST TRAM-ADR-FROM-TRAM-ADR-REG-PMR-LIST
	  '(FAST-CLOCK-ENABLE-L 1
	    SINGLE-STEP-MODE 0
	    ADVANCE-UINST-REQUEST 0
	    PARITY-STOP-ENABLE 0	;while we are checking things out
	    SPY-ADDRESS-TRAM-L 0
  ;	    DEBUG-CACHE-PERMIT 0
	    FORCE-CSM-USE-SPY-ADDRESS-L 1
  ;	    ALLOW-UINST-CLOCKS 0
	    STAT-HALT-ENABLE-L 1
	    ))

;; -these were removed from the above list: they should default to whatever the old state was
;; hence, this list should be used with change-pmr, not setup.
;;	    FORCE-MI-RESET-L 1
;;	    CLEAR-NOOP-L 1
;;	    RESET-INTERRUPT-COUNTER-L 1

(DEFCONST CSMRAM-ADR-FROM-CSMRAM-ADR-REG-PMR-LIST
	  '(FAST-CLOCK-ENABLE-L 1
	    RESET-INTERRUPT-COUNTER-L 1
	    SINGLE-STEP-MODE 0
	    CLEAR-NOOP-L 1
	    ADVANCE-UINST-REQUEST 0
	    PARITY-STOP-ENABLE 0			;while we are checking things out
	    SPY-ADDRESS-TRAM-L 1
  ;	    DEBUG-CACHE-PERMIT 0
	    FORCE-CSM-USE-SPY-ADDRESS-L 0
  ;	    ALLOW-UINST-CLOCKS 1
	    FORCE-MI-RESET-L 1
	    STAT-HALT-ENABLE-L 1
	  ))

(defun reset-mi ()
  (cond ((= 0 (ldb force-mi-reset-l (read-pmr))))
	(t
	 (change-pmr-and-check '(force-mi-reset-l 0))
	 (change-pmr-and-check '(force-mi-reset-l 1)))))

(defun DISABLE-MI ()
  (change-pmr-and-check '(force-mi-reset-l 0)))

(defun enable-mi-for-maps ()
  (ferror nil "this function not written yet"))

(defun enable-mi ()
  (ferror nil "this function appears to be wrong... rg 1/28/84")
  (cond ((= 0 (ldb force-mi-reset-l (read-pmr))))	;inverted??
	(t
	 (change-pmr-and-check '(force-mi-reset-l 0))
	 (change-pmr-and-check '(force-mi-reset-l 1)))))

(defun reset-t-hold ()
  (reset-mi)
  (lam-reset-cache)
  )

;;; THE DP MODE REGISTER IS MOSTLY UNUSED, BUT SOMEDAY MAY CONTAIN A GREAT DEAL MORE
;;; DEBUGGING INFORMATION.  FOR NOW, IT ONLY HAS TWO SIGNALS, BUT IT CAN ALSO BE USED
;;; TO JUMPER INTERESTING SIGNALS TO SO THAT THEY CAN BE EXAMINED BY THE PROCESSOR WHILE
;;; IT'S RUNNING.  NOTE THAT ONLY THE BOTTOM 6 BITS ARE READ/WRITE - THE TOP TWO BITS
;;; ARE READ ONLY.

;;; There are 8 bits in the DP Mode register :

;;; bit 7 : the divisor sign bit ... 0 = positive , 1 = negitive

(DEFCONST DIVISOR-SIGN 0701) 

;;; bits 6-1 are unused

;;; bit 0 : the PDL.address.high bit ... 0 = M memory (only low 64 locations normally used)
;;;					 1 = PDL memory

(DEFCONST PDL.ADDRESS.HIGH 0001)


(DEFUN READ-DP-MODE (&optional (compare-mask 77))
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-M-SRC LAM-M-SRC-DP-MODE
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-MFO COMPARE-MASK))

(DEFUN WRITE-DP-MODE (NUM)		
  (WRITE-SPY-REG-AND-CHECK (LOGAND 77 NUM))	;NOTE -- YOU CAN ONLY WRITE 6 BITS!!!
  (LAM-EXECUTE (WRITE)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-ALUF LAM-ALU-SETM
	       LAM-IR-FUNC-DEST LAM-FUNC-DEST-DP-MODE))


;(DEFUN CHANGE-DP-MODE (CHANGE-LIST)
;  (WRITE-DP-MODE
;    (UPDATE-VALUE CHANGE-LIST (LOGAND 77 (READ-DP-MODE)))))
(defmacro change-dp-mode (change-list)
  `(write-dp-mode (update-value ,change-list (logand 77 (read-dp-mode)))))

;(DEFUN CHANGE-DP-MODE-AND-CHECK (CHANGE-LIST)
;  (LET ((NEW-VALUE (UPDATE-VALUE CHANGE-LIST (LOGAND 77 (READ-DP-MODE)))))
;    (WRITE-DP-MODE NEW-VALUE)
;    (COND (( NEW-VALUE (LOGAND 77 (READ-DP-MODE)))
;	   (FERROR NIL "~%DP-MODE DID NOT LOAD PROPERLY, WROTE ~O , NOW READS ~O"
;		   NEW-VALUE (LOGAND 77 (READ-DP-MODE)))))))
(defmacro change-dp-mode-and-check (change-list)
  `(let ((new-value (update-value ,change-list (logand 77 (read-dp-mode)))))
     (write-dp-mode new-value)
     (cond ((not (= new-value (logand 77 (read-dp-mode))))
	    (ferror nil "~%DP-MODE DID NOT LOAD PROPERLY, WROTE ~O, NOW READS ~O"
		    new-value (logand 77 (read-dp-mode)))))))

(DEFCONST STANDARD-DP-MODE-LIST
        '(PDL.ADDRESS.HIGH 1
	  ))

(DEFUN SETUP-DP-MODE (&OPTIONAL (SETUP-LIST STANDARD-DP-MODE-LIST))
  (LET ((NEW-VALUE (UPDATE-VALUE SETUP-LIST)))
    (WRITE-DP-MODE NEW-VALUE)
    (COND (( NEW-VALUE (LOGAND 77 (READ-DP-MODE 77)))
	   (FERROR NIL "~%DP-MODE DID NOT LOAD PROPERLY, WROTE ~O , NOW READS ~O"
		   NEW-VALUE (LOGAND 77 (READ-DP-MODE)))))))

(DEFUN PRINT-DP-MODE NIL
  (PRINT-DP-MODE-DATA (READ-DP-MODE)))

(DEFUN PRINT-DP-MODE-DATA (DP-MODE)
  (format t "~%~%&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&")
  (format t "~%  DP MODE REGISTER = ~o  " dp-mode)
  (format t "~%&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&")
  (FORMAT T "~%~[DIVISIOR SIGN : POSITIVE ~;DIVISIOR SIGN : NEGATIVE~]"
	  (LDB DIVISOR-SIGN DP-MODE))
  (FORMAT T "~%~[PDL ADDRESS LOW {M-MEMORY}~;~%PDL ADDRESS HIGH {PDL-MEMORY}~]"
	  (LDB PDL.ADDRESS.HIGH DP-MODE))
  (format t "~%&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&~%"))


;;; THERE IS ALSO A 16 BIT RG MODE REGISTER WHICH HAS LOTS OF INTERESTING THINGS.
;;; IT CONTAINS MOST OF THE FUNCTIONALITY OF THE OLD CADR INTERRRUPT CONTROL REGISTER
;;; NOTE THAT ONLY THE TOP 12 BITS ARE READ/WRITE -- THE LOW 4 BITS ARE WRITE ONLY.
;;; ALSO NOTE THAT THESE 16 BITS ARE THE HIGH 16 BITS OF THE WORD {MFO.<31-16>}.

;;; AS OF VERSION 3 OF THE RG BOARD, THE RG MODE REGISTER IS NOW A FULL 32 BITS. IT
;;; RETAINS THE OLD DEFINITIONS AS BEFORE (EXCEPT THE AUX-STAT-COUNT-CONTROL BIT, WHICH
;;; IS NOW UNUSED), AND NOW HAS 4 MORE READ ONLY BITS (THE RG NUBUS SLOT ID) AND 12
;;; MORE READ/WRITE BITS.  THE WHOLE RG MODE REGISTER NOW LOOKS LIKE 12 READ/WRITE BITS,
;;; 8 READ-ONLY BITS, AND THEN 12 MORE READ/WRITE BITS.

(eval-when (compile load eval)
;;; bit 31 : single.step.macro.inst.mode; 0 = normal execution, 1 = macrocode single stepping

(DEFCONST SINGLE-STEP-MACRO-INST-MODE 3701)

;;; bit 30 : 25.bit.virtual.address.mode L; 0 = 25 bit addresses, 1 = 24 bit addresses

(DEFCONST 25-BIT-VIRTUAL-ADDRESS-MODE-L 3601)

;;; bits 28-29: mid.hi.adr.0 and mid.hi.adr.1
;;; high two bits of MID Ram address when others are comming from the high 10 bits of
;;; the macro.ir.   These allow convenient addressing of the portion of the macro.ir
;;; used for MISC decodeing, etc.  Should be 0 for normal operation.

(defconst mid.hi.adr.1 3501)
(defconst mid.hi.adr.0 3401)
(defconst mid.hi.adr 3402)

;;; bit 27 : interrupt.enable -- enables program interrupts; 0 = no interrupts,
;;; 					         	     1 = normal program interrupts

(DEFCONST INTERRUPT-ENABLE 3301)

;;; bit 26 : sequence.break L -- this bit is checked by the microcode for the instruction
;;;          jump-on-sequence-break.  0 = set the sequence break, 1 = disable sequence breaks

(DEFCONST SEQUENCE-BREAK-L 3201)

;;; bit 25 : enable.misc.MID
;;; when HI let the macro instruction decode stuff dispatch on the whole MISC field
;;; of the instruction, if it is a MISC instruction to destination ignore (0).
;;; MID memory 6000 - 7777 is used to hold dispatch addresses for MISC (6000-6777)
;;;   and MISC1 (7000 - 7777).
;;; On source cycles, if the 40 bit in M.source is set, the above areas are ref'ed on
;;;   a misc instruction regardless of its destination.

(defconst enable-misc-mid 3101)

;;; bit 24 : main.stat.clock.control -- determines whether we clock the main stat counter on
;;;         uinst.clocks (standard) or sm.clocks; 0 = sm.clocking, 1 = uinst.clocking

(DEFCONST MAIN-STAT-CLOCK-CONTROL 3001)

;;; bit 23 : aux.stat.count.control -- determines whether we increment the aux stat-counter
;;;         based on the statistic bit in the current microinstruction, or the signal
;;;         memory.start.next.cycle, which comes on during memory fetches....
;;;						0 = valid.statistics.bit causes increment
;;;						1 = memory.start.next.cycle causes increment

(DEFCONST AUX-STAT-COUNT-CONTROL 2701)

;;; Also see AUX-STAT-CLOCK-CONTROL.
;;; bits 22-20 determine what the main stat-counter increments on.  There are 8 possibilities.
;;;		7 = hi.c -- a permanently high signal, so that you can increment every
;;;			    time ... this allows ratios between the two stat counters
;;;		6 = unused -- can be jumpered to anything needed to examine
;;;		5 = t.statistics.bit -- a bit in the timing ram
;;;		4 = t.hold -- to determine how long we are sitting in "hang" states
;;;			      (note that you probably want to clock on sm.ticks)
;;;		3 = increment.LC -- goes high during fetches of the next macro-instruction
;;;		2 = csm.statistics.bit -- a bit in the cache state machine
;;;					  (usually signifies cache hits)
;;;		1 = memory.start.next.cycle -- goes high during memory fetches
;;;		0 = valid.statistics.bit -- a bit in the current microinstruction

(DEFCONST MAIN-STAT-COUNT-CONTROL-BITS 2403)

;;; bit 22. : main.stat.count.control 2 -- see above

(DEFCONST MAIN-STAT-COUNT-CONTROL-2 2601)

;;; bit 21. : main.stat.count.control 1 -- see above

(DEFCONST MAIN-STAT-COUNT-CONTROL-1 2501)

;;; bit 20. : main.stat.count.control 0 -- see above

(DEFCONST MAIN-STAT-COUNT-CONTROL-0 2401)

;;; bits 17-19 are unused read-only bits

;;; bit 16 : need.macro.inst.fetch L -- asserted when you need another pair of
;;;				       macro-instructions (i.e., you don't need to 
;;;				       memory fetch each one, you first check to see if
;;;				       you still haven't used the other one; if so, assert
;;;				       this bit and you will fetch from memory two more.

(DEFCONST NEED-MACRO-INST-FETCH-L 2001)

;;; bits 15-12 : rg.nubus.id.<3-0> -- the nubus slot id that the RG board is currently in.

(DEFCONST RG-NUBUS-ID   1404)

;;; bit 15 : rg.nubus.id.3 -- bit 3 of the rg nubus slot id

(DEFCONST RG-NUBUS-ID-3 1701)

;;; bit 14 : rg.nubus.id.2 -- bit 2 of the rg nubus slot id

(DEFCONST RG-NUBUS-ID-2 1601)

;;; bit 13 : rg.nubus.id.1 -- bit 1 of the rg nubus slot id

(DEFCONST RG-NUBUS-ID-1 1501)

;;; bit 12 : rg.nubus.id.0 -- bit 0 of the rg nubus slot id

(DEFCONST RG-NUBUS-ID-0 1401)

;;; bits 11-3 are currently unused

;;; bit 4 selects clock for aux stat counter  (this was mod 31 to rev 2 ww boards.
;;;	the mod may not have been made to most rev 2 boards).
(defconst aux-stat-clock-control 0401)  ;1 uinst clock, 0 sm clock.

;;; bits 2-0 determine what the aux stat-counter increments on.  There are 8 possibilities.
;;;		7 = hi.c -- a permanently high signal, so that you can increment every
;;;			    time ... this allows ratios between the two stat counters
;;;		6 = microsecond.clock -- a microsecond clock for timing purposes
;;;		5 = t.statistics.bit -- a bit in the timing ram
;;;		4 = t.hold -- to determine how long we are sitting in "hang" states
;;;			      (note that you probably want to clock on sm.ticks)
;;;		3 = increment.LC -- goes high during fetches of the next macro-instruction
;;;		2 = csm.statistics.bit -- a bit in the cache state machine
;;;					  (usually signifies cache hits)
;;;		1 = memory.start.next.cycle -- goes high during memory fetches
;;;		0 = valid.statistics.bit -- a bit in the current microinstruction

(DEFCONST AUX-STAT-COUNT-CONTROL-BITS 0003)

;;; bit 2. : aux.stat.count.control 2 -- see above

(DEFCONST AUX-STAT-COUNT-CONTROL-2 0201)

;;; bit 1. : aux.stat.count.control 1 -- see above

(DEFCONST AUX-STAT-COUNT-CONTROL-1 0101)

;;; bit 0. : aux.stat.count.control 0 -- see above

(DEFCONST AUX-STAT-COUNT-CONTROL-0 0001)

);end eval-when


(DEFUN READ-RG-MODE ()
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-M-SRC LAM-M-SRC-RG-MODE
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-MFO))

(DEFUN WRITE-RG-MODE (NUM)
  (WRITE-SPY-REG-AND-CHECK (LOGAND 37774007777 NUM))
  (LAM-EXECUTE (WRITE)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-ALUF LAM-ALU-SETM
	       LAM-IR-FUNC-DEST LAM-FUNC-DEST-RG-MODE))

;(DEFUN CHANGE-RG-MODE (CHANGE-LIST)
;  (WRITE-RG-MODE
;    (UPDATE-VALUE CHANGE-LIST (READ-RG-MODE))))
(defmacro change-rg-mode (change-list)
  `(write-rg-mode (update-value ,change-list (read-rg-mode))))

;(DEFUN CHANGE-RG-MODE-AND-CHECK (CHANGE-LIST)
;  (LET ((NEW-VALUE (UPDATE-VALUE CHANGE-LIST (LOGAND 177760_16. (READ-RG-MODE)))))
;    (WRITE-RG-MODE NEW-VALUE)
;    (COND (( NEW-VALUE (LOGAND 177760_16. (READ-RG-MODE)))
;	   (FERROR NIL "~%RG-MODE DID NOT LOAD PROPERLY, WROTE ~O , NOW READS ~O"
;		   NEW-VALUE (LOGAND 177760_16. (READ-RG-MODE)))))))
(defmacro CHANGE-RG-MODE-AND-CHECK (CHANGE-LIST)
  `(LET* ((MASK 37774007777)
	  (NEW-VALUE (UPDATE-VALUE ,CHANGE-LIST (LOGAND MASK (READ-RG-MODE)))))
     (WRITE-RG-MODE NEW-VALUE)
     (COND (( NEW-VALUE (LOGAND MASK (READ-RG-MODE)))
	    (FERROR NIL "~%RG-MODE DID NOT LOAD PROPERLY, WROTE ~O , NOW READS ~O"
		    NEW-VALUE (LOGAND MASK (READ-RG-MODE)))))))

(DEFUN SET-25-BIT-VIRTUAL-ADDRESS-MODE ()
  (CHANGE-RG-MODE-AND-CHECK '(25-BIT-VIRTUAL-ADDRESS-MODE-L 0)))

(DEFUN CLEAR-25-BIT-VIRTUAL-ADDRESS-MODE ()
  (CHANGE-RG-MODE-AND-CHECK '(25-BIT-VIRTUAL-ADDRESS-MODE-L 1)))

(DEFUN SET-SINGLE-STEP-MACRO-INST-MODE ()
  (CHANGE-RG-MODE-AND-CHECK '(SINGLE-STEP-MACRO-INST-MODE 1)))

(DEFUN CLEAR-SINGLE-STEP-MACRO-INST-MODE ()
  (CHANGE-RG-MODE-AND-CHECK '(SINGLE-STEP-MACRO-INST-MODE 0)))

(DEFUN GET-RG-SLOT ()
  (ferror nil "this can't work")
;  (ldb rg-nubus-slot-id rg-mode)
  )

(DEFUN SET-MAIN-STAT-COUNTER-TO-COUNT-CSM-STAT ()
  (change-rg-mode-and-check '(main-stat-clock-control 0 
			      main-stat-count-control-bits 2))
  (write-stat-counter 0))

(DEFCONST STANDARD-RG-MODE-LIST
        '(SINGLE-STEP-MACRO-INST-MODE 0
	  25-BIT-VIRTUAL-ADDRESS-MODE-L 1
	  INTERRUPT-ENABLE 0
	  SEQUENCE-BREAK-L 1
	  MAIN-STAT-CLOCK-CONTROL 1
	  aux-stat-clock-control 1
	  AUX-STAT-COUNT-CONTROL 0
	  MAIN-STAT-COUNT-CONTROL-2 0
	  MAIN-STAT-COUNT-CONTROL-1 0
	  MAIN-STAT-COUNT-CONTROL-0 0
	  AUX-STAT-COUNT-CONTROL-2 0
	  AUX-STAT-COUNT-CONTROL-1 0
	  AUX-STAT-COUNT-CONTROL-0 0
	  ))

(DEFUN SETUP-RG-MODE (&OPTIONAL (SETUP-LIST STANDARD-RG-MODE-LIST))
  (LET* ((MASK 37774007777)
	 (NEW-VALUE (LOGAND MASK (UPDATE-VALUE SETUP-LIST))))
    (WRITE-RG-MODE NEW-VALUE)
    (COND (( NEW-VALUE (LOGAND MASK (READ-RG-MODE)))
	   (FERROR NIL "~%RG-MODE DID NOT LOAD PROPERLY, WROTE ~O , NOW READS ~O"
		   NEW-VALUE (LOGAND MASK (READ-RG-MODE)))))))

(DEFUN PRINT-RG-MODE ()
  (PRINT-RG-MODE-DATA (READ-RG-MODE)))

(DEFUN PRINT-RG-MODE-DATA (RG-MODE)
  (format t "~%     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^")
  (format t "~%       RG MODE REGISTER = ~o  " rg-mode)
  (format t "~%     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^")
  (FORMAT T "~%     ~[NOT SINGLE-STEPPING MACROCODE~;SINGLE-STEPPING MACROCODE~]"
	  (LDB SINGLE-STEP-MACRO-INST-MODE RG-MODE))
  (FORMAT T "~%     ~[25-BIT VIRTUAL ADDRESSES~;24-BIT VIRTUAL ADDRESSES~]"
	  (LDB 25-BIT-VIRTUAL-ADDRESS-MODE-L RG-MODE))
  (format t "~%     MID.HI.ADR ~O" (ldb mid.hi.adr rg-mode))
  (FORMAT T "~%     ~[LAMBDA INTERRUPTS DISABLED ~;LAMBDA INTERRUPTS ENABLED~]"
	  (LDB INTERRUPT-ENABLE RG-MODE))
  (FORMAT T "~%     ~[SEQUENCE BREAK REQUESTED ~;SEQUENCE BREAKS NOT REQUESTED~]"
	  (LDB SEQUENCE-BREAK-L RG-MODE))
  (format t "~%     Automatic MISC decode ~[disabled~;enabled~]"
	  (ldb enable-misc-mid rg-mode))
  (FORMAT T "~%     ~[MAIN STAT-COUNTER CLOCKS ON SM-CLOCKS ~
	       	     ~;MAIN STAT-COUNTER CLOCKS ON UINST-CLOCKS~]"
	  (LDB MAIN-STAT-CLOCK-CONTROL RG-MODE))
  (FORMAT T "~%     ~[MAIN STAT-COUNTER INCREMENTS ON UINST STAT-BIT ~
		     ~;MAIN STAT-COUNTER INCREMENTS ON MEMORY CYCLES ~
	       	     ~;MAIN STAT-COUNTER INCREMENTS ON CSM STAT-BIT ~
	       	     ~;MAIN STAT-COUNTER INCREMENTS ON MACROCODE INCREMENTS ~
	       	     ~;MAIN STAT-COUNTER INCREMENTS ON T.HOLD ASSERTED ~
	       	     ~;MAIN STAT-COUNTER INCREMENTS ON TRAM STAT-BIT ~
	       	     ~;MAIN STAT-COUNTER INCREMENTS ON USER JUMPERED DATA ~
	      	     ~;MAIN STAT-COUNTER INCREMENTS EVERY CLOCK ~]"
	  (LDB MAIN-STAT-COUNT-CONTROL-BITS RG-MODE))
 (FORMAT T "~%     ~[MACROINSTRUCTION FETCH NEEDED~;NO MACROINSTRUCTION FETCH NEEDED~]"
	  (LDB  NEED-MACRO-INST-FETCH-L RG-MODE))
 (FORMAT T "~%     RG SLOT NUMBER ~O (octal)"
	 (ldb rg-nubus-id rg-mode))
 (FORMAT T "~%     ~[AUX STAT-COUNTER INCREMENTS ON UINST STAT-BIT ~
		     ~;AUX STAT-COUNTER INCREMENTS ON MEMORY CYCLES ~
	       	     ~;AUX STAT-COUNTER INCREMENTS ON CSM STAT-BIT ~
	       	     ~;AUX STAT-COUNTER INCREMENTS ON MACROCODE INCREMENTS ~
	       	     ~;AUX STAT-COUNTER INCREMENTS ON T.HOLD ASSERTED ~
	       	     ~;AUX STAT-COUNTER INCREMENTS ON TRAM STAT-BIT ~
	       	     ~;AUX STAT-COUNTER INCREMENTS ON MICROSECOND CLOCK ~
	      	     ~;AUX STAT-COUNTER INCREMENTS EVERY CLOCK ~]"
	       (LDB AUX-STAT-COUNT-CONTROL-BITS RG-MODE))
  (FORMAT T "~%     ~[AUX STAT-COUNTER CLOCKS ON SM-CLOCK ~
		     ~;AUX STAT-COUNTER CLOCKS ON UINST-CLOCK ~]"
	       (LDB AUX-STAT-CLOCK-CONTROL RG-MODE))
  (format t "~%     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^~%"))


;;	the spy locations in detail:
;;
;;		 {	21	PARITY VECTOR (32 bits)
;;		 {	20	PMR (processor mode register 24 bits, read and write;
;;		 {			low 8 bits Configuation Prom, read only)
;;		 {	17	SPY REGISTER (32 bits)
;;		 {	16	MFO ENABLE (reading MFO bus)
;;		 {	15	TREG (output register of TRAM, read only)
;;	RG board {	14	PC (program counter, 16 bits, read only)
;;		 {	13	HPTR (history pointer, 10 bits)
;;		 {	12	HRAM (history ram, 16 bits)
;;		 {	11	TRAM (timing ram)
;;		 {	10	TRAM.ADR (special address register for debug read/write
;;					  of TRAM. 12 bits)
;;


(DEFUN READ-RG-PASSIVE ()
  (FORMAT T "~% PC ~O" (read-pc))
  (FORMAT T "~% SPY-REG ~O" (read-spy-reg))
  (FORMAT T "~% TREG ~O" (read-treg))
  (FORMAT T "~% TRAM-ADR ~O" (read-tram-adr)))


(defun read-parity ()   ;assure machine not running, then (read-parity-internal).
  (spy-read 21))
		 
(defun read-pc ()
  (low-16-BITS (spy-read 14)))

(DEFUN WRITE-SPY-REG-LOOP (DATA)
  (DO () (())
    (SPY-WRITE 17 DATA)))

(DEFUN WRITE-SPY-REG (DATA)
  (SPY-WRITE 17 DATA))

(DEFUN WRITE-SPY-REG-AND-CHECK (DATA)
  (SPY-WRITE 17 DATA)
;  (FORMAT T "pausing to see if that helps")
  (LET ((TEM (READ-SPY-REG)))
    (COND ((NOT (= TEM (LOGAND 37777777777 DATA)))
	   (FERROR NIL "spy reg lost, wrote ~s read ~s" DATA TEM)))))

(DEFUN READ-SPY-REG ()
  (SPY-READ 17))

(DEFUN READ-SPY-REG-VIA-DP ()
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-MFO))

(DEFUN READ-CRAM-ADR-MAP-VIA-DP (ADR)
  (WRITE-PC (LSH ADR 4) 0)
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-CRAM-ADR-MAP
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-MFO))

(DEFUN READ-SPY-REG-VIA-DP-STEPPING ()
  (LAM-EXECUTE (EXECUTOR LAM-EXECUTE-NOCLOCKS)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-ALUF LAM-ALU-SETM)
  (SM-STEP-LOOP))

(DEFUN DP-TEST-LOOP (&OPTIONAL (DATA  17777777777))
    (WRITE-SPY-REG-AND-CHECK DATA)
    (DO ()(())
      (COND ((NOT (= DATA (READ-SPY-REG-VIA-DP)))
	     (TV:BEEP)))))

(DEFUN READ-MFO (&OPTIONAL COMPARE-MASK)
  (SPY-READ 16 COMPARE-MASK))

(DEFUN LAMBDA-CHECK-CONFIGURATION ()
  (LET ((PMR (READ-PMR))
	(CON-REG (READ-CON-REG))
	(LOSE NIL))
    (COND ((NOT (ZEROP (LDB INIT-BIT CON-REG)))
	   (SETQ LOSE T)
	   (FORMAT T "~%INIT BIT ASSERTED")))
    (COND ((NOT (ZEROP (LDB FORCE-T-HOLD PMR)))
	   (SETQ LOSE T)
	   (FORMAT T "~%T.HOLD forced!")))
    (COND ((ZEROP (LDB SPY-ADDRESS-TRAM-L PMR))
	   (SETQ LOSE T)
	   (FORMAT T "~%TRAM ADDRESSED FROM DIAGNOSTIC ADDRESS REGISTER")))
    (COND ((NOT (ZEROP (LDB PARITY-STOP-ENABLE PMR)))
	   (SETQ LOSE T)
	   (FORMAT T "~%PARITY STOP ENABLE SET!")))
    (IF LOSE (FERROR NIL "PMR ~O, CON-REG ~O" PMR CON-REG))))

(defun assure-noop-cleared-and-uinst-clock-low nil
  (assure-noop-cleared)
  (cond ((not (uinst-clock-low-p))
	 (format t "~%forcing uinst clock low at assure-noop-cleared-and-uinst-clock-low")
	 (force-uinst-clock-low)
	 (assure-noop-cleared-and-uinst-clock-low))))



(comment
(DEFUN ASSURE-NOOP-CLEARED NIL	;CLEAR OUT ANY NO-OP THAT MAY BE CARRYING OVER
  (LAMBDA-CHECK-CONFIGURATION)			;error checking for now.
  (COND ((NOOP-P)
	 (COND ((NOT (UINST-CLOCK-LOW-P))
		(FORMAT T"~%forcing uinst clock low at assure-noop-cleared!")
		(FORCE-UINST-CLOCK-LOW)))
	 (let ((PRINTP nil))
	   (COND (PRINTP
		  (FORMAT T"~% ENTERING ASSURE-NOOP-CLEARED.  ABOUT TO 0 IREG")
		  (PRINT-TICK-DATA)
		  (PRINT-CON-REG-ONE-LINE)))
	   (LAM-EXECUTE (EXECUTOR WRITE-IREG-AND-CHECK))
	   (COND (PRINTP
		  (FORMAT T "~% IREG SHOULD BE 0, ABOUT TO DO UINST TICK.")
		  (PRINT-TICK-DATA)
		  (PRINT-CON-REG-ONE-LINE)))
	   (UINST-TICK)
	   (COND ((NOOP-P) (FERROR NIL "noop failed to clear")))
	   (COND (PRINTP
		  (FORMAT T "~% done")
		  (PRINT-TICK-DATA)
		  (PRINT-CON-REG-ONE-LINE)))
	   (COND ((NOOP-P) (FERROR NIL "noop reset while restoring IREG")))	
	   )))) 
  )	;end comment

(defun assure-noop-cleared ()
  (change-pmr-and-check '(clear-noop-l 0))
  (change-pmr-and-check '(clear-noop-l 1))
  (COND ((NOOP-P) (FERROR NIL "noop failed to clear"))))

(DEFUN ASSURE-NOOP-CLEARED-AND-NO-CARRYOVER ()
  (COND ((ACCESS-PATH-LMI-SERIAL-PROTOCOL *PROC*)
	 (FUNCALL *PROC* ':STRING-OUT "46I")
	 (FUNCALL *PROC* ':READ-32))
	(T
	 (LAM-EXECUTE-UINST-CLOCK-PLUS-UINST-CLOCK-LOW IZERO-GOOD-PARITY T))))

(DEFUN NOOP-P ()
  (= (LDB NOOP-BIT (READ-CON-REG)) 1))
	
(DEFUN T-HOLD-P ()
  (= (LDB T-HOLD-L-BIT (READ-CON-REG)) 0))

(DEFUN NOOP-OR-T-HOLD-P ()
 (OR (NOOP-P) (T-HOLD-P)))			;SO WHAT?  IT WORKS.

(DEFUN WRITE-PC (PC &OPTIONAL (N-BIT 1) (CHECK T)  &AUX OLD-PC TEM TEM1)
  (IF (NULL (ACCESS-PATH-LMI-SERIAL-PROTOCOL *PROC*))
      (SETQ OLD-PC (READ-PC)))  ;dont do this on dribble file, since it may not check.
  (LAM-EXECUTE (UINST-CLOCK-PLUS-UINST-CLOCK-LOW)
	       LAM-IR-OP LAM-OP-JUMP	;JUMP INSTRUCTION TO IR
	       LAM-IR-JUMP-ADDR PC
	       LAM-IR-N N-BIT
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
  ;please leave the following check in --rg
  (COND ((AND CHECK (NOT (= (SETQ TEM (READ-PC)) PC)))
	 (FORMAT T "~%PC DID NOT LOAD PROPERLY, IS ~O SHOULD BE ~O, OLD ~O~%" TEM PC OLD-PC)
	 (COND ((NOT (= (SETQ TEM1 (READ-PC)) TEM))
		(FORMAT T "~%PC READ BACK DIFFERENTLY ON SECOND TRY ~O" TEM1)))
	 (BREAK "FOO")))
  T)

(DEFUN WRITE-PC-STEPPING (PC &OPTIONAL (N-BIT 1))
  (LAM-EXECUTE (EXECUTOR LAM-EXECUTE-NOCLOCKS)
	       LAM-IR-OP LAM-OP-JUMP	;JUMP INSTRUCTION TO IR
	       LAM-IR-JUMP-ADDR PC
	       LAM-IR-N N-BIT
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
  (SM-STEP-LOOP ':ZERO-IREG-AFTER-UINST-CLOCK T))

(DEFUN WRITE-PC-FAST (PC &OPTIONAL (N-BIT 1))
  (LAM-EXECUTE (UINST-CLOCK-PLUS-UINST-CLOCK-LOW)
	       LAM-IR-OP LAM-OP-JUMP	;JUMP INSTRUCTION TO IR
	       LAM-IR-JUMP-ADDR PC
	       LAM-IR-N N-BIT
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
  T)

(DEFUN WRITE-AND-INCREMENT-PC (VAL)
  (WRITE-PC VAL)
  (LAM-EXECUTE-UINST-CLOCK-PLUS-UINST-CLOCK-LOW IZERO-GOOD-PARITY T))


(DEFUN READ-PC-CHECKING-LOOP ()
  (LET ((PC (READ-PC)))
    (DO ((TEM)) (())
      (COND ((NOT (= (SETQ TEM (READ-PC)) PC))
	     (FORMAT T "~O " TEM))))))

(defun write-pc-loop (n) (do () (()) (write-pc n)))

(defun read-hptr (&optional (compare-mask 7777))
  (logand 7777 (spy-read 13 compare-mask)))

(defun write-hptr (data)
  (COND ((NOT (UINST-CLOCK-LOW-P))
	 ;execute an instruction to make uinst clock low
	 (read-spy-reg-via-dp)))
  (spy-write 13 data))

;need to turn off ALLOW.UINST.CLOCKS
;need to save old hptr so that we can
;restore it on leaving, or the current
;location we examine will also get the
;current pc when we
;enable ALLOW.UINST.CLOCKS
(defun read-hram (adr &AUX old-hptr old-pmr temp)
  (setq old-pmr (read-pmr))
  (change-pmr-and-check '(ALLOW-UINST-CLOCKS 0))
  (setq old-hptr (read-hptr))
  (write-hptr adr)
  (setq temp (low-16-BITS (spy-read 12)))
  (write-hptr old-hptr)
  (write-pmr old-pmr)
  temp)

(defun write-hram (adr data &AUX old-hptr old-pmr temp)
  (setq old-pmr (read-pmr))
  (change-pmr-and-check '(ALLOW-UINST-CLOCKS 0))
  (setq old-hptr (read-hptr))
  (write-hptr adr)
  (setq temp (spy-write 12  data))
  (write-hptr old-hptr)
  (write-pmr old-pmr)
  temp)

(defun copy-hram-to-array (array start nlocs adr)
  "Fill the array with the hram.  Start writing at address START in the array,
filling NLOCS entries.  The first PC from the the HRAM is read from address ADR."
  (let ((old-pmr (read-pmr))
	(old-hptr (read-hptr)))
    (change-pmr '(allow-uinst-clocks 0))
    (if (not (uinst-clock-low-p))
	(read-spy-reg-via-dp))
    (dotimes (x nlocs)
      (spy-write 13 (- adr x))			;let the hardware do mod-16 for us
      (aset (ldb 0020 (spy-read 12)) array (+ start x)))
    (write-hptr old-hptr)
    (write-pmr old-pmr)))

(defvar hram-array (make-array 10000))

(defun save-hram (&optional n-locs)
  (copy-hram-to-array hram-array 0 (or n-locs 100) (read-hptr)))

(defun print-hram (&optional n-locs save-p)
  (if save-p
      (save-hram n-locs))
  (dotimes (adr (or n-locs 100))
    (format t "~o " (aref hram-array adr))))

(defun write-hram-forever  (adr data &AUX old-hptr old-pmr temp)
  (setq old-pmr (read-pmr))
  (change-pmr-and-check '(ALLOW-UINST-CLOCKS 0))  ;need to turn off ALLOW.UINST.CLOCKS
  (setq old-hptr (read-hptr))			;need to save old hptr so that we can
  (write-hptr adr)				;restore it on leaving, or the current
  (setq temp (spy-write 12  data))
  (do ()((send terminal-io :tyi-no-hang))
    (spy-write 12 data))			;location we write will also get the
  (write-hptr old-hptr)				;current pc when we
  (write-pmr old-pmr)				;enable ALLOW.UINST.CLOCKS
  temp)

(defun read-hram-unsafely (adr)			;use ONLY in the middle of functions that
  (write-hptr adr)				;supply the wrapper of turning off
  (low-16-BITS (spy-read 12 177777)))		;ALLOW.UINST.CLOCKS to protect themselves

(defun write-hram-unsafely (adr data)		;use ONLY in the middle of functions that
  (write-hptr adr)				;supply the wrapper of turning off
  (spy-write 12 data))				;ALLOW.UINST.CLOCKS to protect themselves
						;and set the hptr to something harmless
						;when finished.

(defun write-tram-adr (value)		;12 bit address reg, used only for diagnostics
  (spy-write 10 value))

(defun read-tram-adr ()			;12 bit address reg, used only for diagnostics
  (LOGAND 7777 (spy-read 10 7777)))

(defun read-treg ()
  (spy-read 15))

(defconst tram-parity-field 3404)

(defun read-tram (adr)
  (write-tram-adr adr)
  (spy-read 11)
  )

(defun read-tram-and-check-parity ()
  (let* ((data (spy-read 11))
	 (computed-parity (compute-parity-32 data)))
    (cond ((not (equal computed-parity data))
	   (ferror NIL "TRAM read with bad parity, read ~o, should be ~o"
		   data computed-parity))
	  (t (logand 1777777777 data))))
    )

(defun write-tram (adr data)
  (write-tram-adr adr)
  (spy-write 11 data))

(DEFUN WRITE-TRAM-WITH-GOOD-PARITY (ADR DATA)
  (WRITE-TRAM ADR (COMPUTE-PARITY-32 DATA)))

(DEFUN WRITE-TREG-VIA-TRAM (DATA)
  (WRITE-TRAM 1003 DATA)
  (WRITE-TREG-FROM-TRAM 1003))

(DEFUN WRITE-TREG-VIA-TRAM-WITH-GOOD-PARITY (DATA)
  (WRITE-TRAM-WITH-GOOD-PARITY 1003 DATA)
  (WRITE-TREG-FROM-TRAM 1003))

(defun wipe-tram (&OPTIONAL (data (COMPUTE-PARITY-32 0)))
  (dotimes (adr 10000)
    (write-tram adr data)))

(DEFUN SCAN-TRAM-FOR-BAD-PARITY ()
  (DOTIMES (ADR 10000)
    (LET ((DATA (READ-TRAM ADR)))
      (COND ((CHECK-PARITY-32 DATA)
	     (FORMAT T " at address ~s~%" ADR))))))

(defun check-parity-32 (data)
  (let ((good (compute-parity-32 data)))
    (cond ((= data good)
	   (format t "~%Bad parity, should be ~s, is ~s " good data)
	   nil))))

;FAST ADDRESS TEST WRITES ZEROS AND ONES INTO 2 LOCATIONS 
;WHOSE ADDRESSES DIFFER IN 1 BIT, CHECKS FOR INTERFERENCE.
;THIS DETECTS ADDRESS BITS STUCK AT ZERO OR ONE FOR SOME DATA
;BITS, BUT DOES NOT DETECT ADJACENT ADDRESS BITS SHORTED TOGETHER.

(DEFUN FAST-ADDRESS-TEST-TRAM (&optional dont-reinit)
  (LET ((OFFSET 0)
	(N-DATA-BITS 32.)
	(N-ADDRESS-BITS 12.)
	(READ-FCTN 'READ-TRAM)
	(WRITE-FCTN 'WRITE-TRAM)
	(MESSAGE "FAST-ADDRESS-TEST of Timing RAM"))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE))
  (when (null dont-reinit)
    (INIT-TRAM)			;leave the tram in a good state
    (if (< (send *proc* :major-version) 100.)
	(INIT-TRAM nil ':check t)))			;and check it
  )


;NOTE M-MEM LOCN 0 DOESNT "WORK" SO WE CAN ONLY DO COMPLEMENTED PHASES

(DEFUN FAST-ADDRESS-TEST-M-MEM NIL
  (NOOP-UINST-CLOCKS)			;MAKE SURE NO CARRYOVER WRITES TO SCREW UP
  (LET ((OFFSET 0)
	(N-DATA-BITS 32.)	
	(READ-FCTN 'READ-M-MEM)
	(WRITE-FCTN 'WRITE-M-MEM)
	(N-ADDRESS-BITS 6.)
	(MESSAGE "FAST-ADDRESS-TEST of M-memory"))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE 2)))

(DEFUN FAST-ADDRESS-TEST-hh-M-MEM NIL
  (NOOP-UINST-CLOCKS)			;MAKE SURE NO CARRYOVER WRITES TO SCREW UP
  (LET ((OFFSET 0)
	(N-DATA-BITS 32.)	
	(READ-FCTN 'hh-READ-M-MEM)
	(WRITE-FCTN 'hh-WRITE-M-MEM)
	(N-ADDRESS-BITS 6.)
	(MESSAGE "FAST-ADDRESS-TEST of M-memory"))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE 2)))


;A-MEM LOCN 0 IS OK, SO THE WHOLE THING CAN WIN

(DEFUN FAST-ADDRESS-TEST-A-MEM NIL
  (NOOP-UINST-CLOCKS)			;MAKE SURE NO CARRYOVER WRITES TO SCREW UP
  (LET ((OFFSET 0)
	(N-DATA-BITS 32.)	       
	(READ-FCTN 'READ-A-MEM)
	(WRITE-FCTN 'WRITE-A-MEM)
	(N-ADDRESS-BITS 12.)
	(MESSAGE "FAST-ADDRESS-TEST of A-memory"))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN 
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE)))

(DEFUN FAST-ADDRESS-TEST-hh-A-MEM NIL
  (NOOP-UINST-CLOCKS)			;MAKE SURE NO CARRYOVER WRITES TO SCREW UP
  (LET ((OFFSET 0)
	(N-DATA-BITS 32.)	       
	(READ-FCTN 'hh-READ-A-MEM)
	(WRITE-FCTN 'hh-WRITE-A-MEM)
	(N-ADDRESS-BITS 12.)
	(MESSAGE "FAST-ADDRESS-TEST of A-memory"))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN 
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE)))


;NOTE M-MEM LOCN 0 DOESNT "WORK" SO WE CAN ONLY DO COMPLEMENTED PHASES

(DEFUN FAST-ADDRESS-TEST-A-MEM-VIA-M-MEM NIL
  (NOOP-UINST-CLOCKS)			;MAKE SURE NO CARRYOVER WRITES TO SCREW UP
  (LET ((OFFSET 0)
	(N-DATA-BITS 32.)	       
	(READ-FCTN 'READ-A-MEM)
	(WRITE-FCTN 'WRITE-M-MEM)
	(N-ADDRESS-BITS 6.)
	(MESSAGE "FAST-ADDRESS-TEST of reading A-memory via writing M-memory "))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN 
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE 2)))

(DEFUN FAST-ADDRESS-TEST-LEVEL-1-MAP NIL
  (SET-25-BIT-VIRTUAL-ADDRESS-MODE)
  (NOOP-UINST-CLOCKS)			;MAKE SURE NO CARRYOVER WRITES TO SCREW UP
  (LET ((pmr (read-pmr))
	(OFFSET 0)
	(N-DATA-BITS 10.)
	(READ-FCTN 'READ-LEVEL-1-MAP)
	(WRITE-FCTN 'WRITE-LEVEL-1-MAP)
	(N-ADDRESS-BITS 12.)
	(MESSAGE "FAST-ADDRESS-TEST of Level-1 Map ... mi NOT reset"))
    (change-pmr-and-check '(force-mi-reset-l 1))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE)
    (write-pmr pmr))
  (CLEAR-25-BIT-VIRTUAL-ADDRESS-MODE))


(DEFUN FAST-ADDRESS-TEST-LEVEL-2-MAP-CONTROL NIL
  (NOOP-UINST-CLOCKS)			;MAKE SURE NO CARRYOVER WRITES TO SCREW UP
  (LET ((pmr (read-pmr))
	(OFFSET 0)
	(N-DATA-BITS 16.)	       
	(READ-FCTN 'READ-LEVEL-2-MAP-CONTROL)
	(WRITE-FCTN 'WRITE-LEVEL-2-MAP-CONTROL)
	(N-ADDRESS-BITS 11.)	;ASSUME 24 BIT VIRTUAL ADDRESS MODE FOR NOW.
	(MESSAGE "FAST-ADDRESS-TEST of Level-2 Map Control ... mi NOT reset"))
    (change-pmr-and-check '(force-mi-reset-l 1))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE)
    (write-pmr pmr)))

(DEFUN FAST-ADDRESS-TEST-LEVEL-2-MAP-PHYSICAL-PAGE NIL
  (NOOP-UINST-CLOCKS)			;MAKE SURE NO CARRYOVER WRITES TO SCREW UP
  (LET ((pmr (read-pmr))
	(OFFSET 0)
	(N-DATA-BITS 24.)	       
	(READ-FCTN 'READ-LEVEL-2-MAP-PHYSICAL-PAGE)
	(WRITE-FCTN 'WRITE-LEVEL-2-MAP-PHYSICAL-PAGE)
	(N-ADDRESS-BITS 12.)
	(MESSAGE "FAST-ADDRESS-TEST of Level-2 Map Physical Page"))
    (change-pmr-and-check '(force-mi-reset-l 1))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE)
    (write-pmr pmr)))

(DEFUN LAM-PRINT-BIT-LIST (MESSAGE BITLIST)
  (COND (BITLIST
	 (IF MESSAGE (SEND TERMINAL-IO ':STRING-OUT MESSAGE))
	 (DO ((L (SORT BITLIST #'LESSP) (CDR L))
	      (COMMA NIL T)
	      (LASTVALUE -2 (CAR L))
	      (RANGE-END NIL)
	      (RANGE-START))
	     ((NULL L)
	      (AND RANGE-END
		   (IF (= (1+ RANGE-START) RANGE-END)
		       (FORMAT T ", ~D" RANGE-END)
		     (FORMAT T "-~D" RANGE-END))))
	   (COND ((= (CAR L) (1+ LASTVALUE))
		  (OR RANGE-END (SETQ RANGE-START LASTVALUE))
		  (SETQ RANGE-END (CAR L)))
		 (T
		  (AND RANGE-END
		       (IF (= (1+ RANGE-START) RANGE-END)
			   (FORMAT T ", ~D" RANGE-END)
			 (FORMAT T "-~D" RANGE-END)))
		  (SETQ RANGE-END NIL)
		  (AND COMMA (SEND TERMINAL-IO ':STRING-OUT ", "))
		  (FORMAT:ONUM (CAR L)))))
	 (SEND TERMINAL-IO ':TYO #\CR))))

(DEFUN LAM-WRONG-BITS-LIST (GOOD BAD N-DATA-BITS)
  (DO ((BITNO 0 (1+ BITNO))
       (PPSS 0001 (+ 100 PPSS))
       (L NIL))
      ((= BITNO N-DATA-BITS) L)
    (OR (= (LOGLDB PPSS GOOD) (LOGLDB PPSS BAD))
	(SETQ L (CONS BITNO L)))))

(DEFUN FAST-ADDRESS-TEST-KERNAL
       (WRITE-FCTN READ-FCTN OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE
	&OPTIONAL (PHASE 0) NO-PRINT)
  (FORMAT T "~%~A" Message)
  (LET ((ABORT-MSG (*CATCH 'ABORTING
  (DO ((PHASE PHASE (1+ PHASE))			;even values of phase cause us to
      						;write zeroes followed by ones as data.
						;odd values - ones followed by
						;zeroes.  in the first two phases,
						;we address the ram with floating
						;ones; in the third and fourth phases
						;by floating zeroes
       (ONES (SUB1 (EXPT 2 N-DATA-BITS)))
       (ADR-MASK (1- (EXPT 2 N-ADDRESS-BITS)))
       (ZEROS 0))
      ((= PHASE 4))
    (DO ((BITNO 0 (1+ BITNO))			;bitno is the number of the address bit
						;which we are testing on this cycle
	 (GOOD1 (COND ((EVENP PHASE) ZEROS) (T ONES)))
	 (GOOD2 (COND ((EVENP PHASE) ONES) (T ZEROS)))
	 (BAD1)
	 (BAD2)
	 (BAD3)
	 (OTHER-LOC)
	 (tested-location)
	 TEM)
	((= BITNO N-ADDRESS-BITS))
      (AND (send terminal-io :tyi-no-hang)(*THROW 'ABORTING ".....ABORTING"))
      (SETQ tested-location (+ OFFSET (COND ((< PHASE 2)
			       (LSH 1 BITNO))
			      (T (LOGXOR ADR-MASK (LSH 1 BITNO))))))
      (SETQ OTHER-LOC (COND ((< PHASE 2) OFFSET)
			    (T (+ OFFSET ADR-MASK))))
      (FUNCALL WRITE-FCTN tested-location GOOD2)
      (COND ((AND (NOT (EQUAL (SETQ BAD2 (FUNCALL READ-FCTN tested-location)) GOOD2))
		 (NULL NO-PRINT))
	     (FORMAT T "~%~%tested location ~o bad on immed readback:~
   		  wrote: ~O, read: ~O~%"
		     tested-location GOOD2 BAD2)
	     (lam-PRINT-BIT-LIST " fails in data bits "
				(lam-WRONG-BITS-LIST GOOD2 BAD2 N-DATA-BITS))
	     (SETQ TEM (FUNCALL READ-FCTN tested-location))
	     (FORMAT T "  reread was ~:[different~;same~] ~O" (= TEM BAD2) TEM)
;	     (ferror nil "foo")
	     ))
      (FUNCALL WRITE-FCTN OTHER-LOC GOOD1)
      (COND ((AND (NOT (EQUAL (SETQ BAD1 (FUNCALL READ-FCTN OTHER-LOC)) GOOD1))
		  (NULL NO-PRINT))
	     (FORMAT T "~%~%other location ~o bad on immed readback: wrote: ~O, read: ~O~%"
		     OTHER-LOC GOOD1 BAD1)
	     (lam-PRINT-BIT-LIST " fails in data bits "
				(lam-WRONG-BITS-LIST GOOD1 BAD1 N-DATA-BITS))
	     (SETQ TEM (FUNCALL READ-FCTN OTHER-LOC))
	     (FORMAT T "  reread  was ~:[different~;same~] ~O" (= TEM BAD1) TEM)))
      (COND ((AND (NOT (EQUAL (SETQ BAD3 (FUNCALL READ-FCTN tested-location)) GOOD2))
		  (NULL NO-PRINT))
	     (FORMAT T "~%Writing adr ~s (the other location) affected adr ~s (the tested location)"
		     OTHER-LOC tested-location)
	     (FORMAT T " address bit ~D" BITNO)
	     (lam-PRINT-BIT-LIST (COND ((EVENP PHASE)
				       " fails storing 1's then 0 in data bits ")
				      (T " fails storing 0 then 1's in data bits "))
				(lam-WRONG-BITS-LIST GOOD2 BAD3 N-DATA-BITS))
	     (SETQ TEM (FUNCALL READ-FCTN tested-location))
	     (FORMAT T "  reread was ~:[different~;same~] ~O = #x~:*~x" (= TEM BAD3) TEM))))))))
    (AND (STRINGP ABORT-MSG) (FORMAT LAMBDA-DIAG-STREAM "~A" ABORT-MSG))
    ABORT-MSG))

;;
;;		 {	22 CRAM.ADR.MAP (control memory address map, 12 bits)
;;		 {	07 LOW CRAM (low half of control memory, 32 bits)
;;	CM board {	06 HIGH CRAM (high half of control memory, 32 bits)
;;		 {	05 LOW IREG (low half of instruction register, 32 bits,
;;		 {	   	read doesn't use USE.LOW.I)
;;		 {	04 HIGH IREG (high half of instruction register, 32 bits,
;;		 {	  	read doesn't use USE.HIGH.I)


(DEFUN WRITE-CRAM-ADR-MAP-AT-CURRENT-PC (DATA)
  (SPY-WRITE 22 DATA))

(DEFUN READ-CRAM-ADR-MAP (&OPTIONAL (ADR NIL) (FERROR-P T))
  (IF ADR (WRITE-PC (LSH ADR 4)))
  (LET* ((FIRST-TIME (LOGAND 7777 (SPY-READ 22)))
	 (SECOND-TIME (LOGAND 7777 (SPY-READ 22))))
    (IF (NOT (= FIRST-TIME SECOND-TIME))
	(PROGN (TV:BEEP) 
	 (IF FERROR-P
  	    (FERROR ()
		    "~%read cram adr map differently second time: adr=~O first=~O second=~O"
		    ADR FIRST-TIME SECOND-TIME)
	  (FORMAT T  "~%read cram adr map differently second time: adr=~O first=~O second=~O"
		  ADR FIRST-TIME SECOND-TIME))))
    FIRST-TIME))

(defun fast-read-cram-adr-map-loop ()
  (do-forever
    (bb-nd-read-fastest-loop (+ #xf8000000 22_2))))

(defun fast-write-cram-adr-map-loop ()
  (do-forever
    (bb-nd-write-fastest-loop (+ #xf8000000 22_2) 5555)))

(defun write-low-cram (data)			;address is whatever pc is
  (spy-write 7 data))

(defun cram-clobbered-loop ()
  (write-pc 4)
  (write-low-cram -1)
  (write-pc 4)
  ;;this does write-low-cram, but clobbers stuff at address 4
  (let ((adr (+ (dpb (send *proc* :rg-slot) (byte 4 24.) #xf0000000) 7_2)))
    (bb-nd-write-fastest-loop adr 0)))

(defun write-high-cram (data)
  (spy-write 6 data))

(defun read-low-cram ()
  (spy-read 7))

(defun fast-read-low-cram-loop ()
  (do-forever
    (bb-nd-read-fastest-loop (+ #xf8000000 7_2))))

(defun fast-write-low-cram-loop ()
  (do-forever
    (bb-nd-write-fastest-loop (+ #xf8000000 7_2) 555555)))

(defun read-high-cram ()
  (spy-read 6))

(defun write-low-ireg (data)
  (spy-write 5 data))

(defun write-low-ireg-loop (data)
  (let ((adr (+ (dpb (send *proc* :rg-slot) (byte 4 24.) #xf0000000) 5_2)))
    (bb-nd-write-fastest-loop adr data)))

(defun write-high-ireg (data)
  (spy-write 4 data))

(defun write-high-ireg-loop (data)
  (let ((adr (+ (dpb (send *proc* :rg-slot) (byte 4 24.) #xf0000000) 4_2)))
    (bb-nd-write-fastest-loop adr data)))

(defun read-low-ireg ()
  (spy-read 5))

(defun read-high-ireg ()
  (spy-read 4))

(defun write-ireg (data)
  (if (and (>= (send *proc* :major-version) 100.)
	   (not (zerop (ldb (byte 4 60.) data))))
      (ferror nil "half-half processors don't have parity"))
  (COND ((NOT (UINST-CLOCK-LOW-P))
	 (FERROR NIL "ATTEMPTED TO WRITE IREG WHEN UINST-CLOCK HIGH")))
  (write-low-ireg (logand 37777777777 data))
  (COND ((NOT (UINST-CLOCK-LOW-P))
	 (FERROR NIL "writing low ireg affected uinst-clock")))
  (write-high-ireg (logand 37777777777 (ash data -40)))
  (COND ((NOT (UINST-CLOCK-LOW-P))
	 (FERROR NIL "writing high ireg affected uinst-clock"))))

(DEFUN WRITE-IREG-WITH-GOOD-PARITY (DATA)
  (cond ((< (send *proc* :major-version) 100.)
	 (WRITE-IREG (COMPUTE-PARITY-64 DATA)))
	(t
	 (write-ireg data))))

(defun read-ireg ()
  (logior (ash (read-high-ireg) 40)
	  (read-low-ireg)))

(defun read-ireg-and-check-uinst-clock ()
  (let ((uip (uinst-clock-low-p))
	(val
	  (logior (ash (read-high-ireg) 40)
		  (read-low-ireg))))
    (if (not (eq (uinst-clock-low-p) uip))
	(ferror nil "read-ireg affected uinst clock"))
    val))

(DEFUN WRITE-CRAM-ADR-MAP (ADR DATA)
  ;(setq this-time (and (= adr 0) (= data 200)))
  (WRITE-PC (LSH ADR 4))
  (COND ((NOT (UINST-CLOCK-LOW-P))
	 ;(FORCE-UINST-CLOCK-LOW)
	 (FERROR NIL "uinst clock not left low by write-pc")))
  (WRITE-CRAM-ADR-MAP-AT-CURRENT-PC DATA))

(DEFUN WRITE-CAM-WITH-GOOD-PARITY (ADR DATA)
  (WRITE-CRAM-ADR-MAP ADR (compute-parity-11 data)))

(DEFUN WRITE-CRAM-ADR-MAP-VIA-DEST (ADR DATA &AUX TEM)
  (WRITE-PC (LSH ADR 4))
  (WRITE-SPY-REG DATA)
  (LAM-EXECUTE (WRITE)
   LAM-IR-OP LAM-OP-ALU
   LAM-IR-OB LAM-OB-ALU
   LAM-IR-ALUF LAM-ALU-SETM
   LAM-IR-M-SRC LAM-M-SRC-SPY-REG
   LAM-IR-FUNC-DEST LAM-FUNC-DEST-CRAM-MAP
   LAM-IR-SLOW-DEST 1)
  (COND ((NOT (= DATA (SETQ TEM (READ-CRAM-ADR-MAP ADR))))
	 (FERROR NIL "WRITE-CRAM-ADR-MAP-VIA-DEST FAILED, WROTE ~S, READ ~S" DATA TEM))))

(DEFUN WRITE-CRAM-ADR-MAP-VIA-DEST-STEPPING (ADR DATA)
  (WRITE-PC (LSH ADR 4))
  (WRITE-SPY-REG DATA)
  (LAM-EXECUTE (EXECUTOR LAM-EXECUTE-NOCLOCKS)
   LAM-IR-OP LAM-OP-ALU
   LAM-IR-OB LAM-OB-ALU
   LAM-IR-ALUF LAM-ALU-SETM
   LAM-IR-M-SRC LAM-M-SRC-SPY-REG
   LAM-IR-FUNC-DEST LAM-FUNC-DEST-CRAM-MAP
   LAM-IR-SLOW-DEST 1)
  (SM-STEP-LOOP ':ZERO-IREG-AFTER-UINST-CLOCK T))

;SAME AS FAST-LOAD-STRAIGHT-CRAM-ADR-MAP BUT JUST LOOPS WRITING 7777@CAM.
(DEFUN UINST-WRITE-CAM-TEST-LOOP ()
  (WRITE-M-MEM 1 7777)	;location to clobber
  (WRITE-M-MEM 2 1)	;last locn to clobber. Also used as constant!
  (WRITE-M-MEM 3 0)	;constant for DPBing into
  (ULOAD ()
    0
	 (LAM-IR-OP LAM-OP-BYTE	      ;((oa-reg-low) dpb m-1 oal-cram-page-number a-3)
	  LAM-IR-BYTE-FUNC LAM-BYTE-FUNC-DPB
	  LAM-IR-M-SRC 1
	  LAM-IR-BYTL-1 11.
	  LAM-IR-MROT 18.
	  LAM-IR-A-SRC 3
	  LAM-IR-FUNC-DEST LAM-FUNC-DEST-IMOD-LOW)
         (LAM-IR-OP LAM-OP-JUMP	      ;(call-xct-next 17)
	  LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
	  LAM-IR-JUMP-ADDR 17
	  LAM-IR-P 1
	  LAM-IR-N 0)
	 (LAM-IR-POPJ-AFTER-NEXT 1	;(popj-after-next (cram-adr-map) setm m-1)
	  LAM-IR-OP LAM-OP-ALU
	  LAM-IR-OB LAM-OB-ALU
	  LAM-IR-ALUF LAM-ALU-SETM
	  LAM-IR-M-SRC 1
	  LAM-IR-FUNC-DEST LAM-FUNC-DEST-CRAM-MAP
	  LAM-IR-SLOW-DEST 1)

	 (LAM-IR-OP LAM-OP-JUMP			;3
	  LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
	  LAM-IR-M-SRC 1
	  LAM-IR-A-SRC 2
	  LAM-IR-JUMP-ADDR 0
	  LAM-IR-N 0)
	 (LAM-IR-OP LAM-OP-ALU			;4
  ;	  LAM-IR-OB LAM-OB-ALU
  ;	  LAM-IR-ALUF LAM-ALU-SUB
  ;	  LAM-IR-M-SRC 1
  ;	  LAM-IR-A-SRC 2
  ;	  LAM-IR-M-MEM-DEST 1
	  )
	 (lam-ir-halt 1) )			;5
  (SETUP-MACHINE-TO-START-AT 0)
  )

(defun write-cram (adr data)
  (cond ((and (>= (send *proc* :major-version) 100.)
	      (not (zerop (ldb (byte 4 60.) data))))
	 (ferror nil "half-half's don't have parity")))
	 
  (write-pc adr)
  (COND ((AND *PARANOID-MODE* (NOT (UINST-CLOCK-LOW-P)))
	 ;(FORCE-UINST-CLOCK-LOW)
	 (FERROR NIL "uinst clock not left low by write-pc")))
  ;(WRITE-IREG 0)		;make sure write uinst bits clear.
  (write-low-cram (logand 37777777777 data))
  (write-high-cram (logand 37777777777 (ash data -40))))

(defun write-cram-dont-worry-about-parity (adr data)
  (write-pc adr)
  (write-low-cram (logand 37777777777 data))
  (write-high-cram (logand 37777777777 (ash data -40))))

(DEFUN WRITE-CRAM-WITH-GOOD-PARITY (ADR DATA)
  (cond ((< (send *proc* :major-version) 100.)
	 (WRITE-CRAM ADR (COMPUTE-PARITY-64 DATA)))
	(t
	 (write-cram adr data))))

(DEFUN WRITE-CRAM-WITH-GOOD-PARITY-and-check (ADR DATA &aux tem)
  (cond ((< (send *proc* :major-version) 100.)
	 (setq data (COMPUTE-PARITY-64 DATA))))
  (WRITE-CRAM ADR data)
  (cond ((not (= data (setq tem (read-cram adr))))
	 (format t "~%write cram failed, address ~o, wrote ~o read ~o, dfrs in bits "
		 adr data tem)
	 (print-bits (logxor data tem)))))

(defun write-cram-fast-optimized (adr data)
  (let ((pc (read-pc)))
    (cond ((= (1+ pc) adr)
	   (LAM-EXECUTE-UINST-CLOCK-PLUS-UINST-CLOCK-LOW IZERO-GOOD-PARITY T))
	  (t
	   (write-pc-fast adr)))
    (COND ((AND *PARANOID-MODE* (NOT (UINST-CLOCK-LOW-P)))
						;(FORCE-UINST-CLOCK-LOW)
	   (FERROR NIL "uinst clock not left low by write-pc")))
    (write-low-cram (logand 37777777777 data))
    (write-high-cram (logand 37777777777 (ash data -40)))))

(defun write-cram-fast (adr data)
  (write-pc-fast adr)
  (COND ((AND *PARANOID-MODE* (NOT (UINST-CLOCK-LOW-P)))
	 ;(FORCE-UINST-CLOCK-LOW)
	 (FERROR NIL "uinst clock not left low by write-pc")))
  (write-low-cram (logand 37777777777 data))
  (write-high-cram (logand 37777777777 (ash data -40))))

(DEFUN WRITE-CRAM-PHYSICAL (adr data)	;uses 7776 in CRAM-ADR-MAP as temp.
  (LET ((HI-PART (LDB (BYTE 10. 4) ADR))
	(LO-PART (LDB (BYTE 4 0) ADR)))
    (WRITE-CRAM-ADR-MAP 7776 HI-PART)
    (WRITE-CRAM (+ 177740 LO-PART) DATA)))

(defun write-cram-AT-CURRENT-PC (data)
  (COND ((NOT (UINST-CLOCK-LOW-P))
	 (FERROR NIL "UINST CLOCK NOT LOW")))
  ;(WRITE-IREG 0)		;make sure write uinst bits clear.
  (write-low-cram (logand 37777777777 data))
  (write-high-cram (logand 37777777777 (ash data -40))))

(defun write-high-cram-at-address (adr data)
  (write-pc adr)
  ;(WRITE-IREG 0)
  (write-high-cram data))

(defun read-cram (&OPTIONAL (adr NIL))		;reads "virtual" address
  (IF ADR (write-pc adr))
  (logior (ash (read-high-cram) 40)
	  (read-low-cram)))

(DEFUN READ-CRAM-PHYSICAL (ADR)	;uses 7776 in CRAM-ADR-MAP as temp.
  (LET ((HI-PART (LDB (BYTE 10. 4) ADR))
	(LO-PART (LDB (BYTE 4 0) ADR)))
    (WRITE-CRAM-ADR-MAP 7776 HI-PART)
    (READ-CRAM (+ 177740 LO-PART))))

(defun read-high-cram-at-address (adr)
  (write-pc adr)
  (read-high-cram))
	  
(defun read-low-cram-at-address-fast (adr)
  (write-pc-fast adr)
  (read-low-cram))

(DEFUN LOAD-CRAM-ADR-MAP-WITH-STRAIGHT-MAP nil
  (DOTIMES (ADR 10000)				;take the 12 input address bits and
    (LET ((ADR-MASK (LDB 12 ADR)))		;mask out the two high bits (parity)
      (WRITE-CRAM-ADR-MAP ADR ADR-MASK))))	;for now and write that as data

;this is in wr-rd
;(DEFUN CHECK-STRAIGHT-CRAM-ADR-MAP ()
;  (DOTIMES (ADR 10000)
;    (LET ((DATA (READ-CRAM-ADR-MAP ADR NIL)))
;      (COND ((NOT (= DATA ADR))
;	     (TV:BEEP)
;	     (FORMAT T "~%lose adr ~s, read ~s" ADR DATA))))))

(DEFUN WIPE-CRAM (&OPTIONAL (DATA 0))
  (DOTIMES (ADR 40000)
    (WRITE-CRAM ADR DATA)))

(DEFUN FAST-ADDRESS-TEST-CRAM-ADR-MAP NIL
  (NOOP-UINST-CLOCKS)			;MAKE SURE NO CARRYOVER WRITES TO SCREW UP
  (LET ((OFFSET 0)
	(N-DATA-BITS 12.)	       
	(READ-FCTN 'READ-CRAM-ADR-MAP)
	(WRITE-FCTN 'WRITE-CRAM-ADR-MAP)
	(N-ADDRESS-BITS 12.)
	(MESSAGE "FAST-ADDRESS-TEST of CRAM Address Map"))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE))
	;Try to leave something reasonable in the map
  (cond ((< (send *proc* :major-version) 100.)
	 (FAST-LOAD-STRAIGHT-CRAM-ADR-MAP))
	(t
	 (load-straight-cram-adr-map (ash 200000 -6))))
  )

(DEFUN FAST-ADDRESS-TEST-high-CRAM NIL
  (LET ((OFFSET 0)
	(N-DATA-BITS 32.)
	(N-ADDRESS-BITS 14.)
	(READ-FCTN 'READ-high-CRAM-at-address)
	(WRITE-FCTN 'WRITE-high-CRAM-at-address)
	(MESSAGE "FAST-ADDRESS-TEST of High CRAM"))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE)))

(DEFUN FAST-ADDRESS-TEST-CRAM NIL
  (LET ((OFFSET 0)
	(N-DATA-BITS 64.)
	(N-ADDRESS-BITS 14.)
	(READ-FCTN 'READ-CRAM)
	(WRITE-FCTN 'WRITE-CRAM-dont-worry-about-parity)
	(MESSAGE "FAST-ADDRESS-TEST of CRAM"))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE)))
(DEFUN FAST-ADDRESS-TEST-LOW-CRAM NIL
  (LET ((OFFSET 0)
	(N-DATA-BITS 64.)
	(N-ADDRESS-BITS 4.)
	(READ-FCTN 'READ-CRAM)
	(WRITE-FCTN 'WRITE-CRAM)
	(MESSAGE "FAST-ADDRESS-TEST of LOW 4 ADDRESS BITS OF CRAM"))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE)))
(defun fast-address-test-cram-banks nil
  (dotimes (bank 4)
    (fast-address-test-kernal 'write-cram 'read-cram (* bank 10000) 64. 12.
			      (format nil "FAST-ADDRESS-TEST of 4K CRAM bank ~d" bank))))

(defun fast-address-test-one-cram-bank (bank) nil
  (fast-address-test-kernal 'write-cram 'read-cram (* bank 10000) 64. 12.
			    (format nil "fast-address-test of cram bank ~d" bank)))

;;
;;		 {	03 MD (memory data register, 32 bits, read only)
;;	MI board {      02 CSM.REG (output register of CSM, 32 bits, read only)
;;		 {	01 CSM.ADR (special address register for debug read/write
;;		 {			of TRAM, low 12 bits, read and write)
;;		 {		& CACHED.PHY.ADR (currently cached physical address,
;;		 {			high 18 bits, read only)
;;		 {		& MEMORY CYCLE STATUS (memory.cycle.pending, bit 31,
;;					and memory.cycle.active, bit 30; read only)
;;		 {	00 CSM (cache state machine, 32 bits)

(DEFUN WRITE-MD-VIA-M-MEM (DATA)
  (WRITE-M-MEM 1 DATA)
  (LAM-EXECUTE (WRITE)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC 1
	       LAM-IR-FUNC-DEST LAM-FUNC-DEST-MD
	       LAM-IR-ALUF LAM-ALU-SETM))

(DEFUN READ-MD (&optional (compare-mask 37777777777))
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-MD-NO-HOLD	;temp until new prom.
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-MFO COMPARE-MASK))


(DEFUN READ-MD-STEPPING ()
  (LAM-EXECUTE (EXECUTOR LAM-EXECUTE-NOCLOCKS)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-MD
	       LAM-IR-ALUF LAM-ALU-SETM)
  (SM-STEP-LOOP))

(DEFUN WRITE-MD (DATA &OPTIONAL NO-ERROR)
  (WRITE-SPY-REG-AND-CHECK DATA)
  (LAM-EXECUTE (WRITE)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC lam-m-src-spy-reg
	       LAM-IR-FUNC-DEST LAM-FUNC-DEST-MD
	       LAM-IR-ALUF LAM-ALU-SETM)
  (IF (AND *PARANOID-MODE* (NULL NO-ERROR))
      (LET ((TEM (READ-MD)))
	(COND ((NOT (= TEM (LOGAND 37777777777 DATA)))
	       (FERROR NIL "MD failed to load with ~s, is ~s" data tem))))))

(DEFUN MD-TEST-LOOP (DATA)
  (DO () (())
    (WRITE-MD DATA T)))

(DEFUN WRITE-MD-STEPPING (DATA)
  (WRITE-SPY-REG-AND-CHECK DATA)
  (LAM-EXECUTE (EXECUTOR LAM-EXECUTE-NOCLOCKS)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC lam-m-src-spy-reg
	       LAM-IR-FUNC-DEST LAM-FUNC-DEST-MD
	       LAM-IR-ALUF LAM-ALU-SETM)
  (SM-STEP-LOOP))

(DEFUN WRITE-L1-MAP (ADDRESS DATA)
  (WRITE-MD ADDRESS)
  (WRITE-SPY-REG-AND-CHECK DATA)
  (LAM-EXECUTE (WRITE)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC lam-m-src-spy-reg
	       LAM-IR-FUNC-DEST LAM-FUNC-DEST-L1-MAP
	       LAM-IR-ALUF LAM-ALU-SETM)
  (COND ((NOT (= (READ-SPY-REG) DATA))
	 (FERROR NIL "spy reg changed spuriously"))))

(DEFUN READ-L1-MAP (ADDRESS)
  (WRITE-MD ADDRESS)
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-L1-MAP
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-MFO))

(DEFUN READ-VMA (&optional (compare-mask 37777777777))
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-VMA
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-MFO COMPARE-MASK))

(DEFUN READ-VMA-STEPPING ()
  (LAM-EXECUTE (executor lam-execute-noclocks)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-VMA
	       LAM-IR-ALUF LAM-ALU-SETM)
  (sm-step-loop))

(DEFUN WRITE-VMA (DATA &OPTIONAL MAKE-SURE &AUX TEMP)
  (PROG NIL 
     TOP (WRITE-SPY-REG-AND-CHECK DATA)
	(LAM-EXECUTE (WRITE)
		     LAM-IR-OP LAM-OP-ALU
		     LAM-IR-OB LAM-OB-ALU
		     LAM-IR-M-SRC lam-m-src-spy-reg
		     LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA
		     LAM-IR-ALUF LAM-ALU-SETM)
	(COND ((AND MAKE-SURE (NOT (= (SETQ TEMP (READ-VMA)) DATA)))
	       (FORMAT T "~%Wrote ~O, Read back ~O, trying again " DATA TEMP)
	       (GO TOP)))))

(DEFUN WRITE-VMA-STEPPING (DATA)
  (WRITE-SPY-REG-AND-CHECK DATA)
  (LAM-EXECUTE (EXECUTOR LAM-EXECUTE-NOCLOCKS)
    LAM-IR-OP LAM-OP-ALU
    LAM-IR-OB LAM-OB-ALU
    LAM-IR-M-SRC lam-m-src-spy-reg
    LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA
    LAM-IR-ALUF LAM-ALU-SETM)
  (SM-STEP-LOOP))

(DEFUN VMA-TEST-LOOP (DATA)
  (DO () (())
    (WRITE-VMA DATA)
    (COND ((NOT (= (READ-VMA) DATA))
	   (TV:BEEP)))))

(DEFUN READ-MD-BUS ()
  (SPY-READ 3))

(DEFUN WRITE-CSM-ADR (DATA)
  (SPY-WRITE 1 DATA))

(DEFUN READ-CSM-ADR ()
  (LOGAND 7777 (SPY-READ 1)))

(defun read-csm-adr-reg () "sets pmr to force use of diagnostic reg, reads, then restores pmr"
       (let ((pmr (read-pmr))
	     (temp))
	 (change-pmr-and-check '(force-csm-use-spy-address-l 0))
	 (setq temp (read-csm-adr))
	 (write-pmr pmr)
	 temp))

(defconst mem-pending-bit (byte 1 31.))
(defconst mem-active-bit (byte 1 30.))

(defun print-memory-status (&aux data)
  (cond ((< (send *proc* :major-version) 100.)
	 (setq data (spy-read 1))
	 (format t "~%   ~[memory cycle not active~;memory cycle active~]"
		 (ldb mem-active-bit data))
	 (format t "~%   ~[memory cycle not pending~;memory cycle pending~]~%"
		 (ldb mem-pending-bit data)))))
  

(DEFUN READ-CSM-REG ()
  (SPY-READ 2))	

(DEFUN READ-CSM (ADR)
  (WRITE-CSM-ADR ADR)
  (SPY-READ 0))

(DEFUN WRITE-CSM (ADR DATA)
  (WRITE-CSM-ADR ADR)
  (if check-parity
      (spy-write 0 (compute-parity-32 data))
  (SPY-WRITE 0 DATA)))

(DEFUN WRITE-CSM-REG-FROM-CSMRAM (ADR)
  (let ((pmr (read-pmr)))
    (SETUP-PMR CSMRAM-ADR-FROM-CSMRAM-ADR-REG-PMR-LIST)
    (WRITE-CSM-ADR ADR)
    (SM-TICK)
    (write-pmr pmr)
    ))

(DEFUN WRITE-CSM-REG-VIA-CSMRAM (DATA)
  (COND ((ACCESS-PATH-LMI-SERIAL-PROTOCOL *PROC*)
	 (FORMAT *PROC* "5,~SC" DATA)
	 (FUNCALL *PROC* ':READ-32))
	(T
	 (WRITE-CSM 7777 DATA)
	 (WRITE-CSM-REG-FROM-CSMRAM 7777))))

(DEFUN WIPE-CSM (&OPTIONAL (DATA (COMPUTE-PARITY-32 0)))
  (COND ((ACCESS-PATH-LMI-SERIAL-PROTOCOL *PROC*)
	 (FUNCALL *PROC* ':STRING-OUT "0c")
	 (FUNCALL *PROC* ':READ-32))
	(t (DOTIMES (ADR 10000)
	     (WRITE-CSM ADR DATA)))))

(DEFUN SCAN-CSM-FOR-BAD-PARITY ()
  (DOTIMES (ADR 10000)
    (LET ((DATA (READ-CSM ADR)))
      (COND ((CHECK-PARITY-32 DATA)
	     (FORMAT T " in adr ~s~%" ADR))))))

(DEFUN FAST-ADDRESS-TEST-CSM NIL
  (LET ((OFFSET 0)
	(N-DATA-BITS 32.)
	(N-ADDRESS-BITS 12.)
	(READ-FCTN 'READ-CSM)
	(WRITE-FCTN 'WRITE-CSM)
	(MESSAGE "FAST-ADDRESS-TEST of Cache State Machine")
	(pmr (read-pmr))
	(check-parity nil))
    
    (change-pmr-and-check '(force-csm-use-spy-address-l 0))
    (FAST-ADDRESS-TEST-KERNAL WRITE-FCTN READ-FCTN
			      OFFSET N-DATA-BITS N-ADDRESS-BITS MESSAGE)
    (write-pmr pmr)
    ))


(DEFUN PRINT-TREG ()
  (PRINT-TRAM-CODEWORD (READ-TREG))
)

(defun print-tram-codeword (tram-data)
  (cond ((< (send *proc* :major-version) 100.)
	 (print-tram-codeword-old tram-data))
	(t
	 (print-tram-codeword-hh tram-data))))

(DEFUN PRINT-TRAM-CODEWORD-old (TRAM-DATA)
    (TERPRI)
  (LET ((FIELD-LIST 
		 '(
		   tram.state 
		   tram.next.select 
		   tram.hold.control 
		   tram.M.address.control ;0 nothing, 1 PDL index, 2 PDL pointer, 3 write address
		   tram.M.CS 
		   tram.M.WE-L
		   tram.A.address.control 
		   tram.A.address.from.dispatch	;otherwise from AM
		   tram.AM.from.write.address	;otherwise from A.source
		   tram.A.WE-L
		   tram.a.clock.next
		   tram.L.to.A-L
		   tram.L.to.M-L
		   tram.source.cycle 
		   tram.data.paths.to.MFO 
		   tram.m.clock.next 
		   tram.slow.dest.write
		   tram.new.uinst
		   tram.parity)))
		 
    (DOLIST (F FIELD-LIST)
      (FORMAT T "~s ~o " F (LDB (SYMEVAL F) TRAM-DATA)))

    (cond ((= (ldb-big (byte 28. 0) tram-data)
	      (ldb-big (byte 28. 0) (tram-location-3000)))
	   (format t "~& (this is 3000@TRAM)~&")))
    ))

(defun print-tram-codeword-hh (data)
  (format t "~&")
  (if (not (zerop (ldb tram.next.select data)))
      (format t "next state ~o " (+ 3000 (ldb tram.state data))))
  (format t "A-adr from ~[SOURCE~;DISPATCH~;WRITE~;??~]"
	  (+ (ash (ldb tram.am.from.write.address data) 1)
	     (ldb tram.a.address.from.dispatch data)))
  (format t "~&")
  (format t "~&A.clock.next ~o M.clock.next ~o "
	  (ldb tram.a.clock.next data)
	  (ldb tram.m.clock.next data))
  (format t "Next cycle number ~o first.source.cycle.next ~o new.uinst ~o"
	  (ldb tram.next.cycle.number data)
	  (ldb tram.first.source.cycle.next data)
	  (ldb tram.new.uinst data))

  (format t "~&")
  (if (zerop (ldb tram.L.to.A-L data))
      (format t "L.to.A "))
  (if (zerop (ldb tram.L.to.M-L data))
      (format t "L.to.M "))
  (if (not (zerop (ldb tram.slow.dest.write data)))
      (format t "SLOW.DEST.WRITE "))
  
  (format t "data.paths.to.mfo ~o"
	  (ldb tram.data.paths.to.MFO  data))

  (cond ((= (ldb-big (byte 28. 0) data)
	    (ldb-big (byte 28. 0) (tram-location-3000)))
	 (format t "~& (this is 3000@TRAM)~&"))))

(defun loop-tram ()
  (disable-lambda)
  (wipe-tram (COMPUTE-PARITY-32 (dpb 3 tram.next.select 0)))
  (enable-lambda)
  (disable-lambda)
  (dotimes (adr 400)
    (write-tram-WITH-GOOD-PARITY adr (dpb 3 tram.next.select (1+ adr))))  ;note it wraps right
  (enable-lambda)	;it should be counting now..
  )


;note this advances to second source cycle if source cycle doubled.

(DEFUN FORCE-SOURCE-CODEWORD NIL
  (LET ((PMR (READ-PMR)))
    (CHANGE-PMR '(SPY-ADDRESS-TRAM-L 0 ALLOW-UINST-CLOCKS 0))

 ;  new rg board
    (WRITE-TRAM-ADR 1005)
    (SM-TICK 2)
    (WRITE-PMR PMR))
  (cond ((< (send *proc* :major-version) 100.)
	 (do ((i 1 (1+ i)))
	     ((source-execute-boundary-p))
	   (if (> i 3)
	       (ferror nil "failed to reach source-execute boundary in force-source codeword")
	     (sm-tick))))
	(t
	)))

(defun source-execute-boundary-p (&aux tadr-contents)
  (if (> (send *proc* :major-version) 100.) (ferror nil "not for this processor"))
  (write-tram-adr (setq tadr-contents (read-tram-adr)))  ;set up to read next TRAM location to be clocked in.
 ;(format t "~%  treg = ~o    tram = ~o  tadr = ~o" (read-treg) (spy-read 11) tadr-contents)  
  (and  (= 0 (ldb tram.source.cycle (spy-read 11)))
	(= 1 (ldb tram.source.cycle (read-treg)))
        ))



(DEFUN WRITE-TREG-FROM-TRAM (ADR)
  (COND ((ACCESS-PATH-LMI-SERIAL-PROTOCOL *PROC*)
	 (FORMAT *PROC* "1,~SC" ADR)
	 (FUNCALL *PROC* ':READ-32))
	(T
	 (let ((pmr (read-pmr)))
	   (change-pmr TRAM-ADR-FROM-TRAM-ADR-REG-PMR-LIST)
	   (WRITE-TRAM-ADR ADR)
	   (SM-TICK)
	   (write-pmr pmr)))))

(DEFUN WRITE-TREG (data &optional (tram-adr 0))
  (let ((pmr (read-pmr)))
    (CHANGE-PMR TRAM-ADR-FROM-TRAM-ADR-REG-PMR-LIST)
    (WRITE-TRAM tram-ADR data)
    (SM-TICK)
    (write-pmr pmr)
    ))

(DEFUN WRITE-TREG-LOOP (data &optional (tram-adr 0))
  (let ((pmr (read-pmr)))
    (CHANGE-PMR TRAM-ADR-FROM-TRAM-ADR-REG-PMR-LIST)
    (WRITE-TRAM tram-ADR data)
    (DO ()
	((send terminal-io :tyi-no-hang)
	 (FORMAT T "~%YUCKO!"))
      (SM-TICK))
    (write-pmr pmr)
    ))

(DEFCONST SM-TICK-DETECT-HANGS NIL)

(DEFCONST SM-TICK-HISTORY-POINTER 0)
(DEFCONST SM-TICK-HISTORY-MAX 20)
(DEFCONST IREG-SM-TICK-HISTORY (MAKE-ARRAY SM-TICK-HISTORY-MAX))
(DEFCONST NOOP-SM-TICK-HISTORY (MAKE-ARRAY SM-TICK-HISTORY-MAX))
(DEFCONST NUMBER-TICKS-SM-TICK-HISTORY (MAKE-ARRAY SM-TICK-HISTORY-MAX))

(DEFUN PRINT-SM-TICK-HISTORY ()
  (DO ((C 0 (1+ C))
       (P SM-TICK-HISTORY-POINTER (\ (+ P (1- SM-TICK-HISTORY-MAX)) SM-TICK-HISTORY-MAX)))
      ((= C SM-TICK-HISTORY-MAX))
    (FORMAT T "~%~S: NOOP ~S, ~S TICKS  " C
	    (AREF NOOP-SM-TICK-HISTORY P)
	    (AREF NUMBER-TICKS-SM-TICK-HISTORY P))
    (LAM-PRINT-UINST (AREF IREG-SM-TICK-HISTORY P))))

(defun simple-sm-tick (&optional (number-of-ticks 1))
  (if (< (send *proc* :major-version) 100.)
      (change-pmr '(debug-clock 0)))
  (let* ((pmr-with-debug-clock-1 (update-value '(debug-clock 1) (read-pmr)))
	 (pmr-with-debug-clock-0 (update-value '(debug-clock 0) pmr-with-debug-clock-1)))
    (dotimes (n number-of-ticks)
      (write-pmr pmr-with-debug-clock-1)
      (write-pmr pmr-with-debug-clock-0))))

(DEFUN SM-TICK (&OPTIONAL NUMBER-OF-TICKS
		(tram-compare tram-compare-mode))
  (if (null number-of-ticks)
      (setq number-of-ticks 1))
  ;(COND ((ACCESS-PATH-LMI-SERIAL-PROTOCOL *PROC*)
  ;	 (FERROR NIL "got to sm-tick")
  ;	 ))
  (COND ((AND SM-TICK-DETECT-HANGS (UINST-CLOCK-LOW-P))
	 (COND ((>= (SETQ SM-TICK-HISTORY-POINTER (1+ SM-TICK-HISTORY-POINTER))
		    SM-TICK-HISTORY-MAX)
		(SETQ SM-TICK-HISTORY-POINTER 0)))
	 (LET ((IREG (READ-IREG)))
	   (ASET IREG IREG-SM-TICK-HISTORY SM-TICK-HISTORY-POINTER)
	   (ASET (NOOP-P) NOOP-SM-TICK-HISTORY SM-TICK-HISTORY-POINTER)
	   (ASET NUMBER-OF-TICKS NUMBER-TICKS-SM-TICK-HISTORY SM-TICK-HISTORY-POINTER)
	   (COND ((OR (NOT (ZEROP (LDB LAM-IR-MACRO-IR-DISPATCH IREG)))
		      (NOT (ZEROP (LDB LAM-IR-SOURCE-TO-MACRO-IR IREG)))
		      (NOT (ZEROP (LDB LAM-IR-MACRO-STREAM-ADVANCE IREG))))
		  (BREAK 'ABOUT-TO-HANG-MACHINE T))))))
  (cond (tram-compare
	 (cond ((zerop number-of-ticks) nil)
	       ((or (zerop (ldb spy-address-tram-l (read-pmr)))
		    (zerop (ldb t-hold-l-bit (read-con-reg))))
		(sm-tick 1 nil))
	       (t
		(let* ((tram-adr (read-tram-adr))
		      (current-tram-data (read-treg))
		      (original-tram-data (aref tram-array tram-adr)))
		  (sm-tick 1 nil)
		  (cond ((not (= current-tram-data original-tram-data))
			 (format t "~%Treg failed to compare!! Is ~s should be ~s. Should have come from ~s~%~%"
				 current-tram-data original-tram-data tram-adr)
			 (find-possible-tram-adr current-tram-data)))
		(sm-tick (1- number-of-ticks) tram-compare)))))
	((< (send *proc* :major-version) 100.)
	 (CHANGE-PMR '(DEBUG-CLOCK 0))
	 (DOTIMES (INDEX NUMBER-OF-TICKS)
	   (CHANGE-PMR '(DEBUG-CLOCK 1))
	   (CHANGE-PMR '(DEBUG-CLOCK 0))))
	(t (DOTIMES (INDEX NUMBER-OF-TICKS)
	     (CHANGE-PMR '(DEBUG-CLOCK 1))
	     (CHANGE-PMR '(DEBUG-CLOCK 0))))
	))

(defun simple-sm-tick-loop ()
  (do-forever
    (bb-nd-bus-write #xf8000040 14440015_8)
    (bb-nd-bus-write #xf8000040 14440035_8)))

(defun check-pc-stepping ()
  (reset)
  (quick-tram-loop)
  (do ((expected-pc 0 (ldb (byte 16. 0) (1+ (read-pc)))))
      (())
    (if (zerop (ldb (byte 10. 0) expected-pc)) (format t "~o " expected-pc))
    (bb-nd-bus-write #xf8000040 14440015_8)
    (bb-nd-bus-write #xf8000040 14440035_8)
    (bb-nd-bus-write #xf8000040 14440015_8)
    (bb-nd-bus-write #xf8000040 14440035_8)
    (if (not (= expected-pc (read-pc)))
	(format t "~&expected ~o  read ~o" expected-pc (read-pc)))))

(defun find-possible-tram-adr (data)
  (let ((current-treg (read-treg))
	(any-found nil))
    (format T "~%")
    (dotimes (adr 10000)
      (cond ((equal (read-tram adr) data)
	     (format T "~O~5X" adr)
	     (setq any-found T))
	    (t nil)))
    (cond ((not any-found)
	   (format T "NO "))
	  (t (format T "possible addresses that got us here")))
    (write-treg current-treg)))

(DEFUN SETUP-TRAM (ADDRESS SETUP-LIST)
  (WRITE-TRAM-WITH-GOOD-PARITY ADDRESS
    (UPDATE-VALUE SETUP-LIST)))

(DEFUN STORE-TRAM-BACKGROUND NIL
  (LET ((TZERO-WITH-GOOD-PARITY (COMPUTE-PARITY-32 0)))
    (DOTIMES (ADR 4000)
      (WRITE-TRAM ADR TZERO-WITH-GOOD-PARITY)))
  (LET ((HALT-WORD
	  (COMPUTE-PARITY-32 (UPDATE-VALUE '(TRAM.NEXT.SELECT 1 TRAM.STATE 377))))) 
    (DOTIMES (ADR 4000)				;LOOP AT 7377 ON HALT
      (WRITE-TRAM (+ ADR 4000) HALT-WORD))))

(DEFUN AT-UINST-BOUNDARY-P ()
  (let ((treg (logand 1777777777 (read-treg)))	;dont look at parity bits
	       (t3000 (logand 1777777777 (tram-location-3000)))
	       )
	  (cond ( (= treg t3000) t)
		( (not (uinst-clock-low-p))
		 (format t "~% UINST CLOCK HIGH when AT-UINST-BOUNDARY-P NIL")
		 (sm-step-loop))
		(t nil))))

(DEFUN ADVANCE-TO-UINST-BOUNDARY NIL
  (DO ((COUNTS 1 (1+ COUNTS)))
      ((> COUNTS 10.)
       (FERROR NIL "UINST DID NOT COMPLETE AFTER 10 SM CLOCKS"))
    (COND ((AT-UINST-BOUNDARY-P)
	   (RETURN COUNTS)))  ;this is a UINST boundary.
    (SM-TICK)
    ))

(DEFUN ADVANCE-TO-UINST-BOUNDARY-PLUS-UINST-CLOCK-LOW NIL
  (ADVANCE-TO-UINST-BOUNDARY)
  (FORCE-UINST-CLOCK-LOW))

(DEFUN WRITE-TRAM-HIGH-AND-LOW (ADR DATA)
  (cond ((and (< (send *proc* :major-version) 100.)
	      (zerop (ldb tram.source.cycle data))
	      (zerop (ldb tram.M.address.control data)))
	 (format t "~%lose! adr:~s, data ~s" adr data)))
  (LET ((DATA-WITH-PARITY (COMPUTE-PARITY-32 DATA)))
    (WRITE-TRAM ADR DATA-WITH-PARITY)
    (WRITE-TRAM (+ ADR 4000) DATA-WITH-PARITY)))

(DEFUN READ-TRAM-AND-CHECK-HIGH-AND-LOW (ADR DATA)
  (READ-TRAM-AND-CHECK ADR DATA)
  (READ-TRAM-AND-CHECK (+ ADR 4000) DATA))


(DEFVAR NUMBER-OF-SOURCE-CYCLES 3)
(DEFVAR NUMBER-OF-EXECUTE-CYCLES 3)

(DEFUN SET-LAMBDA-SPEED (&OPTIONAL NEW-SPEED)
  (COND ((NUMBERP NEW-SPEED)
	 (SETQ NUMBER-OF-SOURCE-CYCLES (LDB 0303 NEW-SPEED))
	 (SETQ NUMBER-OF-EXECUTE-CYCLES (LDB 0003 NEW-SPEED)))
	(T
	 (TV:CHOOSE-VARIABLE-VALUES
	   '((NUMBER-OF-SOURCE-CYCLES "Number of source cycles" :ASSOC (("One" . 1)
									("Two" . 2)
									("Three" . 3)))
	     (NUMBER-OF-EXECUTE-CYCLES "Number of execute cycles" :ASSOC (("One" . 1)
									  ("Two" . 2)
									  ("Three" . 3)))))))
  (SELECT NUMBER-OF-SOURCE-CYCLES
    (1 (SETQ SOURCE-CYCLE-DOUBLED-IN-TRAM NIL)
       (SETQ SOURCE-CYCLE-TRIPLED-IN-TRAM NIL))
    (2 (SETQ SOURCE-CYCLE-DOUBLED-IN-TRAM T)
       (SETQ SOURCE-CYCLE-TRIPLED-IN-TRAM NIL))
    (3 (SETQ SOURCE-CYCLE-DOUBLED-IN-TRAM T)
       (SETQ SOURCE-CYCLE-TRIPLED-IN-TRAM T)))
  (SELECT NUMBER-OF-EXECUTE-CYCLES
    (1 (SETQ EXECUTE-CYCLE-DOUBLED-IN-TRAM NIL)
       (SETQ EXECUTE-CYCLE-TRIPLED-IN-TRAM NIL))
    (2 (SETQ EXECUTE-CYCLE-DOUBLED-IN-TRAM T)
       (SETQ EXECUTE-CYCLE-TRIPLED-IN-TRAM NIL))
    (3 (SETQ EXECUTE-CYCLE-DOUBLED-IN-TRAM T)
       (SETQ EXECUTE-CYCLE-TRIPLED-IN-TRAM T))))

(defvar tram-compare-mode nil)
(defvar tram-array (make-array 4096.))

(defun write-tram-array-high-and-low (adr data)
  (LET ((DATA-WITH-GOOD-PARITY (COMPUTE-PARITY-32 DATA)))
    (write-tram-array adr DATA-WITH-GOOD-PARITY)
    (write-tram-array (+ adr 4000) DATA-WITH-GOOD-PARITY)))

(defun write-tram-array (adr data)
  (aset (compute-parity-32 data) tram-array adr))

(defun write-all-trams-to-file ()
  (dotimes (x 3)
    (dotimes (y 3)
      (select x
	(0 (setq source-cycle-doubled-in-tram nil)
	   (setq source-cycle-tripled-in-tram nil))
	(1 (setq source-cycle-doubled-in-tram t)
	   (setq source-cycle-tripled-in-tram nil))
	(2 (setq source-cycle-doubled-in-tram t)
	   (setq source-cycle-tripled-in-tram t)))
      (select y
	(0 (setq execute-cycle-doubled-in-tram nil)
	   (setq execute-cycle-tripled-in-tram nil))
	(1 (setq execute-cycle-doubled-in-tram t)
	   (setq execute-cycle-tripled-in-tram nil))
	(2 (setq execute-cycle-doubled-in-tram t)
	   (setq execute-cycle-tripled-in-tram t)))
      (write-current-tram-to-file))))

(defun write-current-tram-to-file (&optional choose-new-speed)
  (init-tram choose-new-speed ':make-array-for-sdu t)
  (let ((source-string (cond ((null source-cycle-tripled-in-tram)
			      (cond ((null source-cycle-doubled-in-tram) "normal")
				    (t "doubled")))
			     (t "tripled")))
	(execute-string (cond ((null execute-cycle-tripled-in-tram)
			       (cond ((null execute-cycle-doubled-in-tram) "normal")
				     (t "doubled")))
			      (t "tripled"))))
    (write-tram-array-to-file (format nil "sys:lambda-ucode;ulambda-tram-~A-~A lisp"
				      source-string execute-string)
			      (format nil "~&;;; ~a ~a" source-string execute-string))))

(defun write-tram-array-to-file (file-name &optional extra-info)
  (with-open-file (standard-output file-name ':write)
    (format t ";;;-*- Mode:LISP; Package:LAMBDA; Base:16.;readtable:zl -*-")
    (let ((spy-file-info (cadar (get (si:get-source-file-name 'init-tram)
				     ':file-id-package-alist))))
      (format t "~&;;; LAMBDA TRAM PROGRAM")
      (format t "~&;;; From file ~S (created ~\time\)"
	      (car spy-file-info) (cdr spy-file-info))
      (format t "~&;;; This file created ~\datime\ by ~A" user-id))
    (cond ((stringp extra-info)
	   (send standard-output ':fresh-line)
	   (send standard-output ':string-out extra-info)))
    (format t "~&(setq tram-list '(")
    (dotimes (adr 10000)
      (format t "~&0~16r" (aref tram-array adr)))
    (format t "~&))~&")
    (send standard-output ':truename)))

;SPECIAL TRAM LOCNS
; 3000 BANK ACCESSIBLE BY TRAM.NEXT.SELECT 1
;  3000  FETCH CODEWORD
;  3001  WRITE M-MEM AND EXIT (TO 3000). IN SPACE-PDL-AND-M-WRITE MODE, 
;		THIS TRANSFERS TO  3006.
;  3002  FINISH DISPATCH AND EXIT
;  3003  WRITE-M, THEN FINISH DISPATCH AND EXIT.  CANNOT DO ALL IN ONE CYCLE SINCE
;    AM.SOURCE ADDRESS LINES MUST BE USED TO BRING OVER WRITE ADDRESS, AND ALSO TO
;    BRING DISPATCH BASE ADDRESS FROM A.SOURCE.
;  3004  SECOND SOURCE CYCLE
;  3005  THIRD SOURCE CYCLE
;  3006  NORMAL CONTENTS OF 3001 IN SPACE-PDL-AND-M-WRITE MODE.

;CHECK if set, compares current contents. TRAM is not affected.
;  SLOW-OPCODE-LIST is a list of opcodes to force TRIPLE execute cycles for.
;  the raw opcode number should be on the list, 
;  ie, 0 -> slow alu, 1 byte, 2 jump, 3 dispatch.
;the tram is loaded TRIPLE for opcodes on SLOW-OPCODE-LIST .

;this is the new tram program for "m.clock.next" and "a.clock.next"

(DEFUN NEW-INIT-TRAM (&OPTIONAL CHOOSE-NEW-SPEED
		  &KEY CHECK MAKE-ARRAY-FOR-SDU SLOW-OPCODE-LIST
		   (SPACE-PDL-AND-M-WRITE nil)
		   (UNUSED-TRAM-LOCNS-LOOP T)
		   (dispatch-length nil)  ;number of ticks to settle after A-address
					  ; switched to DISPATCH on dispatch inst.
					  ; 1 -> 1, 2 -> 2, nil -> 1 at x:1, two otherwise.

		   (space-slow-dest nil)  ;TRIPLE SLOW DESTINATIONS, AND DONT ASSERT
					  ; SLOW-DEST WRITE ON FIRST DESTINATION CYCLE.
		   (a-source-clock nil)   ;number of source cycle to clock a.latch.
					  ;  normally last one.
		   (m-source-clock nil)   ;likewise, m.latch.
		   (triple-source-cycle-on-ilong t)
		  &AUX FCTN SINGLE-FCTN
		  (MFO-ON-NOOP 1)	;for less noise.
		  (CHECK-FOR-NUBUS-TIMEOUTS NIL))	;for speed
  "(init-tram) loads
/(init-tram ':check t) checks
/(init-tram ':make-array-for-sdu t) puts tram in TRAM-ARRAY
most complicated:
/(init-tram t ':make-array-for-sdu t ':slow-opcode-list '(0))
   choose new speed, build array, and make ALU instructions slower
For slow opcode list:  0 ALU, 1 BYTE, 2 JUMP, 3 DISPATCH"
  (if choose-new-speed
      (set-lambda-speed choose-new-speed))
  (setq dispatch-length (cond ((null dispatch-length)
			       (if execute-cycle-doubled-in-tram 2 1))
			      ((numberp dispatch-length)
			       dispatch-length)
			      (t 2)))
  (FORMAT T "~&init-tram for a.clock.next and m.clock.next, dispatch length ~d"
	  dispatch-length)
  (cond ((and (null check) (null make-array-for-sdu))
	 (setq fctn 'write-tram-high-and-low)
	 (setq single-fctn 'write-tram-with-good-parity)
	 (format t "~&Loading TRAM: "))
	((and check (null make-array-for-sdu))
	 (setq fctn 'read-tram-and-check-high-and-low)
	 (setq single-fctn 'read-tram-and-check)
	 (format t "~&Checking TRAM: "))
	((and (null check) make-array-for-sdu)
	 (setq fctn 'write-tram-array-high-and-low)
	 (setq single-fctn 'write-tram-array)
	 (format t "~&Building TRAM for SDU: "))
	(t
	 (ferror nil "invalid arguments for init-tram - see its documentation")))

  (format t "source cycle ~:[normal~*~;~:[doubled~;tripled~]~], ~
             execute cycle ~:[normal~*~;~:[doubled~;tripled~]~]"
	source-cycle-doubled-in-tram source-cycle-tripled-in-tram
	execute-cycle-doubled-in-tram execute-cycle-tripled-in-tram)
  (if source-cycle-doubled-in-tram (setq triple-source-cycle-on-ilong nil))
  (cond ((access-path-lmi-serial-protocol *proc*)
	 (cond ((null check)
		(format t "~&serial mode: using default TRAM speeds")
		(format *proc* "ALoading TRAM~%")
		(funcall *proc* ':string-out "200i")
		(funcall *proc* ':read-32))
	       (t
		(format t "~&can't check tram in serial mode"))))
	(t
	   
  (IF (NULL CHECK)
      (DO ((ADR 1000 (1+ ADR))
	   (VAL (IF (NULL UNUSED-TRAM-LOCNS-LOOP)
		    (UPDATE-VALUE '(TRAM.M.ADDRESS.CONTROL 1))
		  (UPDATE-VALUE '(TRAM.M.ADDRESS.CONTROL 1
				  TRAM.NEXT.SELECT 1 TRAM.STATE 7)))))  ;IF IT EVER EXECUTES
					;THIS, GO TO 3007 AND LOOP.
	  ((= ADR 4000))
	(FUNCALL FCTN ADR VAL)))
  ;LOCATIONS ASSUMED BY LOW LEVEL DEBUGGING ROUTINES.
  (FUNCALL FCTN 1000 (UPDATE-VALUE '(TRAM.M.ADDRESS.CONTROL 1)))
  ;use extreme care using this codeword. You can lose clobbering the MD if T.source.cycle
  ; is not asserted on the minor cycle after UINST.CLOCK goes hi.
  (FUNCALL FCTN 1001 (UPDATE-VALUE '(TRAM.NEW.UINST 1 TRAM.M.ADDRESS.CONTROL 1)))
  (FUNCALL FCTN 1002 (UPDATE-VALUE '(TRAM.NEXT.SELECT 1 TRAM.M.ADDRESS.CONTROL 1)))
		  ;CAUSES SOURCE CYCLE NEXT.
  ;locn 1003 used by write-treg-via-tram
  (FUNCALL FCTN 1004  ;pre-source cycle for transitioning from single sm clock mode
		      ;to single.uinst mode with out advancing a uinst. Ie this way
		      ;we "pass by" 3000 again which gives halt.request a chance to do its 
		      ;thing.
       (UPDATE-VALUE '(TRAM.SOURCE.CYCLE 1	;not "last" source cycle.
		       TRAM.A.CLOCK.NEXT 0 TRAM.M.CLOCK.NEXT 0
		       TRAM.A.address.from.dispatch 0
		       TRAM.AM.FROM.WRITE.ADDRESS 0
		       TRAM.A.WE-L 1 TRAM.M.WE-L 1
		       TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
		       TRAM.NEXT.SELECT 1
		       TRAM.STATE 0)))
  (FUNCALL FCTN 1005 ;clear a.clock.next, m.clock.next, then jump to 3000
	   (UPDATE-VALUE '(TRAM.SOURCE.CYCLE 1 ;not "last" source cycle
			   TRAM.A.CLOCK.NEXT 0 TRAM.M.CLOCK.NEXT 0
			   TRAM.A.address.from.dispatch 0
			   TRAM.AM.FROM.WRITE.ADDRESS 0
			   TRAM.A.WE-L 1 TRAM.M.WE-L 1
			   TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
			   TRAM.NEXT.SELECT 1
			   TRAM.STATE 0)))

  (SETUP-3XXX-DATA)	;USED FOR SLOW DEST EVEN IF EXECUTES NOT DOUBLED.
  (DOTIMES (ADR 1000)
    (LET ((DEST-SEQ (LDB (BYTE 3 0) ADR))  ;0 NORMAL, 1 WRITE A, 2 WRITE M,  
		;3 WRITE C-PDL-POINTER, 4 WRITE M AND C-PDL-POINTER, 5 WRITE C-PDL-INDEX
		;6 WRITE M AND C-PDL-INDEX.
	  (SLOW-DEST (LDB (BYTE 1 3) ADR))  ;MEMORY DESTINATION, WAIT UNTIL MEMSUBR FREE.
					    ;ALSO USED FOR WRITES TO MAP.  TAKE EXTRA
					    ;EXECUTE CYCLE AND SET T.SLOW.DEST.WRITE 
					    ;DURING IT.
	  (UNUSED (LDB (BYTE 1 4) ADR))
	  (NO-OP (LDB (BYTE 1 5) ADR))
	  (ILONG (LDB (BYTE 1 6) ADR))
	  (OPCODE (LDB (BYTE 2 7) ADR))
	  (INST 0)
	  (SADR ADR))
  ;THIS FILLS IN THE MOBY DISPATCH AT THE BOTTOM OF TIMING RAM.  THIS CODEWORD IS ACCESSED
  ; DURING THE SOURCE CYCLE AND EXECUTED DURING THE FIRST EXECUTE CYCLE.
      unused
    (IF (ZEROP NO-OP)
      (SELECTQ OPCODE
	((0 1)	;ALU AND BYTE
	 (SELECTQ DEST-SEQ
	   (0 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1
					 TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
					 TRAM.M.WE-L 1 TRAM.A.WE-L 1
					 TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
					 ) INST)))
	   (1 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1
					 TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
				  ;WRITE A
					 TRAM.M.WE-L 1 TRAM.A.address.from.dispatch 0
					 TRAM.AM.FROM.WRITE.ADDRESS 1
					 TRAM.A.WE-L 0 TRAM.M.WE-L 1
					 TRAM.L.to.A-L 0 TRAM.L.TO.M-L 1
					 ) INST)))
	   (2 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1 
					 TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
				  ;WRITE M
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 3
					 TRAM.AM.FROM.WRITE.ADDRESS 1
					 TRAM.L.TO.M-L 0
					 TRAM.L.to.A-L 0
					 TRAM.A.WE-L 0 TRAM.A.address.from.dispatch 0) INST)))
	   (3 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1 
					 TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
				  ;W C-PDL-POINTER
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 2
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1) INST)))
	   (4 (SETQ INST (UPDATE-VALUE '(TRAM.DATA.PATHS.TO.MFO 1
				  ;WRITE M AND C-PDL-POINTER, WRITE C-PDL-POINTER NOW
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 2 
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1
					 TRAM.NEXT.SELECT 1
					 TRAM.STATE 1) INST)))	;TO 3001, WRITE M AND EXIT
	   (5 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1 
					 TRAM.DATA.PATHS.TO.MFO 1
				  ;WRITE C-PDL-BUFFER-INDEX
					 TRAM.NEXT.SELECT 1
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 1
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1) INST)))
	   (6 (SETQ INST (UPDATE-VALUE '(TRAM.DATA.PATHS.TO.MFO 1 
				  ;WRITE M AND C-PDL-BUFFER-INDEX, WRITE C-PDL-INDEX NOW
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 1
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1
					 TRAM.NEXT.SELECT 1
					 TRAM.STATE 1) INST)))	;TO 3001, WRITE M AND EXIT
	   (7 (SETQ INST (UPDATE-VALUE '(TRAM.NEXT.SELECT 1 
					 TRAM.M.WE-L 1 TRAM.A.WE-L 1
					 TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
					 TRAM.STATE 376) INST)))	;UNUSED, BOMB.
	   ))
	(2   ;JUMP, SAME AS ALU AND BYTE FOR NOW.
	 (SELECTQ DEST-SEQ
	   (0 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1 
					 TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
					 TRAM.M.WE-L 1 TRAM.A.WE-L 1
					 TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
					 ) INST)))
	   (1 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1 
					 TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
				  ;WRITE A
					 TRAM.M.WE-L 1 TRAM.A.address.from.dispatch 0
					 TRAM.AM.FROM.WRITE.ADDRESS 1
					 TRAM.A.WE-L 0 TRAM.M.WE-L 1
					 TRAM.L.to.A-L 0 TRAM.L.TO.M-L 1
					 ) INST)))
	   (2 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1 
					 TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
				  ;WRITE M
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 3
					 TRAM.AM.FROM.WRITE.ADDRESS 1
					 TRAM.L.TO.M-L 0
					 TRAM.L.to.A-L 0
					 TRAM.A.WE-L 0 TRAM.A.address.from.dispatch 0) INST)))
	   (3 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1 
					 TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
				  ;W C-PDL-POINTER
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 2
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1) INST)))
	   (4 (SETQ INST (UPDATE-VALUE '(TRAM.DATA.PATHS.TO.MFO 1 
				  ;WRITE M AND C-PDL-POINTER, WRITE C-PDL-POINTER NOW
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 2
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1
					 TRAM.NEXT.SELECT 1
					 TRAM.STATE 1) INST)))	;TO 3001, WRITE M AND EXIT
	   (5 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1 
					 TRAM.DATA.PATHS.TO.MFO 1
				  ;WRITE C-PDL-BUFFER-INDEX
					 TRAM.NEXT.SELECT 1
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 1
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1) INST)))
	   (6 (SETQ INST (UPDATE-VALUE '(TRAM.DATA.PATHS.TO.MFO 1 
				  ;WRITE M AND C-PDL-BUFFER-INDEX, WRITE C-PDL-INDEX NOW
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 1
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1
					 TRAM.NEXT.SELECT 1
					 TRAM.STATE 1) INST)))	;TO 3001, WRITE M AND EXIT
	   (7 (SETQ INST (UPDATE-VALUE '(TRAM.NEXT.SELECT 1 
					 TRAM.M.WE-L 1 TRAM.A.WE-L 1
					 TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
					 TRAM.STATE 376) INST)))	;UNUSED, BOMB.
	   ))
	(3	;DISPATCH.  THIS ONE DIFFERENT, TAKES 3 OR 4 TICKS.  LAST TICK GENERATES.
		; DISPATCH RESULT FROM A-MEM.  Dont bother to clock A register.
	  (SELECTQ DEST-SEQ
	   (0 (SETQ INST (UPDATE-VALUE '(TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
					 TRAM.M.WE-L 1 TRAM.A.WE-L 1
					 TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
					 TRAM.STATE 2) INST)))
	   (1 (SETQ INST (UPDATE-VALUE '(TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
				  ;WRITE A
					 TRAM.M.WE-L 1 TRAM.A.address.from.dispatch 0
					 TRAM.AM.FROM.WRITE.ADDRESS 1
					 TRAM.L.to.A-L 0 TRAM.L.TO.M-L 1
					 TRAM.A.WE-L 0 TRAM.M.WE-L 1
					 TRAM.STATE 2) INST)))
	   (2 (SETQ INST (UPDATE-VALUE '(TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
				  ;WRITE M
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 3
					 TRAM.AM.FROM.WRITE.ADDRESS 1
					 TRAM.L.TO.M-L 0 TRAM.L.to.A-L 0
					 TRAM.A.WE-L 0 TRAM.A.address.from.dispatch 0
					 TRAM.STATE 2) INST)))
	   (3 (SETQ INST (UPDATE-VALUE '(TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
				  ;W C-PDL-POINTER
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 2
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1
					 TRAM.STATE 2) INST)))
	   (4 (SETQ INST (UPDATE-VALUE '(TRAM.DATA.PATHS.TO.MFO 1
				  ;WRITE M AND C-PDL-POINTER, WRITE C-PDL-POINTER NOW
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 2
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1
					 TRAM.NEXT.SELECT 1
					 TRAM.STATE 3) INST)))	;TO 3003, WRITE-M, 
						;DISPATCH FINISH
	   (5 (SETQ INST (UPDATE-VALUE '(TRAM.DATA.PATHS.TO.MFO 1
				  ;WRITE C-PDL-BUFFER-INDEX
					 TRAM.NEXT.SELECT 1
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 1
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1
					 TRAM.STATE 2) INST)))
	   (6 (SETQ INST (UPDATE-VALUE '(TRAM.DATA.PATHS.TO.MFO 1
				  ;WRITE M AND C-PDL-BUFFER-INDEX, WRITE C-PDL-INDEX NOW
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 1
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1
					 TRAM.NEXT.SELECT 1
					 TRAM.STATE 3) INST)))	;TO 3003, WRITE-M,
						;DISPATCH FINISH
	   (7 (SETQ INST (UPDATE-VALUE '(TRAM.NEXT.SELECT 1
					 TRAM.M.WE-L 1 TRAM.A.WE-L 1
					 TRAM.L.TO.M-L 1 TRAM.L.TO.A-L 1
					 TRAM.STATE 376) INST)))	;UNUSED, BOMB.
	   ))
	)
    ;NO-OP TRUE. similar but USUAL TIMING FOR ALL INCLUDING DISPATCH. and maybe dont drive mfo
    ; for noise reasons.  dont bother clocking A latch.
      (SELECTQ DEST-SEQ
	   (0 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1
					 TRAM.NEXT.SELECT 1
					 TRAM.M.WE-L 1 TRAM.A.WE-L 1
					 TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
					 )
				       (UPDATE-VALUE
					 `(TRAM.DATA.PATHS.TO.MFO ,MFO-ON-NOOP)
					 INST))))
	   (1 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1
					 TRAM.NEXT.SELECT 1
				  ;WRITE A
					 TRAM.M.WE-L 1 TRAM.A.address.from.dispatch 0
					 TRAM.AM.FROM.WRITE.ADDRESS 1
					 TRAM.A.WE-L 0 TRAM.M.WE-L 1
					 TRAM.L.to.A-L 0 TRAM.L.TO.M-L 1
					 )
				       (update-value
					 `(TRAM.DATA.PATHS.TO.MFO ,MFO-ON-NOOP)
					 INST))))
	   (2 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1
					 TRAM.NEXT.SELECT 1
				  ;WRITE M
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 3
					 TRAM.AM.FROM.WRITE.ADDRESS 1
					 TRAM.L.TO.M-L 0
					 TRAM.L.to.A-L 0
					 TRAM.A.WE-L 0 TRAM.A.address.from.dispatch 0)
				       (update-value
					 `(TRAM.DATA.PATHS.TO.MFO ,MFO-ON-NOOP)
					 INST))))
	   (3 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1
					 TRAM.NEXT.SELECT 1
				  ;W C-PDL-POINTER
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 2
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1)
				       (update-value
					 `(TRAM.DATA.PATHS.TO.MFO ,MFO-ON-NOOP)
					 INST))))
	   (4 (SETQ INST (UPDATE-VALUE '(
				  ;WRITE M AND C-PDL-POINTER, WRITE C-PDL-POINTER NOW
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 2
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1
					 TRAM.NEXT.SELECT 1
					 TRAM.STATE 1)        ;TO 3001, WRITE M AND EXIT
	                               (update-value
					`(TRAM.DATA.PATHS.TO.MFO ,MFO-ON-NOOP)
					inst))))
	   (5 (SETQ INST (UPDATE-VALUE '(TRAM.NEW.UINST 1
				  ;WRITE C-PDL-BUFFER-INDEX
					 TRAM.NEXT.SELECT 1
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 1
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1)
				       (update-value
					 `(TRAM.DATA.PATHS.TO.MFO ,MFO-ON-NOOP)
					 INST))))
	   (6 (SETQ INST (UPDATE-VALUE '(
				  ;WRITE M AND C-PDL-BUFFER-INDEX, WRITE C-PDL-INDEX NOW
					 TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 1
					 TRAM.L.TO.M-L 0 TRAM.L.TO.A-L 1
					 TRAM.A.WE-L 1
					 TRAM.NEXT.SELECT 1
					 TRAM.STATE 1)	;TO 3001, WRITE M AND EXIT
				       (update-value
					 `(TRAM.DATA.PATHS.TO.MFO ,MFO-ON-NOOP)
					 inst))))
	   (7 (SETQ INST (UPDATE-VALUE '(TRAM.NEXT.SELECT 1
					 TRAM.M.WE-L 1 TRAM.A.WE-L 1
					 TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
					 TRAM.STATE 376) INST)))	;UNUSED, BOMB.
	   ))
    ;never put 0 in M.ADDRESS.CONTROL, it can cause M.address lines which look bad.
    (cond ((zerop (ldb TRAM.M.ADDRESS.CONTROL inst))
	   (setq inst (dpb 1 TRAM.M.ADDRESS.CONTROL inst))))
    (COND ((AND TRIPLE-SOURCE-CYCLE-ON-ILONG
		(NOT (ZEROP ILONG))
		(ZEROP UNUSED)		;DONT WASTE LOCNS DOING THIS IF UNNECESSARY
		(ZEROP NO-OP)
		(NOT (= DEST-SEQ 7)))
	;USE ILONG TO ALLOW FOR A SLOW SOURCE.  UNFORTUNATELY, TRAM.A.CLOCK.NEXT AND
	;TRAM.M.CLOCK.NEXT ARE ONE IN THE NORMAL SOURCE CYCLE, SO WE HAVE TO INSERT
	;TWO, THE FIRST WITH THE CLOCKS 0, THEN 1.
	   (LET ((3XXX-SLOCN1 (GET-3XXX-LOCN))
		 (3XXX-SLOCN2 (GET-3XXX-LOCN)))
	     (FUNCALL FCTN SADR 
	       (UPDATE-VALUE `(TRAM.STATE ,3XXX-SLOCN1
			       TRAM.SOURCE.CYCLE 1
			       TRAM.A.CLOCK.NEXT 0 TRAM.M.CLOCK.NEXT 0
			       TRAM.A.address.from.dispatch 0
			       TRAM.AM.FROM.WRITE.ADDRESS 0
			       TRAM.A.WE-L 1 TRAM.M.WE-L 1
			       TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
			       TRAM.NEXT.SELECT 1)))
	     (FUNCALL FCTN (+ 3000 3XXX-SLOCN1)
	       (UPDATE-VALUE `(TRAM.STATE ,3XXX-SLOCN2
			       TRAM.SOURCE.CYCLE 1
			       TRAM.A.CLOCK.NEXT 1 TRAM.M.CLOCK.NEXT 1 ;REALLY LAST S.C.
			       TRAM.A.address.from.dispatch 0
			       TRAM.AM.FROM.WRITE.ADDRESS 0
			       TRAM.A.WE-L 1 TRAM.M.WE-L 1
			       TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
			       TRAM.NEXT.SELECT 1)))
	     (SETQ SADR (+ 3000 3XXX-SLOCN2)) ;CAUSE NORMAL THING TO GET STORED STARTING HERE.
	     )))
    (COND ((OR (AND (NULL EXECUTE-CYCLE-DOUBLED-IN-TRAM)
		    (ZEROP SLOW-DEST)
		    (ZEROP ILONG)
		    (NULL (MEMQ OPCODE SLOW-OPCODE-LIST)))
	       (NOT (ZEROP UNUSED))  ;DONT WASTE TRAM LOCNS IN THESE UNUSED CASES.
	       (= DEST-SEQ 7))
	   (FUNCALL FCTN SADR INST))
	  (T
	   (LET* ((3XXX-LOCN1 (ALLOCATE-3XXX-LOCN INST))
		  (DP-TO-MFO (IF (ZEROP NO-OP) 1 MFO-ON-NOOP))
		  (M-ADR (LDB TRAM.M.ADDRESS.CONTROL INST))
		  (A-ADR (LDB TRAM.A.ADDRESS.CONTROL INST))
		  (INST2 (UPDATE-VALUE `(TRAM.STATE ,3XXX-LOCN1
			       TRAM.SLOW.DEST.WRITE ,SLOW-DEST
			       TRAM.DATA.PATHS.TO.MFO ,DP-TO-MFO
			       TRAM.NEXT.SELECT 1
			       TRAM.M.WE-L 1 TRAM.A.WE-L 1 
			       TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
			       TRAM.M.ADDRESS.CONTROL ,M-ADR
			       TRAM.A.ADDRESS.CONTROL ,A-ADR) 0)))
	     (COND ((AND (NULL EXECUTE-CYCLE-TRIPLED-IN-TRAM)
			 (NOT (AND (NOT (ZEROP SLOW-DEST))  ;dispatch slow-dest is GC-TEST
				   (= OPCODE 3)))  ;always triple to allow maps to set up
			 (NOT (AND (NOT (ZEROP ILONG))  ;if execute cycle doubled, ILONG 
				   EXECUTE-CYCLE-DOUBLED-IN-TRAM)) ;triples it.
			 (NULL (MEMQ OPCODE SLOW-OPCODE-LIST))
			 (not (and (= 1 slow-dest) space-slow-dest)))
		    (FUNCALL FCTN SADR INST2))
		   (T
		    (LET* ((3XXX-LOCN2 (ALLOCATE-3XXX-LOCN INST2))
			   (M-ADR (LDB TRAM.M.ADDRESS.CONTROL INST2))
			   (A-ADR (LDB TRAM.A.ADDRESS.CONTROL INST2)))
		      (FUNCALL FCTN SADR
		       (UPDATE-VALUE `(TRAM.STATE ,3XXX-LOCN2
			       TRAM.SLOW.DEST.WRITE ,(if space-slow-dest
							 0
							 SLOW-DEST)
			       TRAM.DATA.PATHS.TO.MFO ,DP-TO-MFO
			       TRAM.NEXT.SELECT 1
			       TRAM.M.WE-L 1 TRAM.A.WE-L 1 
			       TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
			       TRAM.M.ADDRESS.CONTROL ,M-ADR
			       TRAM.A.ADDRESS.CONTROL ,A-ADR) 0))))))))))

  ;FETCH CODEWORD, for bottom half, usual case
  ; NOTE: there is also a source.cycle codeword in 1004
  ;a-source-clock and m-source-clock only matter if source cycles are doubled or tripled.
  ;default, if not specified, is to clock on last source cycle.
  (cond ((null a-source-clock)
	 (setq a-source-clock (if (null source-cycle-tripled-in-tram) 2 3))))
  (cond ((null m-source-clock)
	 (setq m-source-clock (if (null source-cycle-tripled-in-tram) 2 3))))
	       
  (FUNCALL SINGLE-FCTN  3000
     (SETQ TRAM-LOCATION-3000
	(COND ((NULL SOURCE-CYCLE-DOUBLED-IN-TRAM)
	       (UPDATE-VALUE '(TRAM.SOURCE.CYCLE 1		;last sc
				   TRAM.A.CLOCK.NEXT 1 TRAM.M.CLOCK.NEXT 1
				   TRAM.A.address.from.dispatch 0
				   TRAM.AM.FROM.WRITE.ADDRESS 0
				   TRAM.A.WE-L 1 TRAM.M.WE-L 1
				   TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
				   TRAM.NEXT.SELECT 0)))
	      ((NULL SOURCE-CYCLE-TRIPLED-IN-TRAM)
	       (UPDATE-VALUE `(TRAM.SOURCE.CYCLE 1		;double source cycle. not last
				   TRAM.A.CLOCK.NEXT ,(tram-select-clock 1 a-source-clock)
				   TRAM.M.CLOCK.NEXT ,(tram-select-clock 1 m-source-clock)
				   TRAM.A.address.from.dispatch 0
				   TRAM.AM.FROM.WRITE.ADDRESS 0
				   TRAM.A.WE-L 1 TRAM.M.WE-L 1
				   TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
				   TRAM.NEXT.SELECT 1
				   TRAM.STATE 4)))
	      (T
	       (UPDATE-VALUE `(TRAM.SOURCE.CYCLE 1		;triple source cycle. not last
				   TRAM.A.CLOCK.NEXT ,(tram-select-clock 1 a-source-clock)
				   TRAM.M.CLOCK.NEXT ,(tram-select-clock 1 m-source-clock)
				   TRAM.A.address.from.dispatch 0
				   TRAM.AM.FROM.WRITE.ADDRESS 0
				   TRAM.A.WE-L 1 TRAM.M.WE-L 1
				   TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
				   TRAM.NEXT.SELECT 1
				   TRAM.STATE 5))))))
  ;FETCH CODEWORD, FOR TOP HALF, HALT REQUEST. This is the one location in which the halves 
  ; differ.
  (FUNCALL SINGLE-FCTN 7000
	   (UPDATE-VALUE '(TRAM.SOURCE.CYCLE 1		;not last
				   TRAM.A.CLOCK.NEXT 0 TRAM.M.CLOCK.NEXT 0
				   TRAM.A.address.from.dispatch 0
				   TRAM.AM.FROM.WRITE.ADDRESS 0
				   TRAM.A.WE-L 1 TRAM.M.WE-L 1
				   TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
				   TRAM.NEXT.SELECT 1
				   TRAM.STATE 0)))  ;loop right here.
			   
  ;WRITE-M AND EXIT
  (FUNCALL FCTN
	   (IF (NULL SPACE-PDL-AND-M-WRITE) 3001 3006)
	   (UPDATE-VALUE '(TRAM.NEW.UINST 1
					  TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
					  TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 3
					  TRAM.AM.FROM.WRITE.ADDRESS 1
					  TRAM.L.TO.M-L 0 TRAM.L.to.A-L 0
					  TRAM.A.WE-L 0 TRAM.A.address.from.dispatch 0)))
  (IF SPACE-PDL-AND-M-WRITE
      (FUNCALL FCTN
	       3001
	       (UPDATE-VALUE '(TRAM.NEW.UINST 0
			       TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
			       TRAM.STATE 6
			       TRAM.M.WE-L 1 TRAM.M.ADDRESS.CONTROL 3
			       TRAM.AM.FROM.WRITE.ADDRESS 1
			       TRAM.L.TO.M-L 0 TRAM.L.to.A-L 0
			       TRAM.A.WE-L 1 TRAM.A.address.from.dispatch 0))))

  (let ((real-last-dispatch-address (if (not (= dispatch-length 1)) (incf 3xxx-locn) 2)))
    (if (not (= dispatch-length 1))
	(funcall fctn 3002 (UPDATE-VALUE `(TRAM.STATE ,real-last-dispatch-address
					   TRAM.DATA.PATHS.TO.MFO 1
					   TRAM.NEXT.SELECT 1
					   TRAM.M.WE-L 1 TRAM.A.WE-L 1 
					   TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
					   tram.a.address.from.dispatch 1
					   tram.am.from.write.address 0
					   TRAM.M.ADDRESS.CONTROL 1
					   ) 0)))
    (funcall fctn (+ 3000 real-last-dispatch-address)
		      (UPDATE-VALUE `(tram.a.clock.next
				       ,(if (and source-cycle-doubled-in-tram
						 (>= a-source-clock 2))
					    1 0)
	;unfortunately, we can only check parity on dispatch if source cycle is doubled,
	; since otherwise A.clock will not have a chance to go down before it has to 
	; go up again.
				      TRAM.NEW.UINST 1
				      TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
				      TRAM.M.WE-L 1 TRAM.A.WE-L 1
				      TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
   ;hold A latch to avoid testing parity on randomness (ie not enuf time)?
				      TRAM.A.address.from.dispatch 1
				    ;DISPATCH BASE FROM A.SOURCE
				      TRAM.AM.FROM.WRITE.ADDRESS 0
				    ;avoid open M.ADDRESS lines.
				      tram.m.address.control 1
				      tram.state 0
				   ))))
 ;  ;FINISH DISPATCH AND EXIT
 ;  (FUNCALL FCTN 3002 (UPDATE-VALUE '(TRAM.NEW.UINST 1
 ;				   TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
 ;				   TRAM.M.WE-L 1 TRAM.A.WE-L 1
 ;				   TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
 ;   ;hold A latch to avoid testing parity on randomness (ie not enuf time)?
 ;				   TRAM.A.address.from.dispatch 1
 ;				   TRAM.AM.FROM.WRITE.ADDRESS 0  ;DISPATCH BASE FROM A.SOURCE
 ;				   tram.m.address.control 1  ;avoid open M.ADDRESS lines.
 ;				   )))

  ;WRITE-M, THEN DISPATCH AND EXIT.
  (FUNCALL FCTN 3003 (UPDATE-VALUE '(TRAM.DATA.PATHS.TO.MFO 1 TRAM.NEXT.SELECT 1
				   TRAM.M.WE-L 0 TRAM.M.ADDRESS.CONTROL 3
				   TRAM.AM.FROM.WRITE.ADDRESS 1
				   TRAM.L.TO.M-L 0 TRAM.L.to.A-L 0
				   TRAM.A.WE-L 0 TRAM.A.address.from.dispatch 0
				   TRAM.STATE 2)))
  (IF SOURCE-CYCLE-DOUBLED-IN-TRAM	;store second source cycle in source-doubled mode
   ;this is the last one executed in double and triple mode.
      (FUNCALL FCTN 3004 (UPDATE-VALUE `(TRAM.SOURCE.CYCLE 1	;last sc
				   TRAM.A.CLOCK.NEXT ,(tram-select-clock
							(if source-cycle-tripled-in-tram
							    3 2)
							a-source-clock)
				   TRAM.M.CLOCK.NEXT ,(tram-select-clock
							(if source-cycle-tripled-in-tram
							    3 2)
							m-source-clock)
				   TRAM.A.address.from.dispatch 0
				   TRAM.AM.FROM.WRITE.ADDRESS 0
				   TRAM.A.WE-L 1 TRAM.M.WE-L 1
				   TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
				   TRAM.NEXT.SELECT 0))))
  (IF SOURCE-CYCLE-TRIPLED-IN-TRAM	;store third source cycle in source-tripled mode
      (FUNCALL FCTN 3005 (UPDATE-VALUE `(TRAM.SOURCE.CYCLE 1	;not last sc
				   TRAM.A.CLOCK.NEXT ,(tram-select-clock 2 a-source-clock) 
				   TRAM.M.CLOCK.NEXT ,(tram-select-clock 2 m-source-clock)
				   TRAM.A.address.from.dispatch 0
				   TRAM.AM.FROM.WRITE.ADDRESS 0
				   TRAM.A.WE-L 1 TRAM.M.WE-L 1
				   TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
				   TRAM.NEXT.SELECT 1
				   TRAM.STATE 4))))
  ;3006 USED ABOVE NEAR CODE FOR 3001.

  ;IF UNUSED-TRAM-LOCNS-LOOP IS TRUE, UNUSED TRAM LOCNS WILL BE FILLED IN WITH A TRANSFER
  ; TO 3007, WHICH THEN LOOPS.
  (FUNCALL FCTN 3007 (UPDATE-VALUE '(TRAM.M.ADDRESS.CONTROL 1
				      TRAM.NEXT.SELECT 1 TRAM.STATE 7)))
  (STORE-3XXX-DATA FCTN)
		    )))

(DEFUN hh-INIT-TRAM (&rest ignore)
  (ferror nil "use (init-tram)"))

;this is a fake source then execute cycle, just looping between 3000 and 3001
;generates uinst clocks
(defun quick-tram-loop ()
  (write-tram-high-and-low 3000
			   (UPDATE-VALUE '(
				      tram.first.source.cycle.next-L 0
							     TRAM.A.CLOCK 0
							     TRAM.A.address.from.dispatch 0
							     TRAM.AM.FROM.WRITE.ADDRESS 0
							     TRAM.A.WE-L 1 TRAM.M.WE-L 1
							     TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
							     TRAM.NEXT.SELECT 1
							     tram.state 1)))

  (write-tram-high-and-low 3001
			   (UPDATE-VALUE '(
				      tram.first.source.cycle.next-L 0
							     TRAM.NEW.UINST 1
							     TRAM.A.CLOCK 0
							     TRAM.A.address.from.dispatch 0
							     TRAM.AM.FROM.WRITE.ADDRESS 0
							     TRAM.A.WE-L 1 TRAM.M.WE-L 1
							     TRAM.L.TO.A-L 1 TRAM.L.TO.M-L 1
							     TRAM.NEXT.SELECT 1
							     tram.state 0)))
  (let ((pmr (read-pmr)))
    (CHANGE-PMR '(SPY-ADDRESS-TRAM-L 0 ALLOW-UINST-CLOCKS 0))

    (WRITE-TRAM-ADR 3000)
    (SM-TICK)
    (SM-TICK)
    (WRITE-PMR PMR))

  )
  

(defun tram-select-clock (this-source-cycle-number source-cycle-to-clock-on)
  (if (= this-source-cycle-number source-cycle-to-clock-on)
      1
    0))

(defun init-tram (&rest args)
  (cond ((< (send *proc* :major-version) 100.)
	 (apply #'new-init-tram args))
	(t
;	 (apply 'hh-init-tram args)
	 (apply 'new-hh-init-tram args)
	 )))
	  
(DEFUN READ-TRAM-AND-CHECK (ADR DATA)
  (LET ((TCONTENTS (READ-TRAM ADR))
	(DATA-WITH-PARITY (COMPUTE-PARITY-32 DATA)))
    (COND ((NOT (= DATA-WITH-PARITY TCONTENTS))
	   (FORMAT T "~%TRAM ADR ~S: SHOULD BE ~S, IS ~S" ADR DATA-WITH-PARITY TCONTENTS)))))

(defun search-tram-for-closest (data)
  (do ((adr 0 (1+ adr))
       (closest-adr)
       (closest-data)
       (closest-number-bits-different 32.)
       (ans))
      ((= adr 10000)
       (format t "~%~S bits different." closest-number-bits-different)
       (setq ans (factor-address-and-data closest-adr closest-data))
       (dolist (a ans)
	 (format t "~%At adrs ~s, data is ~s, differs in bits " (car a) (cdr a))
	 (print-bits (logxor data (cdr a))))
       closest-data)
    (let* ((tram-data (read-tram adr))
	   (bits-different (count-bits-up-to (logxor tram-data data)
					     closest-number-bits-different)))
      (cond ((< bits-different closest-number-bits-different)
	     (setq closest-adr (list adr)
		   closest-data (list tram-data)
		   closest-number-bits-different bits-different))
	    ((= bits-different closest-number-bits-different)
	     (push adr closest-adr)
	     (push tram-data closest-data))))))

(defun factor-address-and-data (adr-list data-list)
  (prog (this-adr this-data p)
	(cond ((null data-list) (return nil)))
	(setq this-adr (list (car adr-list))
	      this-data (car data-list)
	      adr-list (cdr adr-list)
	      data-list (cdr data-list))
    l	(cond ((null (member this-data data-list))
	       (return (cons (cons this-adr this-data)
			     (factor-address-and-data adr-list data-list))))
	      (t
	       (setq p (si:find-position-in-list-equal this-data data-list))
	       (setq this-adr
		     (cons (car (nthcdr p adr-list))
			   this-adr))
	       (cond ((zerop p)
		      (setq adr-list (cdr adr-list)
			    data-list (cdr data-list)))
		     (t		      
		      (rplacd (nthcdr (1- p) adr-list)
			      (nthcdr (1+ p) adr-list))
		      (rplacd (nthcdr (1- p) data-list)
			      (nthcdr (1+ p) data-list))))
	       (go l)))))

(defun count-bits-up-to (data up-to)
  (do ((d data (ash d -1))
       (c 0))
      ((or (zerop d)
	   (> c up-to))
       c)
    (cond ((not (zerop (logand d 1)))
	   (setq c (1+ c))))))

(DEFVAR 3XXX-ALIST NIL)
(DEFVAR 3XXX-LOCN NIL)

(DEFUN SETUP-3XXX-DATA ()
  (SETQ 3XXX-ALIST NIL 3XXX-LOCN 7))

(DEFUN GET-3XXX-LOCN ()
  (COND ((>= 3XXX-LOCN 377)
	 (FERROR NIL "RAN OUT OF 3XXX LOCNS"))
	(T (SETQ 3XXX-LOCN (1+ 3XXX-LOCN)))))

(DEFUN ALLOCATE-3XXX-LOCN (INST &AUX TEM)
  (COND ((SETQ TEM (ASSOC INST 3XXX-ALIST))
	 (CDR TEM))
	(T
	 (SETQ 3XXX-ALIST (CONS (CONS INST (GET-3XXX-LOCN))
				3XXX-ALIST))
	 3XXX-LOCN)))

(DEFUN STORE-3XXX-DATA (FCTN)
  (DOLIST (L 3XXX-ALIST)
    (FUNCALL FCTN (+ 3000 (CDR L)) (CAR L))))

(defun uinst-simple-jump-loop (&optional (adr 0))
  (disable-lambda)
  (uload (adr)
    adr
	 (lam-ir-op lam-op-jump
	  lam-ir-jump-addr adr
	  lam-ir-jump-cond lam-jump-cond-unc
	  lam-ir-n 1)
	 (lam-ir-op lam-op-alu)
	 (lam-ir-op lam-op-alu
	  lam-ir-halt 0)
	 (lam-ir-op lam-op-alu
	  lam-ir-halt 1)
	 (lam-ir-op lam-op-alu
	  lam-ir-halt 1)
	 (lam-ir-op lam-op-alu
	  lam-ir-halt 1)
	 )
  (setup-machine-to-start-at adr))

(defun check-simple-jump ()
  (do-forever
    (sm-tick)
    (if (not (= (ldb lam-ir-op (read-ireg)) lam-op-jump))
	(ferror nil "foo"))
    (sm-tick)
    (if (not (= (ldb lam-ir-op (read-ireg)) lam-op-jump))
	(ferror nil "foo"))
    (sm-tick)
    (if (not (= (ldb lam-ir-op (read-ireg)) lam-op-alu))
	(ferror nil "foo"))
    (sm-tick)
    (if (not (= (ldb lam-ir-op (read-ireg)) lam-op-alu))
	(ferror nil "foo"))
    (tyo #/.)
    ))

(defun uinst-just-noop ()
  (disable-lambda)
  (uload ()
    0
	 (lam-ir-op lam-op-alu)
	 (lam-ir-op lam-op-alu)
	 (lam-ir-op lam-op-alu)
	 (lam-ir-op lam-op-alu)
	 )
  (setup-machine-to-start-at 0))


(DEFUN UINST-JUMP-LOOP  (&OPTIONAL (ONE-LOC 1000) (OTHER-LOC 100))
  (DISABLE-LAMBDA)
  (ULOAD (ONE-LOC OTHER-LOC)
    0	      (LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR 0
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
    ONE-LOC   (LAM-IR-OP LAM-OP-ALU
	       LAM-IR-CARRY 1)
	      (LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR OTHER-LOC
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
	      (0)
   OTHER-LOC  (LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR ONE-LOC
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)	
   	      (LAM-IR-STAT-BIT 1))
  (SETUP-MACHINE-TO-START-AT ONE-LOC))

(DEFUN UINST-CALL-RETURN-LOOP  (&OPTIONAL (ONE-LOC 1000) (OTHER-LOC 100))
  (DISABLE-LAMBDA)
  (ULOAD (ONE-LOC OTHER-LOC)
    0	      (LAM-IR-OP LAM-OP-JUMP
	       LAM-IR-JUMP-ADDR 0
	       LAM-IR-N 1
	       lam-ir-stat-bit 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
    ONE-LOC   (lam-ir-op lam-op-alu		;8
	       lam-ir-stat-bit 1)
	      (LAM-IR-OP LAM-OP-JUMP		;9
	       LAM-IR-JUMP-ADDR OTHER-LOC
	       LAM-IR-P 1
	       LAM-IR-N 1
	       lam-ir-stat-bit 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
	      (LAM-IR-OP LAM-OP-JUMP		;a
	       LAM-IR-JUMP-ADDR ONE-LOC
	       LAM-IR-N 1
	       lam-ir-stat-bit 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
	      (lam-ir-stat-bit 1)		;b

   OTHER-LOC  (LAM-IR-OP LAM-OP-JUMP		;20
	       LAM-IR-R 1
	       LAM-IR-N 1
	       lam-ir-stat-bit 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)	
   	      (LAM-IR-STAT-BIT 1))		;21
  (SETUP-MACHINE-TO-START-AT ONE-LOC))

;8 9 a 20 21 a b

(defun uinst-simple-call-loop ()
  (flush)
  (uload ()
	 0
	 (lam-ir-op lam-op-jump
	  lam-ir-jump-addr 0
	  lam-ir-n 1
	  lam-ir-jump-cond lam-jump-cond-unc
	  lam-ir-p 1)
	 (lam-ir-op lam-op-alu)
	 (lam-ir-op lam-op-alu)
	 (lam-ir-op lam-op-alu)
	 )
  (setup-machine-to-start-at 0))

(defun call-return-loop-loop ()
  (flush)
  ; x200 x201 x40 x41 x201 x202
  (uinst-call-return-loop 1000 100)
  (do-forever
    (force-uinst-clock-low)
    (force-source-codeword)
    (dotimes (i 5)
      (write-ireg (dpb 1 lam-ir-stat-bit 0))
      (sm-tick))
    (force-source-codeword)
    (setup-machine-to-start-at 1000)
    (sm-tick)
    (sm-tick)
    (format t "~&arm analyzer ...")
    (tyi)
    (format t " running ...")
    (enable-lambda)
    (tyi)
;    (process-sleep 60.)
    (disable-lambda)
    (format t " stopped at pc ~o #x~:*~x" (read-pc)
	    )))

(DEFUN UINST-M-COUNT-LOOP (&OPTIONAL (M-MEM-LOCN 1))
  (DISABLE-LAMBDA)
  (WIPE-M-MEM)
  (ULOAD (M-MEM-LOCN)
    4
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-MEM-DEST M-MEM-LOCN
	LAM-IR-ALUF LAM-ALU-SETZ)
   LOC (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC M-MEM-LOCN
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-MEM-DEST M-MEM-LOCN
	LAM-IR-ALUF LAM-ALU-M+1
	LAM-IR-CARRY 1)
       (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR LOC
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
       (LAM-IR-STAT-BIT 1)  ;FOR SCOPE TRIGGER
   0   (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR 0
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))
  (SETUP-MACHINE-TO-START-AT 4))

(DEFUN UINST-simple-M-COUNT-LOOP (&OPTIONAL (M-MEM-LOCN 1))
  (DISABLE-LAMBDA)
  (ULOAD (M-MEM-LOCN)
    0
       (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR 0
	LAM-IR-N 0
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)

       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC M-MEM-LOCN
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-MEM-DEST M-MEM-LOCN
	LAM-IR-ALUF LAM-ALU-M+1
	LAM-IR-CARRY 1)
       )
  (SETUP-MACHINE-TO-START-AT 0))

(DEFUN UINST-simple-read-m-LOOP (&OPTIONAL (M-MEM-LOCN 1))
  (DISABLE-LAMBDA)
  (ULOAD (M-MEM-LOCN)
    0
       (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR 0
	LAM-IR-N 0
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)

       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC M-MEM-LOCN
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-ALUF LAM-alu-setm
	)
       )
  (SETUP-MACHINE-TO-START-AT 0))

(DEFUN UINST-simple-m-constant (&OPTIONAL (M-MEM-LOCN 1) (data 123))
  (DISABLE-LAMBDA)
  (flush)
  (hh-write-m-mem 1 100)
  (if (not (= (hh-read-m-mem 1) 100))
      (format t "can't write m mem"))
  (write-spy-reg data)
  (ULOAD (M-MEM-LOCN)
    0
       (lam-ir-op lam-op-alu)
       (lam-ir-op lam-op-alu)
       (lam-ir-op lam-op-jump
	lam-ir-jump-cond lam-jump-cond-unc
	lam-ir-jump-addr 2
	lam-ir-n 0)
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-MEM-DEST M-MEM-LOCN
	LAM-IR-ALUF LAM-ALU-setm
	lam-ir-m-src lam-m-src-spy-reg
	)
       (lam-ir-op lam-op-alu)
       (lam-ir-op lam-op-alu)
       (lam-ir-op lam-op-alu)
       (lam-ir-op lam-op-alu)
       )
  (SETUP-MACHINE-TO-START-AT 0))

(DEFUN UINST-M-LH-COUNT-LOOP (&OPTIONAL (M-MEM-LOCN 1))
  (DISABLE-LAMBDA)
  (WIPE-M-MEM)
  (WRITE-M-MEM 2 2000)
  (ULOAD (M-MEM-LOCN)
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-MEM-DEST M-MEM-LOCN
	LAM-IR-ALUF LAM-ALU-SETZ)
   LOC (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC M-MEM-LOCN
	LAM-IR-A-SRC 2
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-MEM-DEST M-MEM-LOCN
	LAM-IR-ALUF LAM-ALU-ADD
	LAM-IR-CARRY 0)
       (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR LOC
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
       (LAM-IR-STAT-BIT 1)  ;FOR SCOPE TRIGGER
   0   (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR 0
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))
  (SETUP-MACHINE-TO-START-AT 100))

(DEFUN UINST-MD-COUNT-LOOP ()
  (DISABLE-LAMBDA)				
  (ULOAD (M-MEM-LOCN)
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-FUNC-DEST LAM-FUNC-DEST-MD
	LAM-IR-ALUF LAM-ALU-SETZ)
   LOC (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC LAM-M-SRC-MD
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-FUNC-DEST LAM-FUNC-DEST-MD
	LAM-IR-ALUF LAM-ALU-M+1
	LAM-IR-CARRY 1
	LAM-IR-SLOW-DEST 1)
       (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR LOC
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
       (LAM-IR-STAT-BIT 1)  ;FOR SCOPE TRIGGER
   0   (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR 0
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))
  (SETUP-MACHINE-TO-START-AT 100))

(DEFUN UINST-VMA-COUNT-LOOP ()
  (DISABLE-LAMBDA)				
  (ULOAD (M-MEM-LOCN)
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA
	LAM-IR-ALUF LAM-ALU-SETZ)
   LOC (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC LAM-M-SRC-VMA
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA
	LAM-IR-ALUF LAM-ALU-M+1
	LAM-IR-CARRY 1)
       (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR LOC
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
       (LAM-IR-STAT-BIT 1)  ;FOR SCOPE TRIGGER
   0   (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR 0
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))
  (SETUP-MACHINE-TO-START-AT 100))

(DEFUN UINST-PP-COUNT-LOOP ()
  (DISABLE-LAMBDA)
  (ULOAD ()
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-FUNC-DEST LAM-FUNC-DEST-PP
	LAM-IR-ALUF LAM-ALU-SETZ)
   LOC (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC LAM-M-SRC-PP
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-FUNC-DEST LAM-FUNC-DEST-PP
	LAM-IR-ALUF LAM-ALU-M+1
	LAM-IR-CARRY 1)
       (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR LOC
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
       (LAM-IR-STAT-BIT 1)  ;FOR SCOPE TRIGGER
   0   (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR 0
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))
  (SETUP-MACHINE-TO-START-AT 100))

(DEFUN UINST-PI-COUNT-LOOP ()
  (DISABLE-LAMBDA)
  (ULOAD ()
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-FUNC-DEST LAM-FUNC-DEST-PI
	LAM-IR-ALUF LAM-ALU-SETZ)
   LOC (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC LAM-M-SRC-PI
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-FUNC-DEST LAM-FUNC-DEST-PI
	LAM-IR-ALUF LAM-ALU-M+1
	LAM-IR-CARRY 1)
       (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR LOC
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
       (LAM-IR-STAT-BIT 1)  ;FOR SCOPE TRIGGER
   0   (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR 0
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))
  (SETUP-MACHINE-TO-START-AT 100))


(DEFUN UINST-A-COUNT-LOOP (&OPTIONAL (A-MEM-LOCN 1000) (M-MEM-LOCN 1))
  (DISABLE-LAMBDA)
  (ULOAD (A-MEM-LOCN M-MEM-LOCN)
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-MEM-DEST M-MEM-LOCN
	LAM-IR-ALUF LAM-ALU-SETZ)
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC M-MEM-LOCN
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-MEM-DEST M-MEM-LOCN
	LAM-IR-ALUF LAM-ALU-M+1
	LAM-IR-CARRY 1)
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-A-MEM-DEST-FLAG 1
	LAM-IR-A-MEM-DEST A-MEM-LOCN
	LAM-IR-ALUF LAM-ALU-SETZ)
   LOC (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-SRC M-MEM-LOCN
	LAM-IR-A-SRC A-MEM-LOCN
	LAM-IR-A-MEM-DEST-FLAG 1
	LAM-IR-A-MEM-DEST A-MEM-LOCN
	LAM-IR-ALUF LAM-ALU-ADD)
       (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR LOC
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
       (LAM-IR-STAT-BIT 1)  ;FOR SCOPE TRIGGER
   0   (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR 0
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))
  (SETUP-MACHINE-TO-START-AT 100))


(DEFUN UINST-Q-TEST-LOOP ()
  (DISABLE-LAMBDA)
  (ULOAD ()
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-MEM-DEST 1
	LAM-IR-ALUF LAM-ALU-SETZ)
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC 1
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-MEM-DEST 1
	LAM-IR-ALUF LAM-ALU-M+1
	LAM-IR-CARRY 1		;construct constant 1 in 1@m
	LAM-IR-Q LAM-Q-LOAD)
   LOC (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC LAM-M-SRC-Q
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-MEM-DEST 1
	LAM-IR-ALUF LAM-ALU-SETM
	LAM-IR-Q LAM-Q-LEFT)		;shift q
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC LAM-M-SRC-Q
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-ALUF LAM-ALU-SETM)	;bit shift across should be visible here.
       (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR LOC
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
       (LAM-IR-STAT-BIT 1)  ;FOR SCOPE TRIGGER
   0   (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR 0
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))
  (SETUP-MACHINE-TO-START-AT 100))

(DEFUN UINST-SETZ-LOOP ()
  (DISABLE-LAMBDA)
  (ULOAD ()
   LOC (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC 1
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-MEM-DEST 1
	LAM-IR-ALUF LAM-ALU-SETO)
       (LAM-IR-OP LAM-OP-ALU
	LAM-IR-M-SRC 2
	LAM-IR-OB LAM-OB-ALU
	LAM-IR-M-MEM-DEST 2
	LAM-IR-ALUF LAM-ALU-SETZ)
       (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR LOC
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
       (LAM-IR-STAT-BIT 1)  ;FOR SCOPE TRIGGER
    0  (LAM-IR-OP LAM-OP-JUMP
	LAM-IR-JUMP-ADDR 0
	LAM-IR-N 1
	LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))
  (SETUP-MACHINE-TO-START-AT 100)
  )

(DEFUN UINST-ONES-LOOP (&OPTIONAL (A-MEM-LOC 37) (JUMP-DEST 7777))
  (DISABLE-LAMBDA)
  (WIPE-M-MEM)
  (WRITE-MD -1)
  (WRITE-A-MEM A-MEM-LOC -1)
  (ULOAD (A-MEM-LOC JUMP-DEST)
	 0	      (LAM-IR-OP LAM-OP-JUMP
		       LAM-IR-JUMP-ADDR 0
		       LAM-IR-N 1
		       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
	 LOOP	      (LAM-IR-OP LAM-OP-ALU
		       lam-ir-ob lam-ob-alu
		       lam-ir-aluf lam-alu-seto
		       LAM-IR-STAT-BIT 1)
		      (LAM-IR-OP LAM-OP-JUMP
		       LAM-IR-JUMP-ADDR jump-dest
		       lam-ir-m-src LAM-M-SRC-MD
		       lam-ir-a-src A-MEM-LOC
		       LAM-IR-N 1
		       LAM-IR-JUMP-COND lam-jump-cond-m=a)
		      (LAM-IR-OP LAM-OP-ALU)
		      (lam-ir-op lam-op-alu  		;lost if this path taken
		       lam-ir-ob lam-ob-alu
		       lam-ir-aluf lam-alu-m+1
		       lam-ir-carry 1
		       lam-ir-m-src 1
		       lam-ir-m-mem-dest 1 )
		      (LAM-IR-OP LAM-OP-JUMP
		       LAM-IR-JUMP-ADDR LOOP
		       LAM-IR-N 1
		       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
		      (LAM-IR-OP 0)
	   jump-dest  (LAM-IR-OP LAM-OP-JUMP		;won if this path taken
		       LAM-IR-JUMP-ADDR LOOP
		       LAM-IR-N 0
		       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)	
		      (lam-ir-op lam-op-alu
		       lam-ir-ob lam-ob-alu
		       lam-ir-aluf lam-alu-m+1
		       lam-ir-carry 1
		       lam-ir-m-src 2
		       lam-ir-m-mem-dest 2))
  (SETUP-MACHINE-TO-START-AT 1)
  )

(DEFUN SETUP-MACHINE-TO-START-AT (N)
  (ASSURE-NOOP-CLEARED)
  (WRITE-PC N)
  NIL)	;note: many uinst- functions rely on this to return nil, 
	; which is arglist for sm-step-loop.

(DEFUN READ-M-MEM (ADR)
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-M-SRC ADR
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-MFO))


(DEFUN WRITE-M-MEM (ADR NUM)		
  (WRITE-SPY-REG-AND-CHECK NUM)
  (LAM-EXECUTE (WRITE)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-ALUF LAM-ALU-SETM
	       LAM-IR-M-MEM-DEST ADR))

(DEFUN WRITE-M-MEM-STEPPING (ADR NUM)		
  (WRITE-SPY-REG-AND-CHECK NUM)
  (LAM-EXECUTE (EXECUTOR LAM-EXECUTE-NOCLOCKS)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-ALUF LAM-ALU-SETM
	       LAM-IR-M-MEM-DEST ADR)
  (SM-STEP-LOOP ':ZERO-IREG-AFTER-UINST-CLOCK T))

(COMMENT
(DEFUN WRITE-M-MEM (ADR NUM)
  (WRITE-M-MEM-SHIFTING ADR NUM)))

(DEFUN WRITE-M-MEM-SHIFTING (ADR NUM)
  (SETQ NUM (\ NUM (1+ 37777777777)))  ;MAKE SURE ONLY 32 BITS
  (COND ((ZEROP (LDB 3701 NUM))
	 (LAM-EXECUTE (WRITE)			;if the high bit is 0, then set the m-mem
						;location to 0
		     LAM-IR-OB LAM-OB-ALU
		     LAM-IR-ALUF LAM-ALU-SETZ
		     LAM-IR-M-MEM-DEST ADR))
	(T
	  (LAM-EXECUTE (WRITE)			;otherwise, set it to all ones
		      LAM-IR-OB LAM-OB-ALU
		      LAM-IR-ALUF LAM-ALU-SETO
		      LAM-IR-M-MEM-DEST ADR)))
  (COND ((ZEROP NUM))				;already there: no need to shift,though watch
	((= NUM 37777777777))			;out for this if you are writing scope loops
	((DO ((I 30. (1- I)))			;SHIFT IN REMAINING 31 BITS
	     ((MINUSP I))
	   (COND ((ZEROP (LDB (BYTE 1 I) NUM))
		  (LAM-EXECUTE (WRITE)			;if bit is zero, then set location to
			      LAM-IR-OB LAM-OB-ALU	;old value plus itself
			      LAM-IR-ALUF LAM-ALU-M+M
			      LAM-IR-M-SRC ADR
			      LAM-IR-M-MEM-DEST ADR))
		 (T
		   (LAM-EXECUTE (WRITE)			;if bit is one, then set location to
			       LAM-IR-OB LAM-OB-ALU	;old value plus itself plus 1
			       LAM-IR-ALUF LAM-ALU-M+M+1
			       LAM-IR-M-SRC ADR
			       LAM-IR-M-MEM-DEST ADR))))))
  )

(DEFUN WIPE-M-MEM (&OPTIONAL (DATA 0))
  (DO ((ADR 1 (1+ ADR)))
      ((= ADR 100))
    (WRITE-M-MEM ADR DATA)))

(DEFUN CHECK-M-MEM-BACKGROUND (&OPTIONAL (BACKGROUND-DATA 0) KNOWN-CLOBBERED-LOCS)
  (DO ((ADR 1 (1+ ADR))
       M-SIDE A-SIDE)
      ((= ADR 100))
    (SETQ M-SIDE (READ-M-MEM ADR) A-SIDE (READ-A-MEM ADR))
    (COND ((NOT (= A-SIDE M-SIDE))
	   (FORMAT T "~%LOC ~S, M-SIDE ~S A-SIDE ~S" ADR M-SIDE A-SIDE))
	  ((NOT (MEMQ ADR KNOWN-CLOBBERED-LOCS))
	   (COND ((NOT (= M-SIDE BACKGROUND-DATA))
		  (FORMAT T "~%loc ~s is now ~s" ADR M-SIDE)))))))
	   
(defun all-there-test-m-mem (&optional (dir 'up))
  (assure-noop-cleared)
  (do ((adr 1 (1+ adr)))
      ((= adr 77))
    (write-m-mem adr 0))
  (cond ((eq dir 'up)
	 (do ((adr 1 (1+ adr)))
	     ((= adr 100))
	   (write-m-mem adr adr)
	   (let ((tem (read-m-mem adr)))
	     (cond ((not (= adr tem))
		    (format t "~% adr ~s failed to write properly, now reads as ~s"
			    adr tem)))))
	 (do ((adr 1 (1+ adr)))
	     ((= adr 100))
	   (let ((tem (read-m-mem adr)))
	     (cond ((not (= adr tem))
		    (format t "~%adr ~s read as ~s" adr tem))))))
	(t
	 (do ((adr 77 (1- adr)))
	     ((= adr 0))
	   (write-m-mem adr adr)
	   (let ((tem (read-m-mem adr)))
	     (cond ((not (= adr tem))
		    (format t "~% adr ~s failed to write properly, now reads as ~s"
			    adr tem)))))
	 (do ((adr 77 (1- adr)))
	     ((= adr 0))
	   (let ((tem (read-m-mem adr)))
	     (cond ((not (= adr tem))
		    (format t "~%adr ~s read as ~s" adr tem))))))))

(defun all-there-test-A-mem (&optional (dir 'up))
  (assure-noop-cleared)
  (do ((adr 1 (1+ adr)))
      ((= adr 77))
    (write-A-mem adr 0))
  (cond ((eq dir 'up)
	 (do ((adr 1 (1+ adr)))
	     ((= adr 100))
	   (write-A-mem adr adr)
	   (let ((tem (read-A-mem adr)))
	     (cond ((not (= adr tem))
		    (format t "~% adr ~s failed to write properly, now reads as ~s"
			    adr tem)))))
	 (do ((adr 1 (1+ adr)))
	     ((= adr 100))
	   (let ((tem (read-A-mem adr)))
	     (cond ((not (= adr tem))
		    (format t "~%adr ~s read as ~s" adr tem))))))
	(t
	 (do ((adr 77 (1- adr)))
	     ((= adr 0))
	   (write-A-mem adr adr)
	   (let ((tem (read-A-mem adr)))
	     (cond ((not (= adr tem))
		    (format t "~% adr ~s failed to write properly, now reads as ~s"
			    adr tem)))))
	 (do ((adr 77 (1- adr)))
	     ((= adr 0))
	   (let ((tem (read-A-mem adr)))
	     (cond ((not (= adr tem))
		    (format t "~%adr ~s read as ~s" adr tem))))))))



(DEFUN READ-Q-REG ()
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-M-SRC LAM-M-SRC-Q
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-MFO))

(DEFUN WRITE-Q-REG (NUM)
  (WRITE-SPY-REG-AND-CHECK NUM)
  (LAM-EXECUTE (WRITE)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-ALUF LAM-ALU-SETM
	       LAM-IR-Q LAM-Q-LOAD))

(DEFUN source-Q-REG ()
  (LAM-EXECUTE (source)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-M-SRC LAM-M-SRC-Q
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-MFO))



(DEFUN spy-reg-via-masker ()
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-BYTE
	       LAM-IR-M-SRC  LAM-M-SRC-SPY-REG
	       LAM-IR-OB LAM-OB-MSK
	       LAM-IR-BYTE-FUNC LAM-BYTE-FUNC-SELECTIVE-DEPOSIT	;masked bits of m replace a
	       LAM-IR-BYTL-1 31.
	       LAM-IR-MROT 0)
  (READ-MFO))

(defun write-q-reg-via-a-mem (data)
  (write-a-mem 1 data)
  (lam-execute (write)
	       lam-ir-op lam-op-alu
	       lam-ir-a-src 1
	       lam-ir-aluf lam-alu-seta
	       lam-ir-q lam-q-load))

(DEFUN a-source-via-masker (byte-field bit-over)
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-BYTE
	       lam-ir-m-src 2
	       LAM-IR-A-SRC 1
	       LAM-IR-OB LAM-OB-MSK
	       LAM-IR-BYTE-FUNC LAM-BYTE-FUNC-SELECTIVE-DEPOSIT	;masked bits of m replace a
	       LAM-IR-BYTL-1 byte-field
	       LAM-IR-MROT bit-over)
  (READ-MFO))

(defun a-mem-via-output-selector ()
  (let ((tem1 (a-source-via-masker 0 31.)) ; this takes bits 0 to 30.
	(tem2 (a-source-via-masker 1. 5.))) ; this to take bit 31.
    (logior (logand 17777777777 tem1) ; this will return bit 0 thru 31.
	    (logand 20000000000 tem2))))

(defun a-mem-to-set-a-source (data)
  (write-a-mem 1 data)
  (write-m-mem 2 0))


(DEFUN SHIFT-Q-REG-LEFT ()
  (LAM-EXECUTE (WRITE)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-ALUF LAM-ALU-SETM
	       LAM-IR-Q LAM-Q-LEFT))

(DEFUN SHIFT-Q-REG-RIGHT ()
  (LAM-EXECUTE (WRITE)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-ALUF LAM-ALU-SETM
	       LAM-IR-Q LAM-Q-RIGHT))

(DEFUN READ-A-MEM (ADR)
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-A-SRC ADR
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-ALUF LAM-ALU-SETA)
  (READ-MFO))

(DEFUN READ-A-MEM-STEPPING (ADR)
  (LAM-EXECUTE (EXECUTOR LAM-EXECUTE-NOCLOCKS)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-A-SRC ADR
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-ALUF LAM-ALU-SETA)
  (SM-STEP-LOOP ':ZERO-IREG-AFTER-UINST-CLOCK T))

(DEFUN WRITE-A-MEM (ADR NUM)		
  (WRITE-SPY-REG-AND-CHECK NUM)
  (LAM-EXECUTE (WRITE)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-ALUF LAM-ALU-SETM
	       LAM-IR-A-MEM-DEST-FLAG 1
	       LAM-IR-A-MEM-DEST ADR))

(DEFUN WRITE-A-MEM-STEPPING (ADR NUM)		
  (WRITE-SPY-REG-AND-CHECK NUM)
  (LAM-EXECUTE (EXECUTOR LAM-EXECUTE-NOCLOCKS)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-M-SRC LAM-M-SRC-SPY-REG
	       LAM-IR-ALUF LAM-ALU-SETM
	       LAM-IR-A-MEM-DEST-FLAG 1
	       LAM-IR-A-MEM-DEST ADR)
  (SM-STEP-LOOP ':ZERO-IREG-AFTER-UINST-CLOCK T))

(DEFUN WIPE-A-MEM (&OPTIONAL (DATA 0))
  (DOTIMES (ADR 10000)
    (WRITE-A-MEM ADR DATA)))

(DEFUN CHECK-A-MEM-BACKGROUND (&OPTIONAL (BACKGROUND-DATA 0) KNOWN-CLOBBERED-LOCS)
  (DO ((ADR 1 (1+ ADR))
       C)
      ((= ADR 10000))
    (COND ((NOT (MEMQ ADR KNOWN-CLOBBERED-LOCS))
	   (COND ((NOT (= (SETQ C (READ-A-MEM ADR)) BACKGROUND-DATA))
		  (FORMAT T "~%loc ~s is now ~s" ADR C)))))))

(defun print-next-tram-adr-symbolically ()
  (let ((adr (read-tram-adr))
	(treg (read-treg)))
    (cond ((ldb-test (byte 1 8) treg)
	   (format t "~&next tram adr: ~o" adr))
	  (t
	   (print-tram-select-0-adr adr)))))

(defun print-tram-select-0-adr (adr)
  (format t "~&next tram adr: ~o   " adr)
  (format t "dest seq ~[0~;Write-A~;Write-M~;Write-C-PDL-POINTER~;~
			  Write-C-PDL-INDEX then M~;Write-C-PDL-INDEX~;~
			  Write-C-PDL-INDEX then M~;ERROR~]; "
	  (ldb (byte 3 0) adr))
  (format t "Slow Dest ~o; " (ldb (byte 1 3) adr))
  (format t "NO.OP ~o; " (ldb (byte 1 5) adr))
  (format t "ILONG ~o; " (ldb (byte 1 6) adr))
  (format t "OPCODE ~[ALU~;BYTE~;JUMP~;DISPATCH~]; " (ldb (byte 2 7) adr))
  (format t "Halt request ~o" (ldb (byte 1 11.) adr))
  
  )

(DEFUN SM-STEP-LOOP (&OPTIONAL &KEY 
		     (ZERO-IREG-AFTER-UINST-CLOCK NIL)
		     (CSM-PRINTOUT NIL)
		     (TREG-PRINTOUT T)
		     (UINST-PRINTOUT T)
		     (SINGLE-UINST-MODE NIL)
		     (tram-compare-mode nil))
  (PROG (COM CH IREG TREG CSMREG UINST-CLOCK-SEEN-LOW UINST-CLOCK-SEEN-HIGH-AFTER-LOW TEM)
	(PRINT-REGS)
	(PRINT-MEMORY-STATUS)
	(cond ((< (send *proc* :major-version) 100.)
	       (PRINT-PARITY)))
   SU0	(COND (SINGLE-UINST-MODE
	       (SETQ COM (SM-STEP-LOOP-SINGLE-UINST ':UINST-PRINTOUT UINST-PRINTOUT))
	       (SETQ SINGLE-UINST-MODE NIL)
	       (COND ((EQ COM 'QUIT)
		      (RETURN NIL))
		     ((EQ COM 'SINGLE-SM-CLOCK)
		      (GO L0))
		     (T (FERROR NIL "UNKNOWN COM")))))
	(DISABLE-LAMBDA)
     L0 (FORMAT T "~%SINGLE SM CLOCK MODE")
     L  (COND ((NULL ZERO-IREG-AFTER-UINST-CLOCK))
	      ((AND (UINST-CLOCK-LOW-P)
		    UINST-CLOCK-SEEN-HIGH-AFTER-LOW)
	       (FORMAT T "~%***forcing IR 0***")   ;flush randomness which has been clocked in.
	       (WRITE-IREG-AND-CHECK izero-good-parity))
	      ((UINST-CLOCK-LOW-P)
	       (SETQ UINST-CLOCK-SEEN-LOW T))
	      (UINST-CLOCK-SEEN-LOW
	       (SETQ UINST-CLOCK-SEEN-HIGH-AFTER-LOW T)))
	(setq treg (read-treg)
	      IREG (READ-IREG)
	      CSMREG (READ-CSM-REG))
	(COND (TREG-PRINTOUT
	       (PRINT-TREG)
	       (print-next-tram-adr-symbolically)
	       (format t "~%pc: ~o #x~:*~x, mfo: ~o #x~:*~x"
		       (read-pc)
		       (READ-MFO)
		       ))
	      (T (format t "~%treg: ~o, pc: ~o #x~:*~x, ireg: ~o, mfo: ~o #x~:*x"
			 TREG
			 (read-pc) IREG
			 (READ-MFO))))
	(PRINT-CON-REG-ONE-LINE)		;really con-reg
	(PRINT-MEMORY-STATUS)
	(cond (UINST-PRINTOUT
	       (TERPRI)
	       (LAM-PRINT-UINST IREG)))
	(COND (CSM-PRINTOUT
	       (FORMAT T "~%CSMADR: ~o  ~s"
		       (SETQ TEM (READ-CSM-ADR))
		       (CSM-SYMBOLIC-LOCATION (LOGAND 3777 TEM)))
	       (PRINT-CSM-REG)))
	(terpri)
	(setq ch (tyi))
	(SELECTQ CH
	  (#\RUBOUT
	   (RETURN NIL))
	  ((#/R #/r)
	   (FORMAT T "~%RESET-MI and LAM-RESET-CACHE~%")
	   (reset-mi)
	   (lam-reset-cache))
	  ((#/C #/c)
	   (setq csm-printout (not csm-printout)))
	  (#\ctrl-p
	   (format t "--run--")
	   (enable-lambda)
	   (tyi)
	   (disable-lambda)
	   (format t "**stop**"))
	  ((#/h #/H)
	   (let ((old (ldb single-step-mode (read-pmr))))
	     (write-pmr (dpb (logxor 1 old) single-step-mode (read-pmr)))))
	  ((#/s #/S)
	   (PRINT-PMR) (PRINT-CON-REG))
	  ((#/t #/T)
	   (reset-t-hold))
	  ((#/U #/u)
	   (SETQ SINGLE-UINST-MODE T)
	   (GO SU0))
	  ((#/I #/i)
	   (RESET-MI))
	  ((#/z #/Z)
	   (force-uinst-clock-low)
	   (zero-ireg))
	  
	  (#/=
	   (setq tram-compare-mode (not tram-compare-mode))
	   (if tram-compare-mode (init-tram nil ':make-array-for-sdu t)))
	  ((#\HELP #/?)
	   (FORMAT T "~%You are in the SM-step command loop, <space> advances one minor clock.
 <rubout> returns, cntrl-P proceeds machine, S prints regs, C complements CSM printout mode,
 U goes to single-uinst mode, R resets MI and CACHE, T /"resets/" THOLD, I calls RESET-MI,
 = toggles TRAM compare mode, Z zeros ireg"))
	  (#\SPACE
	   (IF (AND (LDB-TEST LAM-IR-HALT IREG)
		    (UINST-CLOCK-LOW-P))
	       (cond ((< (send *proc* :major-version) 100.)
		      (WRITE-IREG (compute-parity-for-ireg (DPB 0 LAM-IR-HALT IREG))))
		     (t
		      (write-ireg (dpb 0 (byte 4 60.) (dpb 0 lam-ir-halt ireg))))))
	   (sm-tick 1 tram-compare-mode)))
	(go l)))



(DEFUN SM-STEP-LOOP-SINGLE-UINST (&OPTIONAL &KEY 
		     (UINST-PRINTOUT T))
  (PROG (CH IREG)
    SL0 (FORMAT T "~%Single uinst mode")
    SL1	(ENABLE-LAMBDA-SINGLE-STEPPING T)
    SL  (FORMAT T "~%PC:~O, IREG:~O" (READ-PC) (SETQ IREG (READ-IREG)))
	(PRINT-CON-REG-ONE-LINE)
	(print-memory-status)
	(COND (UINST-PRINTOUT
	       (TERPRI)
	       (LAM-PRINT-UINST IREG)))
	(TERPRI)
	(SETQ CH (TYI))
	(SELECTQ CH
	  (#\RUBOUT
	   (DISABLE-LAMBDA-AND-CLEAR-SINGLE-STEP)
	   (RETURN 'QUIT))
	  ((#/M #/m)
	   (DISABLE-LAMBDA-AND-CLEAR-SINGLE-STEP)
	   (RETURN 'SINGLE-SM-CLOCK))
	  (#\CTRL-P
	   (FORMAT T "--RUN--")
	   (CLEAR-SINGLE-STEP-MODE)
	   (TYI)
	   (SET-SINGLE-STEP-MODE)
	   (FORMAT T "**STOP**")
	   (GO SL))
	  ((#/s #/S)
	   (PRINT-PMR)
	   (PRINT-CON-REG)
	   (GO SL))
	  ((#/D #/d)
	   (format t "~%md-bus: ~s" (read-md-bus))
	   (go sl))
	  ((#/E #/e)
	   (DISABLE-LAMBDA-AND-CLEAR-SINGLE-STEP)
	   (LET ((PC (READ-PC))
		 (IREG (READ-IREG))
		 (NOOP-P (NOOP-P)))
	     (LAM-EXECUTE-W izero-good-parity T)	;assure noop cleared.
	     (LET ((LC (READ-LC)))
	       (FORMAT T "~%MD: ~S, MACRO-IR: ~S" (READ-MD) (READ-FULL-MACRO-IR))
	       (WRITE-LC LC))
	     (WRITE-PC PC (IF NOOP-P 1 0))
	     (WRITE-IREG IREG)
	     (FORCE-TRAM-TO-REDO-SOURCE-CYCLE)
	   ;  (RETURN 'SINGLE-SM-CLOCK)
	     )
	   (GO SL1))
	  ((#\HELP #/?)
	   (FORMAT T "~%You are in the UINST-step command loop, <space> advances one uinst.
 <rubout> stops clock and returns, cntrl-P proceeds machine, S prints regs,
 M goes to single-SM.clock mode, D prints MD-BUS, 
 E performs a save and restore which should be a NOOP."))
	  (#\space
	   (COND ((LDB-TEST LAM-IR-HALT IREG)
		  ;;so as to single-step past...
		  (WRITE-IREG-with-good-parity (DPB 0 LAM-IR-HALT IREG))
		  ))
	   (ADVANCE-UINST)
	   ))

	(GO SL)
	))

(DEFUN FORCE-TRAM-TO-REDO-SOURCE-CYCLE NIL
  (COND ((ACCESS-PATH-LMI-SERIAL-PROTOCOL *PROC*)
	 (FUNCALL *PROC* ':STRING-OUT "100I")
	 (FUNCALL *PROC* ':READ-32))
	((< (send *proc* :major-version) 100.)
	 (COND ((NULL (AT-UINST-BOUNDARY-P))
		(FERROR NIL "Not at uinst boundary when entering single.uinst mode.  Lose.")))
	 (WRITE-TREG-FROM-TRAM 1004))	;points to source cycle.  gives halt.request a chance
					;to happen without advancing to the next uinst.
	(t
	 (COND ((NULL (AT-UINST-BOUNDARY-P))
		(FERROR NIL "Not at uinst boundary when entering single.uinst mode.  Lose.")))
	 (force-source-codeword))
	))

(defun initialize-tram-from-list (tram-value-list)    ;takes something like initial-tram-list
  (STORE-TRAM-BACKGROUND)
  (write-tram-from-list 1000 tram-value-list))

(defun write-tram-from-list (adr tram-value-list)
  ;the previous do* thing was a loser -- rg
  (do ((i adr (1+ i))				;made up of pairs of byte-selects and values
       (tram-value-pointer tram-value-list (cdr tram-value-pointer)))
      ((null tram-value-pointer))
    (setup-tram i (car tram-value-pointer))))

(defconst initial-tram-list
	  '(()  			;1000
  ;use extreme care using this codeword. You can lose clobbering the MD if T.source.cycle
  ; is not asserted on the minor cycle after UINST.CLOCK goes hi.
	    (tram.new.uinst 1)		;1001
	    (tram.next.select 1)	;1002  this will transfer to fetch codeword.
	    ))

;(defun uinst-tick (&OPTIONAL (number-of-ticks 1))
;  (FORCE-UINST-CLOCK-LOW)
;  (write-tram-from-list 1000 initial-tram-list)
;  (dotimes (index number-of-ticks)
;    (WRITE-TREG-FROM-TRAM 1001)
;    (WRITE-TREG-FROM-TRAM 1000)
;    (WRITE-TREG-FROM-TRAM 1000)))			;to make sure we never get in a 
						;wedged state


(DEFCONST UINST-TICK-PMR-LIST			;LOW LEVEL MODE FOR DOING UINST CLOCKS
        '(FAST-CLOCK-ENABLE-L 1
	  RESET-INTERRUPT-COUNTER-L 1
	  SINGLE-STEP-MODE 0
	  CLEAR-NOOP-L 1
	  ADVANCE-UINST-REQUEST 0
	  PARITY-STOP-ENABLE 0			;while we are checking things out
	  SPY-ADDRESS-TRAM-L 0
  ;	  DEBUG-CACHE-PERMIT 0
  ;	  FORCE-CSM-USE-SPY-ADDRESS-L 0
	  FORCE-T-HOLD 1
	  ALLOW-UINST-CLOCKS 0
	  FORCE-MI-RESET-L 1
	  ))


;This function is obsolete!!  DO NOT USE in new code without seeing RG.
; this is to be used only to initialize machine at LAMBDA-POWER-UP.  Other than that,
; it may not work for hairy reasons, ie, T.SOURCE.CYCLE is not asserted on minor cycle
; after uinst.clock, which can cause MD register to get clobbered.
(defun uinst-tick (&optional (number-of-ticks 1))
  (COND ((ACCESS-PATH-LMI-SERIAL-PROTOCOL *PROC*)
	 (FORMAT *PROC* "3,~SC" NUMBER-OF-TICKS)
	 (FUNCALL *PROC* ':READ-32))
	(T
	 (let ((con-reg (read-con-reg))
	       (pmr (read-pmr)))
	   (if (= 1 (ldb ENABLE-SM-CLOCK-BIT con-reg))
	       (FERROR NIL "TRIED TO TICK WHILE MACHINE RUNNING!")) 
	   (COND ((NOT (UINST-CLOCK-LOW-P))
		  (FERROR NIL "TRIED TICK WHEN UINST-CLOCK ALREADY HIGH")))
	   (SETUP-PMR UINST-TICK-PMR-LIST)	;asserts t.hold, FORCES CSM TO USE SPY ADDRESS
	   (WRITE-TRAM-adr 1000)		;this assumes the standard load in tram
	   (ZERO-IREG-THEN-SM-TICK)		;NOW WEVE CLEARED BOTH TREG AND UINST CLOCK
	   (CHANGE-PMR '(FORCE-T-HOLD 0
				      ALLOW-UINST-CLOCKS 1))
						;(PRINT-TICK-DATA)
	   (dotimes (index number-of-ticks)
	     (write-tram-adr 1001)
	     (ZERO-IREG-THEN-SM-TICK)
	     (write-tram-adr 1000)
	     (ZERO-IREG-THEN-SM-TICK))
	   (ZERO-IREG-THEN-SM-TICK)		;TICK IT AGAIN TO CLEAR TREG
	   (cond ((not (uinst-clock-low-p))
		  (ferror NIL "UINST-CLOCK HIGH AFTER UINST-TICK")))
	   (write-pmr pmr)			;PUT BACK THE PMR
	   (write-con-reg con-reg)))))		;PUT BACK CON REG

(DEFUN FORCE-UINST-CLOCK-LOW ()
  (COND ((ACCESS-PATH-LMI-SERIAL-PROTOCOL *PROC*)
	 (FUNCALL *PROC* ':STRING-OUT "4I")
	 (FUNCALL *PROC* ':READ-32))
	((UINST-CLOCK-LOW-P))
	(T
	 (LET ((PMR (READ-PMR))
	       (treg (read-treg))
	       tem)
	   (change-pmr '(force-t-hold 1 ALLOW-UINST-CLOCKS 0))
	   (COND ((NOT (= 0 (LDB T-HOLD-L-BIT (READ-CON-REG))))
		  (FERROR NIL "~%UNABLE TO FORCE T.HOLD")))
	   (sm-tick)				;t-hold prevents us from losing the contents
						;of the treg; but the sm tick while uinst
						;clocks are not allowed causes a 0 to be
						;loaded to uinst.clock
	   (cond ((not (= treg (setq tem (read-treg))))
		  (ferror nil "SM.TICK WITH HOLD ON CHANGED TREG FROM ~S TO ~S
			 (before restoring PMR)" treg tem)))
	   (WRITE-PMR PMR)
	   (COND ((NOT (UINST-CLOCK-LOW-P))
		  (FERROR NIL "UNABLE TO FORCE UINST-CLOCK LOW"))
		 ((not (= treg (setq tem (read-treg))))
		  (ferror nil "SM.TICK WITH HOLD ON CHANGED TREG FROM ~S TO ~S" treg tem)))
	   )))
  1)	;one sm-tick, although it really doesnt advance any.

(defun force-uinst-clock-loop ()
      (change-pmr '(force-t-hold 1 ALLOW-UINST-CLOCKS 0))
      (COND ((NOT (= 0 (LDB T-HOLD-L-BIT (READ-CON-REG))))
	     (FERROR NIL "~%UNABLE TO FORCE T.HOLD")))
      (do()(())(sm-tick)))			;t-hold prevents us from losing the contents
						;of the treg; but the sm tick while uinst
						;clocks are not allowed causes a 0 to be
						;loaded to uinst.clock

(DEFUN ZAM ()
  (POWER-UP-INITIALIZE)
  (SELECT-TEST))

(DEFUN SELECT-TEST ()
  (PROG (OPTION-LIST CHOICE)
    ;note ULOAD automatically does LOAD-STRAIGHT-CRAM-ADR-MAP enough to win..
   TOP	(SETQ CHOICE (TV:MENU-CHOOSE
		  '(UINST-JUMP-LOOP
		    UINST-M-COUNT-LOOP
		    UINST-M-LH-COUNT-LOOP
		    UINST-A-COUNT-LOOP
		    UINST-JUMP-EQUAL-LOOP
		    UINST-COMPARE-LOOP
		    UINST-COMPARE-PASSAROUND-LOOP
		    UINST-JUMP-HALT-LOOP
		    UINST-MD-COUNT-LOOP
		    UINST-VMA-COUNT-LOOP
		    UINST-MAIN-MEM-READ-LOOP
		    UINST-MAIN-MEM-WRITE-LOOP
		    UINST-MAIN-MEM-COUNT-LOOP
		    UINST-TRANSPORTER-OLD-SPACE-TEST-LOOP
		    UINST-SUCCESSIVE-WRITE-TEST
		    UINST-PP-COUNT-LOOP
		    UINST-PI-COUNT-LOOP
		    UINST-SETZ-LOOP
		    UINST-ONES-LOOP
		    UINST-CALL-RETURN-LOOP
		    UINST-US-POP-LOOP
		    UINST-WRITE-CAM-TEST-LOOP
		    UINST-DIVIDE-LOOP
		    UINST-WRITE-MID-TEST-LOOP
		    TEST-MACRO-FETCH-LOOP
		    UINST-Q-TEST-LOOP
		    BIT-TEST-JUMP-LOOP
		    SINGLE-UINST-MODE
		    SINGLE-MINOR-CYCLE-MODE)))
      (COND ((EQ CHOICE 'SINGLE-UINST-MODE)
	     (SETQ OPTION-LIST (MERGE-OPTION-LIST '(:SINGLE-UINST-MODE T) OPTION-LIST))
	     (GO TOP))
	    ((EQ CHOICE 'SINGLE-MINOR-CYCLE-MODE)
	     (SETQ OPTION-LIST (MERGE-OPTION-LIST '(:SINGLE-UINST-MODE NIL) OPTION-LIST))
	     (GO TOP)))
      (NOOP-UINST-CLOCKS)
      (COND (CHOICE
	     (APPLY 'SM-STEP-LOOP (MERGE-OPTION-LIST OPTION-LIST (FUNCALL CHOICE)))))))

(DEFUN MERGE-OPTION-LIST (NEW-OPTIONS OLD-OPTIONS)
  (COND ((NULL NEW-OPTIONS)
	 OLD-OPTIONS)
	(T (MERGE-OPTION-LIST (CDDR NEW-OPTIONS)
			      (MERGE-OPTION (CAR NEW-OPTIONS)
					    (CADR NEW-OPTIONS)
					    OLD-OPTIONS)))))

(DEFUN MERGE-OPTION (KEY VALUE OLD-OPTIONS)
  (COND ((NULL (MEMQ-ALTERNATE KEY (LOCF OLD-OPTIONS)))
	 (CONS KEY (CONS VALUE OLD-OPTIONS)))
	((EQ KEY (CAR OLD-OPTIONS))
	 (CONS KEY (CONS VALUE (CDDR OLD-OPTIONS))))
	(T (CONS (CAR OLD-OPTIONS)
		 (CONS (CADR OLD-OPTIONS)
		       (MERGE-OPTION KEY VALUE (CDDR OLD-OPTIONS)))))))

(DEFUN MEMQ-ALTERNATE (ITEM LIST)
  (COND ((NULL LIST) NIL)
	((EQ ITEM (CAR LIST)) T)
	(T (MEMQ-ALTERNATE ITEM (CDDR LIST)))))

(defun zoom ()
  (POWER-UP-INITIALIZE))

(DEFUN POWER-UP-LOAD-PROM NIL
  (ZOOM)
  (MEMORY-SETUP)
  (COND ((NOT (= 200 (INITIALIZE-DISK-CONTROL)))
	 (FERROR NIL "eagle failed to initialize")))
  (LAM-LOAD-PROM)
  (PRINT-DISK-LABEL "lam")
  (LAM))

(DEFUN RG-ZOOM ()
  (RESET)
  (INIT-TRAM)
  (SETUP-PMR STANDARD-PMR-LIST)
  (print-con-reg)
  (print-pmr))


(deff lambda-power-up-debug 'lambda-power-up)   ;no longer different.

(DEFUN LAMBDA-POWER-UP (&key &optional (and-start t) no-power-up-initialize
			 prom-already-loaded)
 ;  (setq *share-mode* nil
 ;	  *use-configuration-structure* nil)
  (ND-SETUP-1)
  (IF (NULL NO-POWER-UP-INITIALIZE)
      (LAM-ZERO-ENTIRE-MACHINE)
    ;  (POWER-UP-INITIALIZE)  ;USE THIS TO AVOID REINITING
    )			      ;TRAM IF ALREADY LOADED WITH GOOD STUFF.
  (MEMORY-SETUP (SEND *PROC* :MEM-SLOT))
  (SET-UP-TV)
  (INITIALIZE-DISK-CONTROL)
  (if (null prom-already-loaded) (LAM-LOAD-PROM))
  (clear-share-multibus-indicators)
  (reset-mi)
  (LAM-DUMMY-FULL-SAVE)
  (if and-start
      (prog (prom-stop-jumpto-adr)
	    (lam-parity-off)
	    (cond ((access-path-lmi-serial-protocol *proc*)
		   (format *proc* "AStarting PROM~%")))
	    (LAM-REGISTER-DEPOSIT RASA 36000)	;start of bootstrap
            (LAM-REGISTER-DEPOSIT RAGO 1)  ;this hacks the disk, so its the MOBY GO
	    (LAM-CONTROL-P-WAIT "PROM wait")

 ;       L  (COND ((SETQ CHAR (KBD-TYI-NO-HANG))
 ;		   (LAM-REGISTER-DEPOSIT RASTOP 0)
 ;		   (format t"~%Aborting initialization. PROM was started")
 ;		   (return nil))
 ;		  ((ZEROP (LAM-REGISTER-EXAMINE RAGO)) (GO X)))
 ;          (PROCESS-SLEEP 30. "PROM wait")         ;WHY WAIT AS LONG?
 ;	    (GO L)      
 ;      X  (LAM-REGISTER-DEPOSIT RASTOP 0)

	    (setq prom-stop-jumpto-adr (ldb lam-ir-jump-addr (lam-register-examine rasir)))
	    (cond ((and (not (= lam-saved-pc 36005))		;new thing
			(not (= 6  prom-stop-jumpto-adr)))	;old thing
		   (format t "~%Bad prom halt. Lose.")
		   (return nil)))
	  (cond ((access-path-lmi-serial-protocol *proc*)
		 (format *proc* "APROM completed OK~%")))
	  (lam-cold-boot t)  ;lam-cold-boot will not load symbols unless necessary.
	 ))
  )

(defun clear-share-multibus-indicators ()
  (dotimes (c 8)
    (multibus-byte-write (+ c #x80) 0)))

;true if A-memory must be munged to tell UCODE about configuration.
(defun lam-non-standard-configuration-p (&optional ucode-version)
  (or (not (= (send *proc* :tv-slot) tv-slot-on-normal-sdu))
      (and (not (= (send *proc* :rg-slot) 0))
	   (or (null ucode-version)
   ;5 series ucode > 506 can deal with RG board in a random slot.
	       (not (OR (= 6 (// UCODE-VERSION 100.))
			(and (= 5 (// ucode-version 100.))
			     (> (\ ucode-version 100.) 6))))))))

(DEFUN LAMBDA-ALREADY-UP NIL
  (ND-SETUP-1)
  (SETUP-FOR-DISK)
  (setup-nubus-configuration)
  (SETQ TRAM-LOCATION-3000 NIL)
  (SETQ LAM-PASSIVE-SAVE-VALID NIL
	LAM-FULL-SAVE-VALID NIL)
  )

(DEFUN TRAM-LOCATION-3000 ()
  (IF (NULL TRAM-LOCATION-3000)
      (SETQ TRAM-LOCATION-3000 (READ-TRAM 3000)))
  TRAM-LOCATION-3000)

(DEFUN LAMBDA-SDU-DIED-AGAIN NIL
  (ND-SETUP-1)
  (SET-UP-TV)
  (INITIALIZE-DISK-CONTROL)
  (FIND-AND-INITIALIZE-MEMORIES))

(DEFUN LAMBDA-RESTORE-INTERRUPTS (&OPTIONAL (TV-SLOT #X8))
  "enable TV interrupts and .."
  (tv-enable-interrupts)
  ;.... maybe more was intended, this function left unfinished with unbalenced parens.. rg
  )

(defun safe-power-up-initialize ()
  (power-up-initialize nil ':do-reset nil))

(DEFUN POWER-UP-INITIALIZE (&optional dont-trust-data-paths &key (do-reset t))
  (if do-reset (RESET))
  (INIT-TRAM)
  (COND ((UINST-CLOCK-LOW-P) (WRITE-IREG izero-good-parity)))
  (WIPE-CSM)
  (COND ((UINST-CLOCK-LOW-P) (WRITE-IREG izero-good-parity)))
  (WRITE-TREG-FROM-TRAM 1000)
  (INIT-LAMBDA)		;MAKE SURE NO RANDOMNESS HAS HAPPENNED SINCE LAST DUE TO CLOCKING
			; BEFORE CSM ZEROED. (frobs init bit in CON reg).
  (FORCE-UINST-CLOCK-LOW)
  (SETUP-PMR STANDARD-PMR-LIST)
  (NOOP-UINST-CLOCKS)
  (UINST-TICK 3)
  (NOOP-TO-UINST-BOUNDARY)
  (LOAD-CSM)
  (lam-reset-cache)
 ;it should probably do these later when doing LAM-TEST-MACHINE since they tend to bomb
 ; out if the data-paths are screwwed before spy-reg has been tested.
 ;instead, how about making lam-test-machine call with a different argument
  (cond ((null dont-trust-data-paths)
	 (SETUP-DP-MODE STANDARD-DP-MODE-LIST)	  ;make sure pdl uses pdl space, not M memory
	 (SETUP-RG-MODE STANDARD-RG-MODE-LIST)))  ;good initial rg mode value
  (PRINT-CON-REG)
  (PRINT-PMR))

(defun hh-power-up ()
  (reset)
  (init-tram)
  (flush))

(DEFUN power-up-initialize-no-init-tram ()
  (COND ((UINST-CLOCK-LOW-P) (WRITE-IREG izero-good-parity)))
  (WRITE-TREG-FROM-TRAM 1000)
  (INIT-LAMBDA)		;MAKE SURE NO RANDOMNESS HAS HAPPENNED SINCE LAST DUE TO CLOCKING
			; BEFORE CSM ZEROED. (frobs init bit in CON reg).
  (FORCE-UINST-CLOCK-LOW)
  (SETUP-PMR STANDARD-PMR-LIST)
  (NOOP-UINST-CLOCKS)
  (UINST-TICK 3)
  (NOOP-TO-UINST-BOUNDARY)
  (lam-reset-cache)
  (SETUP-DP-MODE STANDARD-DP-MODE-LIST)	  ;make sure pdl uses pdl space, not M memory
  (SETUP-RG-MODE STANDARD-RG-MODE-LIST)  ;good initial rg mode value
  )

(DEFUN RESET ( &optional (pmr-list standard-pmr-list))	
  (cond ((null (access-path-lmi-serial-protocol *proc*))
	 (test-nd-mode-data-path)
	 (nd-setup-1)))
 ;  (setup-nubus-configuration)
 ;  (send *proc* :set-rg-slot rg-slot)
  (reset-guts pmr-list))

(defun far-reset ()
  (test-nd-mode-data-path)
  (nd-setup-1)
  (setup-nubus-configuration)
  (select-processor-to-debug)
  (reset-guts))

(DEFUN RESET-GUTS ( &optional (pmr-list standard-pmr-list))	
  (condition-case ()
      (progn
       (INIT-LAMBDA)
       (CHANGE-CON-REG-AND-CHECK '(ENABLE-NU-MASTER-BIT 0))
       (SETUP-PMR PMR-LIST)
       (cond ((fboundp 'make-diagnostic-window)
	      (print-regs)
	      (print-memory-status))))
    (nubus-timeout
     (format t "~&No lambda present (or RG board not responding to nubus)")))
  )

(defun flush ()
  (reset)
  (force-source-codeword)
  (write-ireg (lam-execute (return)
			   lam-ir-op lam-op-alu
			   lam-ir-stat-bit 1))
  (advance-to-uinst-boundary)
  (sm-tick)
  (advance-to-uinst-boundary)
  (force-source-codeword)
 )

(DEFUN NOOP-TO-UINST-BOUNDARY ()
  (COND ((ACCESS-PATH-LMI-SERIAL-PROTOCOL *PROC*)
	 (FUNCALL *PROC* ':STRING-OUT "4C")
	 (FUNCALL *PROC* ':READ-32))
	(T
	 (DO ((C 0 (1+ C)))
	     ((AT-UINST-BOUNDARY-P))
	   (IF (> C 4.)
	       (FERROR NIL "unable to noop to uinst boundary"))
	   (ZERO-IREG)
	   (SM-TICK)))))

;this one executes all zero microinstructions.  not good for cold power-up
; since next uinst dest seq can power up 7 (normally unused), and 7 entries in TRAM will not
; go thru source cycle.
(DEFUN NOOP-UINST-CLOCKS (&OPTIONAL (N 20))
  (COND ((ACCESS-PATH-LMI-SERIAL-PROTOCOL *PROC*)
	 (FORMAT *PROC* "2,~SC" N)
	 (FUNCALL *PROC* ':READ-32))
	(T
	 (DOTIMES (C N)
	   (zero-ireg)
	   (SM-TICK))
	 (ZERO-IREG)
	 (FORCE-SOURCE-CODEWORD)		;AVOID LEAVING GARBAGE IN IR
	 (WRITE-IREG izero-good-parity)
	 )))

(DEFUN PRINT-BITS (WD)
  (PRINT-BIT-LIST (WRONG-BITS-LIST 0 WD (HAULONG WD)) NIL NIL))

(DEFUN WRONG-BITS-LIST (GOOD BAD N-DATA-BITS)
  (DO ((BITNO 0 (1+ BITNO))
       (PPSS 0001 (+ 100 PPSS))
       (L NIL))
      ((= BITNO N-DATA-BITS) L)
    (OR (= (LDB PPSS GOOD) (LDB PPSS BAD))
	(SETQ L (CONS BITNO L)))))

(DEFUN PRINT-BIT-LIST-WITH-MESSAGE (MESSAGE BIT-LIST shift-bits)
  (COND (BIT-LIST (PRINC MESSAGE) (PRINT-BIT-LIST BIT-LIST shift-bits))))

(DEFUN PRINT-BIT-LIST (BITLIST shift-bits &OPTIONAL MESSAGE)
  (COND (BITLIST
	(IF MESSAGE (PRINT MESSAGE))
	 (DO ((L (SORT BITLIST #'LESSP) (CDR L))
	      (COMMA NIL T)
	      (LASTVALUE -2 (CAR L))
	      (RANGE-END NIL)
	      (RANGE-START))
	     ((NULL L)
	      (COND (RANGE-END
		     (IF (= (1+ RANGE-START) RANGE-END)
			 (FORMAT T ", ~D" (if shift-bits (+ shift-bits RANGE-END) RANGE-END))
		       (FORMAT T "-~D" (if shift-bits (+ shift-bits RANGE-END) RANGE-END))))))
	   (COND ((= (CAR L) (1+ LASTVALUE))
		  (OR RANGE-END (SETQ RANGE-START LASTVALUE))
		  (SETQ RANGE-END (CAR L)))
		 (T
		  (AND RANGE-END
		       (IF (= (1+ RANGE-START) RANGE-END)
			   (FORMAT T ", ~D"
				   (if shift-bits (+ shift-bits RANGE-END) RANGE-END))
			 (FORMAT T "-~D" (if shift-bits (+ shift-bits RANGE-END) RANGE-END))))
		  (SETQ RANGE-END NIL)
;;; $$$ changed to make all output use (format t ..) <14-Nov-88 rg>
		  (AND COMMA (format t ", "))	;was (SEND TERMINAL-IO ':STRING-OUT ", ")
		  ;was (FORMAT:ONUM (if shift-bits (+ shift-bits (CAR L)) (CAR l)))
		  (format t "~D" (if shift-bits (+ shift-bits (CAR L)) (CAR l)))
		  )))
	 (format t "~%"))))	;was (SEND TERMINAL-IO ':TYO #\CR)

;;		 {	21	PARITY VECTOR (32 bits)
;;		 {	20	PMR (processor mode register 24 bits, read and write;
;;		 {			low 8 bits Configuation Prom, read only)
;;		 {	17	SPY REGISTER (32 bits)
;;		 {	16	MFO ENABLE (reading MFO bus)
;;		 {	15	TREG (output register of TRAM, read only)
;;	RG board {	14	PC (program counter, 16 bits, read only)
;;		 {	13	HPTR (history pointer, 10 bits)
;;		 {	12	HRAM (history ram, 16 bits)
;;		 {	11	TRAM (timing ram)
;;		 {	10	TRAM.ADR (special address register for debug read/write
;;					  of TRAM. 12 bits)
;;		 {	22 CRAM.ADR.MAP (control memory address map, 12 bits)
;;		 {	07 LOW CRAM (low half of control memory, 32 bits)
;;	CM board {	06 HIGH CRAM (high half of control memory, 32 bits)
;;		 {	05 LOW IREG (low half of instruction register, 32 bits,
;;		 {	   	read doesn't use USE.LOW.I)
;;		 {	04 HIGH IREG (high half of instruction register, 32 bits,
;;		 {	  	read doesn't use USE.HIGH.I)
;;		 {	03 MD (memory data register, 32 bits, read only)
;;	MI board {      02 CSM.REG (output register of CSM, 32 bits, read only)
;;		 {	01 CSM.ADR (special address register for debug read/write
;;		 {			of TRAM, low 12 bits, read and write)
;;		 {		& CACHED.PHY.ADR (currently cached physical address,
;;		 {			high 18 bits, read only)
;;		 {		& MEMORY CYCLE STATUS (memory.cycle.pending, bit 31,
;;					and memory.cycle.active, bit 30; read only)
;;		 {	00 CSM (cache state machine, 32 bits)

(defvar spy-locs '(( 0 'csm-data 'mi)
		   ( 1 'csm-adr 'mi)
		   ( 2 'csm-reg 'mi)
		   ( 3 'md 'mi)
		   ( 4 'high-ireg 'cm)
		   ( 5 'low-ireg 'cm)
		   ( 6 'high-cram 'cm)
		   ( 7 'low-cram 'cm)
		   (10 'tram-adr 'rg)
		   (11 'tram-data 'rg)
		   (12 'hram 'rg)
		   (13 'hptr 'rg)
		   (14 'pc 'rg)
		   (15 'treg 'rg)
		   (16 'mfo 'rg)
		   (17 'spy 'rg)
		   (20 'pmr 'rg)
		   (21 'parity 'rg)
		   (22 'cram-adr-map 'cm)))