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

;DEFINITIONS OF VARIOUS WORD FORMATS, FOR BOTH TYPE-OUT AND TYPE-IN

(DEFVAR *DONT-TOUCH-MACHINE* NIL
  "Don't affect machine if T.
Otherwise, print out contents of A mem register addressed as constant by UINST, for example.")

(DEFVAR *NUMERIC-PRINTOUT-ONLY* NIL "Make no attempt to use symbols if T")

(DECLARE (SPECIAL SG-NAME %%ARRAY-NAMED-STRUCTURE-FLAG %%ARRAY-LEADER-BIT))

(DEFCONST LAM-MODE-DESC-TABLE '((H . LAM-HWD-DESC) (B . LAM-BYTE-DESC)
			       (Q . LAM-Q-DESC) (A . LAM-A-DESC) (/_ . LAM-REG-ADDR-DESC)
			       (I . LAM-INST-DESC) (T . LAM-ASCII-BYTE-DESC)
			       (U . LAM-UINST-DESC)
			       ;(V . LAM-O-UINST-DESC)
			       (S . LAM-SEXP-DESC)
			       (/# . LAM-BITS-DESC)
			       (N . LAM-SIGNED-WORD-DESC)
			       (X . lam-hex-desc)
			       (d . lam-header-desc)
			       (v . lam-pht1-desc)
			       (p . lam-pht2-desc)
			       ( { . lam-pq1-desc) ( } . lam-pq2m-desc)
			       ( < . lam-pt1-desc) ( > . lam-pt2-desc)
			       ( + . lam-quantum-number-of-address)
			       ( o . lam-disk-address-decode)
			       ))


(DECLARE (SPECIAL LAM-LOW-LEVEL-FLAG))

(DECLARE (SPECIAL LAM-SYMBOLS-SIZE LAM-SYMBOLS-NAME))

;DESC "LANGUAGE"
; (TYPE LITERAL)
;	type out specified atom.  All frobs typed are followed by space.
; (CTYPE LITERAL)
;	same, but no separating spaces before or after, and uses PRINC.
; (SELECT-FIELD <FIELD-NAME> <FIELD-POSITION> <SYMBOLS FOR CONSECUTIVE VALUES>)
;	value of field selects element of list, which is symbolic name or
;		NIL -> null typeout, and this value is the default on input.
;		T  -> numeric typeout of value.  For values that aren't expected.
;		A list can appear instead of a symbol, containing
;		alternate names.  NIL can be one of them, making that value the
;		default on input.  For type out, if NIL is present in the list
;		then nothing is typed.  The first element of the list
;		is used to tell you what you got if you got it as the default.
; (TYPE-FIELD <FIELD-NAME> <FIELD-POSITION> <REGISTER-ADR OFFSET> <bypass-zero-check>)
;       This is two things in one:
;	 If <REGISTER-ADR OFFSET> is NIL, then the field's contents are a number.
;	 Otherwise, <REGISTER-ADR OFFSET> should be RAAMO, RAMMO, RACMO, RAFDO, etc.
;	 and the contents are a register, which should be handled symbolically.
;	On typeout, if field has zero value, does nothing unless <bypass-zero-check> no-NIL.
; (NUM <FIELD-POSITION> [BASE])
;	pure numeric field, prompting with "#: ".
;       BASE is optional, and defaults to 8.  Only implemented for typeout at the moment.
; (SIGNED-NUM <FIELD-POSITION>) by special hack, it allows fields bigger than fixnum size.
; (SUB-FIELD <DESCRIPTION-NAME>)
;	call sub-description.
; (COND <FIELD-NAME> <FIELD-POSITION> <LIST-OF-DESCRIPTIONS>)
;	value of field selects element of list, do SUB-FIELD call to it.
; (CONSTANT <FIELD-POSITION> <VALUE>)
;	on type-in this constant is added in.
; (CALL <FUNCTION> <FIELD-POSITION> . <ITEMREST>)
;	for type-out, the function is called with 3 args.
;	1st arg is field value.
;	2nd arg is whole word
;	3nd arg is <ITEMREST>.
;	For input, <FUNCTION> should have an INPUT property which is the
;	function to use for input.
;	1st arg is the value accumulated so far.
;	2nd arg is WD-BITS-SET, a mask with 1's in the bits whose values are known as yet.
;	3rd arg is T if this is changing fields in the previous quantity.
;	4th arg is the CDDR of the item, or (<FIELD-POSITION> . <ITEMREST>).
; (IF-EQUAL <FIELD-NAME> <POSITION> <COMPARED-WITH> <DESC-IF-EQUAL> <DESC-IF-NOT>)
;	This is like COND on typeout, except that it is a two way dispatch
;	which compares a field's contents against a single distinguished value.
;	The two DESC arguments should be desc lists or names of such.
;	On input, if the field is already known, the appropriate branch is taken;
;	otherwise, it is required that one of the branches be nil, and the
;	other one is taken (always).
; (INPUT . <DESCS>)
;	the descriptors <DESCS> are processed only on input.
; (OUTPUT . <DESCS>)
;	the descriptors <DESCS> are processed only on output.
; (BITS)  typeout only, type bit numbers of set bits.

(DEFVAR LAM-REG-ADDR-DESC NIL)
(DEFCONST LAM-REG-ADDR-DESC-24 '( (CALL LAM-PRINT-ADDRESS-1 0030) ))
(DEFCONST LAM-REG-ADDR-DESC-25 '( (CALL LAM-PRINT-ADDRESS-1 0031) ))

(DEFCONST LAM-BITS-DESC '( (BITS)))

(DEFCONST LAM-SIGNED-WORD-DESC '( (SIGNED-NUM 0040)))

(defconst lam-hex-desc '( (num 0040 16.)))

(DEFCONST LAM-HWD-DESC '( (NUM 2020) (CTYPE /,/,) (NUM 0020)))

(DEFCONST LAM-BYTE-DESC '( (NUM 0010) (CTYPE /,) (NUM 1010) (CTYPE /,)
			 (NUM 2010) (CTYPE /,) (NUM 3010)))

(DEFCONST LAM-ASCII-BYTE-DESC '( (CHAR 0010) (CHAR 1010)
			       (CHAR 2010) (CHAR 3010)))

(defconst lam-header-desc '( (select-field header-type 2305 
			      (%HEADER-TYPE-ERROR %HEADER-TYPE-FEF %HEADER-TYPE-ARRAY-LEADER
			       %HEADER-TYPE-LIST %HEADER-TYPE-FLONUM %HEADER-TYPE-COMPLEX
			       %HEADER-TYPE-BIGNUM %HEADER-TYPE-RATIONAL
			       %HEADER-TYPE-FAST-FEF-FIXED-ARGS-NO-LOCALS
			       %HEADER-TYPE-FAST-FEF-VAR-ARGS-NO-LOCALS
			       %HEADER-TYPE-FAST-FEF-FIXED-ARGS-WITH-LOCALS
			       %HEADER-TYPE-FAST-FEF-VAR-ARGS-WITH-LOCALS
			       ))))

(DEFVAR LAM-SEXP-DESC NIL)
(DEFCONST LAM-SEXP-DESC-24 '( (CALL LAM-Q-PRINT-TOPLEV-1 0035) ))
(DEFCONST LAM-SEXP-DESC-25 '( (CALL LAM-Q-PRINT-TOPLEV-1 0036) ))


(DEFVAR LAM-Q-DESC NIL)
(DEFCONST LAM-Q-DESC-24 '( (SELECT-FIELD CDR 3602 (NIL CDR-TRAP CDR-NIL CDR-NEXT))
		      (SELECT-FIELD FLAG-BIT 3501 (NIL FLAG-BIT))
		      (SELECT-FIELD DATA-TYPE 3005
		       (NIL NULL FREE SYMBOL SYMBOL-HEADER FIX EXTENDED-NUMBER HEADER
			GC-FORWARD EXTERNAL-VALUE-CELL-POINTER ONE-Q-FORWARD
			HEADER-FORWARD BODY-FORWARD
			   LOCATIVE LIST U-ENTRY FEF-POINTER
			ARRAY-POINTER ARRAY-HEADER STACK-GROUP CLOSURE SMALL-FLONUM
		            SELECT-METHOD INSTANCE INSTANCE-HEADER
			ENTITY STACK-CLOSURE SELF-REF-POINTER T T T T T))
		      (NUM 0030)))

(DEFCONST LAM-Q-DESC-25 '((SELECT-FIELD CDR 3602 (NIL CDR-TRAP CDR-NIL CDR-NEXT))
			 (SELECT-FIELD DATA-TYPE 3105
			  (NIL NULL FREE SYMBOL SYMBOL-HEADER FIX EXTENDED-NUMBER HEADER
			   GC-FORWARD EXTERNAL-VALUE-CELL-POINTER ONE-Q-FORWARD
			   HEADER-FORWARD BODY-FORWARD
			      LOCATIVE LIST U-ENTRY FEF-POINTER
			   ARRAY-POINTER ARRAY-HEADER STACK-GROUP CLOSURE SMALL-FLONUM
			       SELECT-METHOD INSTANCE INSTANCE-HEADER
			   ENTITY STACK-CLOSURE SELF-REF-POINTER CHARACTER rplacd-forward T T T))
			 (NUM 0031)))

(DEFCONST LAM-Q-DESC-25-0 '((SELECT-FIELD CDR 3602 (cdr-next cdr-error cdr-normal cdr-nil))
			 (SELECT-FIELD DATA-TYPE 3105
			  (NIL NULL FREE SYMBOL SYMBOL-HEADER FIX EXTENDED-NUMBER HEADER
			   GC-FORWARD EXTERNAL-VALUE-CELL-POINTER ONE-Q-FORWARD
			   HEADER-FORWARD BODY-FORWARD
			      LOCATIVE LIST U-ENTRY FEF-POINTER
			   ARRAY-POINTER ARRAY-HEADER STACK-GROUP CLOSURE SMALL-FLONUM
			       SELECT-METHOD INSTANCE INSTANCE-HEADER
			   ENTITY STACK-CLOSURE SELF-REF-POINTER CHARACTER rplacd-forward T T T))
			 (NUM 0031)))

(DEFCONST lam-pht1-desc '((type virtual-page)
			  (num 1021)
			  (select-field scav-ws 0701 (nil scav-ws))
			  (select-field valid 0601 (not-valid valid))
			  (select-field modified 0501 (nil modified))
			  (select-field age 0302 (nil age-1 age-2 age-3))
			  (select-field swap-status 0003
					(empty normal flushable prepage age-trap wired
						t t))))

(defconst lam-pht2-desc '((type phys-page)
			  (num 0026)
			  (select-field volatility 2602 (nil v1 v2 v3))
			  (select-field rep-type 3002 (list struct both t))
			  (select-field extra-pdl 3201 (extra-pdl nil))
			  (select-field old 3301 (old nil))
			  (select-field status 3403 
					(map-not-valid meta-only read-only read-write-first
					 read-write pdl-buffer mar physical))
			  (select-field access 3602
					(no-access no-access-and-write
					 read-only read-write))))

(DEFCONST LAM-A-DESC '( (CONSTANT 3005 2)	;ARRAY-HEADER DATA-TYPE
		      (SELECT-FIELD ARRAY-TYPE 2305
		       (T ART-1B ART-2B ART-4B ART-8B ART-16B ART-32B ART-Q 
			ART-Q-LIST ART-STRING ART-STACK-GROUP-HEAD ART-SPECIAL-PDL 
			ART-TVB ART-REG-PDL T T T T T T T T T T T T T T T T T T))
		   (SELECT-FIELD HIGH-SPARE-BIT 2201 (NIL HIGH-SPARE-BIT))
		   (SELECT-FIELD LEADER 2101 (NIL LEADER))
		   (SELECT-FIELD DISPLACED 2001 (NIL DISPLACED))
		   (SELECT-FIELD FLAG 1701 (NIL FLAG))
		   (TYPE-FIELD /#DIMS 1403 NIL)
		   (SELECT-FIELD LONG 1301 (NIL LONG))
		   (SELECT-FIELD SPARE-BIT 1201 (NIL SPARE-BIT))
		   (TYPE-FIELD INDEX-LENGTH 0012 NIL)))

(defvar lam-inst-desc nil)
(DEFCONST LAM-INST-DESC-24 '( (SELECT-FIELD OP-CODE 1104
		       (CALL CALL0 MOVE CAR
			CDR CADR CDDR CDAR
			CAAR NIL NIL NIL
			NIL MISC T T))
		      (COND OP-CODE 1104 (LAM-I-DEST-DESC LAM-I-DEST-DESC LAM-I-DEST-DESC 
			LAM-I-DEST-DESC LAM-I-DEST-DESC LAM-I-DEST-DESC 
			LAM-I-DEST-DESC LAM-I-DEST-DESC LAM-I-DEST-DESC 
			LAM-I-11-DESC LAM-I-12-DESC LAM-I-13-DESC
			LAM-I-BR-DESC LAM-I-DEST-DESC NIL NIL))
		      (COND SUB-OP 1104 (LAM-I-ADDR-DESC LAM-I-ADDR-DESC LAM-I-ADDR-DESC 
			LAM-I-ADDR-DESC LAM-I-ADDR-DESC LAM-I-ADDR-DESC 
			LAM-I-ADDR-DESC LAM-I-ADDR-DESC LAM-I-ADDR-DESC 
			LAM-I-ADDR-DESC LAM-I-ADDR-DESC LAM-I-ADDR-DESC 
			NIL LAM-I-15-DESC NIL NIL))))

