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


;;this file contains the diagnostics for the macro.ir.decode ram and the
;;macro instruction register


(DEFUN READ-MACRO-IR ()		;reads selected 16 bits.
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-M-SRC LAM-M-SRC-MACRO.IR
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-MFO))

(DEFUN READ-FULL-MACRO-IR ()	;clobbers LC
  (LET ((LOW (PROGN (USE-LOW-MACRO-IR) (READ-MACRO-IR)))
	(HIGH (PROGN (USE-HIGH-MACRO-IR) (READ-MACRO-IR))))
    (DPB HIGH 2020 LOW)))

(DEFUN READ-MACRO-IR-DISPLACEMENT ()
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-M-SRC LAM-M-SRC-MACRO.IR.DISPLACEMENT
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-MFO))

(DEFUN WRITE-MACRO-IR-BOTH-HALVES (DATA &OPTIONAL MAKE-SURE)
  (WRITE-MACRO-IR (LOGIOR (ASH DATA 16.) DATA) MAKE-SURE))

;make sure can only test 16 bits.  The halves should be the same if it is T.
(DEFUN WRITE-MACRO-IR (DATA &OPTIONAL MAKE-SURE)
  (DECLARE (SPECIAL SM-TICK-DETECT-HANGS))
  (WRITE-SPY-REG-AND-CHECK DATA)
  (write-pc 0)
  (LET ((SM-TICK-DETECT-HANGS NIL))
;    (selectq lambda-minor-version-number
;      (0 (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-SOURCE-TO-MACRO-IR 1))
;      (t (LAM-EXECUTE (READ)
;		      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-SOURCE-TO-MACRO-IR 1)))
    (LAM-EXECUTE (READ)
		 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-SOURCE-TO-MACRO-IR 1))

 ;  (WRITE-IREG 0)	;clear out IR-SOURCE-TO-MACRO-IR bit, which can result in clobberage.
  (IF MAKE-SURE
      (let ((read-back (read-macro-ir)))
	(IF (NOT (= (LOGAND DATA 177777) read-back))
	    (FERROR NIL "macro ir failed to load; wrote ~O read ~O" data read-back)))))

(DEFUN MD-TO-MACRO-IR ()
  (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-MD-NO-HOLD	;TEMPORARY?? RICH, HOW DID THIS WORK?
	       LAM-IR-SOURCE-TO-MACRO-IR 1)
  )

(DEFUN ZERO-CRAM (&OPTIONAL (NUMLOC 100.))
  (DOTIMES (I NUMLOC)
    (WRITE-CRAM I 0)))

;NOTE: LC INCREMENTS SIMULTANEOUSLY WITH INITIATION OF FETCH.  THUS, IF BIT 1 OF LC
; IS SET, WE ARE EXECUTING THE FIRST, IE LOW, HALF OF THE INSTRUCTION WORD.
(DEFUN USE-HIGH-MACRO-IR (&aux temp-lc)		;note source.cycle XORs with this.
  (WRITE-LC (setq temp-lc (logand 37777777775 (READ-LC))))
  (if ( temp-lc (read-lc))
      (ferror t "failed to write LC properly while forcing use of high macro-ir")))

(DEFUN USE-LOW-MACRO-IR (&aux temp-lc)		;note source.cycle XORs with this.
  (WRITE-LC (setq temp-lc (LOGIOR 2 (READ-LC))))
  (if ( temp-lc (read-lc))
      (ferror t "failed to write LC properly while forcing use of high macro-ir")))

(DEFUN READ-MID (ADDRESS)
  (WRITE-MACRO-IR-BOTH-HALVES (LSH ADDRESS 6) T)
  (READ-MID-SOURCE))

;This one can address the entire MID, not just the bottom quarter normally used.
(DEFUN READ-MID-FULL (ADDRESS)
  (let ((rg-mode (read-rg-mode)))
    (write-rg-mode (dpb 0 enable-misc-mid
			(dpb (ldb (byte 2 10.) address) mid.hi.adr rg-mode)))
    (WRITE-MACRO-IR-BOTH-HALVES (LSH (logand 1777 ADDRESS) 6) T)
    (prog1 (READ-MID-SOURCE)
	   (write-rg-mode rg-mode))))

(DEFUN READ-MID-SOURCE ()
  (LAM-EXECUTE (READ)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-M-SRC LAM-M-SRC-MACRO.IR.DECODE.RAM
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-ALUF LAM-ALU-SETM)
  (READ-MFO))

;;THE MID is written as a slow destination
(DEFUN WRITE-MID (ADDRESS DATA)
  (WRITE-MACRO-IR-BOTH-HALVES (ASH ADDRESS 6) T)	;in both halves
  (WRITE-SPY-REG-AND-CHECK DATA)
  (LAM-EXECUTE (uinst-clock-plus-uinst-clock-low) ;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-MID
	       LAM-IR-SLOW-DEST 1
	       LAM-IR-ALUF LAM-ALU-SETM))

;This one can address the entire MID, not just the bottom quarter normally used.
(DEFUN WRITE-MID-FULL (ADDRESS DATA)
  (let ((rg-mode (read-rg-mode)))
    (write-rg-mode (dpb (ldb (byte 2 10.) address) mid.hi.adr rg-mode))
    (WRITE-MACRO-IR-BOTH-HALVES (ASH (logand 1777 ADDRESS) 6) T)	;in both halves
    (WRITE-SPY-REG-AND-CHECK DATA)
    (LAM-EXECUTE (uinst-clock-plus-uinst-clock-low) ;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-MID
	       LAM-IR-SLOW-DEST 1
	       LAM-IR-ALUF LAM-ALU-SETM)
    (write-rg-mode rg-mode)))

(DEFUN WRITE-MID-STEPPING (ADDRESS DATA)
  (USE-LOW-MACRO-IR)		;do this first so low half reads out.
  (WRITE-MACRO-IR-BOTH-HALVES (ASH ADDRESS 6) T)
  (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-MID
	       LAM-IR-SLOW-DEST 1
	       LAM-IR-ALUF LAM-ALU-SETM)
  (SM-STEP-LOOP))

;;; Althought the following works, you are better off running FAST-CLEAR-MID,
;;; as wipe-mid takes a VERY LONG TIME to run.....
(defun wipe-mid ()
  (do ((address 0 (1+ address)))
      ((> address 1777))     ;only 10 bits worth of addresses can be written simplemindedly
    (write-mid address 0)))  ; this way.