(DEFCONST LAM-INST-DESC-25 '( (SELECT-FIELD OP-CODE 1105
		       (CALL CALL0 MOVE CAR
			CDR CADR CDDR CDAR
			CAAR NIL NIL NIL
			NIL MISC QIND4 T
			AREFI-NEW QIND5 T T
			T T T T
			T NIL NIL NIL
			NIL MISC1 QIND4 T))
		      (COND OP-CODE 1105 (LAM-I-DEST-DESC LAM-I-DEST-DESC LAM-I-DEST-DESC 
			LAM-I-DEST-DESC LAM-I-DEST-DESC LAM-I-DEST-DESC 
			LAM-I-DEST-DESC LAM-I-DEST-DESC LAM-I-DEST-DESC 
			LAM-I-11-DESC LAM-I-12-DESC LAM-I-13-DESC
			LAM-I-BR-DESC LAM-I-DEST-DESC LAM-I-16-DESC NIL
			LAM-I-DEST-DESC LAM-I-21-DESC NIL NIL NIL NIL NIL NIL NIL
			LAM-I-11-DESC LAM-I-12-DESC LAM-I-13-DESC
			LAM-I-BR-DESC LAM-I-DEST-DESC LAM-I-16-DESC NIL))
		      (COND SUB-OP 1105 (LAM-I-ADDR-DESC LAM-I-ADDR-DESC LAM-I-ADDR-DESC 
			LAM-I-ADDR-DESC LAM-I-ADDR-DESC LAM-I-ADDR-DESC 
			LAM-I-ADDR-DESC LAM-I-ADDR-DESC LAM-I-ADDR-DESC 
			LAM-I-ADDR-DESC LAM-I-ADDR-DESC LAM-I-ADDR-DESC 
			NIL LAM-I-15-DESC LAM-I-16-ADDR-DESC NIL
			LAM-I-20-ADDR-DESC LAM-I-ADDR-DESC NIL NIL NIL NIL NIL NIL NIL
			LAM-I-ADDR-DESC LAM-I-ADDR-DESC LAM-I-ADDR-DESC NIL
			LAM-I-35-DESC LAM-I-16-ADDR-DESC NIL))))

(defvar lam-i-dest-desc nil)
(DEFCONST LAM-I-DEST-DESC-24 '( (SELECT-FIELD DEST 1503
			  (IGNORE CODE-1 PDL CODE-3
			   RETURN CODE-5 LAST CODE-7))
))
(DEFCONST LAM-I-DEST-DESC-25 '( (SELECT-FIELD DEST 1602
			  (IGNORE PDL RETURN LAST))
))

(DEFCONST LAM-I-ADDR-DESC '( (COND ADR-TYPE 1001 (LAM-I-ADDR-F-DESC LAM-I-ADDR-R-DESC))
))

(DEFCONST LAM-I-ADDR-F-DESC '( (TYPE FEF) (NUM 0010) ))

(DEFCONST LAM-I-ADDR-R-DESC '( (SELECT-FIELD ADR 0602 (QTPG LCL ARG PDL))
			     (NUM 0006)))

(DEFCONST LAM-I-16-ADDR-DESC '( (COND SUBOP 1503 (LAM-I-IMMED-ADDR-DESC LAM-I-IMMED-ADDR-DESC 
  LAM-I-IMMED-ADDR-DESC LAM-I-IMMED-ADDR-DESC LAM-I-IMMED-ADDR-DESC 
  LAM-I-ADDR-DESC LAM-I-ADDR-DESC T))
))

(DEFCONST LAM-I-IMMED-ADDR-DESC '( (NUM 0011)))

(DEFCONST LAM-I-20-ADDR-DESC '( (NUM 0011)))	;AREFI-NEW.  TEMP.

(DEFCONST LAM-I-21-DESC '( (SELECT-FIELD OP 1602
			     (1+ 1- T T))
			  ))

(DEFCONST LAM-I-BR-DESC '( (SELECT-FIELD BRANCH 1503
		       (BR BR-NIL BR-NOT-NIL BR-NIL-OR-POP
			BR-NOT-NIL-OR-POP BR-ATOM BR-NOT-ATOM T))
		      (NUM 0011)  ;FOR NOW, DOESN'T INTERPRET BRANCH DELTA
))

(DEFCONST LAM-I-11-DESC '( (SELECT-FIELD OP 1503
			(T + - * // LOGAND LOGXOR LOGIOR))
))

(DEFCONST LAM-I-12-DESC '( (SELECT-FIELD OP 1503
			(= > < EQ SCDR SCDDR 1+ 1-))
))

(DEFCONST LAM-I-13-DESC '( (SELECT-FIELD OP 1503
			(BIND BINDNIL BINDPOP SETNIL SETZERO PUSH-E MOVEM POP))
))

(DEFCONST LAM-I-15-DESC '( (TYPE-FIELD MISC-OP 0011 NIL)
		      (OUTPUT (CALL LAM-I-MISC-NAME 0011)) ))	

(DEFCONST LAM-I-35-DESC '( (TYPE-FIELD MISC1-OP 0011 NIL)
		      (OUTPUT (CALL LAM-I-MISC1-NAME 0011)) ))

(DEFCONST LAM-I-16-DESC '( (SELECT-FIELD OP 1503
			(STACK-CLOSURE-DISCONNECT STACK-CLOSURE-UNSHARE MAKE-STACK-CLOSURE
			 PUSH-NUMBER STACK-CLOSURE-DISCONNECT-FIRST
			 PUSH-CDR-IF-CAR-EQUAL
			 PUSH-CDR-STORE-CAR-IF-CONS
			 T))
))

(DEFUN LAM-I-MISC-NAME (DISP IGNORE IGNORE)
  (COND ((< DISP 200)
	 (FORMAT T "~A (~D.) "
		 (NTH (LDB 0403 DISP)
		      '(AR-1 ARRAY-LEADER %INSTANCE-REF ???
			AS-1 STORE-ARRAY-LEADER %INSTANCE-SET ???))
		 (+ (LDB 0004 DISP)
		    (IF (= (LDB 0403 DISP) 2) 1 0))))
	((< DISP 220) (FORMAT T "UNBIND ~D bindings " (- DISP 177)))
	((< DISP 240) (FORMAT T "POP-PDL ~D times " (- DISP 217)))
	(T
	 (LET ((OP (SYS:MICRO-CODE-SYMBOL-NAME-AREA (- DISP 200))))  ;uses local machine's
	       (COND (OP (FORMAT T "~A " OP)))))))                   ; context.

(DEFUN LAM-I-MISC1-NAME (DISP IGNORE IGNORE)
  (LET ((OP (SYS:MICRO-CODE-SYMBOL-NAME-AREA (- (+ DISP 1000) 200))))  ;uses local machine's
    (COND (OP (FORMAT T "~A " OP)))))                   ; context.


;Functions used by the descriptors for _U output and input.

;(CALL LAM-BYTE-FIELD-OUT 00nn always-reflect-mrot length-is-minus-one)
;nn should be 05 for a jump insn where the length minus one is zero.
;nn it is 12 for a byte insn which has 5 bits of mrot and 5 bits of length minus one.
(DEFPROP LAM-BYTE-FIELD-OUT LAM-BYTE-FIELD-IN INPUT)
(DEFUN LAM-BYTE-FIELD-OUT (VAL WD ITEMREST)
    (FORMAT T "(Byte-field ")
    (PRIN1-THEN-SPACE
       (COND ((CADR ITEMREST)
	      (1+ (LDB 0606 VAL)))
	     (T (LDB 0606 VAL))))
    (LET ((TEM (LDB 0006 VAL)))
	 (COND ((ZEROP TEM))
	       ((OR (CAR ITEMREST) (= 1 (LDB LAM-IR-BYTE-FUNC WD)))
		(SETQ TEM (- 32. TEM))))
	 (PRIN1 TEM))
    (FORMAT T " ) "))

(DEFUN LAM-BYTE-FIELD-IN (WD WD-BITS-SET TYPE-OVER ITEMREST)
  (PROG (TEM FIELD)
    (FORMAT T "(Byte-field ")
    (SETQ FIELD (COND ((SYMBOLP (CAR ITEMREST))
		       (SYMEVAL (CAR ITEMREST)))
		      (T (CAR ITEMREST))))
    (COND ((= FIELD 0006) (PRINC '|WIDTH 1 |))
	  (T
	   (SETQ TEM (LDB 0606 (LDB FIELD WD)))
	   (AND (CADDR ITEMREST) (SETQ TEM (1+ TEM)))
	   (SETQ TEM (LAM-TYPE-IN '((TYPE-FIELD WIDTH 0006 NIL))
				 (COND (TYPE-OVER
					TEM)
				       (T 0))
				 TYPE-OVER))
	   ;(TYO 10) (TYO 10) (TYO 10) (TYO 10)
	   (AND (CADDR ITEMREST) (SETQ TEM (1- TEM)))
	   (SETQ WD (DPB (LDB FIELD (DPB TEM 0606 WD))
			    FIELD WD))
	   (SETQ WD-BITS-SET (DPB (LDB FIELD (DPB -1 0606 WD-BITS-SET))
				     FIELD WD-BITS-SET))))
    (SETQ TEM (LAM-TYPE-IN '((TYPE-FIELD POSITION 0006 NIL))
			  (COND ((NOT TYPE-OVER) 0)
				((OR (CADR ITEMREST) (= 1 (LDB LAM-IR-BYTE-FUNC WD)))
				 (LOGAND 37 (- 40 (LDB 0006 WD))))
				(T (LDB 0006 WD)))
			  TYPE-OVER))
    ;(TYO 10) (TYO 10) (TYO 10) (TYO 10)
    
    (COND ((OR (CADR ITEMREST) (= 1 (LDB LAM-IR-BYTE-FUNC WD)))
	   (SETQ TEM (- 32. TEM))))
    (SETQ WD (DPB TEM 0006 WD))
    (SETQ WD-BITS-SET (DPB -1 0006 WD-BITS-SET))
    (PRINC '|) |)
    (RETURN (LIST WD WD-BITS-SET))))

;(CALL LAM-BYTE-FIELD-OUT 00nn always-reflect-mrot length-is-minus-one)
;nn should be 05 for a jump insn where the length minus one is zero.
;nn it is 12 for a byte insn which has 5 bits of mrot and 5 bits of length minus one.
;
;this function depends on the byte-spec being right aligned in the uinst
(DEFUN LAM-BYTE-FIELD-OUT-explorer (VAL WD ITEMREST)
  val
    (FORMAT T "(Byte-field ")
    (format t "~a " (ldb rav-ir-rotation-length wd))

    (cond ((zerop (ldb rav-ir-rotate-right wd))
	   (let ((count (ldb rav-ir-rotation-count wd)))
	     (cond ((zerop count))
		   ((or (car itemrest) ;always-reflect-mrot
			(= (ldb rav-ir-byte-func wd) rav-byte-func-ldb))
		    (setq count (- 32. count))))
	     (format t "~a" count)))
	  (t
	   (format t "rotated-right...can't-tell")))
    (format t " ) "))

(DEFPROP LAM-BYTE-FIELD-OUT-explorer LAM-BYTE-FIELD-IN-explorer INPUT)
(DEFUN LAM-BYTE-FIELD-IN-explorer (WD WD-BITS-SET TYPE-OVER ITEMREST)
  (PROG (TEM FIELD)
    (FORMAT T "(Byte-field ")
    (SETQ FIELD (COND ((SYMBOLP (CAR ITEMREST))
		       (SYMEVAL (CAR ITEMREST)))
		      (T (CAR ITEMREST))))
    (COND ((= FIELD com-ir-rotation-count) (format t "WIDTH 1 "))
	  (T
	   (SETQ TEM (LDB com-ir-rotation-length (LDB FIELD WD)))
	   (AND (eq *target-processor-type* :lambda) (CADDR ITEMREST) (SETQ TEM (1+ TEM)))
	   (SETQ TEM (LAM-TYPE-IN '((TYPE-FIELD WIDTH com-ir-rotation-count NIL))
				  (COND (TYPE-OVER
					 TEM)
					(T 0))
				  TYPE-OVER))
	   (AND (eq *target-processor-type* :lambda) (CADDR ITEMREST) (SETQ TEM (1- TEM)))
	   (SETQ WD (DPB (LDB FIELD (DPB TEM com-ir-rotation-length WD))
			 FIELD WD))
	   (SETQ WD-BITS-SET (DPB (LDB FIELD (DPB -1 com-ir-rotation-length WD-BITS-SET))
				  FIELD WD-BITS-SET))))
    (SETQ TEM (LAM-TYPE-IN '((TYPE-FIELD POSITION com-ir-rotation-count NIL))
			   (COND ((NOT TYPE-OVER) 0)
				 ((OR (CADR ITEMREST) (= 1 (LDB com-IR-BYTE-FUNC WD)))
				  (LOGAND 37 (- 40 (LDB com-ir-rotation-count WD))))
				 (T (LDB com-ir-rotation-count WD)))
			   TYPE-OVER))
    
    (COND ((OR (CADR ITEMREST) (= 1 (LDB com-IR-BYTE-FUNC WD)))
	   (SETQ TEM (- 32. TEM))))
    (SETQ WD (DPB TEM com-ir-rotation-count WD))
    (SETQ WD-BITS-SET (DPB -1 com-ir-rotation-count WD-BITS-SET))
    (format t ") ")
    (RETURN (LIST WD WD-BITS-SET))))

(DEFUN LAM-TYPE-JUMP-CONDITION (IGNORE1 NUMBER IGNORE2)
  IGNORE1 IGNORE2
  (PROG (TEM)
    (PRINC (NTH (LDB LAM-IR-JUMP-CALL-RETURN NUMBER) '(JUMP CALL POPJ CALL-POPJ-??)))
    (COND ((ZEROP (LDB LAM-IR-JUMP-TEST-CONDITION NUMBER))
	   (PRINC '|-IF-BIT-|)
	   (COND ((ZEROP (LDB LAM-IR-JUMP-INVERT-CONDITION NUMBER))
		  (PRINC 'SET))
		 (T (PRINC 'CLEAR)))
	   (COND ((ZEROP (LDB LAM-IR-N NUMBER))
		  (PRINC '|-XCT-NEXT|)))
	   (PRINC '| (BYTE-FIELD 1 |)
	   (PRIN1 (- 32. (LOGAND 37 NUMBER)))
	   (PRINC '|)|))
	  (T
	   (SETQ TEM (NTH (COND ((ZEROP (LDB LAM-IR-JUMP-INVERT-CONDITION NUMBER))
				 (LDB LAM-IR-JUMP-COND-LOW NUMBER))
				(T (+ 20 (LDB LAM-IR-JUMP-COND-LOW NUMBER))))
	;-equal, -page-fault reversed from CADR so far.
			  '(T -LESS-THAN -LESS-OR-EQUAL -NOT-EQUAL
			      -IF-NO-PAGE-FAULT -IF-PAGE-FAULT-OR-INTERRUPT
			      -IF-SEQUENCE-BREAK NIL
			    nil -DATA-TYPE-NOT-EQUAL nil nil  nil nil nil nil
			      T -GREATER-OR-EQUAL -GREATER-THAN -EQUAL
			      -IF-PAGE-FAULT -IF-NO-PAGE-FAULT-OR-INTERRUPT
			      -IF-NO-SEQUENCE-BREAK -NEVER
			    nil -DATA-TYPE-EQUAL nil nil  nil nil nil nil)))
	   (COND ((EQ TEM T)
		  (COND ((ZEROP (LDB LAM-IR-N NUMBER))
			 (PRINC '|-XCT-NEXT|)))
		  (PRINC '| JUMP-CONDITION |) (PRIN1 (LDB LAM-IR-JUMP-COND-LOW NUMBER))
		  (OR (ZEROP (LDB LAM-IR-JUMP-INVERT-CONDITION NUMBER))
		      (PRINC '| (INVERTED)|)))
		 (T
		  (AND TEM (PRINC TEM))
		  (COND ((ZEROP (LDB LAM-IR-N NUMBER))
			 (PRINC '|-XCT-NEXT|)))))))
    (PRINC '/ )))

(DEFUN LAM-TYPE-JUMP-CONDITION-explorer (IGNORE NUMBER IGNORE)
  (format t "~[JUMP~;CALL~;POPJ~;CALL-POPJ-??~]"
	  (LDB rav-IR-JUMP-CALL-RETURN NUMBER))

  (COND ((not (ZEROP (LDB rav-IR-JUMP-on-bit NUMBER)))
	 (format t "-IF-BIT-~:[SET~;CLEAR~]" (ldb-test rav-ir-jump-invert-cond number))
	 (COND ((ZEROP (LDB rav-IR-N NUMBER))
		(format t "-XCT-NEXT")))
	 (format t " (BYTE-FIELD 1 ~s)" (- 32. (LOGAND 37 NUMBER))))
	(T
	 (let ((condition
		 (select (ldb rav-ir-jump-cond number)
		   (RAV-JUMP-COND-M<A "LESS-THAN")
		   (RAV-JUMP-COND-M>=A "GREATER-OR-EQUAL")
		   (RAV-JUMP-COND-M<=A "LESS-OR-EQUAL")
		   (RAV-JUMP-COND-M>A "GREATER-THAN")
		   (RAV-JUMP-COND-MA "NOT-EQUAL")
		   (RAV-JUMP-COND-M=A "EQUAL")
		   (RAV-JUMP-COND-PAGE-FAULT "PAGE-FAULT")
		   (RAV-JUMP-COND-PAGE-FAULT-OR-INTERRUPT "PAGE-FAULT-OR-INTERRUPT")
		   (RAV-JUMP-COND-PAGE-FAULT-OR-INTERRUPT-OR-SEQUENCE-BREAK "SEQUENCE-BREAK")
		   (RAV-JUMP-COND-UNC nil)
		   (RAV-JUMP-COND-DATA-TYPE-NOT-EQUAL "DATA-TYPE-NOT-EQUAL")
		   (RAV-JUMP-COND-DATA-TYPE-EQUAL "DATA-TYPE-EQUAL")
		   (RAV-JUMP-COND-BOXED-SIGN-BIT-SET "BOXED-SIGN-BIT-SET")
		   (RAV-JUMP-COND-BOXED-SIGN-BIT-clear "BOXED-SIGN-BIT-CLEAR")
		   (RAV-JUMP-COND-Q0 "Q0")
		   (RAV-JUMP-COND-NUBUS-ERROR "NUBUS-ERROR")
		   (RAV-JUMP-COND-NOT-FIXNUM-OVERFLOW "NOT-FIXNUM-OVERFLOW")
		   (RAV-JUMP-COND-FIXNUM-OVERFLOW "FIXNUM-OVERFLOW")
		   (T "UNKNOWN"))))
	   (if condition
	       (format t "-~a" condition))
	   (if (zerop (ldb rav-ir-n number))
	       (format t "-XCT-NEXT")))))
  (format t " "))

(DECLARE (SPECIAL ART-STRING %FEFHI-FCTN-NAME 
		  Q-DATA-TYPES LAM-SEXP-PRINLEVEL LAM-SEXP-PRINLENGTH 
		  %%ARRAY-TYPE-FIELD))

(DEFUN LAM-Q-PRINT-TOPLEV-1 (TYPED-POINTER WD ITEMREST)
    WD ITEMREST
    (LAM-Q-PRINT TYPED-POINTER LAM-SEXP-PRINLEVEL))

(DECLARE (SPECIAL SI:*IOLST SI:*IOCH))

(DEFUN LAM-Q-EXPLODE (X &AUX (SI:*IOLST NIL) (SI:*IOCH T))
  (LET ((STANDARD-OUTPUT (FUNCTION SI:EXPLODE-STREAM)))
    (LAM-Q-PRINT-TOPLEV X))
  (NREVERSE SI:*IOLST))

(DEFVAR *LAM-PRINT-ESCAPE* T
  "Non-NIL means print readably (PRIN1).  NIL means print with no quoting chars (PRINC).")

(DEFVAR *LAM-PRINT-PACKAGES* nil)

(DEFUN LAM-Q-PRINT-TOPLEV (TYPED-POINTER)
  (QF-INITIALIZE-FOR-LISP-REFERENCE)
  (LET ((*LAM-PRINT-ESCAPE* T))
    (LAM-Q-PRINT TYPED-POINTER LAM-SEXP-PRINLEVEL)))

(DEFUN LAM-Q-PRINC-TOPLEV (TYPED-POINTER)
  (QF-INITIALIZE-FOR-LISP-REFERENCE)
  (LET ((*LAM-PRINT-ESCAPE* NIL))
    (LAM-Q-PRINT TYPED-POINTER LAM-SEXP-PRINLEVEL)))

(COND ((NULL (BOUNDP 'LAM-SEXP-PRINLEVEL))
       (SETQ LAM-SEXP-PRINLEVEL 20)))

(COND ((NULL (BOUNDP 'LAM-SEXP-PRINLENGTH))
       (SETQ LAM-SEXP-PRINLENGTH 100)))

;; Copied from LAD: RELEASE-3.LAMBDA-DIAG; PRINT-UINST.LISP#38 on 2-Oct-86 05:20:14
(DEFUN LAM-Q-PRINT (TYPED-POINTER I-PRINLEVEL)
  (PROG (PRINLENGTH-COUNT DATA-TYPE Q-POINTER HEADER TEM PREVIOUS-TYPED-POINTER)
	(IF (NULL PHT-ADDR) (QF-SETUP-PHT-ADDR))
	(SETQ PRINLENGTH-COUNT 0)
   top	(SETQ DATA-TYPE (LDB %%QF-DATA-TYPE TYPED-POINTER))
	(SETQ Q-POINTER (LDB-BIG %%QF-POINTER TYPED-POINTER))
	(COND ((= data-type dtp-gc-forward)
	       (format t "!GC-forward ")
	       (setq typed-pointer (qf-typed-pointer (lam-mem-read q-pointer)))
	       (go top))
	      ((LAM-Q-ATOM TYPED-POINTER)
	       (COND ((= DATA-TYPE DTP-SYMBOL)
		      (if *lam-print-packages*
			  (let ((pack (qf-typed-pointer (lam-mem-read (+ q-pointer 4)))))
			    (lam-q-print-string (qf-pkg-name pack))
			    (format t ":")))
		      (RETURN (LAM-Q-PRINT-STRING (LAM-MEM-READ Q-POINTER))))
		     ((= DATA-TYPE DTP-FIX)
		      (RETURN (LAM-Q-PRINT-FIX Q-POINTER)))
		     (T (GO BOMB))))
	      ((= DATA-TYPE DTP-STACK-GROUP)
	       (PRINC "#<Stack Group ")
	       (SETQ TEM (QF-ARRAY-LEADER (QF-MAKE-Q (QF-POINTER TYPED-POINTER)
						     DTP-ARRAY-POINTER)
					  SG-NAME)
		     DATA-TYPE (LDB %%QF-DATA-TYPE TEM))
	       (COND ((= DATA-TYPE DTP-ARRAY-POINTER)) ;a string?
		     ((= DATA-TYPE DTP-SYMBOL)
		      (SETQ TEM (LAM-MEM-READ TEM))) ;get-pname
		     (T (ERROR '|SG name has a bad type -- LAM-Q-PRINT|)))
	       (LAM-Q-PRINT-STRING TEM)
	       (PRINC ">")
	       (RETURN NIL))
	      ((= DATA-TYPE DTP-ARRAY-POINTER)
	       (SETQ HEADER (LAM-MEM-READ Q-POINTER)) ;get array header following forwarding ptr
	       (COND ((= (MASK-FIELD-FROM-FIXNUM %%ARRAY-TYPE-FIELD HEADER)
			 ART-STRING)
		      (IF *LAM-PRINT-ESCAPE* (PRINC "/""))
		      (LAM-Q-PRINT-STRING Q-POINTER)
		      (IF *LAM-PRINT-ESCAPE* (PRINC "/""))
		      (RETURN NIL))
		     ((NOT (ZEROP (MASK-FIELD-FROM-FIXNUM %%ARRAY-NAMED-STRUCTURE-FLAG
							  HEADER)))
		      ;; The array is a named-structure.
		      ;; Apparently using leader+2 as a "NAME" is part of history
		      ;; and is no longer used
		      (LET ((NSS NIL) )
			(COND ((NOT (ZEROP (MASK-FIELD-FROM-FIXNUM
					    %%ARRAY-LEADER-BIT HEADER)))
			       (SETQ NSS (QF-ARRAY-LEADER TYPED-POINTER 1))
			       )
			      (T (SETQ NSS (QF-AR-1 TYPED-POINTER 0))
				 ))
			(PRINC "#<")
			(LAM-Q-PRINT NSS I-PRINLEVEL)
 			(PRINC " ")
			(PRIN1 (LDB-BIG %%QF-POINTER TYPED-POINTER))
			(PRINC ">"))
		      (RETURN NIL))
		     (T (GO BOMB))))
	      ((= DATA-TYPE DTP-U-ENTRY)
	       (RETURN (LAM-Q-PRINT-U-ENTRY TYPED-POINTER I-PRINLEVEL)))
	      ((= DATA-TYPE DTP-FEF-POINTER)
	       (RETURN (LAM-Q-PRINT-FRAME TYPED-POINTER I-PRINLEVEL)))
	      ((NOT (= DATA-TYPE DTP-LIST))
	       (GO BOMB))
	      ((= I-PRINLEVEL 0)
	       (PRINC "#")
	       (RETURN NIL)))
	(PRINC "(" )
    L	(SETQ TEM (QF-CAR TYPED-POINTER))
	(COND (NIL ;; (= (LDB %%QF-DATA-TYPE TEM) DTP-STACK-CLOSURE)
	       ;MAKE SURE ITS COMMING FROM A PDL AREA.
	       (LET* ((Q-AREA (QF-AREA-NUMBER-OF-POINTER TYPED-POINTER))
		      (A-R-B (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-BITS))
		      (REGION-BITS (QF-MEM-READ (+ A-R-B Q-AREA))))
		 (COND ((NOT (= (LDB %%REGION-MAP-STATUS-CODE REGION-BITS)
				%PHT-MAP-STATUS-PDL-BUFFER))
			(FORMAT T "~%DTP-STACK-CLOSURE IN AREA ~S, NOT PDL-AREA~%" Q-AREA))))))
	(LAM-Q-PRINT TEM (1- I-PRINLEVEL))
	(SETQ PREVIOUS-TYPED-POINTER TYPED-POINTER)
	(SETQ TYPED-POINTER (QF-CDR TYPED-POINTER))
	(COND ((LAM-Q-NULL TYPED-POINTER)
	       (PRINC ")")
	       (RETURN NIL)))
	(PRINC " ")
	(COND ((NOT (= DTP-LIST (SETQ DATA-TYPE (LDB %%QF-DATA-TYPE TYPED-POINTER))))
	       (PRINC "." )
	       (LAM-Q-PRINT TYPED-POINTER (1- I-PRINLEVEL))
	       (PRINC ")")
	       (RETURN NIL))
	      ((> (SETQ PRINLENGTH-COUNT (1+ PRINLENGTH-COUNT)) LAM-SEXP-PRINLENGTH)
	       (PRINC "...")
	       (RETURN NIL)))
	(GO L)

   BOMB	(RETURN (LAM-Q-PRINT-BOMB TYPED-POINTER))
))

;;;*** This knows that NIL is at location zero.
(DEFUN LAM-Q-NULL (TYPED-POINTER)
   (COND ((AND (= 0 (LDB-BIG %%QF-POINTER TYPED-POINTER))
	       (= (LDB %%QF-DATA-TYPE TYPED-POINTER) 
	           DTP-SYMBOL))
	    T)))

(DEFUN LAM-Q-ATOM (TYPED-POINTER)
  (PROG (DATA-TYPE)
	(SETQ DATA-TYPE (LDB %%QF-DATA-TYPE TYPED-POINTER))
	(COND ((OR (= DATA-TYPE DTP-SYMBOL)
		   (= DATA-TYPE DTP-FIX)
		   (= DATA-TYPE DTP-EXTENDED-NUMBER))
		(RETURN T)))
	(RETURN NIL)))

(DEFUN LAM-Q-PRINT-FIX (Q-NUM)
  (COND ((NOT (ZEROP (LDB %%qf-boxed-sign-bit Q-NUM)))
	 (SETQ Q-NUM (%LOGDPB 1 %%qf-boxed-sign-bit (LDB (byte 24. 0) Q-NUM)))))
  (PRIN1 Q-NUM))

(DECLARE (SPECIAL QF-ARRAY-DATA-ORIGIN QF-ARRAY-LENGTH
		  QF-ARRAY-HAS-LEADER-P QF-ARRAY-HEADER-ADDRESS))

;;; Print a string.  Note that it is truncated to at most 200 characters to
;;; avoid printing infinite garbage
(DEFVAR LAM-Q-PRINT-STRING-MAXL 200)

(DEFUN LAM-Q-PRINT-STRING (ADR &OPTIONAL (STREAM STANDARD-OUTPUT) inhibit-forwarding-messages)
  (QF-ARRAY-SETUP (QF-MAKE-Q (QF-POINTER ADR) DTP-ARRAY-POINTER) inhibit-forwarding-messages)
  (DO ((LEN (COND (QF-ARRAY-HAS-LEADER-P
		   (QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 2))))
		  (T QF-ARRAY-LENGTH)))
       (ADR QF-ARRAY-DATA-ORIGIN)
       (I 0 (1+ I))
       (CH)
       (WD))
      ((OR (>= I LEN) (= I LAM-Q-PRINT-STRING-MAXL))
       (AND (< I LEN) (PRINC '/././. STREAM))
       NIL)
    (DECLARE (FIXNUM LEN ADR I WD))
    (COND ((ZEROP (LOGAND 3 I))	;Get next word
	   (SETQ WD (QF-MEM-READ ADR)
		 ADR (1+ ADR))))
    (SETQ CH (LOGAND 377 WD)
	  WD (ASH WD -8))
    (TYO CH STREAM)))
		
(DEFUN LAM-Q-PRINT-U-ENTRY (TYPED-POINTER I-PRINLEVEL)
  (PROG (TEM)
	(SETQ TEM (QF-INITIAL-AREA-ORIGIN 'MICRO-CODE-ENTRY-NAME-AREA))
	(COND ((= TEM 0)
		(RETURN (LAM-Q-PRINT-BOMB TYPED-POINTER))))
	(SEND *standard-output* ':STRING-OUT "#<DTP-U-ENTRY ")
	(LAM-Q-PRINT (QF-MEM-READ (+ TEM (LDB-BIG %%QF-POINTER TYPED-POINTER))) I-PRINLEVEL)
	(SEND *standard-output* ':TYO #/>)))

(DEFUN LAM-Q-PRINT-FRAME (TYPED-POINTER I-PRINLEVEL)
  (LET ((Q (LAM-MEM-READ (+ %FEFHI-FCTN-NAME (LDB-BIG %%QF-POINTER TYPED-POINTER)))))
    (SEND *STANDARD-OUTPUT* ':STRING-OUT "#<DTP-FEF-POINTER ")
    (LAM-Q-PRINT Q I-PRINLEVEL)
    (SEND *STANDARD-OUTPUT* ':TYO #\Space)
    (PRIN1 (QF-POINTER TYPED-POINTER))
    (SEND *STANDARD-OUTPUT* ':TYO #/>)))

(DEFUN LAM-Q-PRINT-BOMB (TYPED-POINTER)
  (PROG (DATA-TYPE Q-POINTER)
	(SETQ DATA-TYPE (LDB %%QF-DATA-TYPE TYPED-POINTER))
	(SETQ Q-POINTER (LDB-BIG %%QF-POINTER TYPED-POINTER))
	(SEND *standard-output* ':STRING-OUT "#<")
	(let ((type-name (NTH DATA-TYPE Q-DATA-TYPES)))
	  (cond ((null type-name)
		 (format t "BAD-DATA-TYPE-~O" data-type))
		(t
		 (format t "~A" type-name))))
	(SEND *standard-output* ':TYO #\Space)
	(PRIN1 Q-POINTER)
	(COND ((= DATA-TYPE DTP-NULL)
	       (TYO 40)
	       (LAM-Q-PRINT-STRING (LAM-MEM-READ TYPED-POINTER)))
	      ((= DATA-TYPE DTP-SYMBOL-HEADER)
	       (TYO 40)
	       (LAM-Q-PRINT-STRING TYPED-POINTER))
	      ((= DATA-TYPE DTP-FEF-POINTER)
	       (TYO 40)
	       (LAM-Q-PRINT-STRING (LAM-MEM-READ (+ %FEFHI-FCTN-NAME TYPED-POINTER)))))
	(SEND *standard-output* ':TYO #/>)
	(RETURN T)))

(DEFUN LAM-MEM-READ (ADDR &optional inhibit-forwarding-messages)
    (DO ((X (QF-MEM-READ ADDR) (QF-MEM-READ ADDR))
	 (DTP))
	(NIL)
      (SETQ DTP (QF-DATA-TYPE X))
      (COND ((= DTP DTP-BODY-FORWARD)
	     (LET ((OFFSET (- (QF-POINTER ADDR) (QF-POINTER X))))
	       (SETQ X (+ (QF-MEM-READ X) OFFSET))))
	    ((OR (= DTP DTP-HEADER-FORWARD)
		 (= DTP DTP-ONE-Q-FORWARD)
		 (= DTP DTP-GC-FORWARD)
		 (= DTP DTP-EXTERNAL-VALUE-CELL-POINTER)
		 (= dtp dtp-rplacd-forward))
	     (unless inhibit-forwarding-messages
	       (format t "!~s " (nth dtp q-data-types)))) ;loop
            (T (RETURN X)))
      (SETQ ADDR X)))



(DECLARE (SPECIAL *ITEM* *DESC* *DESC-STACK*))

(DEFUN LAM-TYPE-IN (*DESC* WD TYPE-OVER)
 (PROG (*DESC-STACK* SYL N TEM T1 CH *ITEM* WD-BITS-SET)
  (SEND *STANDARD-OUTPUT* ':TYO #\Space)
  (SETQ WD-BITS-SET 0)		;MASK FOR BITS SET THIS TIME AROUND
A (AND (ATOM *DESC*) (SETQ *DESC* (SYMEVAL *DESC*)))
B (SETQ *ITEM* '(OUTPUT))
  (LAM-TI-CONTROL-SEQUENCE)
AA
  (COND ((NULL *ITEM*)
	 (PRINC '|   |)
	 (RETURN WD)))
  ;;DEAL WITH STANDARD CONTROL-SEQUENCE DESCRIPTORS IN STANDARD WAY.
  (AND (LAM-TI-CONTROL-SEQUENCE) (GO AA))
  ;MAYBE THIS DESCRIPTION ITEM DOESN'T CALL FOR TYPE-IN?  OR NEEDS PROMPT
  (COND ((EQ (CAR *ITEM*) 'CONSTANT)
	 (SETQ WD (PLUS WD (DPB (CADDR *ITEM*) (SETQ TEM (EVAL (CADR *ITEM*))) 0)))
	 (SETQ WD-BITS-SET (DPB -1 TEM WD-BITS-SET))
	 (GO B))
	((EQ (CAR *ITEM*) 'CALL)
	 (COND ((SETQ CH (GET (CADR *ITEM*) 'INPUT))
		(SETQ CH (FUNCALL CH WD WD-BITS-SET TYPE-OVER (CDDR *ITEM*)))
		(SETQ WD (CAR CH) WD-BITS-SET (CADR CH))
		(GO B))
	       (T (PRINC '|I can't hack this |)
		  (RETURN NIL))))
	;; We require that an IF-EQUAL either be determined from bits already set
	;; or have only one non-empty alternative (which we always take).
	((EQ (CAR *ITEM*) 'IF-EQUAL)
	  (PUSH *DESC* *DESC-STACK*)
	  (COND ((NOT (ZEROP (LDB (SETQ TEM (EVAL (CADDR *ITEM*))) WD-BITS-SET)))
		 (SETQ *DESC* (COND ((= (CADDDR *ITEM*) (LDB TEM WD))
				   (CAR (CDDDDR *ITEM*)))
				  (T (CADR (CDDDDR *ITEM*))))))
		((NULL (CAR (CDDDDR *ITEM*)))
		 (SETQ *DESC* (CADR (CDDDDR *ITEM*))))
		((NULL (CADR (CDDDDR *ITEM*)))
		 (SETQ *DESC* (CAR (CDDDDR *ITEM*))))
		(T (BREAK "BAD-IF-EQUAL-DESC-FOR-INPUT")))
	  (GO B))
	((AND (EQ (CAR *ITEM*) 'COND)	;COND THAT DEPENDS ON PREVIOUS TYPE-IN
	      (NOT (ZEROP (LDB (SETQ TEM (EVAL (CADDR *ITEM*))) WD-BITS-SET))))
	 (SETQ *ITEM* `(SUB-FIELD ,(NTH (LDB TEM WD) (CADDDR *ITEM*))))
	 (LAM-TI-CONTROL-SEQUENCE)
	 (GO AA))
	((MEMQ (CAR *ITEM*) '(SELECT-FIELD TYPE-FIELD COND))
	 (PRIN1-THEN-SPACE (CADR *ITEM*)))
	((EQ (CAR *ITEM*) 'NUM)
	 (PRINC '|#: |)))
  (SETQ SYL NIL)

  ;ITEM IS A DESCRIPTOR, SYL HAS TYPE-IN SO FAR.
  ;HERE TO READ MORE.
C (COND (LAM-LOW-LEVEL-FLAG (LAM-REPLACE-STATE)))
  (SETQ CH (TYI-UPPERCASIFY))
  (COND ((OR (= CH #/?) (= CH #\SP) (= CH #/)) (GO D))
	((< CH #\SP)
	 (TERPRI)
	 (MAPC 'TYO SYL))
	((= CH #\RUBOUT)
	 (OR SYL (RETURN (PROGN (PRINC "??  ") NIL)))
	 (SETQ SYL (NREVERSE (CDR (NREVERSE SYL))))
	 (CURSORPOS 'X))
	((NULL SYL) (SETQ SYL (LIST CH)))
	((RPLACD (LAST SYL) (LIST CH))))
  (GO C)

  ;HAVE SOME TYPE-IN, CH HAS DELIMITER.
  D
  (COND ((AND TYPE-OVER (= CH 40) (NULL SYL))
	 (GO K)))
 
  ;FIRST SET TEM TO LIST OF POSSIBLE COMPLETIONS
  (SETQ TEM (ELIMINATE-DUPLICATES (LAM-TI-POSSIBILITIES SYL *ITEM*)))
  (COND ((NULL TEM)
	 (PRINC '-IMPOSS-))
	((= CH #/?)
	 (MAPC 'PRIN1-THEN-SPACE TEM))
	((= CH #/)
	 (GO F))
	((COND ((NULL SYL)		;CHECK FOR AMBIGUITY,
		(NOT (MEMQ NIL TEM)))	;HACKING DEFAULT AND EXACT-MATCH
	       ((AND (> (LENGTH TEM) 1)
		     (NOT (AND (MEMQ (SETQ CH (READLIST SYL)) TEM)
			       (SETQ TEM (CONS CH TEM)))) )))
	 (PRINC '-AMBIG-))
	((GO H)))
  ;RETYPE THE SYLLABLE AND READ MORE.
  (MAPC 'TYO SYL)
  (GO C)

  ;HERE TO DO COMPLETION, SYL HAS LIST OF CHARS TYPED SO FAR,
  ;TEM HAS LIST OF POSSIBILITIES, TYPE OUT ALL CHARS THAT ARE FORCED.
F (CURSORPOS 'X)	;UNECHO THE ALTMODE
  (AND (NUMBERP (CAR TEM))
       (GO C))		;CAN'T COMPLETE PURE-NUMERIC TYPEIN
G (SETQ N (1+ (LENGTH SYL))) ;INDEX OF CHAR TO LOOK AT
  (SETQ CH (inhibit-style-warnings (GETCHARN (CAR TEM) N)))
  (AND (= CH 0) (GO C))
  ;CH HAS PROPOSED CHARACTER, SEE IF ALL POSSIBILITIES AGREE
  (AND (DO TEM (CDR TEM) (CDR TEM) (NULL TEM)
	(OR (= CH (GETCHARN (CAR TEM) N))
	    (RETURN T)))
       (GO C))		;DISAGREEMENT, STOP HERE
  (TYO CH)
  (COND ((NULL SYL) (SETQ SYL (LIST CH)))
	((RPLACD (LAST SYL) (LIST CH))))
  (GO G)

  ;TYPEIN HAS BEEN COMPLETED AND ACCEPTED, DIGEST IT.
H (SETQ TEM (AND SYL (CAR TEM)))
  (CURSORPOS 'B)	;UNSPACE
  (OR (NUMBERP TEM)
      (NULL SYL)
      (DO ((CH)		;DO FINAL STAGE OF COMPLETION
	   (N (1+ (LENGTH SYL)) (1+ N)))
	  (NIL)
	(AND (= 0 (SETQ CH (GETCHARN TEM N)))
	     (RETURN NIL))
	(TYO CH)))
  (PRINC '/ )		;SPACE AFTER FIELD
I (COND ((EQ (CAR *ITEM*) 'TYPE))
	((EQ (CAR *ITEM*) 'SELECT-FIELD)
	 (SETQ TEM (COND ((NUMBERP TEM) TEM)
			 ((AND (NULL SYL)
			       (MEMQ NIL (CDR (MEMQ NIL (CADDDR *ITEM*)))))
			  (GO B))		;MULTIPLE NILS, DEFER DECISION
			 ((DO ((L (CADDDR *ITEM*) (CDR L)) (I 0 (1+ I))) ((NULL L) NIL)
			     (AND (OR (EQ (CAR L) TEM)
				      (AND (NOT (ATOM (CAR L))) (MEMQ TEM (CAR L))))
				  (RETURN I))))))
	 (SETQ WD (DPB TEM (SETQ T1 (EVAL (CADDR *ITEM*))) WD))
	 (SETQ WD-BITS-SET (DPB -1 T1 WD-BITS-SET)))
	((EQ (CAR *ITEM*) 'TYPE-FIELD)
	 (SETQ TEM (COND ((NUMBERP TEM) TEM)
			 ((NULL TEM) 0)
			 ((DIFFERENCE (LAM-LOOKUP-NAME TEM)
				      (SYMEVAL (CADDDR *ITEM*))))))
	 (SETQ WD (DPB TEM (SETQ T1 (EVAL (CADDR *ITEM*))) WD))
	 (SETQ WD-BITS-SET (dpb-big -1 T1 WD-BITS-SET)))
	((EQ (CAR *ITEM*) 'NUM)
	 (SETQ WD (DPB-BIG TEM (SETQ T1 (EVAL (CADR *ITEM*))) WD))
	 (SETQ WD-BITS-SET (DPB-BIG -1 T1 WD-BITS-SET)))
	((EQ (CAR *ITEM*) 'COND)
	 (DO ((DL (CADDDR *ITEM*) (CDR DL))
	      (N 0 (1+ N)))
	     ((NULL DL) (BREAK "COND-BARF"))
	    (SETQ CH `(SUB-FIELD ,(CAR DL)))
	    (COND ((MEMQ TEM (LAM-TI-POSSIBILITIES SYL CH))
		   (SETQ WD (DPB N (SETQ T1 (EVAL (CADDR *ITEM*))) WD))
		   (SETQ WD-BITS-SET (DPB -1 T1 WD-BITS-SET))
		   (RETURN NIL))))
	 (SETQ *ITEM* CH)
	 (LAM-TI-CONTROL-SEQUENCE)
	 (GO I))
	((LAM-TI-CONTROL-SEQUENCE) (GO I))
	(T (BREAK "INPUT-LOSSAGE-GOBBLING")))
  (PRINC '/ )
  (GO B)

  ;LEAVE THIS FIELD WITH SAME VALUE AS BEFORE
K (TYO #\BACKSPACE)     ;Don't leave two spaces on the screen.
KK
  (COND ((EQ (CAR *ITEM*) 'TYPE))
	((MEMQ (CAR *ITEM*) '(SELECT-FIELD TYPE-FIELD))
	 (SETQ WD-BITS-SET (DPB -1 (EVAL (CADDR *ITEM*)) WD-BITS-SET)))
	((EQ (CAR *ITEM*) 'NUM)
	 (SETQ WD-BITS-SET (dpb-big -1 (EVAL (CADR *ITEM*)) WD-BITS-SET)))
	((EQ (CAR *ITEM*) 'COND)
	 (SETQ *ITEM* `(SUB-FIELD ,(NTH (LDB (EVAL (CADDR *ITEM*)) WD) (CADDDR *ITEM*))))
	 (LAM-TI-CONTROL-SEQUENCE)
	 (GO KK))
	((LAM-TI-CONTROL-SEQUENCE)
	 (GO KK))
	(T (BREAK "INPUT-LOSSAGE-SPACE")))
  (LAM-TYPE-OUT WD (LIST *ITEM*) NIL NIL) ;RE-TYPE THE THING
  (PRINC '/ )
  (GO B)
))

(DEFUN LAM-TI-CONTROL-SEQUENCE ()
  (PROG ()
    (SELECTQ (CAR *ITEM*)
	((SUB-FIELD INPUT)
	  (PUSH *DESC* *DESC-STACK*)
	  (SETQ *DESC* (COND ((EQ (CAR *ITEM*) 'INPUT) (CDR *ITEM*)) (T (CADR *ITEM*)))))
	(OUTPUT)
	(CTYPE
	  (TYO #\BACKSPACE)
	  (PRINC (CADR *ITEM*)))
	(OTHERWISE (RETURN NIL)))
    LOOP
    (COND ((AND *DESC* (ATOM *DESC*))
	   (SETQ *DESC* (SYMEVAL *DESC*))
	   (GO LOOP))
	  (*DESC*)
	  (*DESC-STACK* (SETQ *DESC* (POP *DESC-STACK*))
		      (GO LOOP)))
    (SETQ *ITEM* (POP *DESC*))
    (RETURN T)))

;Given a desc ITEM *ITEM*, and given *DESC* and *DESC-STACK* as they are,
;compute the matches of the list of characters SYL against *ITEM* or the
;items that follow it/are called by it.
(DEFUN LAM-TI-POSSIBILITIES (SYL *ITEM*)
  (LET ((*DESC* *DESC*) (*DESC-STACK* *DESC-STACK*))
     (PROG ()
	 LOOP
	 (RETURN (COND
	       ((LAM-TI-CONTROL-SEQUENCE) (GO LOOP))
	       ((AND SYL (EVERY SYL '(LAMBDA (CH) (AND (> CH 57) (< CH 72)))))
		(LIST (READLIST SYL)))	;IT IS, ONLY POSSIBILITY IS THAT NUMBER
	       ((EQ (CAR *ITEM*) 'TYPE)
		(AND (LAM-TI-MATCH SYL (CADR *ITEM*)) (CDR *ITEM*)))
	       ((EQ (CAR *ITEM*) 'SELECT-FIELD)
		(LAM-TI-SELECT-FIELD-POSSIBILITIES SYL (CADDDR *ITEM*)))
	       ((EQ (CAR *ITEM*) 'NUM)
		NIL)	;ONLY NUMBERS ALLOWED?
	       ((EQ (CAR *ITEM*) 'TYPE-FIELD)
		(COND ((NULL (CADDDR *ITEM*)) NIL) ;ONLY NUMBERS ALLOWED?
		      ((NULL SYL)
		       (LIST NIL (inhibit-style-warnings
				   (IMPLODE (append (inhibit-style-warnings
						      (EXPLODE (CADR *ITEM*)))
						    '(- M E M - A D R))))))
		      (T	;HACK COMPLETIONS OF REGISTER ADDRESSES
		       (LET ((FROM-I 0) (TO-I 0))
			    (COND ((NULL SYL)
				   (SETQ FROM-I 0 TO-I LAM-SYMBOLS-SIZE))
				  (T (LET ((SYL+1 (copylist SYL)))
					  (LET ((L (LAST SYL+1)))
					       (RPLACA L (1+ (CAR L))))
					  (SETQ FROM-I (LAM-FIND-NAME (inhibit-style-warnings
									(IMPLODE SYL)))
						TO-I (LAM-FIND-NAME (inhibit-style-warnings
								      (IMPLODE SYL+1)))))))
			    (DO ((I FROM-I (1+ I))
				 (ANS NIL))
				((NOT (< I TO-I)) (NREVERSE ANS))
				(LET ((E (ARRAYCALL T LAM-SYMBOLS-NAME I)))
				     (AND (LAM-ADR-CLOSE-ENOUGH
					   (CADDDR *ITEM*)
					   (GET (LAM-FIND-REG-ADR-RANGE (CDR E))
						'LAM-LOWEST-ADR))
					  (SETQ ANS (CONS (CAR E) ANS))))))
		       )))
	       ((EQ (CAR *ITEM*) 'COND)	;HAIR....
		(PUSH *DESC* *DESC-STACK*)
		(MAPCAN (FUNCTION (LAMBDA (*DESC*)
			    (AND (ATOM *DESC*) (SETQ *DESC* (SYMEVAL *DESC*)))
			    (COND ((NULL *DESC*) NIL)
				  ((copylist (LAM-TI-POSSIBILITIES SYL (POP *DESC*)))))))
			(CADDDR *ITEM*)))
	       (T
		(BREAK "LAM-TI-POSSIBILITIES-LOSES")))))))

;Find the possible matches for SYL in a symbol or list of symbols or lists of ...
(DEFUN LAM-TI-SELECT-FIELD-POSSIBILITIES (SYL SYM)
    (COND ((ATOM SYM)
	   (AND (LAM-TI-MATCH SYL SYM)
		(LIST SYM)))
	  (T
	   (DO ((SYM SYM (CDR SYM)) (RESULT))
	       ((NULL SYM) RESULT)
	      (SETQ RESULT (NCONC (LAM-TI-SELECT-FIELD-POSSIBILITIES SYL (CAR SYM)) RESULT))))))

;Match the list of characters SYL against the head of the symbol SYM.
(DEFUN LAM-TI-MATCH (SYL SYM)
 (COND ((EQ SYM T) NIL)		;T ISN'T REALLY A SYMBOL!
       ((DO ((SYL SYL (CDR SYL))
	     (N 1 (1+ N)))
            ((NULL SYL) T)
	 (OR (= (CAR SYL) (inhibit-style-warnings (GETCHARN SYM N)))
	     (RETURN NIL))))))

(DEFUN ELIMINATE-DUPLICATES (L)
  (COND ((NULL L) NIL)
	((MEMQ (CAR L) (CDR L))
	 (ELIMINATE-DUPLICATES (CDR L)))
	((CONS (CAR L) (ELIMINATE-DUPLICATES (CDR L))))))

(DEFUN LAM-ADR-CLOSE-ENOUGH (TARGET POSSIBILITY)
  (OR (EQ TARGET POSSIBILITY)
      (AND (EQ TARGET 'RAMMO) (EQ POSSIBILITY 'RAFSO)) ;FUNC SRCS ARE OK AS M MEMORY
    ))


(DEFUN LAM-TYPE-OUT (WD *DESC* PROMPTP *DONT-TOUCH-MACHINE*)
 (cond ((null wd)
	(format t "No current value.  "))
  (t
  (PROG (DC ITEM VAL TEM SYM-BASE)
	(SETQ DC (COND ((ATOM *DESC*) (SYMEVAL *DESC*))
		       (T *DESC*)))
     L	(COND ((NULL DC) (RETURN T)))
	(SETQ ITEM (CAR DC))
	(COND ((EQ (CAR ITEM) 'TYPE-FIELD)
	       (GO T-F))
	      ((EQ (CAR ITEM) 'SELECT-FIELD)
	       (SETQ VAL (LDB (EVAL (CADDR ITEM)) WD))
	       (SETQ TEM (NTH VAL (CADDDR ITEM)))
	       (OR (ATOM TEM)
		   (SETQ TEM (COND (PROMPTP (AND (CADR TEM) (CAR TEM)))
				   (T (CAR TEM)))))
	       (COND ((NULL TEM))
		     ((EQ TEM T)
		      (AND PROMPTP (PRIN1-THEN-SPACE (CADR ITEM)))
		      (PRIN1-THEN-SPACE (LDB (EVAL (CADDR ITEM)) WD))) 
		     (T(AND (EQ PROMPTP 'ALL) (PRIN1-THEN-SPACE (CADR ITEM)))
		       (PRIN1-THEN-SPACE TEM))))
	      ((EQ (CAR ITEM) 'SUB-FIELD)
	       (LAM-TYPE-OUT WD (CADR ITEM) PROMPTP *DONT-TOUCH-MACHINE*))
	      ((EQ (CAR ITEM) 'COND)
	       (GO COND))
	      ((EQ (CAR ITEM) 'IF-EQUAL)
	       (SETQ TEM (CDDDDR ITEM))
	       (COND ((NOT (= (LDB (EVAL (CADDR ITEM)) WD) (CADDDR ITEM)))
		      (SETQ TEM (CDR TEM))))
	       (AND (CAR TEM)
		    (LAM-TYPE-OUT WD (CAR TEM) PROMPTP *DONT-TOUCH-MACHINE*)))
	      ((EQ (CAR ITEM) 'CALL)
	       (FUNCALL (CADR ITEM) (LDB-BIG (EVAL (CADDR ITEM)) WD) WD (CDDDR ITEM)))
	      ((EQ (CAR ITEM) 'TYPE)
	       (PRIN1-THEN-SPACE (CADR ITEM)))
	      ((EQ (CAR ITEM) 'CTYPE)
	       ;(TYO 10)
	       (PRINC (CADR ITEM)))
	      ((EQ (CAR ITEM) 'NUM)
	       (let ((base (or (caddr item) 8)))
		 (PRIN1-THEN-SPACE (LDB-BIG (EVAL (CADR ITEM)) WD))))
	      ((EQ (CAR ITEM) 'SIGNED-NUM)
	       (PRIN1-THEN-SPACE (LAM-UNSIGNED-TO-SIGNED (CADR ITEM)
							 (LDB-BIG (EVAL (CADR ITEM)) WD))))
	      ((EQ (CAR ITEM) 'CHAR)
	       (TYO (LDB (EVAL (CADR ITEM)) WD)))
	      ((EQ (CAR ITEM) 'CONSTANT))
	      ((EQ (CAR ITEM) 'INPUT))
	      ((EQ (CAR ITEM) 'OUTPUT)
	       (LAM-TYPE-OUT WD (CDR ITEM) PROMPTP *DONT-TOUCH-MACHINE*))
	      ((EQ (CAR ITEM) 'BITS)
	       (PRINT-BITS WD))
	      (T (PRINT (LIST (CAR ITEM) 'IN ITEM  'UNKNOWN-DESCRIPTOR))))
     L1	(SETQ DC (CDR DC))
	(GO L)
	
     T-F(SETQ VAL (LDB-BIG (EVAL (CADDR ITEM)) WD))
	(COND ((NULL (CADDDR ITEM))		;3RD ARG IS NIL - PRINT NUMBER.
	       (AND PROMPTP (PRIN1-THEN-SPACE (CADR ITEM)))
	       (PRIN1-THEN-SPACE VAL)
	       (GO L1)))
	(SETQ SYM-BASE (SYMEVAL (CADDDR ITEM)))
	(COND ((MEMQ (CADDDR ITEM) '(RACMO RADMO))
	       (LAM-C-OR-D-ADR-OUT (CADR ITEM) VAL SYM-BASE))
	      (T (LAM-A-OR-M-ADR-OUT (CADR ITEM) VAL SYM-BASE (FIFTH ITEM))))
	(GO L1)
	
    COND(SETQ VAL (LDB (EVAL (CADDR ITEM)) WD))
	(SETQ TEM (CADDDR ITEM))
     C-1(COND ((NULL TEM) (GO L1))
	      ((= VAL 0) (GO C-2)))
	(SETQ TEM (CDR TEM))
	(SETQ VAL (1- VAL))
	(GO C-1)				;
     C-2(LAM-TYPE-OUT WD (CAR TEM) PROMPTP *DONT-TOUCH-MACHINE*)
	(GO L1)
	))))

(DEFUN LAM-UNSIGNED-TO-SIGNED (FLD WD)
  (LET ((SIGN-BIT (ASH 1 (1- (LDB 0006 FLD)))))
    (IF (NOT (ZEROP (LOGAND SIGN-BIT WD)))
	(MINUS (1+ (LOGXOR WD (1- (ASH SIGN-BIT 1)))))
	WD)))

(DEFUN LAM-C-OR-D-ADR-OUT (TYPE VAL SYM-BASE &aux symbolic-address)
  TYPE
  (cond ((and (null *numeric-printout-only*)
	      (setq symbolic-address (lam-find-closest-sym (+ sym-base val))))
	 (format t "~s " symbolic-address))
	((= sym-base racmo)
	 (format t "~s@C " val))
	((= sym-base radmo)
	 (format t "~s@D " val))
	(t
	 (format t "~s " val))))

(defun lam-a-or-m-adr-out (type val sym-base bypass-zero-check)
  (let ((sym-adr (lam-find-closest-sym (+ sym-base val))))
    (cond ((and (null bypass-zero-check)
		(zerop val)))
	  ((and (not (null sym-adr))
		(symbolp sym-adr))
	   (format t "~s " sym-adr))
	  ((and (eq *dont-touch-machine* :get-from-running-a-mem)
		(< 0 val 1024.))
	   (format t "~s@~s[~s] "
		   val type (dpb (%p-ldb (byte 16. 16.) (%pointer-plus si:a-memory-virtual-address val))
				 (byte 16. 16.)
				 (%p-ldb (byte 16. 0) (%pointer-plus si:a-memory-virtual-address val)))))
	  ((or *numeric-printout-only*
	       *dont-touch-machine*)
	   (format t "~s@~s " val type))
	  (t
	   (format t "~s@~s[~s] "
		   val type (lam-register-examine (+ val sym-base)))))))

;(DEFUN LAM-A-OR-M-ADR-OUT (TYPE VAL SYM-BASE BYPASS-ZERO-CHECK)
;  (PROG (TEM)
;	(COND ((AND (NULL BYPASS-ZERO-CHECK)
;		    (ZEROP VAL))
;	       (RETURN NIL))
;	      ((OR *NUMERIC-PRINTOUT-ONLY*
;		   (AND (SETQ TEM (LAM-FIND-CLOSEST-SYM (+ SYM-BASE VAL)))
;			(ATOM TEM))
;		   *DONT-TOUCH-MACHINE*)
;	       (COND ((NULL TEM)
;		      (COND ((= SYM-BASE RAAMO)
;			     (FORMAT T "~S@A" VAL))
;			    ((= SYM-BASE RAMMO)
;			     (FORMAT T "~s@m" VAL))
;			    (T (FERROR NIL "bad sym base"))))
;		     (T
;		      (PRIN1 TEM))))
;	      (T
;	       (PRIN1 VAL)
;	       (PRINC '/@)
;	       (PRINC TYPE)
;	       (PRINC '/[)
;	       (PRIN1 (LAM-REGISTER-EXAMINE (+ VAL SYM-BASE)))
;	       (PRINC '/])))
;	(PRINC '/ )))


(DEFCONST LAM-O-UINST-DESC
	  '((SELECT-FIELD POPJ-AFTER-NEXT LAM-IR-POPJ-AFTER-NEXT (NIL PJ))
	    (COND OPCD LAM-IR-OP
		  (LAM-O-ALU-DESC
		   LAM-O-JMP-DESC 
		   LAM-O-DSP-DESC 
		   LAM-O-BYT-DESC))
	    (SELECT-FIELD MACRO-IR-DISPATCH LAM-IR-MACRO-IR-DISPATCH (NIL MACRO-IR-DISPATCH))
	    (SELECT-FIELD SOURCE-TO-MACRO-IR LAM-IR-SOURCE-TO-MACRO-IR
			  (NIL SOURCE-TO-MACRO-IR))
	    (SELECT-FIELD MACRO-STREAM-ADVANCE LAM-IR-MACRO-STREAM-ADVANCE
			  (NIL MACRO-STREAM-ADVANCE))
	    (SELECT-FIELD SLOW-DEST LAM-IR-SLOW-DEST (NIL SLOW-DEST))
	    (SELECT-FIELD ILONG LAM-IR-ILONG (NIL ILONG))
	    (SELECT-FIELD STAT-BIT LAM-IR-STAT-BIT (NIL STAT-BIT))
	    (SELECT-FIELD CLOBBERS-MEM-SUBR LAM-IR-CLOBBERS-MEM-SUBR-BIT
			  (NIL CLOBBERS-MEM-SUBR))
	    (SELECT-FIELD HALT-BIT LAM-IR-HALT (NIL HALT))
	    (TYPE-FIELD PARITY-FIELD LAM-IR-PARITY-FIELD NIL)
	    ))
	
(DEFCONST LAM-O-ALU-DESC
	  '((TYPE ALU)
	    (TYPE-FIELD A LAM-IR-A-SRC RAAMO)
	    (TYPE-FIELD M LAM-IR-M-SRC RAMMO)
	    (SELECT-FIELD OB LAM-IR-OB (MSK NIL ALUL1 OB-3 OB-4 ALUR1 OB-6 OB-7))
	    (SUB-FIELD LAM-O-DEST-DESC)
	    (SELECT-FIELD ALUF LAM-IR-ALUF-ONLY
			  (SETZ AND ANDCA SETM ANDCM SETA XOR IOR
			   ANDCB EQV SETCA ORCA SETCM ORCM ORCB SETO
			   T T T T T T SUB T
			   T ADD T T INCM T T LSHM
			   MUL DIV T T T DIVRC T T
			   T DIVFS T T T T T T
			   T T T T T T T T T T T T T T T T))
	    (SELECT-FIELD CARRY LAM-IR-CARRY (C0 C1))
	    (SELECT-FIELD Q LAM-IR-Q (NIL QLEFT QRIGHT LOADQ))
	    (SELECT-FIELD MF LAM-IR-MF (NIL T T T))
	    ))

(DEFCONST LAM-O-DSP-DESC
	  '((TYPE DSP)
	    (TYPE-FIELD DC LAM-IR-DISP-DISPATCH-CONSTANT NIL)
	    (TYPE-FIELD M LAM-IR-M-SRC RAMMO)
	    (TYPE-FIELD DO LAM-IR-A-SRC RADMO)	;a source serves as dispatch offset
	    (TYPE-FIELD BYTL LAM-IR-DISP-BYTL NIL)
	    (TYPE-FIELD MROT LAM-IR-MROT NIL)
	    (SELECT-FIELD LPC LAM-IR-DISP-LPC (NIL LPC))
 ;	    (SELECT-FIELD IFETCH 3001 (NIL IFETCH))
	    (SELECT-FIELD MAP LAM-IR-DISP-ENABLE-META NIL)
 ;	    (SELECT-FIELD MF LAM-IR-MF (NIL T D-MEM-WRITE LOW-PC-BIT-SEL-HW))
	    ))

(DEFCONST LAM-O-JMP-DESC '((TYPE JMP)
		      (TYPE-FIELD A LAM-IR-A-SRC RAAMO)
		      (TYPE-FIELD M LAM-IR-M-SRC RAMMO)
		      (TYPE-FIELD J-ADR LAM-IR-JUMP-ADDR RACMO)
		      (SELECT-FIELD R LAM-IR-R (NIL R))
		      (SELECT-FIELD P LAM-IR-P (NIL P))
		      (SELECT-FIELD N LAM-IR-N (NIL N))
		      (SELECT-FIELD INV LAM-IR-JUMP-INVERT-CONDITION (NIL INV))
		      (COND TC LAM-IR-JUMP-TEST-CONDITION
			    (LAM-O-JMP-BIT-DESC LAM-O-JMP-ALU-DESC))
  ;		      (SELECT-FIELD MF LAM-IR-MF (NIL T T LOW-PC-BIT-SEL-HW))
))

(DEFCONST LAM-O-JMP-BIT-DESC '( (TYPE MROT) (NUM LAM-IR-MROT)	;CAN'T USE TYPE-FIELD DUE TO TYPEIN BUG
))

(DEFCONST LAM-O-JMP-ALU-DESC '( (SELECT-FIELD CONDITION LAM-IR-JUMP-COND-LOW
				(T M<A M<=A M=A PF INT-OR-PF SB-OR-INT-OR-PF UNC))
))

(DEFCONST LAM-O-BYT-DESC '((TYPE BYT)
		      (TYPE-FIELD A LAM-IR-A-SRC RAAMO)
		      (TYPE-FIELD M LAM-IR-M-SRC RAMMO)
		      (SUB-FIELD LAM-O-DEST-DESC)
		      (SELECT-FIELD BYTM LAM-IR-BYTE-FUNC (NIL LDB SSUB DPB))	
		      (TYPE-FIELD BYTL-1 LAM-IR-BYTL-1 NIL)
		      (TYPE-FIELD MROT LAM-IR-MROT NIL)
  ;		      (SELECT-FIELD MF LAM-IR-MF (NIL T T LOW-PC-BIT-SEL-HW))
))

(DEFCONST LAM-O-DEST-DESC '( (COND DEST LAM-IR-A-MEM-DEST-FLAG
				   (LAM-O-M-DEST-DESC LAM-O-A-DEST-DESC))))

(DEFCONST LAM-O-M-DEST-DESC '( (TYPE-FIELD DM LAM-IR-M-MEM-DEST RAMMO)
			      (TYPE-FIELD FD LAM-IR-FUNC-DEST RAFDO)
))

(DEFCONST LAM-O-A-DEST-DESC '( (TYPE-FIELD DA LAM-IR-A-MEM-DEST RAAMO)
))

;New assembler-style micro-instruction type-out and type-in.
(DEFCONST LAM-UINST-DESC-lambda '( (CTYPE | (|)
		       (SELECT-FIELD POPJ-AFTER-NEXT?
				     LAM-IR-POPJ-AFTER-NEXT (NIL (POPJ-AFTER-NEXT YES)))
		       (COND OPCLASS LAM-IR-OP
			     (LAM-ALU-DESC-lambda
			      LAM-BYT-DESC-lambda
			      LAM-JMP-DESC-lambda
			      LAM-DSP-DESC-lambda))
		       (SELECT-FIELD STAT-BIT LAM-IR-STAT-BIT (NIL (STAT-BIT YES)))
		       (SELECT-FIELD CLOBBERS-MEM-SUBR LAM-IR-CLOBBERS-MEM-SUBR-BIT
				     (NIL (CLOBBERS-MEM-SUBR YES)))
		       (SELECT-FIELD HALT-BIT LAM-IR-HALT (NIL (HALT-BIT YES)))
		       (SELECT-FIELD MACRO-IR-DISPATCH LAM-IR-MACRO-IR-DISPATCH
				     (NIL (MACRO-IR-DISPATCH YES)))
		       (SELECT-FIELD SOURCE-TO-MACRO-IR LAM-IR-SOURCE-TO-MACRO-IR
				     (NIL (SOURCE-TO-MACRO-IR YES)))
		       (SELECT-FIELD MACRO-STREAM-ADVANCE LAM-IR-MACRO-STREAM-ADVANCE
				     (NIL (MACRO-IR-STREAM-ADVANCE YES)))
		       (SELECT-FIELD SLOW-DEST LAM-IR-SLOW-DEST
				     (NIL (SLOW-DEST YES)))
		       (CTYPE |) |) ))

(DEFCONST LAM-UINST-DESC-lambda-hh '( (CTYPE | (|)
		       (select-field  pred-write lam-ir-pred-write (nil (pred-write yes)))
		       (select-field tag-control lam-ir-tag-control
				     (nil tag-control-1 tag-control-2
					  tag-control-3 tag-control-4 tag-control-5
					  tag-control-6 tag-control-7))
			     
		       (SELECT-FIELD POPJ-AFTER-NEXT?
				     LAM-IR-POPJ-AFTER-NEXT (NIL (POPJ-AFTER-NEXT YES)))
		       (COND OPCLASS LAM-IR-OP
			     (LAM-ALU-DESC-lambda
			      LAM-BYT-DESC-lambda
			      LAM-JMP-DESC-lambda
			      LAM-DSP-DESC-lambda))
		       (SELECT-FIELD STAT-BIT LAM-IR-STAT-BIT (NIL (STAT-BIT YES)))
		       (SELECT-FIELD CLOBBERS-MEM-SUBR LAM-IR-CLOBBERS-MEM-SUBR-BIT
				     (NIL (CLOBBERS-MEM-SUBR YES)))
		       (SELECT-FIELD HALT-BIT LAM-IR-HALT (NIL (HALT-BIT YES)))
		       (SELECT-FIELD MACRO-IR-DISPATCH LAM-IR-MACRO-IR-DISPATCH
				     (NIL (MACRO-IR-DISPATCH YES)))
		       (SELECT-FIELD SOURCE-TO-MACRO-IR LAM-IR-SOURCE-TO-MACRO-IR
				     (NIL (SOURCE-TO-MACRO-IR YES)))
		       (SELECT-FIELD MACRO-STREAM-ADVANCE LAM-IR-MACRO-STREAM-ADVANCE
				     (NIL (MACRO-IR-STREAM-ADVANCE YES)))
		       (SELECT-FIELD SLOW-DEST LAM-IR-SLOW-DEST
				     (NIL (SLOW-DEST YES)))
		       (CTYPE |) |) ))

(DEFCONST LAM-ALU-DESC-lambda '(  (INPUT (TYPE ALU))
			 (OUTPUT (SUB-FIELD LAM-DEST-DESC-lambda))
			 (SELECT-FIELD ALU-FUNCTION LAM-IR-ALUF-ONLY
	;used to be (SETA NIL) in next line. Unfortunately, its not smart enuf to be that
        ;clever since ambigious uinst is printed if m-source (for side effect) exists too.
			  (SETZ AND ANDCA SETM ANDCM SETA XOR IOR	;boolean operations
			   ANDCB EQV SETCA ORCA SETCM ORCM ORCB SETO	;15-0

			   MSTEP MSTEP-LAST DFSTEP DSTEP RSTEP T SUB T	;arithmetic operations
			   T ADD T T INCM T T LSHM		;31-16
			   
			   T T T T T T T T		;conditional alu
			   T T T T T T T T			;operations 47-32
			   
			   T T T T T T T T T T T T T T T T))	;more conditional ops
								;not used by system
			 					;63-48
		      (INPUT (SUB-FIELD LAM-DEST-DESC-lambda))
		      (IF-EQUAL ALU LAM-IR-ALUF-ONLY 26
				LAM-SUB-CARRY-DESC-lambda LAM-NORMAL-CARRY-DESC-lambda)
		      (SELECT-FIELD OUTPUT-SELECTOR LAM-IR-OB
				    (A-SOURCE-0	;0 ON SELECTOR
				      NIL	;2 ON SELECTOR
				      OUTPUT-SELECTOR-RIGHTSHIFT-1 ;4 ON SELECTOR
				      ALU-EXTEND-25	;6 ON SELECTOR
				      ROTATOR-4		;1 ON SELECTOR
				      A-SOURCE-5	;3 ON SELECTOR
				      OUTPUT-SELECTOR-LEFTSHIFT-1	;5 ON SELECTOR
				      ALU-MIRROR))	;7 ON SELECTOR

		      (OUTPUT (SELECT-FIELD Q LAM-IR-Q (NIL SHIFT-Q-LEFT SHIFT-Q-RIGHT NIL)))
		      (INPUT (SELECT-FIELD Q LAM-IR-Q
					   (NIL SHIFT-Q-LEFT SHIFT-Q-RIGHT LOAD-Q)))
		      (SUB-FIELD LAM-M-SOURCE-DESC-lambda)
		      (TYPE-FIELD A LAM-IR-A-SRC RAAMO)
		      (SELECT-FIELD MF LAM-IR-MF (NIL T T T))
		      (SELECT-FIELD ILONG LAM-IR-ILONG ((NIL NO-ILONG) (ILONG YES)))
))

(DEFCONST LAM-SUB-CARRY-DESC-lambda '((SELECT-FIELD CARRY LAM-IR-CARRY (ALU-CARRY-IN-ZERO
						    (ALU-CARRY-IN-ONE NIL)))))

(DEFCONST LAM-NORMAL-CARRY-DESC-lambda '((SELECT-FIELD CARRY LAM-IR-CARRY ((NIL ALU-CARRY-IN-ZERO)
						       ALU-CARRY-IN-ONE))))

(DEFCONST LAM-DSP-DESC-lambda '(  (TYPE DISPATCH)
		      (IF-EQUAL DISP-CONST LAM-IR-DISP-DISPATCH-CONSTANT
				0 NIL LAM-DSP-CONST-DESC-lambda)
		      (CALL LAM-BYTE-FIELD-OUT LAM-BYTE-SPEC T NIL)
		      (SUB-FIELD LAM-M-SOURCE-DESC-lambda)
		      (TYPE-FIELD D LAM-IR-A-SRC RADMO)
		      (SELECT-FIELD WRITE-VMA?  LAM-IR-DISP-WRITE-VMA (NIL (WRITE-VMA YES)))
		      (SELECT-FIELD PUSH-OWN-ADDRESS?
				    LAM-IR-DISP-LPC (NIL (PUSH-OWN-ADDRESS YES)))
  ;		      (SELECT-FIELD IFETCH? 3001 (NIL (IFETCH YES)))
		      (SELECT-FIELD MAP LAM-IR-DISP-ENABLE-META
				    (NIL MAP-1 MAP-2 MAP-3))
  ;		      (SELECT-FIELD MF LAM-IR-MF (NIL T D-MEM-WRITE LOW-PC-BIT-SEL-HW))
		      (SELECT-FIELD ILONG LAM-IR-ILONG (NO-ILONG (ILONG NIL YES)))))

(DEFCONST LAM-DSP-CONST-DESC-lambda '((CTYPE | (|)
			  (TYPE-FIELD I-ARG LAM-IR-DISP-DISPATCH-CONSTANT NIL)
			  (CTYPE |) |)))

(DEFCONST LAM-JMP-DESC-lambda '((INPUT (TYPE JUMP)
				(SELECT-FIELD CALL-RETURN LAM-IR-JUMP-CALL-RETURN
					      ((JUMP NIL) CALL RETURN T))
				(COND COND LAM-IR-JUMP-TEST-CONDITION
				      (((SELECT-FIELD SENSE LAM-IR-JUMP-INVERT-CONDITION
						      (BIT-SET BIT-CLEAR))
					(CALL LAM-BYTE-FIELD-OUT LAM-IR-MROT T T))
				       ((COND COND LAM-IR-JUMP-INVERT-CONDITION
					      (((SELECT-FIELD COND LAM-IR-JUMP-COND-LOW
						 (T LESS-THAN LESS-OR-EQUAL NOT-EQUAL
						    NO-PAGE-FAULT PAGE-FAULT-OR-INTERRUPT
						    |SEQUENCE-BREAK-OR-...|
						    (ALWAYS NIL)
						  T DATA-TYPE-NOT-EQUAL)))
					       ((SELECT-FIELD COND LAM-IR-JUMP-COND-LOW
						 (T GREATER-OR-EQUAL
						 GREATER-THAN EQUAL
						 PAGE-FAULT NO-PAGE-FAULT-OR-INTERRUPT
						 |NO-SEQUENCE-BREAK-OR-...|
						 NEVER
						 T DATA-TYPE-EQUAL))))))))
				  (SELECT-FIELD DONT-XCT-NEXT LAM-IR-N
						(XCT-NEXT (DONT-XCT-NEXT NIL))))
			 (OUTPUT (CALL LAM-TYPE-JUMP-CONDITION LAM-IR-JUMP-COND-BITS))
			 (SUB-FIELD LAM-M-SOURCE-DESC-lambda)
			 (TYPE-FIELD A LAM-IR-A-SRC RAAMO)
			 (TYPE-FIELD J LAM-IR-JUMP-ADDR RACMO)
	;		 (SELECT-FIELD MF LAM-IR-MF (NIL T T LOW-PC-BIT-SEL-HW))
			 (SELECT-FIELD ILONG LAM-IR-ILONG ((NIL NO-ILONG) (ILONG YES)))
))

(DEFCONST LAM-BYT-DESC-lambda '((INPUT (TYPE BYTE))
		    (OUTPUT (SUB-FIELD LAM-DEST-DESC-lambda))
		    (SELECT-FIELD BYTE-OPERATION
				  LAM-IR-BYTE-FUNC (T LDB SELECTIVE-DEPOSIT DPB))
		    (INPUT (SUB-FIELD LAM-DEST-DESC-lambda))
		    (CALL LAM-BYTE-FIELD-OUT LAM-BYTE-SPEC NIL T)
		    (SUB-FIELD LAM-M-SOURCE-DESC-lambda)
		    (TYPE-FIELD A LAM-IR-A-SRC RAAMO)
      ;		    (SELECT-FIELD MF LAM-IR-MF (NIL T T LOW-PC-BIT-SEL-HW))
		    (SELECT-FIELD ILONG LAM-IR-ILONG ((NIL NO-ILONG) ILONG))
))

(DEFCONST LAM-DEST-DESC-lambda
	  '((OUTPUT (IF-EQUAL DEST LAM-IR-DEST 0 LAM-Q-DEST-DESC-lambda LAM-DEST-DESC-lambda-1))
	    (INPUT (IF-EQUAL DEST LAM-IR-DEST 0 NIL LAM-DEST-DESC-lambda-1))))

(DEFCONST LAM-DEST-DESC-lambda-1 '((CTYPE | (|)
			    (COND DEST LAM-IR-A-MEM-DEST-FLAG
				  (LAM-M-DEST-DESC-lambda LAM-A-DEST-DESC-lambda))
			    (OUTPUT (IF-EQUAL ALU LAM-IR-OP 0
					      ((IF-EQUAL DEST LAM-IR-Q 3 ((TYPE Q-R)) NIL))
					 NIL))
			    (CTYPE |) |)))

(DEFCONST LAM-Q-DEST-DESC-lambda '((IF-EQUAL ALU LAM-IR-OP 0
				 ((IF-EQUAL DEST LAM-IR-Q 3 ((CTYPE | (Q-R) |)) NIL))
				 NIL)))

(DEFCONST LAM-M-DEST-DESC-lambda
	  '((TYPE-FIELD M LAM-IR-M-MEM-DEST RAMMO)
	    (SELECT-FIELD FDEST LAM-IR-FUNC-DEST
			  (NIL
			   LOCATION-COUNTER
			   INTERRUPT-CONTROL
			   T
			   MAIN-STATISTICS-COUNTER
			   MID-RAM
                           CRAM-HIGH
			   CRAM-LOW
       			   C-PDL-POINTER	;10
			   C-PDL-POINTER-PUSH
			   C-PDL-INDEX
			   PDL-POINTER
			   T
			   US-DATA-PUSH
			   I-MOD-LOW
			   I-MOD-HIGH
			   VMA			;20
			   VMA-START-READ
			   VMA-START-WRITE
			   L1-MAP
			   L2-MAP-CONTROL
			   T
                           CRAM-MAP
			   T			;27
			   MD			;30
			   MD-START-READ
			   MD-START-WRITE
			   C-PDL-INDEX-INC
		           US-DATA
			   US-POINTER
			   C-PDL-INDEX-DEC
			   MULTIPLIER		;37
			   T			;40
			   INT-CLEAR
			   RG-MODE
			   T
			   AUX-STATISTICS-COUNTER
			   T
			   T
			   T
			   T			;50
			   T
			   T
			   PDL-BUFFER-INDEX	;53
			   T
			   T
			   T
			   T
			   T			;60
			   vma-start-read-force
			   vma-start-write-force
			   T
			   L2-MAP-PHYSICAL-PAGE
			   T
			   T
			   T
			   T			;70
			   T
			   T
			   T
			   T
			   T
			   T
			   T
 ))))

;;
;;  [OLD CADR DESTINATIONS FOR COMPARISON ]
;;
;;                              (NIL LOCATION-COUNTER INTERRUPT-CONTROL T T T T T	;0 - 7
;;			       C-PDL-BUFFER-POINTER C-PDL-BUFFER-POINTER-PUSH	;10, 11
;;			       C-PDL-BUFFER-INDEX PDL-BUFFER-INDEX	        ;12, 13
;;			       PDL-BUFFER-POINTER MICRO-STACK-DATA-PUSH	        ;14, 15
;;			       OA-REG-LOW OA-REG-HI	                        ;16, 17
;;			       VMA VMA-START-READ VMA-START-WRITE VMA-WRITE-MAP T T T T	;20 - 27
;;			       MD T MD-START-WRITE MD-WRITE-MAP T T T T)	;30 - 37
;;


(DEFCONST LAM-A-DEST-DESC-lambda '((TYPE-FIELD A LAM-IR-A-MEM-DEST RAAMO T)))

(DEFCONST LAM-M-SOURCE-DESC-lambda 
	  '((COND M LAM-IR-FUNC-SRC-FLAG
		  (((TYPE-FIELD M LAM-IR-M-SRC RAMMO))
		   ((SELECT-FIELD FSOURCE LAM-IR-M-SRC-ADR
		     (INTERRUPT-POINTER		;0 (0-7 on the random gates board)
		      MACRO-IR-DISPLACEMENT
		      STAT-COUNTER
		      MACRO-IR
		      MID-RAM
		      SPY-DATA
		      MULTIPLIER-FT		;6
		      RG-MODE			;7
		      DISP-CONST		;10 (10-17 on control memory board)
		      MICRO-STACK 		;USP BITS 28-24, SPCn BITS 18-0
		      MICRO-STACK-POP   	;SAME AS MICRO-STACK, BUT ALSO POPS USP
		      T				;13
		      T T T T			;14-17
		      CACHE-ADDRESS		;20 (20-27 on memory interface board)
		      MD-NO-WAIT
		      VMA
		      L1-MAP
		      L2-MAP-CONTROL
		      L2-MAP-PHYSICAL-PAGE
		      LC
		      T				;27
		      PDL-BUFFER-INDEX		;30 (30-77 on data path board)
		      Q-R
		      PDL-BUFFER-POINTER
		      T T 			;33-34
		      DP-MODE			;35
		      C-PDL-BUFFER-POINTER-POP
		      C-PDL-BUFFER-INDEX	;37
		                                ;(40 bit is the pop bit)
						;also causes wait if memory read in progress.
		      T T STAT-COUNTER-AUX T MID-MISC T	;40-45
		      MULTIPLIER		;46
		      T				;47
		      T T T T T T T T		;50-57
		      T MD T T T T T T		;60-67
		      T T T T T T		;70-75
		      C-PDL-BUFFER-POINTER	;76
		      T         		;77
		      )))))))

;;
;; [OLD CADR SOURCES FOR COMPARISON]
;;                   (READ-I-ARG MICRO-STACK-PNTR-AND-DATA		;0, 1
;;		      PDL-BUFFER-POINTER PDL-BUFFER-INDEX
;;		      T C-PDL-BUFFER-INDEX
;;		      C-OPC-BUFFER Q-R
;;		      VMA MEMORY-MAP-DATA	;10, 11
;;				 MD LOCATION-COUNTER
;;				 MICRO-STACK-PNTR-AND-DATA-POP T
;;				 T T
;;				 T T	;20, 21
;;				 T T
;;				 C-PDL-BUFFER-POINTER-POP C-PDL-BUFFER-POINTER
;;				 T T
;;				 T T T T T T T T)
;;


;;; first word of physical quantum map entry
(defconst lam-pq1-desc
	  `((type quantum-map-1)
	    (if-equal quantum-is-valid ,%%pq1-quantum-is-valid 0
		      ((type quantum-not-valid))
		      ((if-equal quantum-is-device ,%%pq1-quantum-is-device 1
				 ((type quantum-is-device))
				 ((type quantum-is-memory)
				  (if-equal page-out-copy-first ,%%pq1m-page-out-copy-first 1
					    ((type copy-first))
					    ((type no-need-to-copy)))
				  (type-field page-offset ,%%pq1m-page-offset nil t))
				 )))))

;;; second word
(defconst lam-pq2m-desc
	  `((type quantum-map-2)
	    (type-field partition-number ,%%pq2m-partition-number nil t)
	    (type-field boot-pages-allocated ,%%pq2m-boot-pages-allocated)
	  ))

;;; partition-table, first word
(defconst lam-pt1-desc
	  `((type partition-table-1)
	    (if-equal entry-valid ,%%pt1-valid 0
		      ((type not-valid))
		      ((type-field unit-number ,%%pt1-unit-number)
		       (type-field size ,%%pt1-size))))
	  )

(defconst lam-pt2-desc
	  `((type partition-table-2)
	    (type-field disk-offset ,%%pt2-offset))
	  )

;;; convenient decomposition of a virtual address
(defconst lam-quantum-number-of-address
	  `((type-field quantum ,(byte 11. 14.))
	    (type-field page ,(byte 6 8.))
	    (type-field word ,(byte 8. 0))))

;;; I think this is right.   9/22/86 naha
;;; decomposition of a CADR style disk address
(defconst lam-disk-address-decode
	  `((type disk address)
	    (if-equal dont-add-cylinder-offset ,(byte 1 (+ 11. 16.)) 1	;most significant bit of cylinder
		      ((type don't-add-cylinder-offset)
		       (type-field cylinder ,(byte 11. 16.)))
		      ((type-field cylinder ,(byte 12. 16.))))
	    (type-field head ,(byte 8. 8.))
	    (type-field block ,(byte 8. 0))))


(DEFUN LAM-PRINT-UINST (UINST)
  (LET ((*NUMERIC-PRINTOUT-ONLY* T))
    (LAM-TYPE-OUT UINST LAM-UINST-DESC T T)))

;----- explorer



;New assembler-style micro-instruction type-out and type-in.
(DEFCONST LAM-UINST-DESC-explorer
	  '((CTYPE | (| )
	    (select-field abbrv-jump
			  rav-ir-abbrv-jump
			  (nil and-skip and-call-illop and-call-trap and-call-buserr
			       and-call-unused and-popj popj-after-next))
	    (COND OPCLASS rav-IR-OP
		  (LAM-ALU-DESC-explorer
		   LAM-BYT-DESC-explorer
		   LAM-JMP-DESC-explorer
		   LAM-DSP-DESC-explorer))
	    (SELECT-FIELD HALT-BIT rav-IR-HALT (NIL (HALT-BIT YES)))
	    (CTYPE |) |) ))

(DEFCONST LAM-ALU-DESC-explorer
	  '((INPUT (TYPE ALU))
	    (OUTPUT (SUB-FIELD LAM-DEST-DESC-explorer))
	    (SELECT-FIELD ALU-FUNCTION rav-IR-ALUF-ONLY
			  (SETZ AND ANDCA SETM	;0 .. 3
			   ANDCM SETA XOR IOR	;4 .. 7
			   ANDCB EQV SETCA ORCA ;10..13
			   SETCM ORCM ORCB SETO ;14..17
			   MUL MUL-LAST DIV DIV-FIRST ;20..23
			   DIV-CORR t t t	;24..27
			   t ADD t t		;30..33
			   M+CARRY t SUB M+M	;34..37
			   ))
	    (SELECT-FIELD TYPED-ALU-MODE rav-ir-typed-alu-mode (NIL (TYPED-ALU-MODE YES)))
	    (INPUT (SUB-FIELD LAM-DEST-DESC-explorer))
	    (IF-EQUAL ALU rav-IR-ALUF-ONLY 36
		      LAM-SUB-CARRY-DESC-explorer LAM-NORMAL-CARRY-DESC-explorer)
	    (SELECT-FIELD OUTPUT-SELECTOR rav-IR-OB
			  (ob-a-bus ob-r-bus ob-a-bus2 nil	;0 ..3
			   ob-left-1 ob-right-1 ob-extend-25 ob-mirror))
	    (OUTPUT (SELECT-FIELD Q rav-IR-Q (NIL SHIFT-Q-LEFT SHIFT-Q-RIGHT NIL)))
	    (INPUT (SELECT-FIELD Q rav-IR-Q
				 (NIL SHIFT-Q-LEFT SHIFT-Q-RIGHT LOAD-Q)))
	    (SUB-FIELD LAM-M-SOURCE-DESC-explorer)
	    (TYPE-FIELD A rav-IR-A-SRC RAAMO)
	    (if-equal abbr-jump-cond rav-ir-jump-cond 7 nil ((ctype bad-abbr-jump-cond)))
		  
	    ))

(DEFCONST LAM-SUB-CARRY-DESC-explorer
	  '((SELECT-FIELD CARRY rav-IR-CARRY (ALU-CARRY-IN-ZERO (ALU-CARRY-IN-ONE NIL)))))

(DEFCONST LAM-NORMAL-CARRY-DESC-explorer
	  '((SELECT-FIELD CARRY rav-IR-CARRY ((NIL ALU-CARRY-IN-ZERO) ALU-CARRY-IN-ONE))))

(DEFCONST LAM-DSP-DESC-explorer
	  '((TYPE DISPATCH)
	    (IF-EQUAL DISP-CONST rav-IR-DISP-CONST 0
		      NIL LAM-DSP-CONST-DESC-explorer)
	    (CALL LAM-BYTE-FIELD-OUT-explorer rav-BYTE-SPEC T NIL)
	    (SUB-FIELD LAM-M-SOURCE-DESC-explorer)
	    (TYPE-FIELD D RAV-IR-DISPATCH-ADDR RADMO)
	    (SELECT-FIELD PUSH-OWN-ADDRESS?
			  rav-ir-push-own-address (NIL (PUSH-OWN-ADDRESS YES)))
	    (SELECT-FIELD MAP rav-ir-disp-enable-meta
			  (NIL MAP-GC MAP-OLD MAP-??))
	    (select-field rotation-direction
			  rav-ir-rotation-direction (nil ***rotate-right***))
	    (select-field instruction-stream
			  rav-ir-dispatch-instruction-stream
			  (nil (enable-instruction-stream yes)))
	    (select-field dispatch-source
			  rav-ir-dispatch-source-select
			  (nil mf-bus ibuf-0 ibuf-1))
	    (select-field write-dispatch
			  rav-ir-write-dispatch-memory (nil (write-dispatch-memory yes)))
	    (select-field read-dispatch
			  rav-ir-read-dispatch-memory (nil (read-dispatch-memory yes)))

	    ))

(DEFCONST LAM-DSP-CONST-DESC-explorer
	  '((CTYPE | (|)
	    (TYPE-FIELD I-ARG rav-ir-disp-const NIL)
	    (CTYPE |) |)))

(DEFCONST LAM-JMP-DESC-explorer
	  '((INPUT (TYPE JUMP)
		   (SELECT-FIELD CALL-RETURN rav-ir-jump-call-return
				 ((JUMP NIL) CALL RETURN T))
		   (COND COND rav-IR-JUMP-on-bit
			 (((COND COND rav-IR-JUMP-INVERT-COND
				 (((select-field cond rav-ir-jump-cond-low
						 (t less-than less-or-equal not-equal
						    page-fault page-fault-or-interrupt
						    sequence-break-or...
						    (always nil)
						    data-type-not-equal t q0 nubus-error
						    not-fixnum-overflow boxed-sign-bit
						    t t)))
				  ((select-field cond rav-ir-jump-cond-low
						 (t greater-or-equal greater-than equal
						    no-page-fault no-page-fault-or-interrupt
						    no-sequence-break-or...
						    never
						    data-type-equal t not-q0 no-nubus-error
						    fixnum-overflow no-boxed-sign-bit
						    t t))))))

			  ((SELECT-FIELD SENSE rav-IR-JUMP-INVERT-COND
					 (BIT-SET BIT-CLEAR))
			   (CALL LAM-BYTE-FIELD-OUT-explorer RAV-IR-ROTATION-COUNT T T))


			  ))
		   (SELECT-FIELD DONT-XCT-NEXT rav-IR-N
				 (XCT-NEXT (DONT-XCT-NEXT NIL))))
	    (OUTPUT (CALL LAM-TYPE-JUMP-CONDITION-explorer 0))
	    (SUB-FIELD lam-M-SOURCE-DESC-explorer)
	    (TYPE-FIELD A rav-IR-A-SRC RAAMO)
	    (TYPE-FIELD J rav-IR-JUMP-ADDR RACMO)
	    ))

(DEFCONST LAM-BYT-DESC-explorer
	  '((INPUT (TYPE BYTE))
	    (OUTPUT (SUB-FIELD LAM-DEST-DESC-explorer))
	    (SELECT-FIELD BYTE-OPERATION
			  rav-IR-BYTE-FUNC (T LDB SELECTIVE-DEPOSIT DPB))
	    (INPUT (SUB-FIELD LAM-DEST-DESC-explorer))
	    (CALL LAM-BYTE-FIELD-OUT-explorer rav-BYTE-SPEC NIL T)
	    (SUB-FIELD LAM-M-SOURCE-DESC-explorer)
	    (TYPE-FIELD A rav-IR-A-SRC RAAMO)
	    ))

(DEFCONST LAM-DEST-DESC-explorer
	  '((OUTPUT (IF-EQUAL DEST rav-IR-DEST 0
			      LAM-Q-DEST-DESC-explorer LAM-DEST-DESC-explorer-1))
	    (INPUT (IF-EQUAL DEST rav-IR-DEST 0
			     NIL LAM-DEST-DESC-explorer-1))))

(DEFCONST LAM-DEST-DESC-explorer-1
	  '((CTYPE | (|)
	    (COND DEST rav-IR-A-MEM-DEST-FLAG
		  (LAM-M-DEST-DESC-explorer LAM-A-DEST-DESC-explorer))
	    (OUTPUT (IF-EQUAL ALU rav-IR-OP 0
			      ((IF-EQUAL DEST rav-IR-Q 3
					 ((TYPE Q-R)) NIL))
			      NIL))
	    (CTYPE |) |)))

(DEFCONST LAM-Q-DEST-DESC-explorer
	  '((IF-EQUAL ALU rav-IR-OP 0
		      ((IF-EQUAL DEST rav-IR-Q 3
				 ((CTYPE | (Q-R) |)) NIL))
		      NIL)))

(DEFCONST LAM-M-DEST-DESC-explorer
	  '((TYPE-FIELD M rav-IR-M-MEM-DEST RAMMO)
	    (SELECT-FIELD FDEST rav-IR-FUNC-DEST
			  (NIL			;0
			   location-counter	;1
			   MCR			;2
			   MICRO-STACK-POINTER	;3
			   MICRO-STACK		;4
			   MICRO-STACK-DATA-PUSH ;5
			   IMOD-LOW		; 6
			   IMOD-HIGH		; 7
			   MACRO-IR		; 10
			   t t t t t t		; 11 .. 16
			   TEST-SYNCH		; 17

			   VMA			; 20
			   VMA-WRITE-L1		; 21
			   VMA-WRITE-L2-MAP-CONTROL ; 22
			   VMA-WRITE-L2-MAP-PHYSICAL-PAGE ; 23
			   VMA-START-READ	; 24
			   VMA-START-WRITE	; 25
			   VMA-START-READ-UNMAPPED ; 26
			   VMA-START-WRITE-UNMAPPED ; 27

			   MD			; 30
			   MD-WRITE-L1		; 31
			   md-WRITE-L2-CONTROL	; 32
			   MD-WRITE-L2-PHYSICAL-PAGE	; 33
			   MD-START-READ	; 34
			   MD-START-WRITE	; 35
			   MD-START-READ-UNMAPPED	; 36
			   MD-START-WRITE-UNMAPPED	; 37

			   C-PDL-BUFFER-POINTER	; 40
			   C-PDL-BUFFER-INDEX	; 41
			   t t
			   C-PDL-BUFFER-POINTER-PUSH	; 44
			   C-PDL-BUFFER-INDEX-INC	; 45
			   t t

			   PDL-BUFFER-POINTER	; 50
			   PDL-BUFFER-INDEX	; 51
			   t t			; 52 .. 53
			   t t t t		; 54 .. 57
			   t t t t		; 60 .. 63
			   t t			; 64 .. 65
			   VMA-START-READ-BYTE-UNMAPPED	; 66
			   VMA-START-WRITE-BYTE-UNMAPPED	; 67
			   
			   t t t t		;70 .. 73
			   t t			;74 .. 75
			   MD-START-READ-BYTE-UNMAPPED	; 76
			   MD-START-WRITE-BYTE-UNMAPPED	; 77
 ))))

(DEFCONST LAM-A-DEST-DESC-explorer '((TYPE-FIELD A rav-IR-A-MEM-DEST RAAMO T)))

(DEFCONST LAM-M-SOURCE-DESC-explorer 
	  '((COND M RAV-ir-FUNC-SRC-flag
		  (
		   ((TYPE-FIELD M rav-IR-M-SRC RAMMO))
		   ((SELECT-FIELD FSOURCE rav-IR-M-SRC-ADR
		     (
		      VMA			;0
		      Q-R			; 1
		      MACRO-IR-DISPLACEMENT	;2
		      MICRO-STACK-POINTER	; 3
		      MCR			; 4
		      location-counter		; 5
		      L2-MAP-PHYSICAL-PAGE	; 6
		      DISP-CONSTANT		; 7
		      L1-MAP			; 10
		      L2-MAP-CONTROL		; 11
		      MACRO-IR			; 12
		      MACRO-IR-BRACH-OFFSET	; 13
		      t t t t
		      MICRO-STACK-data		; 20
		      MICRO-STACK-data-POP	; 21
		      MD			; 22
		      t
		      t t t t
		      t t t t
		      t t t t
		      C-PDL-BUFFER-POINTER	; 40
		      C-PDL-BUFFER-INDEX	; 41
		      t t
		      C-PDL-BUFFER-POINTER-POP	; 44
		      C-PDL-BUFFER-INDEX-DEC	; 45
		      t t
		      PDL-BUFFER-POINTER	; 50
		      PDL-BUFFER-INDEX		; 51
		      t t
		      PDL-BUFFER-POINTER-POP	; 54
		      PDL-BUFFER-INDEX-DEC	; 55
		      t t
		      t t t t
		      t t t t
		      t t t t
		      t t t t
		      )))
		   ))))

#|
;some tests

(raven-execute (print)
  rav-ir-op rav-op-alu)

(raven-execute (print)
  rav-ir-op rav-op-jump
  rav-ir-jump-cond rav-jump-cond-m=a
  rav-ir-n 1
  )

(raven-execute (print)
  rav-ir-op rav-op-alu
  rav-ir-ob rav-ob-alu
  rav-ir-aluf rav-alu-sub
  rav-ir-carry 1
  rav-ir-a-src 123
  rav-ir-m-src 21
  rav-ir-func-dest rav-func-dest-vma
  )

(raven-execute (print)
  rav-ir-op rav-op-jump
  rav-ir-jump-on-bit 1
  rav-ir-m-src 21
  rav-ir-rotation-count 5
  rav-ir-n 1
  rav-ir-r 1
  rav-ir-jump-addr 100
  )

(raven-execute (print)
  rav-ir-op rav-op-dispatch
  rav-ir-m-src 5
  rav-ir-rotation-count 5
  rav-ir-rotation-length 5
  rav-ir-dispatch-addr 123
  )

(raven-execute (print)
  rav-ir-op rav-op-byte
  rav-ir-m-src rav-m-src-md
  rav-ir-a-src 6
  rav-ir-m-mem-dest 7
  rav-ir-rotation-count 5
  rav-ir-rotation-length 6
  rav-ir-byte-func rav-byte-func-dpb
  )

|#