(defun fast-address-test-MID ()
  (DECLARE (SPECIAL SM-TICK-DETECT-HANGS))
  (let ((offset 0)
	(n-data-bits 16.)
	(read-fctn 'read-MID)
	(write-fctn 'write-MID)
	(n-address-bits 10.)			;Test only bottom quarter for now
	(message "FAST-ADDRESS-TEST of Macroinstruction Decode")
	(SM-TICK-DETECT-HANGS NIL))
    (fast-address-test-kernal write-fctn read-fctn
			      offset n-data-bits n-address-bits message 2)))


(DEFUN UINST-WRITE-MID-TEST-LOOP (&AUX (A-CONSTANT-1 1) (M-A 2) (mid-loc 3))
  (WRITE-M-MEM A-CONSTANT-1 1)
  (WRITE-M-MEM MID-LOC 100)	;address location 1
  (ULOAD (A-CONSTANT-1 M-A mid-loc)
   0
	 ;((MD) DPB M-MID-LOC (BYTE-FIELD 20 20) A-MID-LOC)
	 (LAM-IR-OP LAM-OP-BYTE
	  LAM-IR-BYTL-1 17
	  LAM-IR-MROT 20
	  LAM-IR-BYTE-FUNC LAM-BYTE-FUNC-DPB
	  LAM-IR-A-SRC mid-loc
	  LAM-IR-M-SRC mid-loc
	  LAM-IR-FUNC-DEST LAM-FUNC-DEST-MD
	  LAM-IR-SLOW-DEST 1)

	 ;((M-A) 1)
	 (LAM-IR-OP LAM-OP-ALU
	  LAM-IR-OB LAM-OB-ALU
	  LAM-IR-A-SRC A-CONSTANT-1
	  LAM-IR-ALUF LAM-ALU-SETA
	  LAM-IR-M-MEM-DEST M-A)

	 ;(SOURCE-TO-MACRO-IR SETM MD)
	 (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-MD
	  LAM-IR-SOURCE-TO-MACRO-IR 1
	  LAM-IR-SLOW-DEST 1)

         ;((MACRO-IR-DECODE) M-A)
	 (LAM-IR-OP LAM-OP-ALU
	  LAM-IR-OB LAM-OB-ALU
	  LAM-IR-ALUF LAM-ALU-SETM
	  LAM-IR-M-SRC M-A
	  LAM-IR-FUNC-DEST LAM-FUNC-DEST-MID
	  LAM-IR-SLOW-DEST 1)
	 
	 ;(JUMP 0)
	 (LAM-IR-OP LAM-OP-JUMP
	  LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
	  LAM-IR-JUMP-ADDR 0
	  LAM-IR-N 1)
	 ;()
	 (LAM-IR-SPARE-BIT 1)
	 )
  (SETUP-MACHINE-TO-START-AT 0)
  '(:SINGLE-UINST-MODE T :CSM-PRINTOUT T)
)


;stores NWDS words of "macroinstructions" starting at location 0.  The 16 bit
;macroinstructions are simply consecutive numbers.  The macroinstruction decode
;ram is loaded with (<consecutive numbers>*10)+100.  The "main instruction loop"
;is placed in low memory.  The "execute" routine for each macroinstruction
;consists of a compare of a counter (1@m) with the desired value, followed by incrementing
;the counter.  NWDS*2 A memory locations 100+n contain the constant N for use in these
;comparisions.
(DEFUN TEST-MACRO-FETCH-LOOP (&optional &key (enable-cache nil) (pkt-code 0) &AUX (NWDS 5))
  (DISABLE-LAMBDA)				
  (SETUP-RG-MODE)
  (FLD-STRAIGHT-MAP		;FAST-LOAD-STRAIGHT-MAP
    ':L2C-CONTENTS (DPB PKT-CODE (BYTE 2 11.)
			  (DPB (IF ENABLE-CACHE 1 0)
			       (BYTE 1 14.)
			       (DPB 3 (BYTE 2 8) 0))))
  (COND (ENABLE-CACHE (enable-cache)))
  (FORMAT T "~%straight virtual-to-physical memory map loaded, cache ~:[disabled~;enabled~]"
	  ENABLE-CACHE)
 ;  (RESET-MI)
 ;  (WRITE-CSM-REG-VIA-CSMRAM 0)
  (MEMORY-SETUP (SEND *PROC* :MEM-SLOT))
  ;initial data in main memory
  (DOTIMES (C NWDS)
    (IF (= C (- NWDS 2))
	(send *proc* :bus-slot-write (SEND *PROC* :MEM-SLOT) C -1)   ;EXTRA WORD OF -1'S
      (send *proc* :bus-slot-write (SEND *PROC* :MEM-SLOT) C (DPB (ASH (1+ (* 2 C)) 6) 2020 (ASH (* 2 C) 6)))))
  (fast-clear-mid)
  ;initialize data in MID
  (DOTIMES (C (* NWDS 2))
    (WRITE-MID C (+ 100 (* C 10))))
  (write-mid 1777 (+ 100 60))		;-1 S GO TO 400
  ;initialize A memory
  (DOTIMES (C (* 2 NWDS))
    (WRITE-A-MEM (+ C 100) C))
  (WRITE-A-MEM 20 (DPB 1 LAM-US-TOP-LEVEL-FLAG 10))	;return to main loop
  (WRITE-M-MEM 1 0)			;counter to compare against.
  (WRITE-USP 0)  			;initialize usp
  (WRITE-A-MEM 7000 (DPB 1 LAM-DISP-R-BIT 0))
  (INCREMENT-USP-AND-WRITE-US (DPB 1 LAM-US-TOP-LEVEL-FLAG 10))
  (WRITE-LC 0)				;initialize LC
  (ULOAD ()
    0	      (LAM-IR-OP LAM-OP-JUMP		;stray transfer
	       LAM-IR-JUMP-ADDR 0
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
    	      (LAM-IR-OP LAM-OP-ALU)
    2	      (LAM-IR-OP LAM-OP-JUMP		;bad page fault
	       LAM-IR-JUMP-ADDR 2
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
	      (LAM-IR-OP LAM-OP-ALU)
    4	      (LAM-IR-OP LAM-OP-JUMP		;bad compare at "macroinstruction"
	       LAM-IR-JUMP-ADDR 4
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
	      (LAM-IR-OP LAM-OP-ALU)
    6	      (LAM-IR-OP LAM-OP-JUMP		;a pop to get started
	       LAM-IR-N 1
	       LAM-IR-R 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
    	      (LAM-IR-OP LAM-OP-ALU)

    10   (LAM-IR-OP LAM-OP-JUMP			;main loop
	  LAM-IR-JUMP-ADDR 2
	  LAM-IR-N 1
	  LAM-IR-JUMP-COND LAM-JUMP-COND-PAGE-FAULT)
         (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-MD
	  LAM-IR-SOURCE-TO-MACRO-IR 1
	  LAM-IR-MACRO-IR-DISPATCH 1)
	 (LAM-IR-OP LAM-OP-ALU
	  LAM-IR-OB LAM-OB-ALU
	  LAM-IR-ALUF LAM-ALU-SETA
	  LAM-IR-A-SRC 20
	  LAM-IR-FUNC-DEST LAM-FUNC-DEST-MICRO-STACK-PUSH)
	 )
  (DOTIMES (C (* 2 NWDS))
  ;wds 0, 1 normal uinsts.
  ;wds 2, 3 return with POP
  ;wds 4, 5 return with dispatch
  ;wds 6, 7 are -1 opcodes.  microcode for hacking them produced below.
  ;wds 10  closes loop.
    (LET ((C-MEM-ADR (+ 100 (* C 10)))
	  (A-MEM-ADR (+ 100 C)))
      (COND ((or (< c 2)
		 (and (not (memq c '(2 3 4 5 6 7)))
		      (not (= C (- (* 2 NWDS) 1)))))
	     ;normal thing when nothing special.
	     (ULOAD (C-MEM-ADR A-MEM-ADR)
	      C-MEM-ADR
	        (LAM-IR-OP LAM-OP-JUMP   ;(jump-not-equal 1@m a-mem-adr illop)
		  LAM-IR-M-SRC 1
		  LAM-IR-A-SRC A-MEM-ADR
		  LAM-IR-JUMP-ADDR 4
		  LAM-IR-N 1
		  LAM-IR-JUMP-COND LAM-JUMP-COND-M-NEQ-A)
       		(LAM-IR-POPJ-AFTER-NEXT 1;(popj-after-next
		 LAM-IR-OP LAM-OP-ALU    ;  (1@m) m+1 1@m)
		 LAM-IR-OB LAM-OB-ALU
		 LAM-IR-M-SRC 1
		 LAM-IR-M-MEM-DEST 1
		 LAM-IR-ALUF LAM-ALU-M+1
		 LAM-IR-CARRY 1)
		(LAM-IR-OP LAM-OP-ALU)))
	    ((memq C '(2 3))
	     (ULOAD (C-MEM-ADR A-MEM-ADR)
	      C-MEM-ADR
	        (LAM-IR-OP LAM-OP-JUMP
		  LAM-IR-M-SRC 1
		  LAM-IR-A-SRC A-MEM-ADR
		  LAM-IR-JUMP-ADDR 4
		  LAM-IR-N 1
		  LAM-IR-JUMP-COND LAM-JUMP-COND-M-NEQ-A)
		(LAM-IR-OP LAM-OP-JUMP
		 LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
		 LAM-IR-R 1
		 LAM-IR-N 0)
       		(LAM-IR-OP LAM-OP-ALU
		 LAM-IR-OB LAM-OB-ALU
		 LAM-IR-M-SRC 1
		 LAM-IR-M-MEM-DEST 1
		 LAM-IR-ALUF LAM-ALU-M+1
		 LAM-IR-CARRY 1)
		(LAM-IR-OP LAM-OP-ALU)))
	    ((MEMQ C '(4 5))
	     (ULOAD (C-MEM-ADR A-MEM-ADR)
	      C-MEM-ADR
	        (LAM-IR-OP LAM-OP-JUMP
		  LAM-IR-M-SRC 1
		  LAM-IR-A-SRC A-MEM-ADR
		  LAM-IR-JUMP-ADDR 4
		  LAM-IR-N 1
		  LAM-IR-JUMP-COND LAM-JUMP-COND-M-NEQ-A)
		(LAM-IR-OP LAM-OP-DISPATCH
		 LAM-IR-ILONG 1
		 LAM-IR-DISP-BYTL 0
		 LAM-IR-DISP-ADDR 7000)
       		(LAM-IR-OP LAM-OP-ALU
		 LAM-IR-OB LAM-OB-ALU
		 LAM-IR-M-SRC 1
		 LAM-IR-M-MEM-DEST 1
		 LAM-IR-ALUF LAM-ALU-M+1
		 LAM-IR-CARRY 1)
		(LAM-IR-OP LAM-OP-ALU)))	     
	    ((MEMQ C '(6 7))
	     ;both -1's come here, so no test.
	     (ULOAD (C-MEM-ADR)
	      C-MEM-ADR
       		(LAM-IR-POPJ-AFTER-NEXT 1;(popj-after-next
		 LAM-IR-OP LAM-OP-ALU    ;  (1@m) m+1 1@m)
		 LAM-IR-OB LAM-OB-ALU
		 LAM-IR-M-SRC 1
		 LAM-IR-M-MEM-DEST 1
		 LAM-IR-ALUF LAM-ALU-M+1
		 LAM-IR-CARRY 1)
		(LAM-IR-OP LAM-OP-ALU)))
	    (T
	     (ULOAD (C-MEM-ADR)
	      C-MEM-ADR (LAM-IR-POPJ-AFTER-NEXT 1
			 LAM-IR-OP LAM-OP-ALU
			 LAM-IR-OB LAM-OB-ALU
			 LAM-IR-ALUF LAM-ALU-SETZ
			 LAM-IR-M-MEM-DEST 1		;zero check counter
			 LAM-IR-FUNC-DEST LAM-FUNC-DEST-LC)
	      		(LAM-IR-OP LAM-OP-ALU))))))
  (SETUP-MACHINE-TO-START-AT 6)		;start at initial pop
  '(:SINGLE-UINST-MODE T))

;--similar to above, but macroinstructions alternate low order bit wordwise,
; ie,  (1,,0) (2,,3) (5,,4) , etc.  This lets you see frobbing if you are looking
; at bit 6 of a macro-ir half.
;stores NWDS words of "macroinstructions" starting at location 0.  The 16 bit
;macroinstructions are simply consecutive numbers.  The macroinstruction decode
;ram is loaded with (<consecutive numbers>*10)+100.  The "main instruction loop"
;is placed in low memory.  The "execute" routine for each macroinstruction
;consists of a compare of a counter (1@m) with the desired value, followed by incrementing
;the counter.  NWDS*2 A memory locations 100+n contain the constant N for use in these
;comparisions.
(DEFUN TEST-MACRO-FETCH-LOOP-1 (&AUX (NWDS 4))
  (DISABLE-LAMBDA)				
  (SETUP-RG-MODE)
  (FAST-LOAD-STRAIGHT-MAP)
 ;  (RESET-MI)
 ;  (WRITE-CSM-REG-VIA-CSMRAM 0)
  (MEMORY-SETUP (SEND *PROC* :MEM-SLOT))
  ;initial data in main memory
  (DOTIMES (C NWDS)
    (send *proc* :bus-slot-write
	  (SEND *PROC* :MEM-SLOT) C (DPB (ASH (logxor (logand c 1) (1+ (* 2 C))) 6)
			  2020 (ASH (logxor (logand c 1) (* 2 C)) 6))))
  ;initialize data in MID
  (DOTIMES (C (* NWDS 2))
    (WRITE-MID C (+ 100 (* C 10))))

  ;initialize A memory
  (DOTIMES (C (* 2 NWDS))
    (WRITE-A-MEM (+ C 100) C))
  (WRITE-A-MEM 20 (DPB 1 LAM-US-TOP-LEVEL-FLAG 10))	;return to main loop
  (WRITE-M-MEM 1 0)			;counter to compare against.
  (WRITE-USP 0)  			;initialize usp
  (WRITE-A-MEM 7000 (DPB 1 LAM-DISP-R-BIT 0))
  (INCREMENT-USP-AND-WRITE-US (DPB 1 LAM-US-TOP-LEVEL-FLAG 10))
  (WRITE-LC 0)				;initialize LC
  (ULOAD ()
    0	      (LAM-IR-OP LAM-OP-JUMP		;stray transfer
	       LAM-IR-JUMP-ADDR 0
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
    	      (LAM-IR-OP LAM-OP-ALU)
    2	      (LAM-IR-OP LAM-OP-JUMP		;bad page fault
	       LAM-IR-JUMP-ADDR 2
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
	      (LAM-IR-OP LAM-OP-ALU)
    4	      (LAM-IR-OP LAM-OP-JUMP		;bad compare at "macroinstruction"
	       LAM-IR-JUMP-ADDR 4
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
	      (LAM-IR-OP LAM-OP-ALU)
    6	      (LAM-IR-OP LAM-OP-JUMP		;a pop to get started
	       LAM-IR-N 1
	       LAM-IR-R 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)
    	      (LAM-IR-OP LAM-OP-ALU)

    10   (LAM-IR-OP LAM-OP-JUMP			;main loop
	  LAM-IR-JUMP-ADDR 2
	  LAM-IR-N 1
	  LAM-IR-JUMP-COND LAM-JUMP-COND-PAGE-FAULT)
         (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-MD
	  LAM-IR-SOURCE-TO-MACRO-IR 1
	  LAM-IR-MACRO-IR-DISPATCH 1)
	 (LAM-IR-OP LAM-OP-ALU
	  LAM-IR-OB LAM-OB-ALU
	  LAM-IR-ALUF LAM-ALU-SETA
	  LAM-IR-A-SRC 20
	  LAM-IR-FUNC-DEST LAM-FUNC-DEST-MICRO-STACK-PUSH)
	 )
  (DOTIMES (C (* 2 NWDS))
  ;wds 0, 1 normal uinsts.
  ;wds 2, 3 return with POP
  ;wds 4, 5 return with dispatch
    (LET ((C-MEM-ADR (+ 100 (* C 10)))
	  (A-MEM-ADR (+ 100 (logxor C (logand 1 (lsh c -1))))))
      (COND ((or (< c 2)
		 (and (not (memq c '(2 3 4 5)))
		      (not (= C (- (* 2 NWDS) 1)))))
	     ;normal thing when nothing special.
	     (ULOAD (C-MEM-ADR A-MEM-ADR)
	      C-MEM-ADR
	        (LAM-IR-OP LAM-OP-JUMP		;(jump-not-equal m-1 a-mem-adr 4)
		  LAM-IR-M-SRC 1
		  LAM-IR-A-SRC A-MEM-ADR
		  LAM-IR-JUMP-ADDR 4
		  LAM-IR-N 1
		  LAM-IR-JUMP-COND LAM-JUMP-COND-M-NEQ-A)
       		(LAM-IR-POPJ-AFTER-NEXT 1
		 LAM-IR-OP LAM-OP-ALU
		 LAM-IR-OB LAM-OB-ALU
		 LAM-IR-M-SRC 1
		 LAM-IR-M-MEM-DEST 1
		 LAM-IR-ALUF LAM-ALU-M+1
		 LAM-IR-CARRY 1)
		(LAM-IR-OP LAM-OP-ALU)))
	    ((memq C '(2 3))
	     (ULOAD (C-MEM-ADR A-MEM-ADR)
	      C-MEM-ADR
	        (LAM-IR-OP LAM-OP-JUMP
		  LAM-IR-M-SRC 1
		  LAM-IR-A-SRC A-MEM-ADR
		  LAM-IR-JUMP-ADDR 4
		  LAM-IR-N 1
		  LAM-IR-JUMP-COND LAM-JUMP-COND-M-NEQ-A)
		(LAM-IR-OP LAM-OP-JUMP
		 LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
		 LAM-IR-R 1
		 LAM-IR-N 0)
       		(LAM-IR-OP LAM-OP-ALU
		 LAM-IR-OB LAM-OB-ALU
		 LAM-IR-M-SRC 1
		 LAM-IR-M-MEM-DEST 1
		 LAM-IR-ALUF LAM-ALU-M+1
		 LAM-IR-CARRY 1)
		(LAM-IR-OP LAM-OP-ALU)))
	    ((MEMQ C '(4 5))
	     (ULOAD (C-MEM-ADR A-MEM-ADR)
	      C-MEM-ADR
	        (LAM-IR-OP LAM-OP-JUMP
		  LAM-IR-M-SRC 1
		  LAM-IR-A-SRC A-MEM-ADR
		  LAM-IR-JUMP-ADDR 4
		  LAM-IR-N 1
		  LAM-IR-JUMP-COND LAM-JUMP-COND-M-NEQ-A)
		(LAM-IR-OP LAM-OP-DISPATCH
		 LAM-IR-ILONG 1
		 LAM-IR-DISP-BYTL 0
		 LAM-IR-DISP-ADDR 7000)
       		(LAM-IR-OP LAM-OP-ALU
		 LAM-IR-OB LAM-OB-ALU
		 LAM-IR-M-SRC 1
		 LAM-IR-M-MEM-DEST 1
		 LAM-IR-ALUF LAM-ALU-M+1
		 LAM-IR-CARRY 1)
		(LAM-IR-OP LAM-OP-ALU)))	     
	    (T
	     (ULOAD (C-MEM-ADR)
	      C-MEM-ADR (LAM-IR-POPJ-AFTER-NEXT 1
			 LAM-IR-OP LAM-OP-ALU
			 LAM-IR-OB LAM-OB-ALU
			 LAM-IR-ALUF LAM-ALU-SETZ
			 LAM-IR-M-MEM-DEST 1		;zero check counter
			 LAM-IR-FUNC-DEST LAM-FUNC-DEST-LC)
	      		(LAM-IR-OP LAM-OP-ALU))))))
  (SETUP-MACHINE-TO-START-AT 6)		;start at initial pop
  '(:SINGLE-UINST-MODE T))

;;; it's hard to say where this test should go...

; the problem is that when you do a dispatch, and the micro stack points
; to a word with the "TOP LEVEL" flag on, and you have POPJ-AFTER-NEXT, then
; the machine misteakenly fetchs a new macro instruction.

(defun test-bad-macro-ir-reload ()
  ;(popj-after-next dispatch (byte-field 1 0) md 0)
  (write-cram 0 4100007070000000140)
  (write-usp 377)
  (us-push 1000000)
  (write-lc 0)
  )


(defun test-mid-dispatch ()
  (disable-lambda)
  (FAST-CLEAR-MID)
  (WRITE-MID 1777 100)
  (ULOAD ()
     0	      (LAM-IR-OP LAM-OP-JUMP		;stray transfer
	       LAM-IR-JUMP-ADDR 0
	       LAM-IR-N 1
	       LAM-IR-JUMP-COND LAM-JUMP-COND-UNC)

    100
    LOOP  (LAM-IR-OP LAM-OP-ALU ;((md) setz)
	   LAM-IR-OB LAM-OB-ALU
	   LAM-IR-ALUF LAM-ALU-SETZ
	   LAM-IR-FUNC-DEST LAM-FUNC-DEST-MD)
	  (LAM-IR-OP LAM-OP-ALU ;(() md load-macro-ir)
	   LAM-IR-OB LAM-OB-ALU
	   LAM-IR-ALUF LAM-ALU-SETM
	   LAM-IR-M-SRC LAM-M-SRC-MD
	   LAM-IR-SOURCE-TO-MACRO-IR 1)				       
	  (LAM-IR-OP LAM-OP-ALU		;((md) seto)
	   LAM-IR-OB LAM-OB-ALU
	   LAM-IR-ALUF LAM-ALU-SETO
	   LAM-IR-FUNC-DEST LAM-FUNC-DEST-MD)
	  (LAM-IR-OP LAM-OP-ALU		;(() md load-macro-ir macro-ir-dispatch)
	   LAM-IR-OB LAM-OB-ALU
	   LAM-IR-ALUF LAM-ALU-SETM
	   LAM-IR-M-SRC LAM-M-SRC-MD
	   LAM-IR-SOURCE-TO-MACRO-IR 1
	   LAM-IR-MACRO-IR-DISPATCH 1)
	  (LAM-IR-OP LAM-OP-ALU	          ;((us-data-push) setz)
	   LAM-IR-OB LAM-OB-ALU
	   LAM-IR-ALUF LAM-ALU-SETZ
	   LAM-IR-FUNC-DEST LAM-FUNC-DEST-MICRO-STACK-PUSH)
   )
  (SETUP-MACHINE-TO-START-AT 100)		;start at initial pop
  '(:SINGLE-UINST-MODE T))

(defun read-mid-via-d-bus (adr)
  (write-macro-ir-both-halves (ash adr 6.))
  (lam-execute (uinst-clock)
	       LAM-IR-OP LAM-OP-ALU
	       LAM-IR-OB LAM-OB-ALU
	       LAM-IR-MACRO-IR-DISPATCH 1)
  (read-pc))

(DEFUN UINST-WRITE-MID-TEST-LOOP-1 (adr data-1 data-2 &AUX (A-data-1 1)
				    (a-data-2 2)  (mid-loc 3) )
  (WRITE-M-MEM A-data-1 (logand 177777 data-1))
  (write-m-mem a-data-2 (logand 177777 data-2))
  (WRITE-M-MEM MID-LOC (ash adr 6))	;
  (ULOAD (A-data-1 a-data-2  mid-loc)
   0
	 ;((MD) DPB M-MID-LOC (BYTE-FIELD 20 20) A-MID-LOC)
	 (LAM-IR-OP LAM-OP-BYTE
	  LAM-IR-BYTL-1 17
	  LAM-IR-MROT 20
	  LAM-IR-BYTE-FUNC LAM-BYTE-FUNC-DPB
	  LAM-IR-A-SRC mid-loc
	  LAM-IR-M-SRC mid-loc
	  LAM-IR-FUNC-DEST LAM-FUNC-DEST-MD
	  LAM-IR-SLOW-DEST 1)

	 ;(SOURCE-TO-MACRO-IR SETM MD)
	 (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-MD
	  LAM-IR-SOURCE-TO-MACRO-IR 1
	  LAM-IR-SLOW-DEST 1)

         ;((MACRO-IR-DECODE) a-data-1)
	 (LAM-IR-OP LAM-OP-ALU
	  LAM-IR-OB LAM-OB-ALU
	  LAM-IR-ALUF LAM-ALU-SETM
	  LAM-IR-M-SRC a-data-1
	  LAM-IR-FUNC-DEST LAM-FUNC-DEST-MID
	  LAM-IR-SLOW-DEST 1)

	 (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-mid
	  lam-ir-m-mem-dest 5)

	 (lam-ir-op lam-op-jump
	  lam-ir-jump-addr error1
	  lam-ir-jump-cond lam-jump-cond-m-neq-a
	  lam-ir-m-src 5
	  lam-ir-a-src a-data-1
	  lam-ir-n 1)

;	 (LAM-IR-OP LAM-OP-BYTE
;	  LAM-IR-BYTL-1 17
;	  LAM-IR-MROT 20
;	  LAM-IR-BYTE-FUNC LAM-BYTE-FUNC-DPB
;	  LAM-IR-A-SRC mid-loc
;	  LAM-IR-M-SRC mid-loc
;	  LAM-IR-FUNC-DEST LAM-FUNC-DEST-MD
;	  LAM-IR-SLOW-DEST 1)

;	 (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-MD
;	  LAM-IR-SOURCE-TO-MACRO-IR 1
;	  LAM-IR-SLOW-DEST 1)

	 (LAM-IR-OP LAM-OP-ALU
	  LAM-IR-OB LAM-OB-ALU
	  LAM-IR-ALUF LAM-ALU-SETM
	  LAM-IR-M-SRC a-data-2
	  LAM-IR-FUNC-DEST LAM-FUNC-DEST-MID
	  LAM-IR-SLOW-DEST 1)

	 (lam-ir-op lam-op-alu
	  lam-ir-ob lam-ob-alu
	  lam-ir-aluf lam-alu-setm
	  lam-ir-m-mem-dest 6
	  lam-ir-m-src lam-m-src-mid)

	 (lam-ir-op lam-op-jump
	  lam-ir-jump-addr error2
	  lam-ir-jump-cond lam-jump-cond-m-neq-a
	  lam-ir-m-src 6
	  lam-ir-a-src a-data-2
	  lam-ir-n 1)
	 
	 ;(JUMP 0)
	 (LAM-IR-OP LAM-OP-JUMP
	  LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
	  LAM-IR-JUMP-ADDR 0
	  LAM-IR-N 1)
	 ;()
	 (LAM-IR-SPARE-BIT 1)

	 error1
	 (lam-ir-halt 1)

	 (lam-ir-halt 1)
	 error2
	 (lam-ir-halt 1)
	 
	 (lam-ir-halt 1)
	 )
  (SETUP-MACHINE-TO-START-AT 0)
  '(:SINGLE-UINST-MODE T :CSM-PRINTOUT T)
)

(defun test-mid-slow-speed (address data)
  (WRITE-MACRO-IR-BOTH-HALVES (ASH ADDRESS 6) T)	;in both halves
  (WRITE-SPY-REG-AND-CHECK DATA)
  (do ()(())
    (LAM-EXECUTE (uinst-clock-plus-uinst-clock-low)	;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-MID
		 LAM-IR-SLOW-DEST 1
		 LAM-IR-ALUF LAM-ALU-SETM)))